From 11f14094a2999070c6f7c2aa1271a86a3728a993 Mon Sep 17 00:00:00 2001 From: Sridhar Ratnakumar Date: Sun, 19 Apr 2020 14:12:47 -0400 Subject: [PATCH 1/3] Group zettels query by the matching tags Adds a `?grouped` flag that enabled this behaviour. --- src/Neuron/Zettelkasten/Link.hs | 8 ++-- src/Neuron/Zettelkasten/Link/Theme.hs | 43 +++++++++++++++++----- src/Neuron/Zettelkasten/Link/View.hs | 35 +++++++++++++----- src/Neuron/Zettelkasten/Query.hs | 11 ++---- src/Neuron/Zettelkasten/Tag.hs | 13 ++++++- test/Neuron/Zettelkasten/Link/ThemeSpec.hs | 34 +++++++++++++++++ test/Neuron/Zettelkasten/LinkSpec.hs | 7 ++-- 7 files changed, 116 insertions(+), 35 deletions(-) create mode 100644 test/Neuron/Zettelkasten/Link/ThemeSpec.hs diff --git a/src/Neuron/Zettelkasten/Link.hs b/src/Neuron/Zettelkasten/Link.hs index 9e0c1a74b..80cf991be 100644 --- a/src/Neuron/Zettelkasten/Link.hs +++ b/src/Neuron/Zettelkasten/Link.hs @@ -35,9 +35,9 @@ type instance QueryConnection [Tag] = () type family QueryViewTheme q -type instance QueryViewTheme Zettel = LinkTheme +type instance QueryViewTheme Zettel = ZettelView -type instance QueryViewTheme [Zettel] = LinkTheme +type instance QueryViewTheme [Zettel] = ZettelsView type instance QueryViewTheme [Tag] = () @@ -66,9 +66,9 @@ neuronLinkFromMarkdownLink ml@MarkdownLink {markdownLinkUri = uri} = do Just someQ -> Just <$> do withSome someQ $ \q -> case q of Query_ZettelByID _ -> - pure $ NeuronLink (q, connectionFromURI uri, linkThemeFromURI uri) + NeuronLink . (q,connectionFromURI uri,) <$> linkThemeFromURI uri Query_ZettelsByTag _ -> - pure $ NeuronLink (q, connectionFromURI uri, linkThemeFromURI uri) + NeuronLink . (q,connectionFromURI uri,) <$> zettelsViewFromURI uri Query_Tags _ -> pure $ NeuronLink (q, (), ()) diff --git a/src/Neuron/Zettelkasten/Link/Theme.hs b/src/Neuron/Zettelkasten/Link/Theme.hs index 80381d738..042df1b22 100644 --- a/src/Neuron/Zettelkasten/Link/Theme.hs +++ b/src/Neuron/Zettelkasten/Link/Theme.hs @@ -1,4 +1,5 @@ {-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} @@ -9,26 +10,48 @@ module Neuron.Zettelkasten.Link.Theme where +import Control.Monad.Except import Relude import qualified Text.URI as URI +data ZettelsView = ZettelsView + { zettelsViewLinkTheme :: LinkTheme, + zettelsViewGroupByTag :: Bool + } + deriving (Eq, Show, Ord) + +type ZettelView = LinkTheme + data LinkTheme = LinkTheme_Default | LinkTheme_Simple | LinkTheme_WithDate deriving (Eq, Show, Ord) --- TODO: MonadError -linkThemeFromURI :: HasCallStack => URI.URI -> LinkTheme -linkThemeFromURI uri = - fromMaybe LinkTheme_Default $ listToMaybe $ flip mapMaybe (URI.uriQuery uri) $ \case - URI.QueryFlag _ -> Nothing +zettelsViewFromURI :: MonadError Text m => URI.URI -> m ZettelsView +zettelsViewFromURI uri = + ZettelsView + <$> linkThemeFromURI uri + <*> groupByTag + where + groupByTag = do + x <- fmap (listToMaybe . catMaybes) $ flip traverse (URI.uriQuery uri) $ \case + URI.QueryFlag (URI.unRText -> key) | key == "grouped" -> + pure $ Just True + _ -> pure Nothing + pure $ fromMaybe False x + +linkThemeFromURI :: MonadError Text m => URI.URI -> m LinkTheme +linkThemeFromURI uri = do + ltm <- fmap (listToMaybe . catMaybes) $ flip traverse (URI.uriQuery uri) $ \case + URI.QueryFlag _ -> pure Nothing URI.QueryParam (URI.unRText -> key) (URI.unRText -> val) -> case key of "linkTheme" -> case val of - "default" -> Just LinkTheme_Default - "simple" -> Just LinkTheme_Simple - "withDate" -> Just LinkTheme_WithDate - _ -> error $ "Unknown link theme: " <> val - _ -> Nothing + "default" -> pure $ Just LinkTheme_Default + "simple" -> pure $ Just LinkTheme_Simple + "withDate" -> pure $ Just LinkTheme_WithDate + _ -> throwError $ "Unknown link theme: " <> val + _ -> pure Nothing + pure $ fromMaybe LinkTheme_Default ltm diff --git a/src/Neuron/Zettelkasten/Link/View.hs b/src/Neuron/Zettelkasten/Link/View.hs index 29d00358c..9fcb0649e 100644 --- a/src/Neuron/Zettelkasten/Link/View.hs +++ b/src/Neuron/Zettelkasten/Link/View.hs @@ -1,4 +1,5 @@ {-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} @@ -17,16 +18,17 @@ module Neuron.Zettelkasten.Link.View ) where +import qualified Data.Map.Strict as Map import Data.Some import Lucid import Neuron.Web.Route (Route (..), routeUrlRelWithQuery) import Neuron.Zettelkasten.ID import Neuron.Zettelkasten.Link -import Neuron.Zettelkasten.Link.Theme (LinkTheme (..)) +import Neuron.Zettelkasten.Link.Theme import Neuron.Zettelkasten.Markdown (MarkdownLink (..)) import Neuron.Zettelkasten.Query import Neuron.Zettelkasten.Store -import Neuron.Zettelkasten.Tag (Tag (unTag)) +import Neuron.Zettelkasten.Tag (Tag (unTag), tagMatchAny) import Neuron.Zettelkasten.Zettel import Relude import qualified Rib @@ -51,18 +53,22 @@ neuronLinkExt store = f inline -- | Render the custom view for the given neuron link -renderNeuronLink :: Monad m => ZettelStore -> NeuronLink -> HtmlT m () +renderNeuronLink :: forall m. Monad m => ZettelStore -> NeuronLink -> HtmlT m () renderNeuronLink store = \case NeuronLink (Query_ZettelByID zid, _conn, linkTheme) -> -- Render a single link renderZettelLink linkTheme $ lookupStore zid store - NeuronLink (q@(Query_ZettelsByTag _pats), _conn, linkTheme) -> do - -- Render a list of links + NeuronLink (q@(Query_ZettelsByTag pats), _conn, ZettelsView {..}) -> do + let zettels = sortZettelsReverseChronological $ runQuery store q toHtml $ Some q - let zettels = sortOn Down $ zettelID <$> runQuery store q - ul_ $ do - forM_ zettels $ \zid -> - li_ $ renderZettelLink linkTheme $ lookupStore zid store + case zettelsViewGroupByTag of + False -> + -- Render a list of links + renderZettelLinks zettelsViewLinkTheme zettels + True -> + forM_ (Map.toList $ groupZettelsByTagsMatching pats zettels) $ \(tag, zettelGrp) -> do + span_ [class_ "ui basic pointing below grey label"] $ toHtml $ unTag tag + renderZettelLinks zettelsViewLinkTheme zettelGrp NeuronLink (q@(Query_Tags _), (), ()) -> do -- Render a list of tags toHtml $ Some q @@ -71,6 +77,17 @@ renderNeuronLink store = \case forM_ tags $ \(unTag -> tag) -> do let tagUrl = routeUrlRelWithQuery Route_Search [queryKey|tag|] tag li_ $ a_ [href_ tagUrl] $ toHtml tag + where + sortZettelsReverseChronological = + sortOn (Down . zettelIDDay . zettelID) + groupZettelsByTagsMatching pats zettels = + fmap sortZettelsReverseChronological $ Map.fromListWith (<>) $ flip concatMap zettels $ \z -> + flip concatMap (zettelTags z) $ \t -> [(t, [z]) | tagMatchAny pats t] + renderZettelLinks :: LinkTheme -> [Zettel] -> HtmlT m () + renderZettelLinks ltheme zettels = + ul_ $ do + forM_ zettels $ \z -> + li_ $ renderZettelLink ltheme z -- | Render a link to an individual zettel. renderZettelLink :: forall m. Monad m => LinkTheme -> Zettel -> HtmlT m () diff --git a/src/Neuron/Zettelkasten/Query.hs b/src/Neuron/Zettelkasten/Query.hs index f2cb07abe..2e7f5aeae 100644 --- a/src/Neuron/Zettelkasten/Query.hs +++ b/src/Neuron/Zettelkasten/Query.hs @@ -56,10 +56,10 @@ instance ToHtml (Some Query) where in span_ [class_ "ui basic pointing below black label", title_ desc] $ toHtml qs Some (Query_Tags []) -> "All tags" - Some (Query_Tags (fmap unTagPattern -> pats)) -> + Some (Query_Tags (fmap unTagPattern -> pats)) -> do let qs = intercalate ", " pats - desc = toText $ "Tags matching '" <> qs <> "'" - in span_ [class_ "ui basic pointing below grey label", title_ desc] $ toHtml qs + "Tags matching: " + toHtml qs type QueryResults = [Zettel] @@ -113,10 +113,7 @@ runQuery store = \case Query_Tags [] -> allTags Query_Tags pats -> - -- TODO: Use step from https://hackage.haskell.org/package/filepattern-0.1.2/docs/System-FilePattern.html#v:step - -- for efficient matching. - flip filter allTags $ \t -> - any (`tagMatch` t) pats + filter (tagMatchAny pats) allTags where allTags = Set.toList $ Set.fromList $ foldMap zettelTags (Map.elems store) diff --git a/src/Neuron/Zettelkasten/Tag.hs b/src/Neuron/Zettelkasten/Tag.hs index f23840d55..28785ccf5 100644 --- a/src/Neuron/Zettelkasten/Tag.hs +++ b/src/Neuron/Zettelkasten/Tag.hs @@ -8,6 +8,7 @@ module Neuron.Zettelkasten.Tag TagPattern (unTagPattern), mkTagPattern, tagMatch, + tagMatchAny, ) where @@ -22,7 +23,15 @@ newtype TagPattern = TagPattern {unTagPattern :: FilePattern} deriving (Eq, Show) mkTagPattern :: Text -> TagPattern -mkTagPattern = TagPattern . toString +mkTagPattern = + TagPattern . toString tagMatch :: TagPattern -> Tag -> Bool -tagMatch (TagPattern pat) (Tag tag) = pat ?== toString tag +tagMatch (TagPattern pat) (Tag tag) = + pat ?== toString tag + +tagMatchAny :: [TagPattern] -> Tag -> Bool +tagMatchAny pats tag = + -- TODO: Use step from https://hackage.haskell.org/package/filepattern-0.1.2/docs/System-FilePattern.html#v:step + -- for efficient matching. + any (`tagMatch` tag) pats diff --git a/test/Neuron/Zettelkasten/Link/ThemeSpec.hs b/test/Neuron/Zettelkasten/Link/ThemeSpec.hs new file mode 100644 index 000000000..be88baf8b --- /dev/null +++ b/test/Neuron/Zettelkasten/Link/ThemeSpec.hs @@ -0,0 +1,34 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE NoImplicitPrelude #-} + +module Neuron.Zettelkasten.Link.ThemeSpec + ( spec, + ) +where + +import Neuron.Zettelkasten.Link.Theme +import Relude +import Test.Hspec +import Text.URI (URI, mkURI) + +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 + it "Parse grouped query flag" $ do + parseURIWith zettelsViewFromURI "zquery://search?tag=foo&grouped" + `shouldBe` Right (ZettelsView LinkTheme_Default True) + parseURIWith zettelsViewFromURI "zquery://search?tag=foo" + `shouldBe` Right (ZettelsView LinkTheme_Default False) + where + parseURIWith :: (URI -> Either Text a) -> Text -> Either Text a + parseURIWith f = + either (Left . toText . displayException) f . mkURI diff --git a/test/Neuron/Zettelkasten/LinkSpec.hs b/test/Neuron/Zettelkasten/LinkSpec.hs index b4deba883..2cd5a216d 100644 --- a/test/Neuron/Zettelkasten/LinkSpec.hs +++ b/test/Neuron/Zettelkasten/LinkSpec.hs @@ -8,7 +8,7 @@ where import Neuron.Zettelkasten.ID import Neuron.Zettelkasten.Link -import Neuron.Zettelkasten.Link.Theme (LinkTheme (..)) +import Neuron.Zettelkasten.Link.Theme (LinkTheme (..), ZettelsView (..)) import Neuron.Zettelkasten.Markdown (MarkdownLink (..)) import Neuron.Zettelkasten.Query import Neuron.Zettelkasten.Tag @@ -20,6 +20,7 @@ spec :: Spec spec = describe "NeuronLink" $ do let zid = parseZettelID "1234567" + zettelsView = ZettelsView LinkTheme_Default False it "alias link" $ mkMarkdownLink "1234567" "1234567" `shouldParseAs` Just (NeuronLink (Query_ZettelByID zid, Folgezettel, LinkTheme_Default)) @@ -40,10 +41,10 @@ spec = `shouldParseAs` Just (NeuronLink (Query_ZettelByID zid, OrdinaryConnection, LinkTheme_Default)) it "zquery: link" $ mkMarkdownLink "." "zquery://search?tag=science" - `shouldParseAs` Just (NeuronLink (Query_ZettelsByTag [mkTagPattern "science"], Folgezettel, LinkTheme_Default)) + `shouldParseAs` Just (NeuronLink (Query_ZettelsByTag [mkTagPattern "science"], Folgezettel, zettelsView)) it "zcfquery: link" $ mkMarkdownLink "." "zcfquery://search?tag=science" - `shouldParseAs` Just (NeuronLink (Query_ZettelsByTag [mkTagPattern "science"], OrdinaryConnection, LinkTheme_Default)) + `shouldParseAs` Just (NeuronLink (Query_ZettelsByTag [mkTagPattern "science"], OrdinaryConnection, zettelsView)) it "normal link" $ do mkMarkdownLink "foo bar" "https://www.google.com" `shouldParseAs` Nothing From e991c44da1ffda5617e2e445f1bf5876bb3b243c Mon Sep 17 00:00:00 2001 From: Sridhar Ratnakumar Date: Sun, 19 Apr 2020 14:14:32 -0400 Subject: [PATCH 2/3] Add documentation Also reformat using default emacs flow thingy --- guide/2011506.md | 24 +++++++++++++++++++----- 1 file changed, 19 insertions(+), 5 deletions(-) diff --git a/guide/2011506.md b/guide/2011506.md index 266ffb0ce..23db41547 100644 --- a/guide/2011506.md +++ b/guide/2011506.md @@ -2,13 +2,16 @@ title: Linking to multiple zettels --- -You may create a query that will list the matching zettels automatically. For example, to include a list of a zettels with the "science" tag (from the example at [2011505](zcf://metadata)): +You may create a query that will list the matching zettels automatically. For +example, to include a list of a zettels with the "science" tag (from the example +at [2011505](zcf://metadata)): ```markdown [.](zquery://search?tag=science&linkTheme=withDate) ``` -You can use the CLI to see which zettels will be included in a given query; see [2013501](zcf://searching). +You can use the CLI to see which zettels will be included in a given query; see +[2013501](zcf://searching). ## Example @@ -17,10 +20,21 @@ Zettelkasten: [.](zcfquery://search?tag=walkthrough) -It was created by `[.](zcfquery://search?tag=walkthrough)`. Note that here we use `zcfquery` to not affect the graph; whereas `zquery` will form the appropriate new connections to the listed notes. +It was created by `[.](zcfquery://search?tag=walkthrough)`. Note that here we +use `zcfquery` to not affect the graph; whereas `zquery` will form the +appropriate new connections to the listed notes. ## Hierarchical tags -Queries can also link to zettels whose tags match a glob pattern. For instance, `[.](zquery://search?tag=science/*)` will link to all zettels tagged "science/physics" and "science/biology". +Queries can also link to zettels whose tags match a glob pattern. For instance, +`[.](zquery://search?tag=science/*)` will link to all zettels tagged +"science/physics" and "science/biology". -Recursive globs are supported too, so if you want to include deeper nested tags, `[.](zquery://search?tag=science/**)` will also match them (e.g. "science/physics/kinematics"). This will also include zettels that are tagged "science" only, though this behavior can be avoided by querying "science/\*/\*\*" instead. +Recursive globs are supported too, so if you want to include deeper nested tags, +`[.](zquery://search?tag=science/**)` will also match them (e.g. +"science/physics/kinematics"). This will also include zettels that are tagged +"science" only, though this behavior can be avoided by querying +"science/\*/\*\*" instead. + +Add `?grouped` parameter to your query in to view the results grouped by the +matching tag. From 5eefbf81f6700330043960d33c5166ae7b2b4228 Mon Sep 17 00:00:00 2001 From: Sridhar Ratnakumar Date: Sun, 19 Apr 2020 14:28:11 -0400 Subject: [PATCH 3/3] Refactor --- guide/2011506.md | 4 +- src/Neuron/Zettelkasten/Link/Theme.hs | 58 +++++++++++++++++---------- 2 files changed, 38 insertions(+), 24 deletions(-) diff --git a/guide/2011506.md b/guide/2011506.md index 23db41547..e936a51bd 100644 --- a/guide/2011506.md +++ b/guide/2011506.md @@ -36,5 +36,5 @@ Recursive globs are supported too, so if you want to include deeper nested tags, "science" only, though this behavior can be avoided by querying "science/\*/\*\*" instead. -Add `?grouped` parameter to your query in to view the results grouped by the -matching tag. +Add `?grouped` parameter to your query in order to view the results grouped by +the matching tag. diff --git a/src/Neuron/Zettelkasten/Link/Theme.hs b/src/Neuron/Zettelkasten/Link/Theme.hs index 042df1b22..c2d3c3b36 100644 --- a/src/Neuron/Zettelkasten/Link/Theme.hs +++ b/src/Neuron/Zettelkasten/Link/Theme.hs @@ -3,16 +3,25 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ViewPatterns #-} {-# LANGUAGE NoImplicitPrelude #-} -module Neuron.Zettelkasten.Link.Theme where +module Neuron.Zettelkasten.Link.Theme + ( ZettelsView (..), + ZettelView, + LinkTheme (..), + zettelsViewFromURI, + linkThemeFromURI, + ) +where import Control.Monad.Except import Relude import qualified Text.URI as URI +import Text.URI.QQ (queryKey) data ZettelsView = ZettelsView { zettelsViewLinkTheme :: LinkTheme, @@ -32,26 +41,31 @@ zettelsViewFromURI :: MonadError Text m => URI.URI -> m ZettelsView zettelsViewFromURI uri = ZettelsView <$> linkThemeFromURI uri - <*> groupByTag - where - groupByTag = do - x <- fmap (listToMaybe . catMaybes) $ flip traverse (URI.uriQuery uri) $ \case - URI.QueryFlag (URI.unRText -> key) | key == "grouped" -> - pure $ Just True - _ -> pure Nothing - pure $ fromMaybe False x + <*> pure (hasQueryFlag [queryKey|grouped|] uri) linkThemeFromURI :: MonadError Text m => URI.URI -> m LinkTheme -linkThemeFromURI uri = do - ltm <- fmap (listToMaybe . catMaybes) $ flip traverse (URI.uriQuery uri) $ \case - URI.QueryFlag _ -> pure Nothing - URI.QueryParam (URI.unRText -> key) (URI.unRText -> val) -> - case key of - "linkTheme" -> - case val of - "default" -> pure $ Just LinkTheme_Default - "simple" -> pure $ Just LinkTheme_Simple - "withDate" -> pure $ Just LinkTheme_WithDate - _ -> throwError $ "Unknown link theme: " <> val - _ -> pure Nothing - pure $ fromMaybe LinkTheme_Default ltm +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 + Nothing -> pure Nothing + _ -> throwError "Invalid value for linkTheme" + +getQueryParam :: URI.RText 'URI.QueryKey -> URI.URI -> Maybe Text +getQueryParam k uri = + listToMaybe $ catMaybes $ flip fmap (URI.uriQuery uri) $ \case + URI.QueryFlag _ -> Nothing + URI.QueryParam key (URI.unRText -> val) -> + if key == k + then Just val + else Nothing + +hasQueryFlag :: URI.RText 'URI.QueryKey -> URI.URI -> Bool +hasQueryFlag k uri = + fromMaybe False $ listToMaybe $ catMaybes $ flip fmap (URI.uriQuery uri) $ \case + URI.QueryFlag key -> + if key == k + then Just True + else Nothing + _ -> Nothing