diff --git a/neuron/src/app/Neuron/CLI/Types.hs b/neuron/src/app/Neuron/CLI/Types.hs index fe2add42b..60e83441b 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 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 <- diff --git a/neuron/src/lib/Neuron/Web/Zettel/View.hs b/neuron/src/lib/Neuron/Web/Zettel/View.hs index 4e891536b..121084614 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..d4670080e 100644 --- a/neuron/src/lib/Neuron/Zettelkasten/Graph.hs +++ b/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. diff --git a/neuron/src/lib/Neuron/Zettelkasten/Query.hs b/neuron/src/lib/Neuron/Zettelkasten/Query.hs index ad6f1fc49..c70e68a69 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 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