Switch to regular link style

cf. #151

neuron.cabal

@@ -64,7 +64,8 @@ common library-common
     dependent-sum,
     dependent-sum-template,
     aeson-gadt-th,
-    parser-combinators
+    parser-combinators,
+    data-default
 
 library
   import: library-common

src/Neuron/Web/View.hs

@@ -25,6 +25,7 @@ import Clay hiding (id, ms, object, reverse, s, style, type_)
 import qualified Clay as C
 import Data.Aeson ((.=), object)
 import qualified Data.Aeson.Text as Aeson
+import Data.Default (def)
 import Data.FileEmbed (embedStringFile)
 import Data.Foldable (maximum)
 import qualified Data.Set as Set
@@ -39,7 +40,6 @@ import Neuron.Zettelkasten.Connection
 import qualified Neuron.Zettelkasten.Graph as G
 import Neuron.Zettelkasten.Graph (ZettelGraph)
 import Neuron.Zettelkasten.ID (ZettelID (..), zettelIDSourceFileName, zettelIDText)
-import Neuron.Zettelkasten.Query.Theme (LinkTheme (..))
 import Neuron.Zettelkasten.Query.View (renderZettelLink)
 import Neuron.Zettelkasten.Zettel
 import Relude
@@ -96,7 +96,7 @@ renderIndex Config {..} graph = do
       Left (toList -> cyc) -> div_ [class_ "ui orange segment"] $ do
         h2_ "Cycle detected"
         forM_ cyc $ \zettel ->
-          li_ $ renderZettelLink LinkTheme_Default zettel
+          li_ $ renderZettelLink def zettel
       _ -> mempty
     let clusters = G.categoryClusters graph
     p_ $ do
@@ -105,7 +105,7 @@ renderIndex Config {..} graph = do
     forM_ clusters $ \forest ->
       div_ [class_ $ "ui stacked " <> Theme.semanticColor neuronTheme <> " segment"] $ do
         -- Forest of zettels, beginning with mother vertices.
-        ul_ $ renderForest True Nothing LinkTheme_Default graph forest
+        ul_ $ renderForest True Nothing True graph forest
     renderBrandFooter True
   -- See ./src-purescript/hello/README.md
   script_ helloScript
@@ -151,16 +151,16 @@ renderZettel config@Config {..} (graph, (z@Zettel {..}, ext)) zid = do
       div_ [class_ "ui two column grid"] $ do
         div_ [class_ "column"] $ do
           div_ [class_ "ui header"] "Down"
-          ul_ $ renderForest True (Just 2) LinkTheme_Simple graph $
+          ul_ $ renderForest True (Just 2) False graph $
             G.frontlinkForest Folgezettel z graph
         div_ [class_ "column"] $ do
           div_ [class_ "ui header"] "Up"
           ul_ $ do
-            renderForest True Nothing LinkTheme_Simple graph $
+            renderForest True Nothing False graph $
               G.backlinkForest Folgezettel z graph
           div_ [class_ "ui header"] "Other backlinks"
           ul_ $ do
-            renderForest True Nothing LinkTheme_Simple graph
+            renderForest True Nothing False graph
               $ fmap (flip Node [])
               $ G.backlinks OrdinaryConnection z graph
     div_ [class_ "ui inverted black bottom attached footer segment"] $ do
@@ -210,22 +210,22 @@ renderForest ::
   Monad m =>
   Bool ->
   Maybe Int ->
-  LinkTheme ->
+  Bool ->
   ZettelGraph ->
   [Tree Zettel] ->
   HtmlT m ()
-renderForest isRoot maxLevel ltheme g trees =
+renderForest isRoot maxLevel renderingFullTree g trees =
   case maxLevel of
     Just 0 -> mempty
     _ -> do
       forM_ (sortForest trees) $ \(Node zettel subtrees) ->
         li_ $ do
           let zettelDiv =
                 div_
-                  [class_ $ bool "" "ui black label" $ ltheme == LinkTheme_Default]
+                  [class_ $ bool "" "ui black label" renderingFullTree]
           bool id zettelDiv isRoot $
-            renderZettelLink ltheme zettel
-          when (ltheme == LinkTheme_Default) $ do
+            renderZettelLink def zettel
+          when renderingFullTree $ do
             " "
             case G.backlinks Folgezettel zettel g of
               conns@(_ : _ : _) ->
