Use new RelTag type for the nodes of the tag tree

felko · Apr 19, 2020 · 2c7b98e · 2c7b98e
1 parent 43b1da3
commit 2c7b98e
Show file tree

Hide file tree

Showing 2 changed files with 54 additions and 25 deletions.
diff --git a/src/Neuron/Zettelkasten/Tag.hs b/src/Neuron/Zettelkasten/Tag.hs
@@ -1,14 +1,19 @@
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
 {-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RecordWildCards #-}
 {-# LANGUAGE ViewPatterns #-}
 {-# LANGUAGE NoImplicitPrelude #-}
 
 module Neuron.Zettelkasten.Tag
   ( Tag (..),
     mkTag,
     tagToText,
-    tagTree,
-    foldedTagTree,
+    RelTag (..),
+    getAbsoluteTag,
+    TagTree,
+    mkTagTree,
+    foldTagTree,
     TagPattern (unTagPattern),
     mkTagPattern,
     tagMatch,
@@ -36,36 +41,60 @@ tagToText = toText . unTag
 tagComponents :: HasCallStack => Tag -> NonEmpty Tag
 tagComponents = fromJust . nonEmpty . coerce splitDirectories
 
-joinTags :: NonEmpty Tag -> Tag
-joinTags = coerce joinPath . toList
+joinTags :: Tag -> Tag -> Tag
+joinTags = coerce (</>)
 
-mkTagTree :: [Tag] -> Tree.Forest (Tag, Bool)
-mkTagTree = go . fmap tagComponents
+data RelTag = RelTag
+  { relTagName :: Tag,
+    relTagExists :: Bool,
+    relTagRoot :: Maybe Tag
+  }
+  deriving (Eq, Ord, Show)
+
+getAbsoluteTag :: RelTag -> Tag
+getAbsoluteTag RelTag {..} = maybe relTagName (flip joinTags relTagName) relTagRoot
+
+instance ToJSON RelTag where
+  toJSON RelTag {..} =
+    object $
+      maybeToList (fmap ("root" .=) relTagRoot)
+        ++ [ "name" .= relTagName,
+             "exists" .= relTagExists
+           ]
+
+type TagTree = Tree.Forest RelTag
+
+mkTagTree :: [Tag] -> TagTree
+mkTagTree = go Nothing . fmap tagComponents
   where
-    mkNode tagFolder subTags =
-      Tree.Node (tagFolder, any null subTags)
-        $ go
+    mkNode tagRoot tagFolder subTags =
+      Tree.Node (RelTag tagFolder (any null subTags) tagRoot)
+        $ go (Just tagFolder)
         $ catMaybes
         $ fmap nonEmpty
         $ toList subTags
-    go tags =
+    go root tags =
       let groups = fmap tail <$> groupBy head tags
-       in uncurry mkNode <$> Map.assocs groups
-
-tagTree :: [Tag] -> Tree.Forest Tag
-tagTree = fmap (fmap fst) . mkTagTree
+       in uncurry (mkNode root) <$> Map.assocs groups
 
-foldedTagTree :: [Tag] -> Tree.Forest Tag
-foldedTagTree = fmap go . mkTagTree
+foldTagTree :: TagTree -> TagTree
+foldTagTree = fmap go
   where
-    go :: Tree.Tree (Tag, Bool) -> Tree.Tree Tag
+    go :: Tree.Tree RelTag -> Tree.Tree RelTag
     go = \case
-      Tree.Node (tag, _) [] ->
-        Tree.Node tag []
-      Tree.Node (tag, False) (fmap go -> [Tree.Node tag' subForest]) ->
-        Tree.Node (joinTags (tag :| [tag'])) subForest
-      Tree.Node (tag, _) subForest ->
-        Tree.Node tag $ fmap go subForest
+      Tree.Node relTag [] ->
+        Tree.Node relTag []
+      Tree.Node parentTag (fmap go -> [Tree.Node subTag subForest])
+        | not (relTagExists parentTag) ->
+          let foldedRelTag =
+                RelTag
+                  { relTagName = (joinTags `on` relTagName) parentTag subTag,
+                    relTagExists = relTagExists subTag,
+                    relTagRoot = relTagRoot parentTag
+                  }
+           in Tree.Node foldedRelTag subForest
+      Tree.Node relTag subForest ->
+        Tree.Node relTag $ fmap go subForest
 
 newtype TagPattern = TagPattern {unTagPattern :: FilePattern}
   deriving (Eq, Show)

diff --git a/test/Neuron/Zettelkasten/TagSpec.hs b/test/Neuron/Zettelkasten/TagSpec.hs
@@ -25,8 +25,8 @@ spec = do
   describe "Tag tree" $ do
     forM_ tagTreeCases $ \(name, fmap Z.Tag -> tags, foldTree, fmap (fmap Z.Tag) -> tree) -> do
       it name $ do
-        let res = bool Z.tagTree Z.foldedTagTree foldTree $ tags
-        res `shouldBe` tree
+        let res = bool id Z.foldTagTree foldTree $ Z.mkTagTree tags
+        fmap (fmap Z.relTagName) res `shouldBe` tree
 
 tagMatchCases :: [(String, String, [String], [String])]
 tagMatchCases =