diff --git a/neuron/src/app/Neuron/CLI/Types.hs b/neuron/src/app/Neuron/CLI/Types.hs index fe2add42b..8234e742a 100644 --- a/neuron/src/app/Neuron/CLI/Types.hs +++ b/neuron/src/app/Neuron/CLI/Types.hs @@ -21,6 +21,7 @@ import Data.Default (def) import Data.Some import Data.TagTree (mkTagPattern) import Data.Time +import qualified Neuron.Zettelkasten.Connection as C import Neuron.Zettelkasten.ID (ZettelID, parseZettelID') import Neuron.Zettelkasten.ID.Scheme (IDScheme (..)) import qualified Neuron.Zettelkasten.Query.Error as Q @@ -134,6 +135,26 @@ commandParser defaultNotesDir today = do <|> fmap Right (fmap (const $ Some $ Q.GraphQuery_Id) $ switch (long "graph" <> help "Get the entire zettelkasten graph as JSON")) + <|> fmap + Right + ( fmap (Some . Q.GraphQuery_BacklinksOf Nothing) $ + option + zettelIDReader + ( long "backlinks-of" + <> help "Get backlinks to the given zettel ID" + <> metavar "ID" + ) + ) + <|> fmap + Right + ( fmap (Some . Q.GraphQuery_BacklinksOf (Just C.Folgezettel)) $ + option + zettelIDReader + ( long "uplinks-of" + <> help "Get uplinks to the given zettel ID" + <> metavar "ID" + ) + ) ) searchCommand = do searchBy <- diff --git a/neuron/src/lib/Data/Graph/Labelled/Algorithm.hs b/neuron/src/lib/Data/Graph/Labelled/Algorithm.hs index 5a9b38874..75350ee84 100644 --- a/neuron/src/lib/Data/Graph/Labelled/Algorithm.hs +++ b/neuron/src/lib/Data/Graph/Labelled/Algorithm.hs @@ -50,9 +50,16 @@ preSet (vertexID -> zid) g = -- | Return the preset of a vertex, considering only edges with the given label -- -- WARNING: Dont' call this in a loop. For that, use preSetWithEdgeLabelMany -preSetWithEdgeLabel :: (Eq e, Vertex v, Ord (VertexID v)) => e -> v -> LabelledGraph v e -> [v] -preSetWithEdgeLabel e v g = - preSet v $ induceOnEdge (== e) g +preSetWithEdgeLabel :: + (Eq e, Monoid e, Vertex v, Ord (VertexID v)) => + (e -> Bool) -> + v -> + LabelledGraph v e -> + [(e, v)] +preSetWithEdgeLabel f v g = + let g' = LAM.transpose $ getGraph $ induceOnEdge f g + ns = Map.toList $ Map.findWithDefault mempty (vertexID v) $ LAM.adjacencyMap g' + in fmap (second (getVertex g) . swap) ns -- | Optimized version of preSetWithEdgeLabel for multiple-input vertices. preSetWithEdgeLabelMany :: diff --git a/neuron/src/lib/Neuron/Web/Zettel/View.hs b/neuron/src/lib/Neuron/Web/Zettel/View.hs index 4e891536b..98f925e77 100644 --- a/neuron/src/lib/Neuron/Web/Zettel/View.hs +++ b/neuron/src/lib/Neuron/Web/Zettel/View.hs @@ -69,7 +69,7 @@ renderZettelContentCard (graph, zc) = renderZettelBottomPane :: DomBuilder t m => ZettelGraph -> Zettel -> NeuronWebT t m () renderZettelBottomPane graph z@Zettel {..} = do - let cfBacklinks = nonEmpty $ G.backlinks OrdinaryConnection z graph + let cfBacklinks = nonEmpty $ fmap snd $ G.backlinks (== Just OrdinaryConnection) z graph tags = nonEmpty zettelTags when (isJust cfBacklinks || isJust tags) $ elClass "nav" "ui bottom attached segment deemphasized" diff --git a/neuron/src/lib/Neuron/Zettelkasten/Graph.hs b/neuron/src/lib/Neuron/Zettelkasten/Graph.hs index 5d44c613a..b17ecfd34 100644 --- a/neuron/src/lib/Neuron/Zettelkasten/Graph.hs +++ b/neuron/src/lib/Neuron/Zettelkasten/Graph.hs @@ -48,9 +48,14 @@ backlinkForest conn z = . G.bfsForestBackwards z . G.induceOnEdge (== Just conn) -backlinks :: Connection -> Zettel -> ZettelGraph -> [Zettel] -backlinks conn z g = - G.preSetWithEdgeLabel (Just conn) z g +backlinks :: + (Maybe Connection -> Bool) -> + Zettel -> + ZettelGraph -> + [(Connection, Zettel)] +backlinks f z g = + mapMaybe (\(e, v) -> (,v) <$> e) $ + G.preSetWithEdgeLabel f z g -- | Like backlinks but for multiple zettels. More performant than calling -- `backlinks` in a loop. diff --git a/neuron/src/lib/Neuron/Zettelkasten/Query.hs b/neuron/src/lib/Neuron/Zettelkasten/Query.hs index ad6f1fc49..16895a786 100644 --- a/neuron/src/lib/Neuron/Zettelkasten/Query.hs +++ b/neuron/src/lib/Neuron/Zettelkasten/Query.hs @@ -16,6 +16,7 @@ import Data.Aeson import qualified Data.Map.Strict as Map import Data.TagTree (Tag, tagMatch, tagMatchAny, tagTree) import Data.Tree (Tree (..)) +import Neuron.Zettelkasten.Graph (backlinks, getZettel) import Neuron.Zettelkasten.Graph.Type import Neuron.Zettelkasten.ID import Neuron.Zettelkasten.Query.Error (QueryResultError (..)) @@ -46,9 +47,15 @@ runZettelQuery zs = \case Map.fromListWith (+) $ concatMap (\Zettel {..} -> (,1) <$> zettelTags) zs -runGraphQuery :: ZettelGraph -> GraphQuery r -> r +runGraphQuery :: ZettelGraph -> GraphQuery r -> Either QueryResultError r runGraphQuery g = \case - GraphQuery_Id -> g + GraphQuery_Id -> Right g + GraphQuery_BacklinksOf conn zid -> + case getZettel zid g of + Nothing -> + Left $ QueryResultError_NoSuchZettel zid + Just z -> + Right $ backlinks (maybe isJust (const (== conn)) conn) z g zettelQueryResultJson :: forall r. @@ -95,19 +102,24 @@ graphQueryResultJson :: forall r. (ToJSON (GraphQuery r)) => GraphQuery r -> - r -> + Either QueryResultError r -> -- Zettels that cannot be parsed by neuron (and as such are excluded from the graph) Map ZettelID ZettelError -> Value -graphQueryResultJson q r skippedZettels = +graphQueryResultJson q er skippedZettels = toJSON $ object [ "query" .= toJSON q, - "result" .= resultJson, + either + (\e -> "error" .= toJSON e) + (\r -> "result" .= toJSON (resultJson r)) + er, "skipped" .= skippedZettels ] where - resultJson :: Value - resultJson = case q of + resultJson :: r -> Value + resultJson r = case q of GraphQuery_Id -> toJSON r + GraphQuery_BacklinksOf _ _ -> + toJSON r diff --git a/neuron/src/lib/Neuron/Zettelkasten/Query/Graph.hs b/neuron/src/lib/Neuron/Zettelkasten/Query/Graph.hs index e1ddc0c62..6aed8f224 100644 --- a/neuron/src/lib/Neuron/Zettelkasten/Query/Graph.hs +++ b/neuron/src/lib/Neuron/Zettelkasten/Query/Graph.hs @@ -14,13 +14,21 @@ import Data.Aeson.GADT.TH import Data.Dependent.Sum.Orphans () import Data.GADT.Compare.TH import Data.GADT.Show.TH +import Neuron.Zettelkasten.Connection import Neuron.Zettelkasten.Graph.Type +import Neuron.Zettelkasten.ID +import Neuron.Zettelkasten.Zettel import Relude -- | Like `GraphQuery` but focused on the relationship between zettels. data GraphQuery r where -- | Query the entire graph. GraphQuery_Id :: GraphQuery ZettelGraph + -- | Query backlinks. + GraphQuery_BacklinksOf :: + Maybe Connection -> + ZettelID -> + GraphQuery [(Connection, Zettel)] deriveJSONGADT ''GraphQuery