WIP: Implement a backlinks query for a given Zettel ID

Will be useful for editors to show a "nearby zettels" view.  See
felko/neuron-mode#30 for more details.

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 a backlink graph of ID"
+                        <> metavar "ID"
+                    )
+              )
+            <|> fmap
+              Right
+              ( fmap (Some . Q.GraphQuery_BacklinksOf (Just C.Folgezettel)) $
+                  option
+                    zettelIDReader
+                    ( long "uplinks-of"
+                        <> help "Get an uplink graph of ID"
+                        <> metavar "ID"
+                    )
+              )
         )
     searchCommand = do
       searchBy <-

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"

neuron/src/lib/Neuron/Zettelkasten/Graph.hs

@@ -29,6 +29,7 @@ import qualified Algebra.Graph.Labelled.AdjacencyMap as LAM
 import Data.Default
 import Data.Foldable (maximum)
 import qualified Data.Graph.Labelled as G
+import qualified Data.Map as Map
 import Data.Tree
 import Neuron.Zettelkasten.Connection
 import Neuron.Zettelkasten.Graph.Type
@@ -48,9 +49,12 @@ backlinkForest conn z =
     . G.bfsForestBackwards z
     . G.induceOnEdge (== Just conn)
 
-backlinks :: Connection -> Zettel -> ZettelGraph -> [Zettel]
+backlinks :: Maybe Connection -> Zettel -> ZettelGraph -> [(Connection, Zettel)]
 backlinks conn z g =
-  G.preSetWithEdgeLabel (Just conn) z g
+  let includeConn = maybe isJust (const (== conn)) conn
+      g' = LAM.transpose $ G.getGraph $ G.induceOnEdge includeConn g
+      ns = Map.toList $ Map.findWithDefault mempty (G.vertexID z) $ LAM.adjacencyMap g'
+   in mapMaybe (\(v, e) -> (,) <$> e <*> G.findVertex v g) ns
 
 -- | Like backlinks but for multiple zettels. More performant than calling
 -- `backlinks` in a loop.

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 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

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