Merge pull request #216 from pjones/pjones/backlinks

Implement a backlinks query for a given Zettel ID

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

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

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

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

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

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