Remove TagTree and RelTag

felko · Apr 21, 2020 · 67e5a1c · 67e5a1c
1 parent e153f0c
commit 67e5a1c
Show file tree

Hide file tree

Showing 3 changed files with 34 additions and 76 deletions.
diff --git a/src/Neuron/Zettelkasten/Link/View.hs b/src/Neuron/Zettelkasten/Link/View.hs
@@ -69,7 +69,7 @@ renderNeuronLink store = \case
     -- Render a list of tags
     toHtml $ Some q
     let tags = runQuery store q
-    toHtml $ foldTagTree $ mkTagTree tags
+    renderTagTree $ foldTagTree $ mkTagTree tags
   where
     sortZettelsReverseChronological =
       sortOn (Down . zettelIDDay . zettelID)

diff --git a/src/Neuron/Zettelkasten/Tag/Tree.hs b/src/Neuron/Zettelkasten/Tag/Tree.hs
@@ -10,15 +10,12 @@
 {-# LANGUAGE NoImplicitPrelude #-}
 
 module Neuron.Zettelkasten.Tag.Tree
-  ( TagTree (..),
-    mkTagTree,
+  ( mkTagTree,
     foldTagTree,
-    RelTag (..),
-    getAbsoluteTag,
+    renderTagTree,
   )
 where
 
-import Data.Aeson
 import Data.Tree (Forest, Tree (..))
 import Lucid
 import Neuron.Util.Tree
@@ -27,77 +24,38 @@ import Neuron.Zettelkasten.Tag
 import Relude
 import Text.URI.QQ (queryKey)
 
-newtype TagTree = TagTree
-  {unTagTree :: Forest RelTag}
-
-instance ToJSON TagTree where
-  toJSON (TagTree tree) = toJSON $ fmap nodeToJSON tree
-    where
-      nodeToJSON (Node tag []) = toJSON tag
-      nodeToJSON (Node tag subForest) =
-        object
-          [ "tag" .= toJSON tag,
-            "subTags" .= toJSON (TagTree subForest)
-          ]
-
 -- |  Renders a nested list of relative tags
-instance ToHtml TagTree where
-  toHtmlRaw = toHtml
-
-  toHtml :: forall m. Monad m => TagTree -> HtmlT m ()
-  toHtml (TagTree tags) = div_ [class_ "tag-tree"] $ renderForest tags
-    where
-      renderForest :: Forest RelTag -> HtmlT m ()
-      renderForest forest =
-        ul_ $ do
-          forM_ forest $ \tree -> do
-            li_ $ renderTree tree
-      renderTree :: Tree RelTag -> HtmlT m ()
-      renderTree = \case
-        Node tag [] -> renderRelTag tag
-        Node tag subForest -> do
-          renderRelTag tag
-          renderForest subForest
-      renderRelTag :: RelTag -> HtmlT m ()
-      renderRelTag tag@RelTag {..} =
-        div_ [class_ "rel-tag"] $ do
-          if relTagExists
-            then do
-              let tagUrl = routeUrlRelWithQuery Route_Search [queryKey|tag|] $ unTag $ getAbsoluteTag tag
-              a_ [href_ tagUrl] $ toHtml $ unTag relTagName
-            else toHtml $ unTag relTagName
-
-data RelTag = RelTag
-  { relTagName :: Tag,
-    relTagExists :: Bool,
-    relTagRoot :: Tag
-  }
-  deriving (Eq, Ord, Show)
-
-getAbsoluteTag :: RelTag -> Tag
-getAbsoluteTag RelTag {..} = joinTags relTagRoot relTagName
-
-instance ToJSON RelTag where
-  toJSON RelTag {..} =
-    object
-      [ "name" .= relTagName,
-        "exists" .= relTagExists,
-        "root" .= relTagRoot
-      ]
-
-mkTagTree :: [Tag] -> TagTree
-mkTagTree tags = TagTree $ fmap (mapAbsolutePath toRelTag) $ mkTreeFromPaths $ fmap tagComponents tags
+renderTagTree :: forall m. Monad m => Forest (Tag, Bool) -> HtmlT m ()
+renderTagTree tags = div_ [class_ "tag-tree"] $ renderForest (Tag "") tags
+  where
+    renderForest :: Tag -> Forest (Tag, Bool) -> HtmlT m ()
+    renderForest root forest =
+      ul_ $ do
+        forM_ forest $ \tree -> do
+          li_ $ renderTree root tree
+    renderTree :: Tag -> Tree (Tag, Bool) -> HtmlT m ()
+    renderTree root = \case
+      Node tag [] -> renderTag root tag
+      Node tag subForest -> do
+        renderTag root tag
+        renderForest (joinTags root $ fst tag) subForest
+    renderTag :: Tag -> (Tag, Bool) -> HtmlT m ()
+    renderTag root (tag, exists) =
+      div_ [class_ "rel-tag"] $ do
+        if exists
+          then do
+            let tagUrl = routeUrlRelWithQuery Route_Search [queryKey|tag|] $ unTag $ joinTags root tag
+            a_ [href_ tagUrl] $ toHtml $ unTag tag
+          else toHtml $ unTag tag
+
+mkTagTree :: [Tag] -> Forest (Tag, Bool)
+mkTagTree tags = fmap (mapAbsolutePath toRelTag) $ mkTreeFromPaths $ fmap tagComponents tags
   where
     toRelTag (name :| root) =
-      let rootTag = foldr joinTags (Tag "") root
-       in RelTag name (joinTags rootTag name `elem` tags) rootTag
+      let tag = foldr joinTags name $ reverse root
+       in (name, tag `elem` tags)
 
-foldTagTree :: TagTree -> TagTree
-foldTagTree = TagTree . fmap (foldTreeOnWith (not . relTagExists) concatRelTags) . unTagTree
+foldTagTree :: Forest (Tag, Bool) -> Forest (Tag, Bool)
+foldTagTree = fmap (foldTreeOnWith (not . snd) concatRelTags)
   where
-    concatRelTags parent child =
-      RelTag
-        { relTagName = (joinTags `on` relTagName) parent child,
-          relTagExists = relTagExists child,
-          relTagRoot = relTagRoot parent
-        }
+    concatRelTags (parent, _) (child, exists) = (joinTags parent child, exists)
diff --git a/test/Neuron/Zettelkasten/Tag/TreeSpec.hs b/test/Neuron/Zettelkasten/Tag/TreeSpec.hs
@@ -20,7 +20,7 @@ spec = do
     forM_ tagTreeCases $ \(name, fmap Z.Tag -> tags, foldTree, fmap (fmap Z.Tag) -> tree) -> do
       it name $ do
         let res = bool id Z.foldTagTree foldTree $ Z.mkTagTree tags
-        fmap (fmap Z.relTagName) (Z.unTagTree res) `shouldBe` tree
+        fmap (fmap fst) res `shouldBe` tree
 
 tagTreeCases :: [(String, [Text], Bool, Forest Text)]
 tagTreeCases =