@@ -234,7 +234,7 @@ renderForest isRoot maxLevel ltheme g trees =
                   i_ [class_ "fas fa-link", title_ $ zettelIDText (zettelID zettel2) <> " " <> zettelTitle zettel2] mempty
               _ -> mempty
           when (length subtrees > 0) $ do
-            ul_ $ renderForest False ((\n -> n - 1) <$> maxLevel) ltheme g subtrees
+            ul_ $ renderForest False ((\n -> n - 1) <$> maxLevel) renderingFullTree g subtrees
   where
     -- Sort trees so that trees containing the most recent zettel (by ID) come first.
     sortForest = reverse . sortOn maximum
@@ -243,19 +243,16 @@ style :: Config -> Css
 style Config {..} = do
   let neuronTheme = Theme.mkTheme theme
       linkColor = Theme.withRgb neuronTheme C.rgb
-      linkTitleColor = C.auto
-  "span.zettel-link span.zettel-link-idlink a" ? do
-    C.fontFamily [] [C.monospace]
+  "span.zettel-link-container span.zettel-link a" ? do
     C.fontWeight C.bold
     C.color linkColor
     C.textDecoration C.none
-  "span.zettel-link span.zettel-link-idlink a:hover" ? do
+  "span.zettel-link-container span.zettel-link a:hover" ? do
     C.backgroundColor linkColor
     C.color C.white
-  ".zettel-link .zettel-link-title" ? do
-    C.paddingLeft $ em 0.3
-    C.fontWeight C.bold
-    C.color linkTitleColor
+  "span.zettel-link-container span.extra" ? do
+    C.color C.auto
+    C.paddingRight $ em 0.3
   "div.z-index" ? do
     C.ul ? do
       C.listStyleType C.square

src/Neuron/Zettelkasten/Error.hs

@@ -10,7 +10,7 @@ where
 
 import Neuron.Zettelkasten.ID (ZettelID, zettelIDSourceFileName, zettelIDText)
 import Neuron.Zettelkasten.Query.Error (InvalidQuery (..), QueryError (..), queryErrorUri)
-import Neuron.Zettelkasten.Query.Theme (InvalidLinkTheme (..))
+import Neuron.Zettelkasten.Query.Theme (InvalidLinkView (..))
 import Relude
 import qualified Text.Show
 import qualified Text.URI as URI
@@ -37,8 +37,8 @@ instance Show NeuronError where
                 InvalidQuery_InvalidID e'' ->
                   "with invalidID: " <> show e''
               QueryError_InvalidQueryView _ e' -> case e' of
