Implement tag tree and tag folding

src/Neuron/Zettelkasten/Tag.hs

@@ -7,14 +7,21 @@ module Neuron.Zettelkasten.Tag
   ( Tag (..),
     mkTag,
     tagToText,
+    mkTagTree,
+    foldTagTree,
     TagPattern (unTagPattern),
     mkTagPattern,
     tagMatch,
   )
 where
 
 import Data.Aeson
+import qualified Data.Map as Map
+import qualified Data.Tree as Tree
 import Relude
+import Relude.Extra.Group (groupBy)
+import Relude.Unsafe (fromJust)
+import System.FilePath
 import System.FilePattern
 
 newtype Tag = Tag {unTag :: FilePath}
@@ -26,6 +33,33 @@ mkTag = Tag . toString
 tagToText :: Tag -> Text
 tagToText = toText . unTag
 
+tagComponents :: HasCallStack => Tag -> NonEmpty Tag
+tagComponents = fromJust . nonEmpty . coerce splitDirectories
+
+joinTags :: NonEmpty Tag -> Tag
+joinTags = coerce joinPath . toList
+
+mkTagTree :: [Tag] -> Tree.Forest Tag
+mkTagTree = go . fmap tagComponents
+  where
+    mkNode tagFolder subTags =
+      Tree.Node tagFolder
+        $ go
+        $ catMaybes
+        $ fmap nonEmpty
+        $ toList subTags
+    go tags =
+      let groups = fmap tail <$> groupBy head tags
+       in uncurry mkNode <$> Map.assocs groups
+
+foldTagTree :: Tree.Forest Tag -> Tree.Forest Tag
+foldTagTree = fmap go
+  where
+    go tree@(Tree.Node tag subForest) = case subForest of
+      [] -> tree
+      [Tree.Node tag' subForest'] -> Tree.Node (joinTags (tag :| [tag'])) subForest'
+      _ -> Tree.Node tag (foldTagTree subForest)
+
 newtype TagPattern = TagPattern {unTagPattern :: FilePattern}
   deriving (Eq, Show)