Hierarchical tags

guide/2011505.md

@@ -11,3 +11,7 @@ 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](z:/linking-to-multiple-zettels).

guide/2011506.md

@@ -17,3 +17,12 @@ This will produce a list of zettel links like as follows:
 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.
 
 You can use the CLI to see which zettels will be include in a given query; see [2013501](zcf://searching).
+
+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".
+
+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

@@ -39,6 +39,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,11 +56,11 @@ 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" . tagToText) tags
   route <- URI.mkPathPiece (Rib.routeUrlRel Route_Search)
   params <- sequenceA (qParams ++ tagParams)
   pure
@@ -69,13 +70,13 @@ mkSearchURI terms tags = do
       }
 
 -- 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 +155,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 (tagToText tag)
   div_ [class_ "ui divider"] mempty
   ul_ [id_ "search-results", class_ "zettel-list"] mempty
   script_ $ "let index = " <> toText (Aeson.encodeToLazyText index) <> ";"
@@ -208,7 +209,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 +218,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 '" <> tagToText tag <> "'")
         ]
-        $ toHtml @Text tag
+        $ toHtml (tagToText 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

@@ -1,8 +1,10 @@
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE OverloadedLists #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE RecordWildCards #-}
 {-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TupleSections #-}
 {-# LANGUAGE ViewPatterns #-}
 {-# LANGUAGE NoImplicitPrelude #-}
 
@@ -12,6 +14,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 +23,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 (tagPatternToText -> pat)) =
+    let desc = "Zettels matching tag '" <> pat <> "'"
+     in span_ [class_ "ui basic pointing below black label", title_ desc] $ toHtml pat
 
 instance ToHtml [Query] where
   toHtmlRaw = toHtml
@@ -44,13 +47,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" -> pure $ 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,54 @@
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE OverloadedLists #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE TupleSections #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+
+module Neuron.Zettelkasten.Tag
+  ( Tag (..),
+    TagPattern (..),
+    literalPattern,
+    tagPatternToText,
+    tagMatch,
+    isSubTag,
+    isStrictSubTag,
+  )
+where
+
+import Data.Aeson
+import Relude
+import Relude.Extra.Foldable1
+import System.FilePath
+import System.FilePattern as FilePattern
+
+newtype Tag = Tag {tagToText :: Text}
+  deriving (Eq, Ord, Show, ToJSON, FromJSON)
+
+instance Semigroup Tag where
+  Tag t <> Tag t' = Tag (toText $ toString t </> toString t')
+  sconcat tags = Tag (toText $ foldl1' (</>) $ fmap (toString . tagToText) tags)
+
+newtype TagPattern = TagPattern {toFilePattern :: FilePattern}
+  deriving (Eq, Show)
+
+instance Semigroup TagPattern where
+  TagPattern p <> TagPattern p' = TagPattern (p </> p')
+
+tagPatternToText :: TagPattern -> Text
+tagPatternToText = toText . toFilePattern
+
+literalPattern :: Tag -> TagPattern
+literalPattern = TagPattern . toString . tagToText
+
+tagMatch :: TagPattern -> Tag -> Bool
+tagMatch (TagPattern pat) (Tag tag) = pat ?== toString tag
+
+isSubTag :: Tag -> Tag -> Bool
+isSubTag tag tag' = tagMatch (literalPattern tag <> TagPattern "**") tag'
+
+isStrictSubTag :: Tag -> Tag -> Bool
+isStrictSubTag tag tag' = tagMatch (literalPattern tag <> TagPattern "*" <> TagPattern "**") 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

@@ -1,3 +1,4 @@
+{-# LANGUAGE OverloadedLists #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE QuasiQuotes #-}
 {-# LANGUAGE NoImplicitPrelude #-}
@@ -10,6 +11,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 +51,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

@@ -1,3 +1,4 @@
+{-# LANGUAGE OverloadedLists #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE NoImplicitPrelude #-}
 
@@ -7,6 +8,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 +19,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,53 @@
+{-# 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
+
+shouldMatch :: Z.TagPattern -> Z.Tag -> Expectation
+shouldMatch pat tag
+  | Z.tagMatch pat tag = pure ()
+  | otherwise = expectationFailure $ toString $ Z.tagPatternToText pat <> " was expected to match " <> Z.tagToText tag <> " but didn't"
+
+shouldNotMatch :: Z.TagPattern -> Z.Tag -> Expectation
+shouldNotMatch pat tag
+  | Z.tagMatch pat tag = expectationFailure $ toString $ Z.tagPatternToText pat <> " wasn't expected to match tag " <> Z.tagToText tag <> " but it did"
+  | otherwise = pure ()
+
+spec :: Spec
+spec = do
+  describe "Tag matching" $ do
+    forM_ tagMatchCases $ \(name, Z.TagPattern -> pat, Z.Tag -> tag, expectedToMatch) -> do
+      it name $ if expectedToMatch then pat `shouldMatch` tag else pat `shouldNotMatch` tag
+
+tagMatchCases :: [(String, String, Text, Bool)]
+tagMatchCases =
+  [ ( "matches itself when the tag pattern is literal",
+      "journal/note",
+      "journal/note",
+      True
+    ),
+    ( "matches recursive globs lazily",
+      "math/**/note",
+      "math/algebra",
+      False
+    ),
+    ( "matches a single tag component on glob wildcard",
+      "project/*/task",
+      "project/neuron/hierarchical-tags/task",
+      False
+    ),
+    ( "can match empty with globstar",
+      "math/**/note",
+      "math/note",
+      True
+    )
+  ]