Move tree rendering to Neuron.Zettelkasten.Link.View

felko · Apr 21, 2020 · aa30f4b · aa30f4b
1 parent a71f23c
commit aa30f4b
Show file tree

Hide file tree

Showing 2 changed files with 29 additions and 30 deletions.
diff --git a/src/Neuron/Zettelkasten/Link/View.hs b/src/Neuron/Zettelkasten/Link/View.hs
@@ -1,6 +1,7 @@
 {-# LANGUAGE GADTs #-}
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE QuasiQuotes #-}
 {-# LANGUAGE Rank2Types #-}
 {-# LANGUAGE RecordWildCards #-}
 {-# LANGUAGE ScopedTypeVariables #-}
@@ -16,8 +17,9 @@ where
 
 import qualified Data.Map.Strict as Map
 import Data.Some
+import Data.Tree
 import Lucid
-import Neuron.Web.Route (Route (..))
+import Neuron.Web.Route (Route (..), routeUrlRelWithQuery)
 import Neuron.Zettelkasten.ID
 import Neuron.Zettelkasten.Link
 import Neuron.Zettelkasten.Link.Theme
@@ -31,6 +33,7 @@ import Relude
 import qualified Rib
 import qualified Text.MMark.Extension as Ext
 import Text.MMark.Extension (Extension, Inline (..))
+import Text.URI.QQ (queryKey)
 
 -- | MMark extension to transform neuron links to custom views
 neuronLinkExt :: HasCallStack => ZettelStore -> Extension
@@ -114,3 +117,27 @@ renderZettelLinkSimpleWith url title body =
   a_ [class_ "zettel-link item", href_ url, title_ title] $ do
     span_ [class_ "zettel-link-title"] $ do
       toHtml body
+
+-- |  Renders a nested list of relative 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
diff --git a/src/Neuron/Zettelkasten/Tag/Tree.hs b/src/Neuron/Zettelkasten/Tag/Tree.hs
@@ -12,41 +12,13 @@
 module Neuron.Zettelkasten.Tag.Tree
   ( mkTagTree,
     foldTagTree,
-    renderTagTree,
   )
 where
 
-import Data.Tree (Forest, Tree (..))
-import Lucid
+import Data.Tree (Forest)
 import Neuron.Util.Tree
-import Neuron.Web.Route (Route (..), routeUrlRelWithQuery)
 import Neuron.Zettelkasten.Tag
 import Relude
-import Text.URI.QQ (queryKey)
-
--- |  Renders a nested list of relative 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