From 9e69e0c70981188024832684d016bd6ce03081f8 Mon Sep 17 00:00:00 2001 From: Sridhar Ratnakumar Date: Thu, 30 Apr 2020 10:19:39 -0400 Subject: [PATCH] Switch to regular link style cf. #151 --- neuron.cabal | 3 +- src/Neuron/Web/View.hs | 37 +++++++------- src/Neuron/Zettelkasten/Error.hs | 6 +-- src/Neuron/Zettelkasten/Query/Error.hs | 2 +- src/Neuron/Zettelkasten/Query/Theme.hs | 31 ++++++------ src/Neuron/Zettelkasten/Query/View.hs | 53 ++++++++------------- test/Neuron/Zettelkasten/Query/ThemeSpec.hs | 21 ++++---- 7 files changed, 69 insertions(+), 84 deletions(-) diff --git a/neuron.cabal b/neuron.cabal index 2793cf29d..0a2a80a03 100644 --- a/neuron.cabal +++ b/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 diff --git a/src/Neuron/Web/View.hs b/src/Neuron/Web/View.hs index 0ffedc9af..e4d3b6a15 100644 --- a/src/Neuron/Web/View.hs +++ b/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,11 +210,11 @@ 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 @@ -222,10 +222,10 @@ renderForest isRoot maxLevel ltheme g trees = 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 diff --git a/src/Neuron/Zettelkasten/Error.hs b/src/Neuron/Zettelkasten/Error.hs index 12c88ab95..2f3b5cf3a 100644 --- a/src/Neuron/Zettelkasten/Error.hs +++ b/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 [ "", diff --git a/src/Neuron/Zettelkasten/Query/Error.hs b/src/Neuron/Zettelkasten/Query/Error.hs index 4aa21d15d..10590ad1e 100644 --- a/src/Neuron/Zettelkasten/Query/Error.hs +++ b/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) diff --git a/src/Neuron/Zettelkasten/Query/Theme.hs b/src/Neuron/Zettelkasten/Query/Theme.hs index 9a85efe4d..2e16b854e 100644 --- a/src/Neuron/Zettelkasten/Query/Theme.hs +++ b/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 = diff --git a/src/Neuron/Zettelkasten/Query/View.hs b/src/Neuron/Zettelkasten/Query/View.hs index 336ff0228..6859fd5a7 100644 --- a/src/Neuron/Zettelkasten/Query/View.hs +++ b/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 () diff --git a/test/Neuron/Zettelkasten/Query/ThemeSpec.hs b/test/Neuron/Zettelkasten/Query/ThemeSpec.hs index e5a09f994..52a5b6524 100644 --- a/test/Neuron/Zettelkasten/Query/ThemeSpec.hs +++ b/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)