Hierarchical tags (#115)

CHANGELOG.md

@@ -12,6 +12,7 @@
   - Custom alias redirects
   - #90: Client-side web search
   - #107: Add full path to the zettel in `neuron query` JSON
+  - #115: Hierarchical tags, with tag pattern in zquery
 - CLI revamp
   - Zettelkasten directory is now provided via the `-d` argument.
     - Its default, `~/zettelkasten`, is used when not specified.

guide/2011505.md

@@ -11,3 +11,5 @@ tags:
   - science
 ---
 ```
+
+Tags can also be nested using a "tag/subtag" syntax, to allow a more fine-grained organization of your Zettelkasten, especially when using advanced queries as shown in [2011506](zcf://linking-to-multiple-zettels).

guide/2011506.md

@@ -8,12 +8,19 @@ You may create a query that will list the matching zettels automatically. For ex
 [.](zquery://search?tag=science&linkTheme=withDate)
 ```
 
-This will produce a list of zettel links like as follows:
+You can use the CLI to see which zettels will be included in a given query; see [2013501](zcf://searching).
+
+## Example
+
+As an example here is a list of zettels tagged "walkthrough" on this very
+Zettelkasten:
 
----
 [.](zcfquery://search?tag=walkthrough)
----
 
-The above list is produced by `[.](zcfquery://search?tag=walkthrough)` on this very zettelkasten. Note that here we use `zcfquery` to not affect the graph; whereas `zquery` will form the appropriate new connections to the listed notes.
+It was created by `[.](zcfquery://search?tag=walkthrough)`. Note that here we use `zcfquery` to not affect the graph; whereas `zquery` will form the appropriate new connections to the listed notes.
+
+## Hierarchical tags
+
+Queries can also link to zettels whose tags match a glob pattern. For instance, `[.](zquery://search?tag=science/*)` will link to all zettels tagged "science/physics" and "science/biology".
 
-You can use the CLI to see which zettels will be include in a given query; see [2013501](zcf://searching).
+Recursive globs are supported too, so if you want to include deeper nested tags, `[.](zquery://search?tag=science/**)` will also match them (e.g. "science/physics/kinematics"). This will also include zettels that are tagged "science" only, though this behavior can be avoided by querying "science/\*/\*\*" instead.

neuron.cabal

@@ -86,6 +86,7 @@ library
     Neuron.Zettelkasten.Markdown.Meta
     Neuron.Zettelkasten.Query
     Neuron.Zettelkasten.Store
+    Neuron.Zettelkasten.Tag
     Neuron.Zettelkasten.Zettel
   other-modules:
     Neuron.Version.RepoVersion

src/Neuron/CLI/Types.hs

@@ -17,6 +17,7 @@ module Neuron.CLI.Types
 where
 
 import qualified Neuron.Zettelkasten.Query as Z
+import qualified Neuron.Zettelkasten.Tag as Z
 import Options.Applicative
 import Relude
 import qualified Rib.Cli
@@ -93,7 +94,7 @@ commandParser defaultNotesDir = do
       pure Open
     queryCommand =
       fmap Query $
-        many (Z.ByTag <$> option str (long "tag" <> short 't'))
+        many (Z.ByTag . Z.TagPattern <$> option str (long "tag" <> short 't'))
           <|> option uriReader (long "uri" <> short 'u')
     searchCommand = do
       searchBy <-

src/Neuron/Web/View.hs

@@ -2,7 +2,6 @@
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE GADTs #-}
 {-# LANGUAGE LambdaCase #-}
-{-# LANGUAGE OverloadedLists #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE QuasiQuotes #-}
 {-# LANGUAGE Rank2Types #-}
@@ -39,6 +38,7 @@ import Neuron.Zettelkasten.Link.View (renderZettelLink)
 import Neuron.Zettelkasten.Markdown (neuronMMarkExts)
 import Neuron.Zettelkasten.Query
 import Neuron.Zettelkasten.Store
+import Neuron.Zettelkasten.Tag (Tag (..))
 import Neuron.Zettelkasten.Zettel
 import Relude
 import qualified Rib
@@ -55,27 +55,27 @@ searchScript = $(embedStringFile "./src-js/search.js")
 helloScript :: Text
 helloScript = $(embedStringFile "./src-purescript/hello/index.js")
 
-mkSearchURI :: MonadThrow m => Maybe Text -> [Text] -> m URI
+mkSearchURI :: MonadThrow m => Maybe Text -> [Tag] -> m URI
 mkSearchURI terms tags = do
   let mkParam k v = URI.QueryParam <$> URI.mkQueryKey k <*> URI.mkQueryValue v
       qParams = maybeToList (fmap (mkParam "q") terms)
-      tagParams = fmap (mkParam "tag") tags
+      tagParams = fmap (mkParam "tag" . unTag) tags
   route <- URI.mkPathPiece (Rib.routeUrlRel Route_Search)
   params <- sequenceA (qParams ++ tagParams)
   pure
     emptyURI
-      { uriPath = Just (False, [route]),
+      { uriPath = Just (False, route :| []),
         uriQuery = params
       }
 
 -- TODO: render error message when the query is invalid
-mkSearchQuery :: Maybe Text -> [Text] -> Text
+mkSearchQuery :: Maybe Text -> [Tag] -> Text
 mkSearchQuery terms tags =
   fromMaybe
     (Rib.routeUrlRel Route_Search)
     (URI.render <$> mkSearchURI terms tags)
 
-mkSingleTagQuery :: Text -> Text
+mkSingleTagQuery :: Tag -> Text
 mkSingleTagQuery tag = mkSearchQuery Nothing [tag]
 
 renderRouteHead :: Monad m => Config -> Route store graph a -> store -> HtmlT m ()
@@ -154,7 +154,7 @@ renderSearch store = do
     div_ [class_ "default text"] "Select tags…"
     div_ [class_ "menu"] $ do
       forM_ allTags $ \tag -> do
-        div_ [class_ "item"] $ toHtml @Text tag
+        div_ [class_ "item"] $ toHtml (unTag tag)
   div_ [class_ "ui divider"] mempty
   ul_ [id_ "search-results", class_ "zettel-list"] mempty
   script_ $ "let index = " <> toText (Aeson.encodeToLazyText index) <> ";"
@@ -208,7 +208,7 @@ renderBrandFooter withVersion =
           " "
           code_ $ toHtml @Text neuronVersionFull
 
-renderTags :: Monad m => [Text] -> HtmlT m ()
+renderTags :: Monad m => [Tag] -> HtmlT m ()
 renderTags tags = do
   forM_ tags $ \tag -> do
     -- TODO: Ideally this should be at the top, not bottom. But putting it at
@@ -217,9 +217,9 @@ renderTags tags = do
     span_ [class_ "ui black right ribbon label", title_ "Tag"] $ do
       a_
         [ href_ (mkSingleTagQuery tag),
-          title_ ("See all zettels with tag '" <> tag <> "'")
+          title_ ("See all zettels with tag '" <> unTag tag <> "'")
         ]
-        $ toHtml @Text tag
+        $ toHtml (unTag tag)
     p_ mempty
 
 -- | Font awesome element

src/Neuron/Zettelkasten/Markdown/Meta.hs

@@ -10,13 +10,14 @@ module Neuron.Zettelkasten.Markdown.Meta
 where
 
 import Data.Aeson
+import Neuron.Zettelkasten.Tag
 import Relude
 import Text.MMark (MMark, projectYaml)
 
 -- | YAML metadata in a zettel markdown file
 data Meta = Meta
   { title :: Text,
-    tags :: Maybe [Text]
+    tags :: Maybe [Tag]
   }
   deriving (Eq, Show, Generic, FromJSON)
 

src/Neuron/Zettelkasten/Query.hs

@@ -3,6 +3,7 @@
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE RecordWildCards #-}
 {-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TupleSections #-}
 {-# LANGUAGE ViewPatterns #-}
 {-# LANGUAGE NoImplicitPrelude #-}
 
@@ -12,6 +13,7 @@ module Neuron.Zettelkasten.Query where
 import qualified Data.Map.Strict as Map
 import Lucid
 import Neuron.Zettelkasten.Store
+import Neuron.Zettelkasten.Tag
 import Neuron.Zettelkasten.Zettel
 import Relude
 import qualified Text.URI as URI
@@ -20,14 +22,14 @@ import qualified Text.URI as URI
 --   LinksTo ZettelID
 --   LinksFrom ZettelID
 data Query
-  = ByTag Text
+  = ByTag TagPattern
   deriving (Eq, Show)
 
 instance ToHtml Query where
   toHtmlRaw = toHtml
-  toHtml (ByTag tag) = do
-    let desc = "Zettels tagged '" <> tag <> "'"
-    span_ [class_ "ui basic pointing below black label", title_ desc] $ toHtml tag
+  toHtml (ByTag (TagPattern pat)) =
+    let desc = "Zettels matching tag '" <> toText pat <> "'"
+     in span_ [class_ "ui basic pointing below black label", title_ desc] $ toHtml pat
 
 instance ToHtml [Query] where
   toHtmlRaw = toHtml
@@ -44,13 +46,13 @@ parseQuery uri =
   flip mapMaybe (URI.uriQuery uri) $ \case
     URI.QueryParam (URI.unRText -> key) (URI.unRText -> val) ->
       case key of
-        "tag" -> Just $ ByTag val
+        "tag" -> Just $ ByTag (TagPattern $ toString val)
         _ -> Nothing
     _ -> Nothing
 
 matchQuery :: Zettel -> Query -> Bool
 matchQuery Zettel {..} = \case
-  ByTag tag -> tag `elem` zettelTags
+  ByTag pat -> any (tagMatch pat) zettelTags
 
 matchQueries :: Zettel -> [Query] -> Bool
 matchQueries zettel queries = and $ matchQuery zettel <$> queries

src/Neuron/Zettelkasten/Tag.hs

@@ -0,0 +1,24 @@
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+
+module Neuron.Zettelkasten.Tag
+  ( Tag (..),
+    TagPattern (..),
+    tagMatch,
+  )
+where
+
+import Data.Aeson
+import Relude
+import System.FilePattern
+
+newtype Tag = Tag {unTag :: Text}
+  deriving (Eq, Ord, Show, ToJSON, FromJSON)
+
+newtype TagPattern = TagPattern {unTagPattern :: FilePattern}
+  deriving (Eq, Show)
+
+tagMatch :: TagPattern -> Tag -> Bool
+tagMatch (TagPattern pat) (Tag tag) = pat ?== toString tag

src/Neuron/Zettelkasten/Zettel.hs

@@ -11,6 +11,7 @@ import Data.Aeson
 import Development.Shake (Action)
 import Neuron.Zettelkasten.ID
 import qualified Neuron.Zettelkasten.Markdown.Meta as Meta
+import Neuron.Zettelkasten.Tag
 import Relude hiding (show)
 import qualified Rib.Parser.MMark as MMark
 import Text.MMark (MMark)
@@ -19,7 +20,7 @@ import Text.Show (Show (show))
 data Zettel = Zettel
   { zettelID :: ZettelID,
     zettelTitle :: Text,
-    zettelTags :: [Text],
+    zettelTags :: [Tag],
     zettelContent :: MMark
   }
 
@@ -51,6 +52,6 @@ mkZettelFromPath path = do
       tags = fromMaybe [] $ Meta.tags =<< meta
   pure $ Zettel zid title tags doc
 
-hasTag :: Text -> Zettel -> Bool
-hasTag t Zettel {..} =
-  isJust $ find (== t) zettelTags
+hasTag :: Tag -> Zettel -> Bool
+hasTag tag Zettel {..} =
+  isJust $ find (== tag) zettelTags

test/Neuron/Zettelkasten/Link/ActionSpec.hs

@@ -10,6 +10,7 @@ where
 import Neuron.Zettelkasten.ID
 import Neuron.Zettelkasten.Link.Action
 import Neuron.Zettelkasten.Query
+import Neuron.Zettelkasten.Tag
 import Relude
 import Test.Hspec
 import Text.URI
@@ -49,11 +50,11 @@ linkActionCases =
     ),
     ( "zquery: link",
       (Right (".", "zquery://search?tag=science")),
-      Just $ LinkAction_QueryZettels Folgezettel LinkTheme_Default [ByTag "science"]
+      Just $ LinkAction_QueryZettels Folgezettel LinkTheme_Default [ByTag $ TagPattern "science"]
     ),
     ( "zcfquery: link, with link theme",
       (Right (".", "zcfquery://search?tag=science&linkTheme=withDate")),
-      Just $ LinkAction_QueryZettels OrdinaryConnection LinkTheme_WithDate [ByTag "science"]
+      Just $ LinkAction_QueryZettels OrdinaryConnection LinkTheme_WithDate [ByTag $ TagPattern "science"]
     ),
     ( "normal link",
       (Left "https://www.google.com"),

test/Neuron/Zettelkasten/QuerySpec.hs

@@ -7,6 +7,7 @@ module Neuron.Zettelkasten.QuerySpec
 where
 
 import Neuron.Zettelkasten.Query
+import Neuron.Zettelkasten.Tag
 import Relude
 import Test.Hspec
 import Text.URI (mkURI)
@@ -17,9 +18,14 @@ spec =
     it "Parse all zettels URI" $
       parseQueryString "zquery://search" `shouldBe` Right []
     it "Parse single tag" $
-      parseQueryString "zquery://search?tag=foo" `shouldBe` Right [ByTag "foo"]
+      parseQueryString "zquery://search?tag=foo" `shouldBe` Right [ByTag $ TagPattern "foo"]
+    it "Parse hierarchical tag" $ do
+      parseQueryString "zquery://search?tag=foo/bar" `shouldBe` Right [ByTag $ TagPattern "foo/bar"]
+    it "Parse tag pattern" $ do
+      parseQueryString "zquery://search?tag=foo/**/bar/*/baz" `shouldBe` Right [ByTag $ TagPattern "foo/**/bar/*/baz"]
     it "Parse multiple tags" $
-      parseQueryString "zquery://search?tag=foo&tag=bar" `shouldBe` Right [ByTag "foo", ByTag "bar"]
+      parseQueryString "zquery://search?tag=foo&tag=bar"
+        `shouldBe` Right [ByTag $ TagPattern "foo", ByTag $ TagPattern "bar"]
   where
     parseQueryString =
       bimap displayException parseQuery . mkURI

test/Neuron/Zettelkasten/TagSpec.hs

@@ -0,0 +1,71 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE ViewPatterns #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+
+module Neuron.Zettelkasten.TagSpec
+  ( spec,
+  )
+where
+
+import qualified Neuron.Zettelkasten.Tag as Z
+import Relude
+import Test.Hspec
+
+spec :: Spec
+spec = do
+  describe "Tag matching" $ do
+    forM_ tagMatchCases $ \(name, Z.TagPattern -> pat, fmap Z.Tag -> matching, fmap Z.Tag -> failing) -> do
+      it name $ do
+        forM_ matching $ \tag -> do
+          pat `shouldMatch` tag
+        forM_ failing $ \tag -> do
+          pat `shouldNotMatch` tag
+
+tagMatchCases :: [(String, String, [Text], [Text])]
+tagMatchCases =
+  [ ( "simple tag",
+      "journal",
+      ["journal"],
+      ["science", "journal/work"]
+    ),
+    ( "simple tag with slash",
+      "journal/note",
+      ["journal/note"],
+      ["science/physics", "journal", "journal/note/foo"]
+    ),
+    ( "tag pattern with **",
+      "journal/**",
+      ["journal", "journal/work", "journal/work/clientA"],
+      ["math", "science/physics", "jour"]
+    ),
+    ( "tag pattern with */**",
+      "journal/*/**",
+      ["journal/foo", "journal/foo/bar"],
+      ["science", "journal"]
+    ),
+    ( "tag pattern with ** in the middle",
+      "math/**/note",
+      ["math/note", "math/algebra/note", "math/algebra/linear/note"],
+      ["math/algebra", "journal/note"]
+    ),
+    ( "tag pattern with * in the middle",
+      "project/*/task",
+      ["project/foo/task", "project/bar-baz/task"],
+      ["project", "project/foo", "project/task", "project/foo/bar/task"]
+    )
+  ]
+
+shouldMatch :: Z.TagPattern -> Z.Tag -> Expectation
+shouldMatch pat tag
+  | Z.tagMatch pat tag = pure ()
+  | otherwise =
+    expectationFailure $
+      Z.unTagPattern pat <> " was expected to match " <> toString (Z.unTag tag) <> " but didn't"
+
+shouldNotMatch :: Z.TagPattern -> Z.Tag -> Expectation
+shouldNotMatch pat tag
+  | Z.tagMatch pat tag =
+    expectationFailure $
+      Z.unTagPattern pat <> " wasn't expected to match tag " <> toString (Z.unTag tag) <> " but it did"
+  | otherwise = pure ()