-                InvalidLinkTheme theme ->
-                  "with invalid link theme (" <> theme <> ")"
+                InvalidLinkView view ->
+                  "with invalid link view (" <> view <> ")"
      in toString $
           unlines
             [ "",

src/Neuron/Zettelkasten/Query/Error.hs

@@ -10,7 +10,7 @@ import Text.URI
 
 data QueryError
   = QueryError_InvalidQuery URI InvalidQuery
-  | QueryError_InvalidQueryView URI InvalidLinkTheme
+  | QueryError_InvalidQueryView URI InvalidLinkView
   | QueryError_ZettelNotFound URI ZettelID
   deriving (Eq, Show)
 

src/Neuron/Zettelkasten/Query/Theme.hs

@@ -10,6 +10,7 @@
 module Neuron.Zettelkasten.Query.Theme where
 
 import Control.Monad.Except
+import Data.Default
 import Data.TagTree (Tag)
 import Neuron.Zettelkasten.Zettel
 import Relude
@@ -25,36 +26,34 @@ type instance QueryTheme [Zettel] = ZettelsView
 type instance QueryTheme (Map Tag Natural) = ()
 
 data ZettelsView = ZettelsView
-  { zettelsViewLinkTheme :: LinkTheme,
+  { zettelsViewLinkView :: LinkView,
     zettelsViewGroupByTag :: Bool
   }
   deriving (Eq, Show, Ord)
 
-type ZettelView = LinkTheme
+type ZettelView = LinkView
 
-data LinkTheme
-  = LinkTheme_Default
-  | LinkTheme_Simple
-  | LinkTheme_WithDate
+data LinkView = LinkView
+  { linkViewShowDate :: Bool
+  }
   deriving (Eq, Show, Ord)
 
-data InvalidLinkTheme = InvalidLinkTheme Text
+instance Default LinkView where
+  def = LinkView False
+
+data InvalidLinkView = InvalidLinkView Text
   deriving (Eq, Show)
 
-zettelsViewFromURI :: MonadError InvalidLinkTheme m => URI.URI -> m ZettelsView
+zettelsViewFromURI :: MonadError InvalidLinkView m => URI.URI -> m ZettelsView
 zettelsViewFromURI uri =
   ZettelsView
     <$> linkThemeFromURI uri
     <*> pure (hasQueryFlag [queryKey|grouped|] uri)
 
-linkThemeFromURI :: MonadError InvalidLinkTheme m => URI.URI -> m LinkTheme
-linkThemeFromURI uri =
-  fmap (fromMaybe LinkTheme_Default) $ case getQueryParam [queryKey|linkTheme|] uri of
-    Just "default" -> pure $ Just LinkTheme_Default
-    Just "simple" -> pure $ Just LinkTheme_Simple
-    Just "withDate" -> pure $ Just LinkTheme_WithDate
-    Just x -> throwError $ InvalidLinkTheme x
-    Nothing -> pure Nothing
+linkThemeFromURI :: MonadError InvalidLinkView m => URI.URI -> m LinkView
+linkThemeFromURI uri = do
+  let showDate = maybe False (bool False True . (== "withDate")) $ getQueryParam [queryKey|linkTheme|] uri
+  pure $ def {linkViewShowDate = showDate}
 
 getQueryParam :: URI.RText 'URI.QueryKey -> URI.URI -> Maybe Text
 getQueryParam k uri =

src/Neuron/Zettelkasten/Query/View.hs

@@ -25,7 +25,7 @@ import Neuron.Web.Route (Route (..), routeUrlRelWithQuery)
 import Neuron.Zettelkasten.ID
 import Neuron.Zettelkasten.Query
 import Neuron.Zettelkasten.Query.Eval (EvaluatedQuery (..))
-import Neuron.Zettelkasten.Query.Theme (LinkTheme (..), ZettelsView (..))
+import Neuron.Zettelkasten.Query.Theme (LinkView (..), ZettelsView (..))
 import Neuron.Zettelkasten.Zettel
 import Relude
 import qualified Rib
@@ -41,13 +41,13 @@ renderQueryLink = \case
     case zettelsViewGroupByTag evaluatedQueryTheme of
       False ->
         -- Render a list of links
-        renderZettelLinks (zettelsViewLinkTheme evaluatedQueryTheme) evaluatedQueryResult
+        renderZettelLinks (zettelsViewLinkView evaluatedQueryTheme) evaluatedQueryResult
       True ->
         forM_ (Map.toList $ groupZettelsByTagsMatching pats evaluatedQueryResult) $ \(tag, zettelGrp) -> do
           span_ [class_ "ui basic pointing below grey label"] $ do
             i_ [class_ "tag icon"] mempty
             toHtml $ unTag tag
-          renderZettelLinks (zettelsViewLinkTheme evaluatedQueryTheme) zettelGrp
+          renderZettelLinks (zettelsViewLinkView evaluatedQueryTheme) zettelGrp
   q@(Query_Tags _) :=> EvaluatedQuery {..} -> do
     -- Render a list of tags
     toHtml $ Some q
@@ -57,44 +57,29 @@ renderQueryLink = \case
     groupZettelsByTagsMatching pats matches =
       fmap sortZettelsReverseChronological $ Map.fromListWith (<>) $ flip concatMap matches $ \z ->
         flip concatMap (zettelTags z) $ \t -> [(t, [z]) | tagMatchAny pats t]
-    renderZettelLinks :: LinkTheme -> [Zettel] -> Html ()
+    renderZettelLinks :: LinkView -> [Zettel] -> Html ()
     renderZettelLinks ltheme zs =
       ul_ $ do
         forM_ zs $ \z ->
           li_ $ renderZettelLink ltheme z
 
 -- | Render a link to an individual zettel.
-renderZettelLink :: forall m. Monad m => LinkTheme -> Zettel -> HtmlT m ()
-renderZettelLink ltheme Zettel {..} = do
+renderZettelLink :: forall m. Monad m => LinkView -> Zettel -> HtmlT m ()
+renderZettelLink LinkView {..} Zettel {..} = do
   let zurl = Rib.routeUrlRel $ Route_Zettel zettelID
-      renderDefault :: ToHtml a => a -> HtmlT m ()
-      renderDefault linkInline = do
-        span_ [class_ "zettel-link"] $ do
-          span_ [class_ "zettel-link-idlink"] $ do
-            a_ [href_ zurl, title_ zettelTitle] $ toHtml linkInline
-          span_ [class_ "zettel-link-title"] $ do
-            toHtml zettelTitle
-  case ltheme of
-    LinkTheme_Default ->
-      -- Special consistent styling for Zettel links
-      -- Uses ZettelID as link text. Title is displayed aside.
-      renderDefault zettelID
-    LinkTheme_WithDate ->
-      case zettelIDDay zettelID of
-        Just day ->
-          renderDefault $ show @Text day
-        Nothing ->
-          -- Fallback to using zid
-          renderDefault zettelID
-    LinkTheme_Simple ->
-      renderZettelLinkSimpleWith zurl (zettelIDText zettelID) zettelTitle
-
--- | Render a normal looking zettel link with a custom body.
-renderZettelLinkSimpleWith :: forall m a. (Monad m, ToHtml a) => Text -> Text -> a -> HtmlT m ()
-renderZettelLinkSimpleWith url title body =
-  a_ [class_ "zettel-link item", href_ url, title_ title] $ do
-    span_ [class_ "zettel-link-title"] $ do
-      toHtml body
+      mextra =
+        if linkViewShowDate
+          then case zettelIDDay zettelID of
+            Just day ->
+              Just $ toHtml $ show @Text day
+            Nothing ->
+              Nothing
+          else Nothing
+  span_ [class_ "zettel-link-container"] $ do
+    forM_ mextra $ \extra ->
+      span_ [class_ "extra"] extra
+    span_ [class_ "zettel-link"] $ do
+      a_ [href_ zurl, title_ (zettelIDText zettelID)] $ toHtml zettelTitle
 
 -- |  Render a tag tree along with the count of zettels tagged with it
 renderTagTree :: forall m. Monad m => Forest (NonEmpty TagNode, Natural) -> HtmlT m ()

test/Neuron/Zettelkasten/Query/ThemeSpec.hs

@@ -8,6 +8,7 @@ module Neuron.Zettelkasten.Query.ThemeSpec
   )
 where
 
+import Data.Default (def)
 import Neuron.Zettelkasten.Query.Theme
 import Relude
 import Test.Hspec
@@ -16,15 +17,17 @@ import Util
 spec :: Spec
 spec =
   describe "Link theme extraction from URI" $ do
-    it "Parse basic link theme" $ do
-      parseURIWith linkThemeFromURI "zquery://search?linkTheme=default"
-        `shouldBe` Right LinkTheme_Default
-      parseURIWith linkThemeFromURI "zquery://search?linkTheme=withDate"
-        `shouldBe` Right LinkTheme_WithDate
-      parseURIWith linkThemeFromURI "zcfquery://search?linkTheme=simple"
-        `shouldBe` Right LinkTheme_Simple
+    describe "Legacy link theme" $ do
+      it "Parse linkTheme" $ do
+        parseURIWith linkThemeFromURI "zquery://search?linkTheme=default"
+          `shouldBe` Right (LinkView False)
+        parseURIWith linkThemeFromURI "zquery://search?linkTheme=withDate"
+          `shouldBe` Right (LinkView True)
+      it "Parse 'simple' as default" $ do
+        parseURIWith linkThemeFromURI "zcfquery://search?linkTheme=simple"
+          `shouldBe` Right (LinkView False)
     it "Parse grouped query flag" $ do
       parseURIWith zettelsViewFromURI "zquery://search?tag=foo&grouped"
-        `shouldBe` Right (ZettelsView LinkTheme_Default True)
+        `shouldBe` Right (ZettelsView def True)
       parseURIWith zettelsViewFromURI "zquery://search?tag=foo"
-        `shouldBe` Right (ZettelsView LinkTheme_Default False)
+        `shouldBe` Right (ZettelsView def False)