neuron 0.4.0.0 → 0.6.0.0
raw patch · 78 files changed
+3504/−1889 lines, 78 filesdep +HsYAMLdep +commonmarkdep +commonmark-extensionsdep −gitrevdep −luciddep −mmarkdep ~rib
Dependencies added: HsYAML, commonmark, commonmark-extensions, commonmark-pandoc, dependent-sum-aeson-orphans, either, iso8601-time, pandoc-types, parsec, reflex, reflex-dom-core, reflex-dom-pandoc, shower, skylighting-core, tagged
Dependencies removed: gitrev, lucid, mmark, mmark-ext
Dependency ranges changed: rib
Files
- CHANGELOG.md +0/−41
- README.md +0/−44
- neuron.cabal +63/−37
- src-dhall/Config/Default.dhall +0/−17
- src-dhall/Config/Type.dhall +0/−17
- src-js/search.js +9/−13
- src/app/Data/Structured/Breadcrumb.hs +4/−41
- src/app/Main.hs +23/−54
- src/app/Neuron/CLI.hs +26/−12
- src/app/Neuron/CLI/New.hs +61/−32
- src/app/Neuron/CLI/Search.hs +1/−1
- src/app/Neuron/CLI/Types.hs +51/−19
- src/app/Neuron/Config.hs +26/−64
- src/app/Neuron/Config/Alias.hs +2/−2
- src/app/Neuron/Config/Orphans.hs +12/−0
- src/app/Neuron/Reader.hs +12/−0
- src/app/Neuron/Reader/Org.hs +46/−0
- src/app/Neuron/Version.hs +0/−8
- src/app/Neuron/Version/RepoVersion.hs +0/−21
- src/app/Neuron/Web/Generate.hs +130/−18
- src/app/Neuron/Web/Generate/Route.hs +64/−0
- src/app/Neuron/Web/Route.hs +0/−105
- src/app/Neuron/Web/StructuredData.hs +116/−0
- src/app/Neuron/Web/Theme.hs +0/−79
- src/app/Neuron/Web/View.hs +175/−297
- src/app/Neuron/Zettelkasten/Connection.hs +0/−23
- src/app/Neuron/Zettelkasten/Error.hs +0/−40
- src/app/Neuron/Zettelkasten/Graph.hs +0/−131
- src/app/Neuron/Zettelkasten/Graph/Type.hs +0/−23
- src/app/Neuron/Zettelkasten/Query.hs +0/−129
- src/app/Neuron/Zettelkasten/Query/Error.hs +0/−24
- src/app/Neuron/Zettelkasten/Query/Eval.hs +0/−69
- src/app/Neuron/Zettelkasten/Query/Parser.hs +0/−107
- src/app/Neuron/Zettelkasten/Query/Theme.hs +0/−31
- src/app/Neuron/Zettelkasten/Query/View.hs +0/−141
- src/app/Text/MMark/Extension/ReplaceLink.hs +0/−25
- src/app/Text/MMark/Extension/SetTableClass.hs +0/−17
- src/app/Text/MMark/MarkdownLink.hs +0/−40
- src/app/Text/URI/Util.hs +0/−30
- src/lib/Data/Graph/Labelled.hs +7/−0
- src/lib/Data/Graph/Labelled/Algorithm.hs +57/−8
- src/lib/Data/Graph/Labelled/Type.hs +33/−1
- src/lib/Data/TagTree.hs +3/−2
- src/lib/Neuron/Config/Type.hs +77/−0
- src/lib/Neuron/Orphans.hs +16/−0
- src/lib/Neuron/Reader/Markdown.hs +182/−0
- src/lib/Neuron/Reader/Type.hs +60/−0
- src/lib/Neuron/Web/Common.hs +30/−0
- src/lib/Neuron/Web/Manifest.hs +94/−0
- src/lib/Neuron/Web/Query/View.hs +205/−0
- src/lib/Neuron/Web/Route.hs +62/−0
- src/lib/Neuron/Web/Theme.hs +112/−0
- src/lib/Neuron/Web/Widget.hs +27/−0
- src/lib/Neuron/Web/Widget/AutoScroll.hs +28/−0
- src/lib/Neuron/Web/Widget/InvertedTree.hs +144/−0
- src/lib/Neuron/Web/ZIndex.hs +162/−0
- src/lib/Neuron/Web/Zettel/CSS.hs +126/−0
- src/lib/Neuron/Web/Zettel/View.hs +149/−0
- src/lib/Neuron/Zettelkasten/Connection.hs +34/−0
- src/lib/Neuron/Zettelkasten/Graph.hs +108/−0
- src/lib/Neuron/Zettelkasten/Graph/Build.hs +72/−0
- src/lib/Neuron/Zettelkasten/Graph/Type.hs +23/−0
- src/lib/Neuron/Zettelkasten/ID.hs +30/−10
- src/lib/Neuron/Zettelkasten/Query.hs +128/−0
- src/lib/Neuron/Zettelkasten/Query/Error.hs +50/−0
- src/lib/Neuron/Zettelkasten/Query/Eval.hs +94/−0
- src/lib/Neuron/Zettelkasten/Query/Graph.hs +41/−0
- src/lib/Neuron/Zettelkasten/Query/Parser.hs +126/−0
- src/lib/Neuron/Zettelkasten/Query/Theme.hs +32/−0
- src/lib/Neuron/Zettelkasten/Zettel.hs +98/−32
- src/lib/Neuron/Zettelkasten/Zettel/Meta.hs +47/−13
- src/lib/Neuron/Zettelkasten/Zettel/Parser.hs +68/−0
- src/lib/Text/Pandoc/Util.hs +50/−0
- src/lib/Text/URI/Util.hs +30/−0
- test/Neuron/VersionSpec.hs +9/−9
- test/Neuron/Zettelkasten/IDSpec.hs +5/−4
- test/Neuron/Zettelkasten/Query/ParserSpec.hs +46/−40
- test/Neuron/Zettelkasten/ZettelSpec.hs +18/−18
− CHANGELOG.md
@@ -1,41 +0,0 @@-# Change Log for neuron--## 0.4.0.0--- Notable changes- - More convenient links; `<foobar>` instead of `[foobar](z:/)` (#59)- - Hierarchical tags, with tag pattern in zquery (#115)- - Change default ID generation to use random hash (#151)- - Add `date` field to Markdown metadata- - Added `neuron query` to query the Zettelkasten and get JSON output (#42)-- CLI argument parsing revamp- - Zettelkasten directory is now provided via the `-d` argument.- - Its default, `~/zettelkasten`, is used when not specified.- - This directory must exist, otherwise neuron will error out.- - The output directory is now moved to `.neuron/output`- - `neuron ... rib serve` is now `neuron rib -wS`.-- CLI changes:- - Full text search: `neuron search --full-text`- - #43: Add `neuron search -e` to open the matching zettel in $EDITOR- - Allow customizing output directory- - Added `neuron open` to open the locally generated Zettelkasten site.- - #107: Add full path to the zettel in `neuron query` JSON-- Web interface:- - Custom themes for web interface- - Display all backlinks to a zettel (even those not in category tree) (#34)- - Simplified link style (#151)- - Client-side web search (#90)- - Add JSON-LD breadcrumbs (#147)- - Add query to display tag tree (#121)- - Custom alias redirects- - Tags are restyled and positioned below- - Produce compact CSS in HTML head- - #24: zquery is displayed in HTML view.- - #100: Tables are styled nicely using Semantic UI-- Bug fixes- - Fix regression in neuron library use- - #130: Handle links inside blockquotes--## 0.2.0.0--- Initial public release
− README.md
@@ -1,44 +0,0 @@-<img width="10%" src="./assets/logo.svg">--# neuron--[](https://en.wikipedia.org/wiki/BSD_License)-[](https://builtwithnix.org)-[](https://funprog.zulipchat.com/#narrow/stream/231929-Neuron)--neuron is a system for managing your plain-text [Zettelkasten](https://neuron.zettel.page/2011401.html) notes. --**Features**--- Extended Markdown for easy linking between zettels-- Web interface (auto generated static site)-- Graph view of zettels (organic category tree)-- CLI for creating new zettels with automatic ID--## Getting started--See [neuron.zettel.page](https://neuron.zettel.page/) for the full guide to installing and using neuron.--## Developing--When modifying `src/Neuron`, use ghcid as instructed as follows to monitor compile errors:--```bash-nix-shell --run ghcid-```--You can test your changes by running it on the `./guide` (or any) zettelkasten as follows:--```bash-bin/run -d ./guide rib -wS-```--This command will also automatically recompile and restart when you change any of the Haskell source files.--### Running tests--Unit tests can be run via ghcid as follows:--```-bin/test-```
neuron.cabal view
@@ -1,8 +1,8 @@ cabal-version: 2.4 name: neuron -- This version must be in sync with what's in Default.dhall-version: 0.4.0.0-license: BSD-3-Clause+version: 0.6.0.0+license: AGPL-3.0-only copyright: 2020 Sridhar Ratnakumar maintainer: srid@srid.ca author: Sridhar Ratnakumar@@ -10,16 +10,12 @@ homepage: https://neuron.zettel.page bug-reports: https://github.com/srid/neuron/issues synopsis:- Haskell meets Zettelkasten, for your plain-text delight.+ Future-proof system for plain-text notes. description:- neuron is a system for managing your plain-text Zettelkasten notes.-extra-source-files:- README.md- CHANGELOG.md+ neuron is a future-proof system for managing your plain-text Zettelkasten notes. data-files: src-js/search.js src-bash/neuron-search- src-dhall/Config/*.dhall source-repository head type: git@@ -50,17 +46,61 @@ parser-combinators, containers, filepattern,- mmark,- megaparsec+ megaparsec,+ commonmark ^>= 0.1.0.0,+ commonmark-extensions ^>= 0.1.0.0,+ commonmark-pandoc ^>= 0.1.0.0,+ pandoc-types,+ parsec,+ modern-uri,+ HsYAML,+ aeson-gadt-th,+ dependent-sum,+ dependent-sum-template,+ dependent-sum-aeson-orphans,+ data-default,+ reflex,+ reflex-dom-core,+ reflex-dom-pandoc >= 0.2.0.0,+ clay,+ tagged library import: library-common hs-source-dirs: src/lib exposed-modules:+ Neuron.Config.Type+ Neuron.Reader.Markdown+ Neuron.Reader.Type Neuron.Zettelkasten.ID Neuron.Zettelkasten.Zettel Neuron.Zettelkasten.Zettel.Meta+ Neuron.Zettelkasten.Zettel.Parser+ Neuron.Zettelkasten.Connection+ Neuron.Zettelkasten.Query+ Neuron.Zettelkasten.Query.Graph+ Neuron.Zettelkasten.Query.Error+ Neuron.Zettelkasten.Query.Eval+ Neuron.Zettelkasten.Query.Parser+ Neuron.Zettelkasten.Query.Theme+ Neuron.Zettelkasten.Graph+ Neuron.Zettelkasten.Graph.Type+ Neuron.Zettelkasten.Graph.Build+ Neuron.Web.Route+ Neuron.Web.Manifest+ Neuron.Web.Common+ Neuron.Web.Widget+ Neuron.Web.Widget.AutoScroll+ Neuron.Web.Widget.InvertedTree+ Neuron.Web.Query.View+ Neuron.Web.Zettel.View+ Neuron.Web.Zettel.CSS+ Neuron.Web.ZIndex+ Neuron.Web.Theme+ Neuron.Orphans Text.Megaparsec.Simple+ Text.Pandoc.Util+ Text.URI.Util Data.TagTree Data.PathTree Data.Graph.Labelled@@ -83,17 +123,15 @@ directory, exceptions, file-embed,- gitrev,- lucid -any, optparse-applicative, pandoc,+ skylighting-core, relude,- rib ^>=0.10,+ iso8601-time,+ rib >=0.12, shake -any, time, text,- mmark,- mmark-ext, modern-uri, foldl, filepath,@@ -103,11 +141,12 @@ megaparsec >= 8.0, dependent-sum, dependent-sum-template,- aeson-gadt-th, data-default, uuid, shake,- with-utf8+ with-utf8,+ shower,+ either if (!flag(ghcid)) autogen-modules: Paths_neuron@@ -126,32 +165,17 @@ Neuron.CLI.Types Neuron.Config Neuron.Config.Alias+ Neuron.Config.Orphans Neuron.Version- Neuron.Version.RepoVersion Neuron.Web.Generate- Neuron.Web.Route- Neuron.Web.Theme+ Neuron.Web.Generate.Route Neuron.Web.View- Neuron.Zettelkasten.Connection- Neuron.Zettelkasten.Error- Neuron.Zettelkasten.Graph- Neuron.Zettelkasten.Graph.Type- Neuron.Zettelkasten.ID+ Neuron.Web.StructuredData+ Neuron.Reader+ Neuron.Reader.Org Neuron.Zettelkasten.ID.Scheme- Neuron.Zettelkasten.Query- Neuron.Zettelkasten.Query.Error- Neuron.Zettelkasten.Query.Eval- Neuron.Zettelkasten.Query.Parser- Neuron.Zettelkasten.Query.Theme- Neuron.Zettelkasten.Query.View- Neuron.Zettelkasten.Zettel- Neuron.Zettelkasten.Zettel.Meta Paths_neuron- Text.MMark.Extension.ReplaceLink- Text.MMark.Extension.SetTableClass- Text.MMark.MarkdownLink Text.Megaparsec.Simple- Text.URI.Util test-suite neuron-test import: app-common@@ -178,6 +202,8 @@ -- The executable stanza should always be at the end. The other project will -- strip it to avoid non-core dependencies.+-- To profile: ghc-options: -fexternal-interpreter -prof -fprof-auto -rtsopts executable neuron import: app-common main-is: Main.hs+ ghc-options: -threaded -rtsopts -with-rtsopts=-N
− src-dhall/Config/Default.dhall
@@ -1,17 +0,0 @@-{ siteTitle =- "My Zettelkasten"-, author =- None Text-, siteBaseUrl =- None Text-, editUrl =- None Text-, theme =- "blue"-, aliases =- [] : List Text-, mathJaxSupport =- True-, minVersion =- "0.4"-}
− src-dhall/Config/Type.dhall
@@ -1,17 +0,0 @@-{ siteTitle :- Text-, author :- Optional Text-, siteBaseUrl :- Optional Text-, editUrl :- Optional Text-, theme :- Text-, aliases :- List Text-, mathJaxSupport :- Bool-, minVersion :- Text-}
src-js/search.js view
@@ -1,5 +1,5 @@ let search = "",- selectedTags = [];+ selectedTags = []; let searchResults = document.getElementById("search-results"); // ul element let searchInput = document.getElementById("search-input");@@ -7,24 +7,20 @@ // Create a zettel link from a zettel object function makeZettelLink(zettel) {+ let container = document.createElement("span");+ container.classList.add("zettel-link-container");+ let zettelLink = document.createElement("span"); zettelLink.classList.add("zettel-link"); - let idLink = document.createElement("span");- idLink.classList.add("zettel-link-idlink");- let actualLink = document.createElement("a"); actualLink.href = zettel.id + ".html";- actualLink.innerHTML = zettel.id;- idLink.appendChild(actualLink);- zettelLink.appendChild(idLink);+ actualLink.innerHTML = zettel.title; - let linkTitle = document.createElement("span");- linkTitle.classList.add("zettel-link-title");- linkTitle.innerHTML = zettel.title;- zettelLink.appendChild(linkTitle);+ zettelLink.appendChild(actualLink);+ container.appendChild(zettelLink); - return zettelLink;+ return container; } // Renders the results as a list@@ -91,7 +87,7 @@ initializeSearchFromURL(); $('#search-input').on("change paste keyup", runSearch)- .focus();+ .focus(); $('#search-tags').dropdown({ onChange: (value) => {
src/app/Data/Structured/Breadcrumb.hs view
@@ -13,7 +13,7 @@ import Data.Aeson import Data.Tree-import Lucid+import Reflex.Dom.Core hiding (mapMaybe) import Relude import Text.URI (URI) import qualified Text.URI as URI@@ -27,11 +27,9 @@ newtype Breadcrumb = Breadcrumb {unBreadcrumb :: NonEmpty Item} deriving (Eq, Show, Generic) -instance ToHtml [Breadcrumb] where- toHtmlRaw = toHtml- toHtml bs =- script_ [type_ "application/ld+json"] $- encode bs+renderBreadcrumbs :: DomBuilder t m => [Breadcrumb] -> m ()+renderBreadcrumbs bs =+ elAttr "script" ("type" =: "application/ld+json") $ text $ decodeUtf8 $ encode bs instance ToJSON Breadcrumb where toJSON (Breadcrumb (toList -> crumbs)) =@@ -60,38 +58,3 @@ [] -> [[parent]] childPaths -> fmap (parent :) `concatMap` childPaths-{-- [{- "@context": "https://schema.org",- "@type": "BreadcrumbList",- "itemListElement": [{- "@type": "ListItem",- "position": 1,- "name": "Books",- "item": "https://example.com/books"- },{- "@type": "ListItem",- "position": 2,- "name": "Science Fiction",- "item": "https://example.com/books/sciencefiction"- },{- "@type": "ListItem",- "position": 3,- "name": "Award Winners"- }]- },- {- "@context": "https://schema.org",- "@type": "BreadcrumbList",- "itemListElement": [{- "@type": "ListItem",- "position": 1,- "name": "Literature",- "item": "https://example.com/literature"- },{- "@type": "ListItem",- "position": 2,- "name": "Award Winners"- }]- }]--}
src/app/Main.hs view
@@ -1,72 +1,41 @@+{-# LANGUAGE DataKinds #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-} {-# LANGUAGE NoImplicitPrelude #-} module Main where -import Clay hiding (s, style, type_)-import qualified Clay as C+import Control.Monad.Reader import Development.Shake-import Lucid import Main.Utf8 import Neuron.CLI (run)-import Neuron.Config (Config)-import qualified Neuron.Config as Config+import Neuron.Config.Type (Config)+import Neuron.Version (neuronVersion) import Neuron.Web.Generate (generateSite)-import Neuron.Web.Route (Route (..))-import Neuron.Web.View (renderRouteBody, renderRouteHead, style)+import Neuron.Web.Generate.Route (staticRouteConfig)+import qualified Neuron.Web.Manifest as Manifest+import Neuron.Web.Route (Route (..), runNeuronWeb)+import Neuron.Web.View (renderRoutePage)+import Neuron.Zettelkasten.Graph.Type (ZettelGraph)+import Reflex.Dom.Core import Relude import qualified Rib-import Rib.Extra.CSS (googleFonts, stylesheet) main :: IO () main = withUtf8 $ run generateMainSite -generateMainSite :: Action ()-generateMainSite = do- Rib.buildStaticFiles ["static/**"]- config <- Config.getConfig- let writeHtmlRoute :: Route g a -> (g, a) -> Action ()- writeHtmlRoute r = Rib.writeRoute r . Lucid.renderText . renderPage config r+generateMainSite :: Config -> Action ()+generateMainSite config = do+ notesDir <- Rib.ribInputDir+ Rib.buildStaticFiles ["static/**", ".nojekyll"]+ manifest <- fmap Manifest.mkManifest $ getDirectoryFiles notesDir Manifest.manifestPatterns+ let writeHtmlRoute :: Route a -> (ZettelGraph, a) -> Action ()+ writeHtmlRoute r x = do+ html <- liftIO $ fmap snd $ renderStatic $ do+ runNeuronWeb staticRouteConfig $+ renderRoutePage neuronVersion config manifest r x+ -- FIXME: Make rib take bytestrings+ Rib.writeRoute r $ decodeUtf8 @Text html void $ generateSite config writeHtmlRoute--renderPage :: Config -> Route g a -> (g, a) -> Html ()-renderPage config r val = html_ [lang_ "en"] $ do- head_ $ do- renderRouteHead config r val- case r of- Route_Redirect _ ->- mempty- _ -> do- stylesheet "https://cdn.jsdelivr.net/npm/semantic-ui@2.4.2/dist/semantic.min.css"- stylesheet "https://cdnjs.cloudflare.com/ajax/libs/font-awesome/5.11.2/css/all.min.css"- style_ [type_ "text/css"] $ C.renderWith C.compact [] $ mainStyle config- googleFonts [headerFont, bodyFont, monoFont]- when (Config.mathJaxSupport config) $- with (script_ mempty) [id_ "MathJax-script", src_ "https://cdn.jsdelivr.net/npm/mathjax@3/es5/tex-mml-chtml.js", async_ ""]- body_- $ div_ [class_ "ui text container", id_ "thesite"]- $ renderRouteBody config r val--headerFont :: Text-headerFont = "Oswald"--bodyFont :: Text-bodyFont = "Open Sans"--monoFont :: Text-monoFont = "Roboto Mono"--mainStyle :: Config -> Css-mainStyle cfg = "div#thesite" ? do- C.fontFamily [bodyFont] [C.serif]- C.paddingTop $ em 1- C.paddingBottom $ em 1- "p" ? do- C.lineHeight $ pct 150- "h1, h2, h3, h4, h5, h6, .ui.header" ? do- C.fontFamily [headerFont] [C.sansSerif]- "img" ? do- C.maxWidth $ pct 100 -- Prevents large images from overflowing beyond zettel borders- style cfg
src/app/Neuron/CLI.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE GADTs #-}+{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecordWildCards #-}@@ -17,7 +18,10 @@ import Neuron.CLI.New (newZettelFile) import Neuron.CLI.Rib import Neuron.CLI.Search (interactiveSearch)+import Neuron.Config (getConfig)+import Neuron.Config.Type (Config) import qualified Neuron.Version as Version+import qualified Neuron.Web.Generate as Gen import qualified Neuron.Zettelkasten.Graph as G import qualified Neuron.Zettelkasten.Query as Q import Options.Applicative@@ -28,11 +32,9 @@ import System.Info (os) import System.Posix.Process -run :: Action () -> IO ()+run :: (Config -> Action ()) -> IO () run act = do- today <- utctDay <$> liftIO getCurrentTime- defaultNotesDir <- (</> "zettelkasten") <$> getHomeDirectory- let cliParser = commandParser defaultNotesDir today+ cliParser <- commandParser <$> defaultNotesDir <*> today app <- execParser $ info@@ -42,27 +44,39 @@ where versionOption = infoOption- (toString Version.neuronVersionFull)+ (toString Version.neuronVersion) (long "version" <> help "Show version")+ defaultNotesDir =+ (</> "zettelkasten") <$> getHomeDirectory+ today = do+ tz <- getCurrentTimeZone+ localDay . utcToLocalTime tz <$> liftIO getCurrentTime -runWith :: Action () -> App -> IO ()+runWith :: (Config -> Action ()) -> App -> IO () runWith act App {..} = case cmd of Rib ribCfg ->- runRib act notesDir ribCfg+ runRib (act =<< getConfig) notesDir ribCfg New newCommand -> runRibOnceQuietly notesDir $ do- newZettelFile newCommand+ newZettelFile newCommand =<< getConfig Open -> runRibOnceQuietly notesDir $ do indexHtmlPath <- fmap (</> "index.html") Rib.ribOutputDir putStrLn indexHtmlPath let opener = if os == "darwin" then "open" else "xdg-open" liftIO $ executeFile opener True [indexHtmlPath] Nothing- Query someQ ->+ Query eSomeQ -> runRibOnceQuietly notesDir $ do- withSome someQ $ \q -> do- result <- flip Q.runQuery q <$> G.loadZettels- putLTextLn $ Aeson.encodeToLazyText $ Q.queryResultJson notesDir q result+ (graph, _, errors) <- Gen.loadZettelkasten =<< getConfig+ case eSomeQ of+ Left someQ ->+ withSome someQ $ \q -> do+ let result = Q.runZettelQuery (G.getZettels graph) q+ putLTextLn $ Aeson.encodeToLazyText $ Q.zettelQueryResultJson q result errors+ Right someQ ->+ withSome someQ $ \q -> do+ let result = Q.runGraphQuery graph q+ putLTextLn $ Aeson.encodeToLazyText $ Q.graphQueryResultJson q result errors Search searchCmd -> interactiveSearch notesDir searchCmd
src/app/Neuron/CLI/New.hs view
@@ -15,15 +15,20 @@ import Data.Some import Data.Text (strip) import qualified Data.Text as T+import Data.Time import Development.Shake (Action) import Neuron.CLI.Types-import qualified Neuron.Zettelkasten.Graph as G-import Neuron.Zettelkasten.ID (ZettelID, zettelIDSourceFileName)+import Neuron.Config.Type (Config (..), getZettelFormats)+import Neuron.Reader.Type (ZettelFormat (..))+import Neuron.Web.Generate as Gen+import Neuron.Zettelkasten.ID (zettelIDSourceFileName) import qualified Neuron.Zettelkasten.ID.Scheme as IDScheme import Neuron.Zettelkasten.Zettel (zettelID)+import Neuron.Zettelkasten.Zettel.Meta (formatZettelDate) import Options.Applicative import Relude import qualified Rib+import System.Directory (setCurrentDirectory) import System.FilePath import qualified System.Posix.Env as Env import System.Posix.Process@@ -31,51 +36,75 @@ -- | Create a new zettel file and open it in editor if requested -- -- As well as print the path to the created file.-newZettelFile :: NewCommand -> Action ()-newZettelFile NewCommand {..} = do- zettels <- G.loadZettels+newZettelFile :: NewCommand -> Config -> Action ()+newZettelFile NewCommand {..} config = do+ (_, zettels, _) <- Gen.loadZettelkasten config mzid <- withSome idScheme $ \scheme -> do val <- liftIO $ IDScheme.genVal scheme- pure $ IDScheme.nextAvailableZettelID (Set.fromList $ fmap zettelID zettels) val scheme+ pure $+ IDScheme.nextAvailableZettelID+ (Set.fromList $ fmap (either zettelID zettelID) zettels)+ val+ scheme case mzid of Left e -> die $ show e Right zid -> do- path <- zettelPath zid+ notesDir <- Rib.ribInputDir+ defaultFormat <- head <$> getZettelFormats config+ let zettelFormat = fromMaybe defaultFormat format+ zettelFile = zettelIDSourceFileName zid zettelFormat liftIO $ do- fileAction :: FilePath -> IO () <-+ fileAction :: FilePath -> FilePath -> IO () <- bool (pure showAction) mkEditActionFromEnv edit- writeFileText path $- T.intercalate- "\n"- [ "---",- "title: " <> title,- "date: " <> show day,- "---",- "",- ""- ]- fileAction path+ writeFileText (notesDir </> zettelFile) $ defaultZettelContent zettelFormat day title+ fileAction notesDir zettelFile where- mkEditActionFromEnv :: IO (FilePath -> IO ())+ mkEditActionFromEnv :: IO (FilePath -> FilePath -> IO ()) mkEditActionFromEnv = getEnvNonEmpty "EDITOR" >>= \case Nothing -> die "\n-e option can only be used with EDITOR environment variable set"- Just editorExe ->- pure $ editAction editorExe- editAction editorExe path = do- -- Show it first in case the editor launch fails- showAction path- executeFile editorExe True [path] Nothing- showAction =- putStrLn+ Just editorCli ->+ pure $ editAction editorCli+ editAction editorCli notesDir zettelFile = do+ -- Show the path first, in case the editor launch fails+ showAction notesDir zettelFile+ setCurrentDirectory notesDir+ executeShellCommand $ editorCli <> " " <> zettelFile+ showAction notesDir zettelFile =+ putStrLn $ notesDir </> zettelFile+ -- Like `executeFile` but takes a shell command.+ executeShellCommand cmd =+ executeFile "bash" True ["-c", cmd] Nothing getEnvNonEmpty name = Env.getEnv name >>= \case Nothing -> pure Nothing Just (toString . strip . toText -> v) -> if null v then pure Nothing else pure (Just v) -zettelPath :: ZettelID -> Action FilePath-zettelPath zid = do- notesDir <- Rib.ribInputDir- pure $ notesDir </> zettelIDSourceFileName zid+-- TODO use configurable template files?+defaultZettelContent :: ZettelFormat -> Day -> Maybe Text -> Text+defaultZettelContent format day mtitle = case format of+ ZettelFormat_Markdown ->+ T.intercalate+ "\n"+ [ "---",+ "date: " <> date,+ "---",+ "",+ "# " <> title,+ "\n"+ ]+ ZettelFormat_Org ->+ T.intercalate+ "\n"+ [ "* " <> title,+ " :PROPERTIES:",+ " :Date: " <> date,+ " :END:",+ "\n"+ ]+ where+ date = formatZettelDate day+ defaultTitleName = "Zettel created on " <> date+ title = maybe defaultTitleName T.strip mtitle
src/app/Neuron/CLI/Search.hs view
@@ -23,7 +23,7 @@ searchScriptArgs SearchCommand {..} = let searchByArgs = case searchBy of- SearchByTitle -> ["title: ", "3"]+ SearchByTitle -> ["(^# )|(^title: )", "2"] SearchByContent -> ["", "2"] editArg = bool "echo" "$EDITOR" searchEdit
src/app/Neuron/CLI/Types.hs view
@@ -20,12 +20,16 @@ import Data.Default (def) import Data.Some import Data.TagTree (mkTagPattern)-import qualified Data.Text as T import Data.Time+import Neuron.Reader.Type (ZettelFormat)+import qualified Neuron.Zettelkasten.Connection as C import Neuron.Zettelkasten.ID (ZettelID, parseZettelID') import Neuron.Zettelkasten.ID.Scheme (IDScheme (..))-import Neuron.Zettelkasten.Query as Q+import qualified Neuron.Zettelkasten.Query.Error as Q+import Neuron.Zettelkasten.Query.Graph as Q import qualified Neuron.Zettelkasten.Query.Parser as Q+import Neuron.Zettelkasten.Zettel as Q+import Neuron.Zettelkasten.Zettel.Meta (parseZettelDate) import Options.Applicative import Relude import qualified Rib.Cli@@ -37,7 +41,8 @@ } data NewCommand = NewCommand- { title :: Text,+ { title :: Maybe Text,+ format :: Maybe ZettelFormat, day :: Day, idScheme :: Some IDScheme, edit :: Bool@@ -63,7 +68,7 @@ | -- | Search a zettel by title Search SearchCommand | -- | Run a query against the Zettelkasten- Query (Some Q.Query)+ Query (Either (Some Q.ZettelQuery) (Some Q.GraphQuery)) | -- | Delegate to Rib's command parser Rib RibConfig @@ -98,7 +103,14 @@ command "rib" $ info ribCommand $ progDesc "Generate static site via rib" ] newCommand = do- title <- argument nonEmptyTextReader (metavar "TITLE" <> help "Title of the new Zettel")+ title <- optional $ strArgument (metavar "TITLE" <> help "Title of the new Zettel")+ format <-+ optional+ $ option auto+ $ metavar "FORMAT"+ <> short 'f'+ <> long "format"+ <> help "The document format of the new zettel" edit <- switch (long "edit" <> short 'e' <> help "Open the newly-created zettel in $EDITOR") day <- option dayReader $@@ -118,14 +130,41 @@ <|> fmap (const . Some . IDSchemeCustom) (option str (long "id" <> help "Use a custom ID" <> metavar "IDNAME"))- pure $ New $ NewCommand title day (idSchemeF day) edit+ pure $ New $ NewCommand title format day (idSchemeF day) edit openCommand = pure Open queryCommand = fmap Query $- fmap (Some . flip Q.Query_ZettelByID Nothing) (option zettelIDReader (long "id"))- <|> fmap (\x -> Some $ Q.Query_ZettelsByTag x Nothing def) (many (mkTagPattern <$> option str (long "tag" <> short 't')))- <|> option queryReader (long "uri" <> short 'u')+ ( fmap+ Left+ ( fmap (Some . flip Q.ZettelQuery_ZettelByID Nothing) (option zettelIDReader (long "id"))+ <|> fmap (\x -> Some $ Q.ZettelQuery_ZettelsByTag x Nothing def) (many (mkTagPattern <$> option str (long "tag" <> short 't')))+ <|> option queryReader (long "uri" <> short 'u')+ )+ <|> fmap+ Right+ (fmap (const $ Some $ Q.GraphQuery_Id) $ switch (long "graph" <> help "Get the entire zettelkasten graph as JSON"))+ <|> fmap+ Right+ ( fmap (Some . Q.GraphQuery_BacklinksOf Nothing) $+ option+ zettelIDReader+ ( long "backlinks-of"+ <> help "Get backlinks to the given zettel ID"+ <> metavar "ID"+ )+ )+ <|> fmap+ Right+ ( fmap (Some . Q.GraphQuery_BacklinksOf (Just C.Folgezettel)) $+ option+ zettelIDReader+ ( long "uplinks-of"+ <> help "Get uplinks to the given zettel ID"+ <> metavar "ID"+ )+ )+ ) searchCommand = do searchBy <- bool SearchByTitle SearchByContent@@ -148,20 +187,13 @@ zettelIDReader :: ReadM ZettelID zettelIDReader = eitherReader $ first show . parseZettelID' . toText- queryReader :: ReadM (Some Q.Query)+ queryReader :: ReadM (Some Q.ZettelQuery) queryReader = eitherReader $ \(toText -> s) -> case URI.mkURI s of Right uri ->- either (Left . show) (maybe (Left "Unsupported query") Right) $ Q.queryFromURI uri+ either (Left . toString . Q.showQueryParseError) (maybe (Left "Unsupported query") Right) $ Q.queryFromURI uri Left e -> Left $ displayException e- nonEmptyTextReader :: ReadM Text- nonEmptyTextReader =- eitherReader $ \(T.strip . toText -> s) ->- if T.null s- then Left "Empty text is not allowed"- else Right s dayReader :: ReadM Day dayReader =- maybeReader $- parseTimeM False defaultTimeLocale "%Y-%m-%d"+ maybeReader (parseZettelDate . toText)
src/app/Neuron/Config.hs view
@@ -7,88 +7,50 @@ {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-}-{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE ViewPatterns #-} {-# LANGUAGE NoImplicitPrelude #-} module Neuron.Config- ( Config (..),- configFile,- getConfig,- BaseUrlError (..),- getMarkdownExtensions,+ ( getConfig,+ parsePure, ) where -import Control.Monad.Except-import Data.FileEmbed (embedFile)+import Data.Either.Validation (validationToEither) import Development.Shake (Action, readFile')-import Dhall (FromDhall) import qualified Dhall-import Dhall.TH+import Dhall (FromDhall)+import qualified Dhall.Core+import qualified Dhall.Parser+import qualified Dhall.TypeCheck+import Neuron.Config.Orphans ()+import Neuron.Config.Type (Config, configFile, defaultConfig, mergeWithDefault) import Relude import qualified Rib import System.Directory import System.FilePath-import qualified Text.MMark as MMark-import qualified Text.MMark.Extension.Common as Ext-import Text.MMark.Extension.SetTableClass (setTableClass) --- | Config type for @neuron.dhall@------ See <https://neuron.zettel.page/2011701.html guide> for description of the fields.-makeHaskellTypes- [ SingleConstructor "Config" "Config" "./src-dhall/Config/Type.dhall"- ]--deriving instance Generic Config--deriving instance FromDhall Config--data BaseUrlError- = BaseUrlNotAbsolute- deriving (Eq, Show)--instance Exception BaseUrlError--defaultConfig :: ByteString-defaultConfig = $(embedFile "./src-dhall/Config/Default.dhall")--configFile :: FilePath-configFile = "neuron.dhall"---- | Read the optional @neuron.dhall@ config file from the zettelksaten+-- | Read the optional @neuron.dhall@ config file from the zettelkasten getConfig :: Action Config getConfig = do- inputDir <- Rib.ribInputDir- let configPath = inputDir </> configFile+ configPath <- Rib.ribInputDir <&> (</> configFile) configVal :: Text <- liftIO (doesFileExist configPath) >>= \case True -> do- userConfig <- fmap toText $ readFile' configPath- -- Dhall's combine operator (`//`) allows us to merge two records,- -- effectively merging the record with defaults with the user record.- pure $ decodeUtf8 defaultConfig <> " // " <> userConfig+ mergeWithDefault . toText <$> readFile' configPath False ->- pure $ decodeUtf8 @Text defaultConfig- parseConfig configVal--parseConfig :: MonadIO m => Text -> m Config-parseConfig s =- liftIO $ Dhall.input Dhall.auto s+ pure defaultConfig+ either fail pure $ parsePure configFile $ mergeWithDefault configVal -getMarkdownExtensions :: Config -> [MMark.Extension]-getMarkdownExtensions Config {..} =- defaultExts- <> bool [] [Ext.mathJax (Just '$')] mathJaxSupport- where- defaultExts :: [MMark.Extension]- defaultExts =- [ Ext.fontAwesome,- Ext.footnotes,- Ext.kbd,- Ext.linkTarget,- Ext.punctuationPrettifier,- Ext.skylighting,- setTableClass "ui celled table"- ]+-- | Pure version of `Dhall.input Dhall.auto`+--+-- The config file cannot have imports, as that requires IO.+parsePure :: forall a. FromDhall a => FilePath -> Text -> Either String a+parsePure fn s = do+ expr0 <- first show $ Dhall.Parser.exprFromText fn s+ expr <- maybeToRight "Cannot have imports" $ traverse (const Nothing) expr0+ void $ first show $ Dhall.TypeCheck.typeOf expr+ first show+ $ validationToEither+ $ Dhall.extract @a Dhall.auto+ $ Dhall.Core.normalize expr
src/app/Neuron/Config/Alias.hs view
@@ -4,8 +4,8 @@ module Neuron.Config.Alias where -import Control.Monad.Except-import Neuron.Config+import Control.Monad.Except (liftEither, runExcept, throwError)+import Neuron.Config.Type import qualified Neuron.Zettelkasten.Graph as G import Neuron.Zettelkasten.Graph.Type (ZettelGraph) import Neuron.Zettelkasten.ID
+ src/app/Neuron/Config/Orphans.hs view
@@ -0,0 +1,12 @@+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++module Neuron.Config.Orphans where++import Dhall (FromDhall)+import Neuron.Config.Type++deriving instance FromDhall Config
+ src/app/Neuron/Reader.hs view
@@ -0,0 +1,12 @@+{-# LANGUAGE LambdaCase #-}++module Neuron.Reader where++import Neuron.Reader.Markdown+import Neuron.Reader.Org+import Neuron.Reader.Type++readerForZettelFormat :: ZettelFormat -> ZettelReader+readerForZettelFormat = \case+ ZettelFormat_Markdown -> parseMarkdown+ ZettelFormat_Org -> parseOrg
+ src/app/Neuron/Reader/Org.hs view
@@ -0,0 +1,46 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE NoImplicitPrelude #-}++module Neuron.Reader.Org+ ( parseOrg,+ )+where++import qualified Data.Map as Map+import Data.TagTree (Tag (Tag))+import Data.Tagged+import Data.Time.Calendar (Day)+import Neuron.Reader.Type (ZettelParseError, ZettelReader)+import Neuron.Zettelkasten.Zettel.Meta (Meta (..), parseZettelDate)+import Relude+import Relude.Extra.Map (lookup)+import Text.Pandoc (def, runPure)+import Text.Pandoc.Definition hiding (Meta (..))+import Text.Pandoc.Readers.Org (readOrg)+import Text.Pandoc.Util (getH1)++parseOrg :: ZettelReader+parseOrg _ s = do+ doc <- first show $ runPure $ readOrg def s+ meta <- extractMetadata doc+ pure (meta, doc)++-- | Extract metadata from the properties that are attached to the first headline+extractMetadata :: Pandoc -> Either ZettelParseError (Maybe Meta)+extractMetadata doc+ | Just ((_, _, Map.fromList -> properties), _) <- getH1 doc = do+ date <- traverse parseDate $ lookup "date" properties+ -- title is now deprecated+ let title = Nothing+ tags = fmap Tag . words <$> lookup "tags" properties+ pure $ Just Meta {..}+ | otherwise = pure Nothing+ where+ parseDate :: Text -> Either ZettelParseError Day+ parseDate date = maybeToRight (Tagged $ "Invalid date format: " <> date) $ parseZettelDate @Maybe date
src/app/Neuron/Version.hs view
@@ -4,9 +4,7 @@ module Neuron.Version where -import qualified Data.Text as T import Data.Version (parseVersion, showVersion)-import qualified Neuron.Version.RepoVersion as RepoVersion import Paths_neuron (version) import Relude import Text.ParserCombinators.ReadP (readP_to_S)@@ -14,12 +12,6 @@ -- | Neuron cabal library version neuronVersion :: Text neuronVersion = toText $ showVersion version---- | Neuron full version (cabal library version + git revision)-neuronVersionFull :: Text-neuronVersionFull- | Just gitVersion <- RepoVersion.version = T.concat [neuronVersion, " (", gitVersion, ")"]- | otherwise = neuronVersion -- | Check if `neuronVersion` is older than the given version olderThan :: Text -> Bool
− src/app/Neuron/Version/RepoVersion.hs
@@ -1,21 +0,0 @@-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE NoImplicitPrelude #-}---- | Neuron git repo version------ This module is loaded in ghcid and cabal new-repl. However, nix-build will--- have it overwritten by the then `git describe` (see default.nix).-module Neuron.Version.RepoVersion- ( version,- )-where--import Development.GitRev (gitDescribe, gitDirty)-import Relude--version :: Maybe Text-version- | versionByGit == toText "UNKNOWN" = Nothing- | otherwise = Just versionByGit- where- versionByGit = toText $ $(gitDescribe) <> bool "" "-dirty" $(gitDirty)
src/app/Neuron/Web/Generate.hs view
@@ -1,48 +1,160 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE ViewPatterns #-} {-# LANGUAGE NoImplicitPrelude #-} -- | Main module for using neuron as a library, instead of as a CLI tool. module Neuron.Web.Generate ( generateSite,+ loadZettelkasten, ) where -import Development.Shake (Action)-import Neuron.Config (Config (..))+import Data.FileEmbed (embedStringFile)+import qualified Data.Map.Strict as Map+import Data.Tagged (untag)+import qualified Data.Text as T+import Data.Traversable+import Development.Shake (Action, need) import Neuron.Config.Alias (Alias (..), getAliases)+import Neuron.Config.Type (Config (minVersion), getZettelFormats)+import Neuron.Reader (readerForZettelFormat)+import Neuron.Reader.Type (ZettelFormat, zettelFormatToExtension) import Neuron.Version (neuronVersion, olderThan)+import Neuron.Web.Generate.Route () import qualified Neuron.Web.Route as Z-import qualified Neuron.Zettelkasten.Graph as G-import qualified Neuron.Zettelkasten.Zettel as Z+import qualified Neuron.Zettelkasten.Graph.Build as G+import Neuron.Zettelkasten.Graph.Type (ZettelGraph)+import Neuron.Zettelkasten.ID (ZettelID, getZettelID)+import Neuron.Zettelkasten.Query.Error (showQueryError)+import Neuron.Zettelkasten.Zettel import Options.Applicative import Relude+import qualified Rib+import Rib.Route+import System.FilePath +searchScript :: Text+searchScript = $(embedStringFile "./src-js/search.js")+ -- | Generate the Zettelkasten site generateSite :: Config ->- (forall a. Z.Route G.ZettelGraph a -> (G.ZettelGraph, a) -> Action ()) ->- Action G.ZettelGraph+ (forall a. Z.Route a -> (ZettelGraph, a) -> Action ()) ->+ Action ZettelGraph generateSite config writeHtmlRoute' = do- when (olderThan $ minVersion config)- $ fail- $ toString- $ "Require neuron mininum version " <> minVersion config <> ", but your neuron version is " <> neuronVersion- (zettelGraph, zettels) <- G.loadZettelkasten- let writeHtmlRoute v r = writeHtmlRoute' r (zettelGraph, v)+ when (olderThan $ minVersion config) $ do+ fail $ toString $+ "Require neuron mininum version "+ <> minVersion config+ <> ", but your neuron version is "+ <> neuronVersion+ (zettelGraph, zettelContents, errors) <- loadZettelkasten config+ let writeHtmlRoute :: forall a. a -> Z.Route a -> Action ()+ writeHtmlRoute v r = writeHtmlRoute' r (zettelGraph, v) -- Generate HTML for every zettel- forM_ zettels $ \(z, d) ->- -- TODO: Should `Zettel` not contain ZettelID?- -- See duplication in `renderZettel`- writeHtmlRoute (z, d) $ Z.Route_Zettel (Z.zettelID z)+ forM_ zettelContents $ \val@(sansContent -> z) ->+ writeHtmlRoute val $ Z.Route_Zettel (zettelID z) -- Generate the z-index- writeHtmlRoute () Z.Route_ZIndex+ writeHtmlRoute errors Z.Route_ZIndex -- Generate search page- writeHtmlRoute () Z.Route_Search+ writeHtmlRoute searchScript Z.Route_Search -- Write alias redirects, unless a zettel with that name exists. aliases <- getAliases config zettelGraph forM_ aliases $ \Alias {..} -> writeHtmlRoute targetZettel (Z.Route_Redirect aliasZettel)+ -- Report all errors+ forM_ (Map.toList errors) $ \(zid, err) -> do+ reportError (Z.Route_Zettel zid) $+ case err of+ ZettelError_ParseError (untag -> parseErr) ->+ parseErr :| []+ ZettelError_QueryErrors queryErrs ->+ showQueryError <$> queryErrs+ ZettelError_AmbiguousFiles filePaths ->+ ("Multiple zettels have the same ID: " <> T.intercalate ", " (fmap toText $ toList filePaths))+ :| [] pure zettelGraph++-- | Report an error in the terminal+reportError :: (MonadIO m, IsRoute r) => r a -> NonEmpty Text -> m ()+reportError route errors = do+ path <- liftIO $ routeFile route+ putTextLn $ "E " <> toText path+ forM_ errors $ \err ->+ putText $ " - " <> indentAllButFirstLine 4 err+ where+ indentAllButFirstLine :: Int -> Text -> Text+ indentAllButFirstLine n = unlines . go . lines+ where+ go [] = []+ go [x] = [x]+ go (x : xs) =+ x : fmap (toText . (take n (repeat ' ') <>) . toString) xs++loadZettelkasten ::+ Config ->+ Action+ ( ZettelGraph,+ [ZettelC],+ Map ZettelID ZettelError+ )+loadZettelkasten config = do+ formats <- getZettelFormats config+ zettelFiles <- forM formats $ \fmt -> do+ let pat = toString $ "*" <> zettelFormatToExtension fmt+ files <- Rib.forEvery [pat] pure+ pure (fmt, files)+ loadZettelkastenFrom zettelFiles++-- | Load the Zettelkasten from disk, using the given list of zettel files+loadZettelkastenFrom ::+ NonEmpty (ZettelFormat, [FilePath]) ->+ Action+ ( ZettelGraph,+ [ZettelC],+ Map ZettelID ZettelError+ )+loadZettelkastenFrom fs = do+ notesDir <- Rib.ribInputDir+ -- Use State monad to "gather" duplicate zettel files using same IDs, in the+ -- `Right` of the Either state value; with the `Left` collecting the actual+ -- zettel files to load into the graph.+ zidMap :: Map ZettelID (Either (ZettelFormat, (FilePath, Text)) (NonEmpty FilePath)) <-+ fmap snd $ flip runStateT Map.empty $ do+ forM_ fs $ \(format, files) -> do+ forM_ files $ \relPath -> do+ case getZettelID relPath of+ Nothing ->+ pure ()+ Just zid -> do+ fmap (Map.lookup zid) get >>= \case+ Just (Left (_f, (oldPath, _s))) -> do+ -- The zettel ID is already used by `oldPath`. Mark it as a dup.+ modify $ Map.insert zid (Right $ relPath :| [oldPath])+ Just (Right (toList -> ambiguities)) -> do+ -- Third or later duplicate file with the same Zettel ID+ modify $ Map.insert zid (Right $ relPath :| ambiguities)+ Nothing -> do+ let absPath = notesDir </> relPath+ lift $ need [absPath]+ s <- decodeUtf8With lenientDecode <$> readFileBS absPath+ modify $ Map.insert zid (Left (format, (relPath, s)))+ let dups = fmap ZettelError_AmbiguousFiles $ Map.mapMaybe rightToMaybe zidMap+ files =+ fmap (first (id &&& readerForZettelFormat))+ $ Map.toList+ $ Map.fromListWith (<>)+ $ flip fmap (Map.toList $ Map.mapMaybe leftToMaybe zidMap)+ $ \(zid, (fmt, (path, s))) ->+ (fmt, [(zid, path, s)])+ (g, zs, gerrs) = G.buildZettelkasten files+ errs = Map.unions [dups, gerrs]+ pure (g, zs, errs)
+ src/app/Neuron/Web/Generate/Route.hs view
@@ -0,0 +1,64 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE Rank2Types #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++-- | Static generation of routes+module Neuron.Web.Generate.Route where++import Control.Monad.Except+import Data.Some+import Neuron.Web.Route (Route (..), RouteConfig (..))+import Neuron.Zettelkasten.ID+import Reflex.Dom.Core+import Relude+import Rib (IsRoute (..), routeUrl, routeUrlRel)+import qualified Text.URI as URI++instance IsRoute Route where+ routeFile = \case+ Route_Redirect zid ->+ routeFile $ Route_Zettel zid+ Route_ZIndex ->+ pure "z-index.html"+ Route_Search ->+ pure "search.html"+ Route_Zettel (zettelIDText -> s) ->+ pure $ toString s <> ".html"++staticRouteConfig :: RouteConfig t m+staticRouteConfig =+ RouteConfig True renderStaticRoute staticRouteUrl+ where+ renderStaticRoute :: DomBuilder t m => Some Route -> Map Text Text -> m a -> m a+ renderStaticRoute someR attrs w =+ withSome someR $ \r -> do+ let hrefAttr :: Map Text Text = "href" =: routeFor r+ elAttr "a" (attrs <> hrefAttr) w+ staticRouteUrl someR =+ withSome someR $ \r -> do+ routeFor r+ -- Using relative URLs enables the site work in file:/// URLs+ routeFor = routeUrlRel++data BaseUrlError+ = BaseUrlNotAbsolute+ deriving (Eq, Show)++instance Exception BaseUrlError++-- | Make an absolute URI for a route, given a base URL.+routeUri :: (HasCallStack, IsRoute r) => Text -> r a -> URI.URI+routeUri siteBaseUrl r = either (error . toText . displayException) id $ runExcept $ do+ baseUrl <- liftEither $ URI.mkURI siteBaseUrl+ uri <- liftEither $ URI.mkURI $ routeUrl r+ case URI.relativeTo uri baseUrl of+ Nothing -> liftEither $ Left $ toException BaseUrlNotAbsolute+ Just x -> pure x
− src/app/Neuron/Web/Route.hs
@@ -1,105 +0,0 @@-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE Rank2Types #-}-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE ViewPatterns #-}-{-# LANGUAGE NoImplicitPrelude #-}---- | Zettel site's routes-module Neuron.Web.Route where--import Control.Monad.Except-import qualified Data.Text as T-import GHC.Stack-import Neuron.Config-import Neuron.Zettelkasten.Graph.Type-import Neuron.Zettelkasten.ID-import Neuron.Zettelkasten.Zettel-import Relude-import Rib (IsRoute (..), routeUrl, routeUrlRel)-import Rib.Extra.OpenGraph-import qualified Rib.Parser.MMark as MMark-import Text.MMark.Extension (Extension)-import qualified Text.URI as URI--data Route graph a where- Route_Redirect :: ZettelID -> Route ZettelGraph ZettelID- Route_ZIndex :: Route ZettelGraph ()- Route_Search :: Route ZettelGraph ()- Route_Zettel :: ZettelID -> Route ZettelGraph (Zettel, Extension)--instance IsRoute (Route graph) where- routeFile = \case- Route_Redirect zid ->- routeFile $ Route_Zettel zid- Route_ZIndex ->- pure "z-index.html"- Route_Search ->- pure "search.html"- Route_Zettel (zettelIDText -> s) ->- pure $ toString s <> ".html"---- | Like `routeUrlRel` but takes a query parameter-routeUrlRelWithQuery :: HasCallStack => IsRoute r => r a -> URI.RText 'URI.QueryKey -> Text -> Text-routeUrlRelWithQuery r k v = maybe (error "Bad URI") URI.render $ do- param <- URI.QueryParam k <$> URI.mkQueryValue v- route <- URI.mkPathPiece $ routeUrlRel r- pure- URI.emptyURI- { URI.uriPath = Just (False, route :| []),- URI.uriQuery = [param]- }--routeUri :: (HasCallStack, IsRoute r) => Text -> r a -> URI.URI-routeUri siteBaseUrl r = either (error . toText . displayException) id $ runExcept $ do- baseUrl <- liftEither $ URI.mkURI siteBaseUrl- uri <- liftEither $ URI.mkURI $ routeUrl r- case URI.relativeTo uri baseUrl of- Nothing -> liftEither $ Left $ toException BaseUrlNotAbsolute- Just x -> pure x---- | Return full title for a route-routeTitle :: Config -> a -> Route graph a -> Text-routeTitle Config {..} val =- withSuffix siteTitle . routeTitle' val- where- withSuffix suffix x =- if x == suffix- then x- else x <> " - " <> suffix---- | Return the title for a route-routeTitle' :: a -> Route graph a -> Text-routeTitle' val = \case- Route_Redirect _ -> "Redirecting..."- Route_ZIndex -> "Zettel Index"- Route_Search -> "Search"- Route_Zettel _ ->- zettelTitle $ fst val--routeOpenGraph :: Config -> a -> Route graph a -> OpenGraph-routeOpenGraph Config {..} val r =- OpenGraph- { _openGraph_title = routeTitle' val r,- _openGraph_siteName = siteTitle,- _openGraph_description = case r of- Route_Redirect _ -> Nothing- Route_ZIndex -> Just "Zettelkasten Index"- Route_Search -> Just "Search Zettelkasten"- Route_Zettel _ ->- T.take 300 <$> MMark.getFirstParagraphText (zettelContent $ fst val),- _openGraph_author = author,- _openGraph_type = case r of- Route_Zettel _ -> Just $ OGType_Article (Article Nothing Nothing Nothing Nothing mempty)- _ -> Just OGType_Website,- _openGraph_image = case r of- Route_Zettel _ -> do- img <- MMark.getFirstImg (zettelContent $ fst val)- baseUrl <- URI.mkURI =<< siteBaseUrl- URI.relativeTo img baseUrl- _ -> Nothing,- _openGraph_url = Nothing- }
+ src/app/Neuron/Web/StructuredData.hs view
@@ -0,0 +1,116 @@+{-# LANGUAGE GADTs #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE NoImplicitPrelude #-}++module Neuron.Web.StructuredData+ ( renderStructuredData,+ )+where++import Data.Structured.Breadcrumb (Breadcrumb)+import qualified Data.Structured.Breadcrumb as Breadcrumb+import qualified Data.Text as T+import Data.Time.ISO8601 (formatISO8601)+import Neuron.Config.Type+import Neuron.Web.Generate.Route (routeUri)+import Neuron.Web.Route+import Neuron.Zettelkasten.Connection+import Neuron.Zettelkasten.Graph (ZettelGraph)+import qualified Neuron.Zettelkasten.Graph as G+import Neuron.Zettelkasten.Zettel+import Reflex.Dom.Core hiding ((&))+import Relude+import Rib.Extra.OpenGraph+import qualified Rib.Parser.Pandoc as Pandoc+import Text.Pandoc (runPure, writePlain)+import Text.Pandoc.Definition (Block (Plain), Inline, Pandoc (..))+import Text.Pandoc.Util (getFirstParagraphText)+import qualified Text.URI as URI++renderStructuredData :: DomBuilder t m => Config -> Route a -> (ZettelGraph, a) -> m ()+renderStructuredData config route val = do+ renderOpenGraph $ routeOpenGraph config (snd val) route+ Breadcrumb.renderBreadcrumbs $ routeStructuredData config val route++routeStructuredData :: Config -> (ZettelGraph, a) -> Route a -> [Breadcrumb]+routeStructuredData Config {..} (graph, v) = \case+ Route_Zettel _ ->+ case siteBaseUrl of+ Nothing -> []+ Just baseUrl ->+ let mkCrumb :: Zettel -> Breadcrumb.Item+ mkCrumb Zettel {..} =+ Breadcrumb.Item zettelTitle (Just $ routeUri baseUrl $ Route_Zettel zettelID)+ in Breadcrumb.fromForest $ fmap mkCrumb <$> G.backlinkForest Folgezettel (sansContent v) graph+ _ ->+ []++routeOpenGraph :: Config -> a -> Route a -> OpenGraph+routeOpenGraph Config {..} v r =+ OpenGraph+ { _openGraph_title = routeTitle' v r,+ _openGraph_siteName = siteTitle,+ _openGraph_description = case r of+ Route_Redirect _ -> Nothing+ Route_ZIndex -> Just "Zettelkasten Index"+ Route_Search -> Just "Search Zettelkasten"+ Route_Zettel _ -> do+ doc <- getPandocDoc v+ para <- getFirstParagraphText doc+ paraText <- renderPandocAsText para+ pure $ T.take 300 paraText,+ _openGraph_author = author,+ _openGraph_type = case r of+ Route_Zettel _ -> Just $ OGType_Article (Article Nothing Nothing Nothing Nothing mempty)+ _ -> Just OGType_Website,+ _openGraph_image = case r of+ Route_Zettel _ -> do+ doc <- getPandocDoc v+ image <- URI.mkURI =<< Pandoc.getFirstImg doc+ baseUrl <- URI.mkURI =<< siteBaseUrl+ URI.relativeTo image baseUrl+ _ -> Nothing,+ _openGraph_url = do+ baseUrl <- siteBaseUrl+ pure $ routeUri baseUrl r+ }+ where+ getPandocDoc = either (const Nothing) (Just . zettelContent)++renderOpenGraph :: forall t m. DomBuilder t m => OpenGraph -> m ()+renderOpenGraph OpenGraph {..} = do+ meta' "author" `mapM_` _openGraph_author+ meta' "description" `mapM_` _openGraph_description+ requireAbsolute "OGP URL" (\ourl -> elAttr "link" ("rel" =: "canonical" <> "href" =: ourl) blank) `mapM_` _openGraph_url+ metaOg "title" _openGraph_title+ metaOg "site_name" _openGraph_siteName+ whenJust _openGraph_type $ \case+ OGType_Article (Article {..}) -> do+ metaOg "type" "article"+ metaOg "article:section" `mapM_` _article_section+ metaOgTime "article:modified_time" `mapM_` _article_modifiedTime+ metaOgTime "article:published_time" `mapM_` _article_publishedTime+ metaOgTime "article:expiration_time" `mapM_` _article_expirationTime+ metaOg "article:tag" `mapM_` _article_tag+ OGType_Website -> do+ metaOg "type" "website"+ requireAbsolute "OGP image URL" (metaOg "image") `mapM_` _openGraph_image+ where+ meta' k v =+ elAttr "meta" ("name" =: k <> "content" =: v) blank+ metaOg k v =+ elAttr "meta" ("property" =: ("og:" <> k) <> "content" =: v) blank+ metaOgTime k t =+ metaOg k $ toText $ formatISO8601 t+ requireAbsolute :: Text -> (Text -> m ()) -> URI.URI -> m ()+ requireAbsolute description f uri' =+ if isJust (URI.uriScheme uri')+ then f $ URI.render uri'+ else error $ description <> " must be absolute. this URI is not: " <> URI.render uri'++renderPandocAsText :: [Inline] -> Maybe Text+renderPandocAsText =+ either (const Nothing) Just . runPure . writePlain def . Pandoc mempty . pure . Plain
− src/app/Neuron/Web/Theme.hs
@@ -1,79 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeApplications #-}-{-# LANGUAGE NoImplicitPrelude #-}---- | HTML & CSS-module Neuron.Web.Theme where--import Data.Text (toLower)-import Relude---- | Neuron color theme------ Each theme corresponds to the color supported by Semantic UI--- https://semantic-ui.com/usage/theming.html#sitewide-defaults-data Theme- = Teal- | Brown- | Red- | Orange- | Yellow- | Olive- | Green- | Blue- | Violet- | Purple- | Pink- | Grey- | Black- deriving (Eq, Show, Enum, Bounded)--withRgb :: Theme -> (Integer -> Integer -> Integer -> a) -> a-withRgb theme f =- case theme of- Teal ->- f 0 181 173- Brown ->- f 165 103 63- Red ->- f 219 40 40- Orange ->- f 242 113 28- Yellow ->- f 251 189 8- Olive ->- f 181 204 24- Green ->- f 33 186 69- Blue ->- f 33 133 208- Violet ->- f 100 53 201- Purple ->- f 163 51 200- Pink ->- f 224 57 151- Grey ->- f 118 118 118- Black ->- f 27 28 29---- | Convert Theme to Semantic UI color name-semanticColor :: Theme -> Text-semanticColor = toLower . show @Text---- | Make Theme from Semantic UI color name-mkTheme :: Text -> Theme-mkTheme s =- fromMaybe (error $ "Unsupported theme: " <> s)- $ listToMaybe- $ catMaybes- $ flip fmap [minBound .. maxBound]- $ \theme ->- if s == semanticColor theme- then Just theme- else Nothing--defaultTheme :: Theme-defaultTheme = Teal
src/app/Neuron/Web/View.hs view
@@ -7,7 +7,6 @@ {-# LANGUAGE Rank2Types #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE ViewPatterns #-}@@ -15,330 +14,209 @@ -- | HTML & CSS module Neuron.Web.View- ( renderRouteHead,- renderRouteBody,- style,+ ( renderRoutePage, ) where -import Clay hiding (id, ms, object, reverse, s, style, type_)+import Clay ((?), Css, em, gray, important, pct, px) import qualified Clay as C-import Data.Aeson ((.=), object)+import Control.Monad.Except+import Data.Aeson ((.=), object, toJSON) 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-import Data.Structured.Breadcrumb (Breadcrumb)-import qualified Data.Structured.Breadcrumb as Breadcrumb+import Data.Some import Data.TagTree (Tag (..))-import Data.Tree (Tree (..))-import Lucid-import Neuron.Config-import Neuron.Version (neuronVersionFull)+import Neuron.Config.Type (Config (..))+import Neuron.Web.Common (neuronCommonStyle, neuronFonts)+import Neuron.Web.Manifest (Manifest, renderManifest)+import qualified Neuron.Web.Query.View as QueryView import Neuron.Web.Route+import Neuron.Web.StructuredData+import Neuron.Web.Theme (Theme) import qualified Neuron.Web.Theme as Theme-import Neuron.Zettelkasten.Connection+import Neuron.Web.Widget+import qualified Neuron.Web.ZIndex as ZIndex+import qualified Neuron.Web.Zettel.CSS as ZettelCSS+import qualified Neuron.Web.Zettel.View as ZettelView import qualified Neuron.Zettelkasten.Graph as G import Neuron.Zettelkasten.Graph (ZettelGraph)-import Neuron.Zettelkasten.ID (ZettelID (..), zettelIDSourceFileName, zettelIDText)-import Neuron.Zettelkasten.Query.View (renderZettelLink)+import Neuron.Zettelkasten.ID (ZettelID (..)) import Neuron.Zettelkasten.Zettel-import Relude-import qualified Rib-import Rib.Extra.CSS (mozillaKbdStyle)-import qualified Rib.Parser.MMark as MMark-import Text.MMark (Extension, useExtensions)-import Text.Pandoc.Highlighting (styleToCss, tango)-import Text.URI.QQ+import Reflex.Dom.Core hiding ((&))+import Reflex.Dom.Pandoc (PandocBuilder)+import Relude hiding ((&))+import qualified Skylighting.Format.HTML as Skylighting+import qualified Skylighting.Styles as Skylighting -searchScript :: Text-searchScript = $(embedStringFile "./src-js/search.js")+-- | Render the given route+renderRoutePage :: PandocBuilder t m => Text -> Config -> Manifest -> Route a -> (ZettelGraph, a) -> NeuronWebT t m ()+renderRoutePage neuronVersion config manifest r val =+ elAttr "html" ("lang" =: "en") $ do+ el "head" $ do+ renderRouteHead config manifest r val+ el "body" $ do+ renderRouteBody neuronVersion config r val -renderRouteHead :: Monad m => Config -> Route graph a -> (graph, a) -> HtmlT m ()-renderRouteHead config r val = do- meta_ [httpEquiv_ "Content-Type", content_ "text/html; charset=utf-8"]- meta_ [name_ "viewport", content_ "width=device-width, initial-scale=1"]- title_ $ toHtml $ routeTitle config (snd val) r- link_ [rel_ "shortcut icon", href_ "https://raw.githubusercontent.com/srid/neuron/master/assets/logo.ico"]- case r of+renderRouteHead :: DomBuilder t m => Config -> Manifest -> Route a -> (ZettelGraph, a) -> m ()+renderRouteHead config manifest route val = do+ elAttr "meta" ("http-equiv" =: "Content-Type" <> "content" =: "text/html; charset=utf-8") blank+ elAttr "meta" ("name" =: "viewport" <> "content" =: "width=device-width, initial-scale=1") blank+ el "title" $ text $ routeTitle config (snd val) route+ renderManifest manifest+ case route of Route_Redirect _ ->- mempty+ blank Route_Search {} -> do- with (script_ mempty) [src_ "https://cdn.jsdelivr.net/npm/jquery@3.5.0/dist/jquery.min.js"]- with (script_ mempty) [src_ "https://cdn.jsdelivr.net/npm/semantic-ui@2.4.2/dist/semantic.min.js"]- with (script_ mempty) [src_ "https://cdn.jsdelivr.net/npm/js-search@2.0.0/dist/umd/js-search.min.js"]+ renderCommon+ forM_+ [ "https://cdn.jsdelivr.net/npm/jquery@3.5.0/dist/jquery.min.js",+ "https://cdn.jsdelivr.net/npm/semantic-ui@2.4.2/dist/semantic.min.js",+ "https://cdn.jsdelivr.net/npm/js-search@2.0.0/dist/umd/js-search.min.js"+ ]+ $ \scrpt -> do+ elAttr "script" ("src" =: scrpt) blank _ -> do- toHtml $ routeOpenGraph config (snd val) r- toHtml $ routeStructuredData config val r- style_ [type_ "text/css"] $ styleToCss tango+ renderCommon+ renderStructuredData config route val+ elAttr "style" ("type" =: "text/css") $ text $ toText $ Skylighting.styleToCss Skylighting.tango where- routeStructuredData :: Config -> (g, a) -> Route g a -> [Breadcrumb]- routeStructuredData Config {..} (graph, v) = \case- Route_Zettel _ ->- case siteBaseUrl of- Nothing -> []- Just baseUrl ->- let mkCrumb :: Zettel -> Breadcrumb.Item- mkCrumb Zettel {..} =- Breadcrumb.Item zettelTitle (Just $ routeUri baseUrl $ Route_Zettel zettelID)- in Breadcrumb.fromForest $ fmap mkCrumb <$> G.backlinkForest Folgezettel (fst v) graph- _ ->- []--renderRouteBody :: Monad m => Config -> Route graph a -> (graph, a) -> HtmlT m ()-renderRouteBody config r (g, x) = do- case r of- Route_ZIndex ->- renderIndex config g- Route_Search {} ->- renderSearch g- Route_Zettel zid ->- renderZettel config (g, x) zid- Route_Redirect _ ->- meta_ [httpEquiv_ "Refresh", content_ $ "0; url=" <> (Rib.routeUrlRel $ Route_Zettel x)]+ renderCommon = do+ let neuronCss = toText $ C.renderWith C.compact [] style+ elAttr "link" ("rel" =: "stylesheet" <> "href" =: "https://cdn.jsdelivr.net/npm/fomantic-ui@2.8.5/dist/semantic.min.css") blank+ elAttr "style" ("type" =: "text/css") $ text neuronCss+ elLinkGoogleFonts neuronFonts+ when (mathJaxSupport config) $+ elAttr "script" ("id" =: "MathJax-script" <> "src" =: "https://cdn.jsdelivr.net/npm/mathjax@3/es5/tex-mml-chtml.js" <> "async" =: "") blank+ routeTitle :: Config -> a -> Route a -> Text+ routeTitle Config {..} v =+ withSuffix siteTitle . routeTitle' v+ where+ withSuffix suffix x =+ if x == suffix+ then x+ else x <> " - " <> suffix -renderIndex :: Monad m => Config -> ZettelGraph -> HtmlT m ()-renderIndex Config {..} graph = do+renderRouteBody :: PandocBuilder t m => Text -> Config -> Route a -> (ZettelGraph, a) -> NeuronWebT t m ()+renderRouteBody neuronVersion Config {..} r (g, x) = do let neuronTheme = Theme.mkTheme theme- h1_ [class_ "header"] $ "Zettel Index"- div_ [class_ "z-index"] $ do- -- Cycle detection.- case G.topSort graph of- Left (toList -> cyc) -> div_ [class_ "ui orange segment"] $ do- h2_ "Cycle detected"- forM_ cyc $ \zettel ->- li_ $ renderZettelLink def zettel- _ -> mempty- let clusters = G.categoryClusters graph- p_ $ do- "There " <> countNounBe "cluster" "clusters" (length clusters) <> " in the Zettelkasten graph. "- "Each cluster is rendered as a forest, with their roots (mother zettels) highlighted."- forM_ clusters $ \forest ->- div_ [class_ $ "ui stacked " <> Theme.semanticColor neuronTheme <> " segment"] $ do- -- Forest of zettels, beginning with mother vertices.- ul_ $ renderForest True Nothing True graph forest- renderBrandFooter True- where- countNounBe noun nounPlural = \case- 1 -> "is 1 " <> noun- n -> "are " <> show n <> " " <> nounPlural+ themeSelector = toText $ Theme.themeIdentifier neuronTheme+ indexZettel = G.getZettel (ZettelCustomID "index") g+ elAttr "div" ("class" =: "ui fluid container" <> "id" =: themeSelector) $ do+ case r of+ Route_ZIndex -> do+ actionsNav neuronTheme indexZettel Nothing+ divClass "ui text container" $ do+ let zIndexData = ZIndex.buildZIndex g x+ ZIndex.renderZIndex neuronTheme zIndexData+ renderBrandFooter $ Just neuronVersion+ pure mempty+ Route_Search {} -> do+ actionsNav neuronTheme indexZettel Nothing+ divClass "ui text container" $ do+ renderSearch g x+ renderBrandFooter $ Just neuronVersion+ pure mempty+ Route_Zettel _ -> do+ -- Don't inject neuron verison in zettel pages, to prevent unnecessary rebuilds when upgrading neuron+ let noVersion = Nothing+ zettelEditUrl = (<> toText (zettelPath $ sansContent x)) <$> editUrl+ actionsNav neuronTheme indexZettel zettelEditUrl+ ZettelView.renderZettel (g, x)+ <* renderBrandFooter noVersion+ Route_Redirect _ -> do+ targetUrl <- neuronRouteURL $ Some $ Route_Zettel x+ elAttr "meta" ("http-equiv" =: "Refresh" <> "content" =: ("0; url=" <> targetUrl)) blank -renderSearch :: forall m. Monad m => ZettelGraph -> HtmlT m ()-renderSearch graph = do- h1_ [class_ "header"] $ "Search"- div_ [class_ "ui fluid icon input search"] $ do- input_ [type_ "text", id_ "search-input"]+renderSearch :: DomBuilder t m => ZettelGraph -> Text -> m ()+renderSearch graph script = do+ elClass "h1" "header" $ text "Search"+ divClass "ui fluid icon input search" $ do+ elAttr "input" ("type" =: "text" <> "id" =: "search-input") blank fa "search icon fas fa-search"- div_ [class_ "ui hidden divider"] mempty+ divClass "ui hidden divider" blank let allZettels = G.getZettels graph allTags = Set.fromList $ concatMap zettelTags allZettels index = object ["zettels" .= fmap (object . zettelJson) allZettels, "tags" .= allTags]- div_ [class_ "ui fluid multiple search selection dropdown", id_ "search-tags"] $ do- with (input_ mempty) [name_ "tags", type_ "hidden"]- with (i_ mempty) [class_ "dropdown icon"]- div_ [class_ "default text"] "Select tags…"- div_ [class_ "menu"] $ do- forM_ allTags $ \tag -> do- div_ [class_ "item"] $ toHtml (unTag tag)- div_ [class_ "ui divider"] mempty- ul_ [id_ "search-results", class_ "zettel-list"] mempty- script_ $ "let index = " <> toText (Aeson.encodeToLazyText index) <> ";"- script_ searchScript--renderZettel :: forall m. Monad m => Config -> (ZettelGraph, (Zettel, Extension)) -> ZettelID -> HtmlT m ()-renderZettel config@Config {..} (graph, (z@Zettel {..}, ext)) zid = do- let neuronTheme = Theme.mkTheme theme- div_ [class_ "zettel-view"] $ do- div_ [class_ "ui raised segments"] $ do- div_ [class_ "ui top attached segment"] $ do- h1_ [class_ "header"] $ toHtml zettelTitle- let mmarkExts = getMarkdownExtensions config- MMark.render $ useExtensions (ext : mmarkExts) zettelContent- whenNotNull zettelTags $ \_ ->- renderTags zettelTags- forM_ zettelDay $ \day ->- div_ [class_ "date", title_ "Zettel creation date"] $ toHtml $ show @Text day- div_ [class_ $ "ui inverted " <> Theme.semanticColor neuronTheme <> " top attached connections segment"] $ do- div_ [class_ "ui two column grid"] $ do- div_ [class_ "column"] $ do- div_ [class_ "ui header"] "Down"- 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 False graph $- G.backlinkForest Folgezettel z graph- div_ [class_ "ui header"] "Other backlinks"- ul_ $ do- renderForest True Nothing False graph- $ fmap (flip Node [])- $ G.backlinks OrdinaryConnection z graph- div_ [class_ "ui inverted black bottom attached footer segment"] $ do- div_ [class_ "ui equal width grid"] $ do- div_ [class_ "center aligned column"] $ do- let homeUrl = maybe "." (const "index.html") $ G.getZettel (ZettelCustomID "index") graph- a_ [href_ homeUrl, title_ "/"] $ fa "fas fa-home"- whenJust editUrl $ \urlPrefix ->- div_ [class_ "center aligned column"] $ do- a_ [href_ $ urlPrefix <> toText (zettelIDSourceFileName zid), title_ "Edit this Zettel"] $ fa "fas fa-edit"- div_ [class_ "center aligned column"] $ do- a_ [href_ (Rib.routeUrlRel Route_Search), title_ "Search Zettels"] $ fa "fas fa-search"- div_ [class_ "center aligned column"] $ do- a_ [href_ (Rib.routeUrlRel Route_ZIndex), title_ "All Zettels (z-index)"] $- fa "fas fa-tree"- renderBrandFooter False--renderBrandFooter :: Monad m => Bool -> HtmlT m ()-renderBrandFooter withVersion =- div_ [class_ "ui one column grid footer-version"] $ do- div_ [class_ "center aligned column"] $ do- p_ $ do- "Generated by "- a_ [href_ "https://github.com/srid/neuron"] "Neuron"- when withVersion $ do- " "- code_ $ toHtml @Text neuronVersionFull+ elAttr "div" ("class" =: "ui fluid multiple search selection dropdown" <> "id" =: "search-tags") $ do+ elAttr "input" ("name" =: "tags" <> "type" =: "hidden") blank+ elClass "i" "dropdown icon" blank+ divClass "default text" $ text "Select tags…"+ divClass "menu" $ do+ forM_ allTags $ \t -> do+ divClass "item" $ text (unTag t)+ divClass "ui divider" blank+ elAttr "ul" ("id" =: "search-results" <> "class" =: "zettel-list") blank+ el "script" $ text $ "let index = " <> toText (Aeson.encodeToLazyText index) <> ";"+ el "script" $ text script+ where+ zettelJson Zettel {..} =+ [ "id" .= toJSON zettelID,+ "title" .= zettelTitle,+ "tags" .= zettelTags,+ "day" .= zettelDay+ ] -renderTags :: Monad m => [Tag] -> HtmlT m ()-renderTags tags = do- forM_ tags $ \(unTag -> tag) -> do- -- TODO: Ideally this should be at the top, not bottom. But putting it at- -- the top pushes the zettel content down, introducing unnecessary white- -- space below the title. So we put it at the bottom for now.- span_ [class_ "ui black right ribbon label", title_ "Tag"] $ do- a_- [ href_ $ routeUrlRelWithQuery Route_Search [queryKey|tag|] tag,- title_ ("See all zettels tagged '" <> tag <> "'")- ]- $ toHtml tag- p_ mempty+renderBrandFooter :: DomBuilder t m => Maybe Text -> m ()+renderBrandFooter mver =+ divClass "ui one column grid footer-version" $ do+ divClass "center aligned column" $ do+ divClass "ui tiny image" $ do+ elAttr "a" ("href" =: "https://neuron.zettel.page") $ do+ elAttr+ "img"+ ( "src" =: "https://raw.githubusercontent.com/srid/neuron/master/assets/neuron.svg"+ <> "alt" =: "logo"+ <> "title" =: ("Generated by Neuron" <> maybe "" (" " <>) mver)+ )+ blank -- | Font awesome element-fa :: Monad m => Text -> HtmlT m ()-fa k = with i_ [class_ k] mempty+fa :: DomBuilder t m => Text -> m ()+fa k = elClass "i" k blank -renderForest ::- Monad m =>- Bool ->- Maybe Int ->- Bool ->- ZettelGraph ->- [Tree Zettel] ->- HtmlT m ()-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" renderingFullTree]- bool id zettelDiv isRoot $- renderZettelLink def zettel- when renderingFullTree $ do- " "- case G.backlinks Folgezettel zettel g of- conns@(_ : _ : _) ->- -- Has two or more category backlinks- forM_ conns $ \zettel2 -> do- 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) renderingFullTree g subtrees- where- -- Sort trees so that trees containing the most recent zettel (by ID) come first.- sortForest = reverse . sortOn maximum+actionsNav :: DomBuilder t m => Theme -> Maybe Zettel -> Maybe Text -> NeuronWebT t m ()+actionsNav theme mIndexZettel mEditUrl = elClass "nav" "top-menu" $ do+ divClass ("ui inverted compact neuron icon menu " <> Theme.semanticColor theme) $ do+ forM_ mIndexZettel $ \Zettel {..} ->+ neuronRouteLink (Some $ Route_Zettel zettelID) ("class" =: "left item" <> "title" =: "Home") $+ semanticIcon "home"+ neuronRouteLink (Some Route_Search) ("class" =: "left item" <> "title" =: "Search Zettels") $ do+ semanticIcon "search"+ forM_ mEditUrl $ \editUrl -> do+ let attrs = ("href" =: editUrl <> "title" =: "Edit this Zettel")+ elAttr "a" ("class" =: "center item" <> attrs) $ do+ semanticIcon "edit"+ neuronRouteLink (Some Route_ZIndex) ("class" =: "right item" <> "title" =: "All Zettels (z-index)") $+ semanticIcon "tree" -style :: Config -> Css-style Config {..} = do- let neuronTheme = Theme.mkTheme theme- linkColor = Theme.withRgb neuronTheme C.rgb- "span.zettel-link-container span.zettel-link a" ? do- C.fontWeight C.bold- C.color linkColor- C.textDecoration C.none- "span.zettel-link-container span.zettel-link a:hover" ? do- C.backgroundColor linkColor- C.color C.white- "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- C.paddingLeft $ em 1.5- "div.zettel-view" ? do- "div.date" ? do- C.textAlign C.center- C.color C.gray- C.ul ? do- C.paddingLeft $ em 1.5- C.listStyleType C.square- C.li ? do- mempty -- C.paddingBottom $ em 1- C.h1 ? do- C.paddingTop $ em 0.2- C.paddingBottom $ em 0.2- C.textAlign C.center- C.fontWeight $ weight 700- C.backgroundColor $ Theme.withRgb neuronTheme C.rgba 0.1- C.h2 ? do- C.fontWeight $ weight 600- C.borderBottom C.solid (px 1) C.steelblue- C.marginBottom $ em 0.5- C.h3 ? do- C.fontWeight $ weight 400- C.margin (px 0) (px 0) (em 0.4) (px 0)- C.h4 ? do- C.fontWeight $ weight 300- C.opacity 0.8- codeStyle- blockquoteStyle- kbd ? mozillaKbdStyle- "div.tag-tree" ? do- "div.node" ? do- C.fontWeight C.bold- "a.inactive" ? do- C.color "#555"- "div.connections" ? do- "a" ? do- C.important $ color white- "a:hover" ? do- C.opacity 0.5- ".footer" ? do- "a" ? do- C.color white- ".footer-version, .footer-version a, .footer-version a:visited" ? do- C.color gray- ".footer-version a" ? do- C.fontWeight C.bold- ".footer-version" ? do- C.fontSize $ em 0.7- "[data-tooltip]:after" ? do- C.fontSize $ em 0.7+style :: Css+style = do+ "body" ? do+ neuronCommonStyle+ ZIndex.style+ ZettelCSS.zettelCss+ QueryView.style+ footerStyle+ navBarStyle where- codeStyle = do- C.code ? do- sym margin auto- fontSize $ pct 90- "code, pre, tt" ? do- fontFamily ["SFMono-Regular", "Menlo", "Monaco", "Consolas", "Liberation Mono", "Courier New"] [monospace]- pre ? do- sym padding $ em 0.5- C.overflow auto- C.maxWidth $ pct 100- "div.source-code" ? do- marginLeft auto- marginRight auto- pre ? do- backgroundColor "#f8f8f8"- -- https://css-tricks.com/snippets/css/simple-and-nice-blockquote-styling/- blockquoteStyle =- C.blockquote ? do- C.backgroundColor "#f9f9f9"- C.borderLeft C.solid (px 10) "#ccc"- sym2 C.margin (em 1.5) (px 0)- sym2 C.padding (em 0.5) (px 10)+ footerStyle = do+ ".footer-version img" ? do+ C.filter $ C.grayscale $ pct 100+ ".footer-version img:hover" ? do+ C.filter $ C.grayscale $ pct 0+ ".footer-version, .footer-version a, .footer-version a:visited" ? do+ C.color gray+ ".footer-version a" ? do+ C.fontWeight C.bold+ ".footer-version" ? do+ important $ C.marginTop $ em 1+ C.fontSize $ em 0.7+ navBarStyle = do+ "nav.top-menu" ? do+ C.paddingTop $ em 1+ C.paddingBottom $ em 1+ C.justifyContent C.center+ C.textAlign C.center+ "> *" ? do+ C.paddingLeft $ px 0+ C.paddingRight $ px 0
− src/app/Neuron/Zettelkasten/Connection.hs
@@ -1,23 +0,0 @@-{-# LANGUAGE DeriveAnyClass #-}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE NoImplicitPrelude #-}--module Neuron.Zettelkasten.Connection where--import Data.Aeson (ToJSON)-import Relude---- | Represent the connection between zettels-data Connection- = -- | A folgezettel points to a zettel that is conceptually a *part* of the- -- parent zettel.- Folgezettel- | -- | Any other ordinary connection (eg: "See also")- OrdinaryConnection- deriving (Eq, Ord, Show, Enum, Bounded, Generic, ToJSON)--instance Semigroup Connection where- -- A folgezettel link trumps all other kinds in that zettel.- Folgezettel <> _ = Folgezettel- _ <> Folgezettel = Folgezettel- OrdinaryConnection <> OrdinaryConnection = OrdinaryConnection
− src/app/Neuron/Zettelkasten/Error.hs
@@ -1,40 +0,0 @@-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE NoImplicitPrelude #-}--module Neuron.Zettelkasten.Error- ( NeuronError (..),- )-where--import Neuron.Zettelkasten.ID (ZettelID, zettelIDSourceFileName, zettelIDText)-import Neuron.Zettelkasten.Query.Error-import Relude-import qualified Text.Show-import qualified Text.URI as URI--data NeuronError- = -- A zettel file contains invalid link that neuron cannot parse- NeuronError_BadQuery ZettelID QueryError- deriving (Eq)--instance Show NeuronError where- show (NeuronError_BadQuery fromZid e) =- let msg = case e of- Left qe ->- "it contains a query URI (" <> URI.render (queryParseErrorUri qe) <> ") " <> case qe of- QueryParseError_UnsupportedHost _uri ->- "with unsupported host"- QueryParseError_InvalidID _uri e'' ->- "with invalidID: " <> show e''- Right (QueryResultError_NoSuchZettel zid) ->- "Zettel "- <> zettelIDText zid- <> " does not exist"- in toString $- unlines- [ "",- " Zettel file \"" <> toText (zettelIDSourceFileName fromZid) <> "\" is malformed:",- " " <> msg- ]
− src/app/Neuron/Zettelkasten/Graph.hs
@@ -1,131 +0,0 @@-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TupleSections #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE ViewPatterns #-}-{-# LANGUAGE NoImplicitPrelude #-}--module Neuron.Zettelkasten.Graph- ( -- * Graph type- ZettelGraph,-- -- * Construction- loadZettels,- loadZettelkasten,- loadZettelkastenFrom,-- -- * Graph functions- getZettels,- getZettel,- topSort,- frontlinkForest,- backlinkForest,- backlinks,- clusters,- categoryClusters,- )-where--import Control.Monad.Except-import Data.Foldable (maximum)-import qualified Data.Graph.Labelled as G-import qualified Data.Map.Strict as Map-import Data.Traversable (for)-import Data.Tree-import Development.Shake-import Neuron.Zettelkasten.Connection-import Neuron.Zettelkasten.Error-import Neuron.Zettelkasten.Graph.Type-import Neuron.Zettelkasten.ID-import Neuron.Zettelkasten.Query.Eval-import Neuron.Zettelkasten.Zettel-import Relude-import qualified Rib-import System.FilePath-import Text.MMark.Extension (Extension)-import Text.MMark.Extension.ReplaceLink (replaceLink)--loadZettels :: Action [Zettel]-loadZettels =- fmap (fmap fst . snd) loadZettelkasten--loadZettelkasten :: Action (ZettelGraph, [(Zettel, Extension)])-loadZettelkasten =- loadZettelkastenFrom =<< Rib.forEvery ["*.md"] pure---- | Load the Zettelkasten from disk, using the given list of zettel files-loadZettelkastenFrom :: [FilePath] -> Action (ZettelGraph, [(Zettel, Extension)])-loadZettelkastenFrom files = do- notesDir <- Rib.ribInputDir- zettels <- forM files $ \((notesDir </>) -> path) -> do- s <- fmap toText $ readFile' path- let zid = mkZettelID path- case mkZettelFromMarkdown zid s snd of- Left e -> fail $ toString e- Right zettel -> pure zettel- -- zettels <- mkZettelFromPath `mapM` files- either (fail . show) pure $ mkZettelGraph zettels---- | Build the Zettelkasten graph from a list of zettels------ Also return the markdown extension to use for each zettel.-mkZettelGraph ::- forall m.- MonadError NeuronError m =>- [Zettel] ->- m (ZettelGraph, [(Zettel, Extension)])-mkZettelGraph zettels = do- zettelsWithQueryResults <-- liftEither $ runExcept $ do- for zettels $ \z ->- withExcept (NeuronError_BadQuery (zettelID z)) $- (z,) <$> evalZettelLinks zettels z- zettelsWithExtensions <- for zettelsWithQueryResults $ \(z, resMap) -> liftEither $ runExcept $ do- pure $ (z,) $ replaceLink $ snd `Map.map` resMap- let edges :: [(Maybe Connection, Zettel, Zettel)] = flip concatMap zettelsWithQueryResults $ \(z, resMap) ->- let conns :: [(Connection, Zettel)] = concatMap fst $ Map.elems resMap- in conns <&> \(cs, z2) -> (Just cs, z, z2)- pure (G.mkGraphFrom zettels edges, zettelsWithExtensions)--frontlinkForest :: Connection -> Zettel -> ZettelGraph -> Forest Zettel-frontlinkForest conn z =- G.obviateRootUnlessForest z- . G.dfsForestFrom [z]- . G.induceOnEdge (== Just conn)--backlinkForest :: Connection -> Zettel -> ZettelGraph -> Forest Zettel-backlinkForest conn z =- G.obviateRootUnlessForest z- . G.dfsForestBackwards z- . G.induceOnEdge (== Just conn)--backlinks :: Connection -> Zettel -> ZettelGraph -> [Zettel]-backlinks conn z =- G.preSet z . G.induceOnEdge (== Just conn)--categoryClusters :: ZettelGraph -> [Forest Zettel]-categoryClusters (categoryGraph -> g) =- let cs :: [[Zettel]] = sortMothers $ clusters g- in flip fmap cs $ \zs -> G.dfsForestFrom zs g- where- -- Sort clusters with newer mother zettels appearing first.- sortMothers :: [NonEmpty Zettel] -> [[Zettel]]- sortMothers = sortOn (Down . maximum) . fmap (sortOn Down . toList)--clusters :: ZettelGraph -> [NonEmpty Zettel]-clusters = G.clusters . categoryGraph--topSort :: ZettelGraph -> Either (NonEmpty Zettel) [Zettel]-topSort = G.topSort . categoryGraph--categoryGraph :: ZettelGraph -> ZettelGraph-categoryGraph = G.induceOnEdge (== Just Folgezettel)--getZettels :: ZettelGraph -> [Zettel]-getZettels = G.getVertices--getZettel :: ZettelID -> ZettelGraph -> Maybe Zettel-getZettel = G.findVertex
− src/app/Neuron/Zettelkasten/Graph/Type.hs
@@ -1,23 +0,0 @@-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE NoImplicitPrelude #-}--module Neuron.Zettelkasten.Graph.Type- ( -- * Graph type- ZettelGraph,- )-where--import Data.Graph.Labelled-import Neuron.Zettelkasten.Connection-import Neuron.Zettelkasten.Zettel-import Relude---- | The Zettelkasten graph------ Edges are labelled with `Connection`; Maybe is used to provide the--- `Algebra.Graph.Label.zero` value for the edge label, which is `Nothing` in--- our case, and is effectively the same as there not being an edge between--- those vertices.-type ZettelGraph = LabelledGraph Zettel (Maybe Connection)
− src/app/Neuron/Zettelkasten/Query.hs
@@ -1,129 +0,0 @@-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE StandaloneDeriving #-}-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE TupleSections #-}-{-# LANGUAGE ViewPatterns #-}-{-# LANGUAGE NoImplicitPrelude #-}---- | Queries to the Zettel store-module Neuron.Zettelkasten.Query where--import Control.Monad.Except-import Data.Aeson-import Data.Aeson.GADT.TH-import Data.GADT.Compare.TH-import Data.GADT.Show.TH-import qualified Data.Map.Strict as Map-import Data.Some-import Data.TagTree (Tag, TagPattern (..), tagMatch, tagMatchAny, tagTree)-import Data.Tree (Tree (..))-import Lucid-import Neuron.Zettelkasten.Connection-import Neuron.Zettelkasten.ID-import Neuron.Zettelkasten.Query.Theme-import Neuron.Zettelkasten.Zettel-import Relude-import System.FilePath---- | Query represents a way to query the Zettelkasten.------ TODO: Support querying connections, a la:--- LinksTo ZettelID--- LinksFrom ZettelID-data Query r where- Query_ZettelByID :: ZettelID -> Maybe Connection -> Query (Maybe Zettel)- Query_ZettelsByTag :: [TagPattern] -> Maybe Connection -> ZettelsView -> Query [Zettel]- Query_Tags :: [TagPattern] -> Query (Map Tag Natural)--instance ToHtml (Some Query) where- toHtmlRaw = toHtml- toHtml q =- div_ [class_ "ui horizontal divider", title_ "Neuron Query"] $ do- case q of- Some (Query_ZettelByID _ _) ->- mempty- Some (Query_ZettelsByTag [] _mconn _mview) ->- "All zettels"- Some (Query_ZettelsByTag (fmap unTagPattern -> pats) _mconn _mview) -> do- let qs = intercalate ", " pats- desc = toText $ "Zettels tagged '" <> qs <> "'"- in span_ [class_ "ui basic pointing below black label", title_ desc] $ do- i_ [class_ "tags icon"] mempty- toHtml qs- Some (Query_Tags []) ->- "All tags"- Some (Query_Tags (fmap unTagPattern -> pats)) -> do- let qs = intercalate ", " pats- toHtml $ "Tags matching '" <> qs <> "'"---- | Run the given query and return the results.-runQuery :: [Zettel] -> Query r -> r-runQuery zs = \case- Query_ZettelByID zid _ ->- find ((== zid) . zettelID) zs- Query_ZettelsByTag pats _mconn _mview ->- sortZettelsReverseChronological $ flip filter zs $ \Zettel {..} ->- and $ flip fmap pats $ \pat ->- any (tagMatch pat) zettelTags- Query_Tags [] ->- allTags- Query_Tags pats ->- Map.filterWithKey (const . tagMatchAny pats) allTags- where- allTags :: Map.Map Tag Natural- allTags =- Map.fromListWith (+) $- concatMap (\Zettel {..} -> (,1) <$> zettelTags) zs--queryResultJson :: forall r. (ToJSON (Query r)) => FilePath -> Query r -> r -> Value-queryResultJson notesDir q r =- toJSON $- object- [ "query" .= toJSON q,- "result" .= resultJson- ]- where- resultJson :: Value- resultJson = case q of- Query_ZettelByID _ _mconn ->- toJSON $ zettelJsonFull <$> r- Query_ZettelsByTag _ _mconn _mview ->- toJSON $ zettelJsonFull <$> r- Query_Tags _ ->- toJSON $ treeToJson <$> tagTree r- zettelJsonFull :: ZettelT c -> Value- zettelJsonFull z@Zettel {..} =- object $- [ "path" .= (notesDir </> zettelIDSourceFileName zettelID)- ]- <> zettelJson z- treeToJson (Node (tag, count) children) =- object- [ "name" .= tag,- "count" .= count,- "children" .= fmap treeToJson children- ]--deriveJSONGADT ''Query--deriveGEq ''Query--deriveGShow ''Query--deriving instance Show (Query (Maybe Zettel))--deriving instance Show (Query [Zettel])--deriving instance Show (Query (Map Tag Natural))--deriving instance Eq (Query (Maybe Zettel))--deriving instance Eq (Query [Zettel])--deriving instance Eq (Query (Map Tag Natural))
− src/app/Neuron/Zettelkasten/Query/Error.hs
@@ -1,24 +0,0 @@-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE NoImplicitPrelude #-}--module Neuron.Zettelkasten.Query.Error where--import Neuron.Zettelkasten.ID (InvalidID, ZettelID)-import Relude-import Text.URI--type QueryError = Either QueryParseError QueryResultError--data QueryParseError- = QueryParseError_InvalidID URI InvalidID- | QueryParseError_UnsupportedHost URI- deriving (Eq, Show)---- | This error is only thrown when *using* (eg: in HTML) the query results.-data QueryResultError = QueryResultError_NoSuchZettel ZettelID- deriving (Eq, Show)--queryParseErrorUri :: QueryParseError -> URI-queryParseErrorUri = \case- QueryParseError_InvalidID uri _ -> uri- QueryParseError_UnsupportedHost uri -> uri
− src/app/Neuron/Zettelkasten/Query/Eval.hs
@@ -1,69 +0,0 @@-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE TupleSections #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE NoImplicitPrelude #-}--module Neuron.Zettelkasten.Query.Eval- ( evalZettelLinks,- )-where--import Control.Monad.Except-import Data.Dependent.Sum-import qualified Data.Map.Strict as Map-import Data.Some-import Data.Traversable (for)-import Lucid-import Neuron.Zettelkasten.Connection-import Neuron.Zettelkasten.Query-import Neuron.Zettelkasten.Query.Error-import Neuron.Zettelkasten.Query.Parser (queryFromMarkdownLink)-import Neuron.Zettelkasten.Query.View (renderQueryLink)-import Neuron.Zettelkasten.Zettel-import Relude-import Text.MMark.MarkdownLink--type EvalResult = ([(Connection, Zettel)], Html ())---- | Evaluate all queries in a zettel------ Return the queries with results as a map from the original markdown link.-evalZettelLinks ::- MonadError QueryError m =>- [Zettel] ->- Zettel ->- m (Map MarkdownLink EvalResult)-evalZettelLinks zettels Zettel {..} =- fmap (Map.fromList . catMaybes) $ for (extractLinks zettelContent) $ \ml ->- fmap (ml,) <$> evalMarkdownLink zettels ml---- | Fully evaluate the query in a markdown link.-evalMarkdownLink ::- MonadError QueryError m =>- [Zettel] ->- MarkdownLink ->- m (Maybe EvalResult)-evalMarkdownLink zettels ml =- liftEither $ runExcept $ do- mq <- withExcept Left $ queryFromMarkdownLink ml- case mq of- Nothing -> pure Nothing- Just someQ -> Just <$> do- let qres = withSome someQ $ \q ->- q :=> Identity (runQuery zettels q)- conns = getConnections qres- view <-- withExcept Right $- renderQueryLink qres- pure (conns, view)- where- getConnections :: DSum Query Identity -> [(Connection, Zettel)]- getConnections = \case- Query_ZettelByID _ mconn :=> Identity mres ->- maybe [] pure $ (fromMaybe Folgezettel mconn,) <$> mres- Query_ZettelsByTag _ mconn _mview :=> Identity res ->- (fromMaybe Folgezettel mconn,) <$> res- _ ->- []
− src/app/Neuron/Zettelkasten/Query/Parser.hs
@@ -1,107 +0,0 @@-{-# LANGUAGE DeriveAnyClass #-}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE QuasiQuotes #-}-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE ViewPatterns #-}-{-# LANGUAGE NoImplicitPrelude #-}--module Neuron.Zettelkasten.Query.Parser where--import Control.Monad.Except-import Data.Some-import Data.TagTree (mkTagPattern)-import Neuron.Zettelkasten.Connection-import Neuron.Zettelkasten.ID-import Neuron.Zettelkasten.Query-import Neuron.Zettelkasten.Query.Error-import Neuron.Zettelkasten.Query.Theme-import Relude-import Text.MMark.MarkdownLink (MarkdownLink (..))-import qualified Text.URI as URI-import Text.URI.QQ (queryKey)-import Text.URI.Util (getQueryParam, hasQueryFlag)---- | Parse a query from the given URI.------ This function is used only in the CLI. For handling links in a Markdown file,--- your want `queryFromMarkdownLink` which allows specifying the link text as--- well.-queryFromURI :: MonadError QueryParseError m => URI.URI -> m (Maybe (Some Query))-queryFromURI uri = do- -- We are setting markdownLinkText to the URI to support the new short links- queryFromMarkdownLink $ MarkdownLink {markdownLinkUri = uri, markdownLinkText = URI.render uri}--queryFromMarkdownLink :: MonadError QueryParseError m => MarkdownLink -> m (Maybe (Some Query))-queryFromMarkdownLink MarkdownLink {markdownLinkUri = uri, markdownLinkText = linkText} =- case fmap URI.unRText (URI.uriScheme uri) of- Just proto | not angleBracketLink && proto `elem` ["z", "zcf"] -> do- zid <- liftEither $ first (QueryParseError_InvalidID uri) $ parseZettelID' linkText- let mconn = if proto == "zcf" then Just OrdinaryConnection else Nothing- pure $ Just $ Some $ Query_ZettelByID zid mconn- Just proto | proto `elem` ["zquery", "zcfquery"] ->- case uriHost uri of- Right "search" -> do- let mconn = if proto == "zcfquery" then Just OrdinaryConnection else Nothing- pure $ Just $ Some $- Query_ZettelsByTag (tagPatterns "tag") mconn queryView- Right "tags" ->- pure $ Just $ Some $ Query_Tags (tagPatterns "filter")- _ ->- throwError $ QueryParseError_UnsupportedHost uri- _ -> pure $ do- -- Initial support for the upcoming short links.- -- First, we expect that this is inside <..> (so same link text as link)- guard angleBracketLink- -- Then, non-relevant parts of the URI should be empty- guard- `mapM_` [ URI.uriAuthority uri == Left False,- URI.uriFragment uri == Nothing- ]- let mconn =- if hasQueryFlag [queryKey|cf|] uri- then Just OrdinaryConnection- else Nothing- case fmap URI.unRText (URI.uriScheme uri) of- Just "z" -> do- fmap snd (URI.uriPath uri) >>= \case- (URI.unRText -> "zettels") :| [] -> do- pure $ Some $ Query_ZettelsByTag (tagPatterns "tag") mconn queryView- (URI.unRText -> "tags") :| [] -> do- pure $ Some $ Query_Tags (tagPatterns "filter")- _ ->- Nothing- Just _ -> do- Nothing- Nothing -> do- -- Alias to short links- fmap snd (URI.uriPath uri) >>= \case- (URI.unRText -> path) :| [] -> do- zid <- rightToMaybe $ parseZettelID' path- pure $ Some $ Query_ZettelByID zid mconn- _ ->- -- Multiple path elements, not supported- Nothing- where- angleBracketLink = URI.render uri == linkText- tagPatterns k =- mkTagPattern <$> getParamValues k uri- queryView =- let isTimeline =- -- linkTheme=withDate is legacy format; timeline is current standard.- getQueryParam [queryKey|linkTheme|] uri == Just "withDate"- || hasQueryFlag [queryKey|timeline|] uri- isGrouped = hasQueryFlag [queryKey|grouped|] uri- in ZettelsView (LinkView isTimeline) isGrouped- getParamValues k u =- flip mapMaybe (URI.uriQuery u) $ \case- URI.QueryParam (URI.unRText -> key) (URI.unRText -> val) ->- if key == k- then Just val- else Nothing- _ -> Nothing- uriHost u =- fmap (URI.unRText . URI.authHost) (URI.uriAuthority u)
− src/app/Neuron/Zettelkasten/Query/Theme.hs
@@ -1,31 +0,0 @@-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE DeriveAnyClass #-}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE NoImplicitPrelude #-}--module Neuron.Zettelkasten.Query.Theme where--import Data.Aeson (ToJSON)-import Data.Default-import Relude--data ZettelsView = ZettelsView- { zettelsViewLinkView :: LinkView,- zettelsViewGroupByTag :: Bool- }- deriving (Eq, Show, Ord, Generic, ToJSON)--type ZettelView = LinkView--data LinkView = LinkView- { linkViewShowDate :: Bool- }- deriving (Eq, Show, Ord, Generic, ToJSON)--instance Default LinkView where- def = LinkView False--instance Default ZettelsView where- def = ZettelsView def False
− src/app/Neuron/Zettelkasten/Query/View.hs
@@ -1,141 +0,0 @@-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE QuasiQuotes #-}-{-# LANGUAGE Rank2Types #-}-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeApplications #-}-{-# LANGUAGE ViewPatterns #-}-{-# LANGUAGE NoImplicitPrelude #-}--module Neuron.Zettelkasten.Query.View- ( renderQueryLink,- renderZettelLink,- )-where--import Control.Monad.Except-import Data.Default-import Data.Dependent.Sum-import qualified Data.Map.Strict as Map-import Data.Some-import Data.TagTree (Tag (..), TagNode (..), constructTag, foldTagTree, tagMatchAny, tagTree)-import qualified Data.Text as T-import Data.Tree-import Lucid-import Lucid.Base (makeAttribute)-import Neuron.Web.Route (Route (..), routeUrlRelWithQuery)-import Neuron.Zettelkasten.Query-import Neuron.Zettelkasten.Query.Error (QueryResultError (..))-import Neuron.Zettelkasten.Query.Theme (LinkView (..), ZettelsView (..))-import Neuron.Zettelkasten.Zettel-import Relude-import qualified Rib-import Text.URI.QQ (queryKey)---- | Render the custom view for the given evaluated query-renderQueryLink :: forall m. (MonadError QueryResultError m) => DSum Query Identity -> m (Html ())-renderQueryLink = \case- Query_ZettelByID zid _mconn :=> Identity mres ->- case mres of- Nothing -> throwError $ QueryResultError_NoSuchZettel zid- Just res ->- pure $ renderZettelLink Nothing res- q@(Query_ZettelsByTag pats _mconn view) :=> Identity res -> pure $ do- toHtml $ Some q- case zettelsViewGroupByTag view of- False ->- -- Render a list of links- renderZettelLinks (zettelsViewLinkView view) res- True ->- forM_ (Map.toList $ groupZettelsByTagsMatching pats res) $ \(tag, zettelGrp) -> do- span_ [class_ "ui basic pointing below grey label"] $ do- i_ [class_ "tag icon"] mempty- toHtml $ unTag tag- renderZettelLinks (zettelsViewLinkView view) zettelGrp- q@(Query_Tags _) :=> Identity res -> pure $ do- -- Render a list of tags- toHtml $ Some q- renderTagTree $ foldTagTree $ tagTree res- where- -- TODO: Instead of doing this here, group the results in runQuery itself.- groupZettelsByTagsMatching pats matches =- fmap sortZettelsReverseChronological $ Map.fromListWith (<>) $ flip concatMap matches $ \z ->- flip concatMap (zettelTags z) $ \t -> [(t, [z]) | tagMatchAny pats t]- renderZettelLinks :: LinkView -> [Zettel] -> Html ()- renderZettelLinks ltheme zs =- ul_ $ do- forM_ zs $ \z ->- li_ $ renderZettelLink (Just ltheme) z---- | Render a link to an individual zettel.-renderZettelLink :: forall m. Monad m => Maybe LinkView -> Zettel -> HtmlT m ()-renderZettelLink (fromMaybe def -> LinkView {..}) Zettel {..} = do- let zurl = Rib.routeUrlRel $ Route_Zettel zettelID- mextra =- if linkViewShowDate- then case zettelDay 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- let linkTooltip =- if null zettelTags- then Nothing- else Just $ "Tags: " <> T.intercalate "; " (unTag <$> zettelTags)- span_ ([class_ "zettel-link"] <> withTooltip linkTooltip) $ do- a_ [href_ zurl] $ toHtml zettelTitle- where- withTooltip :: Maybe Text -> [Attribute]- withTooltip = \case- Nothing -> []- Just s ->- [ makeAttribute "data-tooltip" s,- makeAttribute "data-inverted" "",- makeAttribute "data-position" "right center"- ]---- | Render a tag tree along with the count of zettels tagged with it-renderTagTree :: forall m. Monad m => Forest (NonEmpty TagNode, Natural) -> HtmlT m ()-renderTagTree t =- div_ [class_ "tag-tree"] $- renderForest mempty t- where- renderForest :: [TagNode] -> Forest (NonEmpty TagNode, Natural) -> HtmlT m ()- renderForest ancestors forest =- ul_ $ do- forM_ forest $ \tree -> do- li_ $ renderTree ancestors tree- renderTree :: [TagNode] -> Tree (NonEmpty TagNode, Natural) -> HtmlT m ()- renderTree ancestors (Node (tagNode, count) children) = do- renderTag ancestors (tagNode, count)- whenNotNull children $- renderForest (ancestors <> toList tagNode) . toList- renderTag :: [TagNode] -> (NonEmpty TagNode, Natural) -> HtmlT m ()- renderTag ancestors (tagNode, count) = do- div_ [class_ "node"] $ do- let Tag tag = constructTag $ maybe tagNode (<> tagNode) $ nonEmpty ancestors- attrs = case count of- 0 ->- [class_ "inactive"]- _ ->- [ href_ $ routeUrlRelWithQuery Route_Search [queryKey|tag|] tag,- title_ $ show count <> " zettels tagged"- ]- a_ attrs $ renderTagNode tagNode- renderTagNode :: NonEmpty TagNode -> HtmlT m ()- renderTagNode = \case- n :| (nonEmpty -> mrest) ->- case mrest of- Nothing ->- toHtml $ unTagNode n- Just rest -> do- toHtml $ unTagNode n- "/"- renderTagNode rest
− src/app/Text/MMark/Extension/ReplaceLink.hs
@@ -1,25 +0,0 @@-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE NoImplicitPrelude #-}--module Text.MMark.Extension.ReplaceLink- ( replaceLink,- )-where--import Lucid-import Relude-import Relude.Extra.Map-import Text.MMark.Extension (Extension)-import qualified Text.MMark.Extension as Ext-import Text.MMark.MarkdownLink---- | MMark extension to replace links with some HTML.-replaceLink :: Map MarkdownLink (Html ()) -> Extension-replaceLink linkMap =- Ext.inlineRender $ \f -> \case- inline@(Ext.Link inner uri _title) ->- MarkdownLink (Ext.asPlainText inner) uri- & flip lookup linkMap- & fromMaybe (f inline)- inline ->- f inline
− src/app/Text/MMark/Extension/SetTableClass.hs
@@ -1,17 +0,0 @@-{-# LANGUAGE NoImplicitPrelude #-}--module Text.MMark.Extension.SetTableClass- ( setTableClass,- )-where--import Lucid-import Relude-import Text.MMark.Extension (Block (Table), Extension)-import qualified Text.MMark.Extension as Ext--setTableClass :: Text -> Extension-setTableClass tableClass = Ext.blockRender $ \old block ->- case block of- table@(Table _ _) -> with (old table) [class_ tableClass]- other -> old other
− src/app/Text/MMark/MarkdownLink.hs
@@ -1,40 +0,0 @@-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE NoImplicitPrelude #-}--module Text.MMark.MarkdownLink- ( MarkdownLink (..),- extractLinks,- )-where--import Control.Foldl (Fold (..))-import qualified Data.Set as Set-import Relude-import Text.MMark (MMark, runScanner)-import Text.MMark.Extension (Inline (..))-import qualified Text.MMark.Extension as Ext-import qualified Text.URI as URI--data MarkdownLink = MarkdownLink- { markdownLinkText :: Text,- markdownLinkUri :: URI.URI- }- deriving (Eq, Ord)---- | Extract all links from the Markdown document-extractLinks :: MMark -> [MarkdownLink]-extractLinks = Set.toList . Set.fromList . flip runScanner (Fold go [] id)- where- go acc blk = acc <> concatMap f (relevantInlines blk)- f = \case- Link inner uri _title ->- [MarkdownLink (Ext.asPlainText inner) uri]- _ ->- []- relevantInlines = \case- Ext.Naked xs -> toList xs- Ext.Paragraph xs -> toList xs- Ext.Blockquote xs -> concatMap relevantInlines xs- Ext.OrderedList _ xs -> concat $ concatMap (fmap relevantInlines) xs- Ext.UnorderedList xs -> concat $ concatMap (fmap relevantInlines) xs- _ -> []
− src/app/Text/URI/Util.hs
@@ -1,30 +0,0 @@-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE ViewPatterns #-}-{-# LANGUAGE NoImplicitPrelude #-}--module Text.URI.Util where--import Relude-import qualified Text.URI as URI--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
src/lib/Data/Graph/Labelled.hs view
@@ -9,15 +9,22 @@ mkGraphFrom, -- * Querying+ getGraph, findVertex, getVertices,+ hasEdge,+ edgeLabel, -- * Algorithms preSet,+ preSetWithEdgeLabel,+ preSetWithEdgeLabelMany, topSort, clusters, dfsForestFrom, dfsForestBackwards,+ bfsForestFrom,+ bfsForestBackwards, obviateRootUnlessForest, induceOnEdge, )
src/lib/Data/Graph/Labelled/Algorithm.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE GADTs #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ViewPatterns #-}@@ -15,6 +16,10 @@ import Data.Tree (Forest, Tree (..)) import Relude +{-# INLINE getGraph #-}+getGraph :: LabelledGraph v e -> LAM.AdjacencyMap e (VertexID v)+getGraph (LabelledGraph g _) = g+ findVertex :: Ord (VertexID v) => VertexID v -> LabelledGraph v e -> Maybe v findVertex v lg@(LabelledGraph g _) = do guard $ LAM.hasVertex v g@@ -28,11 +33,46 @@ getVertices (LabelledGraph _ lm) = Map.elems lm +hasEdge :: (Ord (VertexID v), Vertex v) => LabelledGraph v e -> v -> v -> Bool+hasEdge (LabelledGraph g _) x y =+ LAM.hasEdge (vertexID x) (vertexID y) g++edgeLabel :: (Monoid e, Ord (VertexID v), Vertex v) => LabelledGraph v e -> v -> v -> Maybe e+edgeLabel lg@(LabelledGraph g _) x y = do+ guard $ hasEdge lg x y+ pure $ LAM.edgeLabel (vertexID x) (vertexID y) g+ -- | Return the backlinks to the given vertex preSet :: (Vertex v, Ord (VertexID v)) => v -> LabelledGraph v e -> [v] preSet (vertexID -> zid) g = fmap (getVertex g) $ toList . LAM.preSet zid $ graph g +-- | Return the preset of a vertex, considering only edges with the given label+--+-- WARNING: Dont' call this in a loop. For that, use preSetWithEdgeLabelMany+preSetWithEdgeLabel ::+ (Eq e, Monoid e, Vertex v, Ord (VertexID v)) =>+ (e -> Bool) ->+ v ->+ LabelledGraph v e ->+ [(e, v)]+preSetWithEdgeLabel f v g =+ let g' = LAM.transpose $ getGraph $ induceOnEdge f g+ ns = Map.toList $ Map.findWithDefault mempty (vertexID v) $ LAM.adjacencyMap g'+ in fmap (second (getVertex g) . swap) ns++-- | Optimized version of preSetWithEdgeLabel for multiple-input vertices.+preSetWithEdgeLabelMany ::+ (Eq e, Monoid e, Vertex v, Ord (VertexID v)) =>+ e ->+ LabelledGraph v e ->+ (v -> [v])+preSetWithEdgeLabelMany e g =+ -- Compute the graph to search once, and then use it multiple times via the+ -- returned function.+ let g' = LAM.transpose $ graph $ induceOnEdge (== e) g+ in \(vertexID -> v) -> fmap (getVertex g) $ toList $ LAM.postSet v g'+ topSort :: (Vertex v, Ord (VertexID v)) => LabelledGraph v e -> Either (NonEmpty v) [v] topSort g = bimap (fmap (getVertex g)) (fmap (getVertex g))@@ -40,6 +80,9 @@ $ LAM.skeleton $ graph g +-- | Returns the clusters in an ayclic graph.+--+-- If the graph is one cluster and that is acyclic, this will return an empty list. clusters :: (Vertex v, Ord (VertexID v)) => LabelledGraph v e -> [NonEmpty v] clusters g = fmap (fmap $ getVertex g) $ mothers $ LAM.skeleton $ graph g@@ -56,6 +99,14 @@ dfsForestBackwards fromV (LabelledGraph g' v') = dfsForestFrom [fromV] $ LabelledGraph (LAM.transpose g') v' +bfsForestBackwards :: (Monoid e, Vertex v, Ord (VertexID v)) => v -> LabelledGraph v e -> Forest v+bfsForestBackwards fromV (LabelledGraph g' v') =+ bfsForestFrom [fromV] $ LabelledGraph (LAM.transpose g') v'++bfsForestFrom :: (Vertex v, Ord (VertexID v)) => [v] -> LabelledGraph v e -> Forest v+bfsForestFrom (fmap vertexID -> vs) g =+ fmap (fmap $ getVertex g) $ Algo.bfsForest vs $ LAM.skeleton $ graph g+ -------------------------- --- More general utilities --------------------------@@ -78,17 +129,15 @@ go acc = \case [] -> acc v : (Set.fromList -> vs) ->- let reach = reachableUndirected v g+ let reach = reachableUndirected v covered = vs `Set.intersection` reach rest = vs `Set.difference` reach in go ((v :| Set.toList covered) : acc) (Set.toList rest)---- | Get the vertexes reachable (regardless of direction) from the given vertex.-reachableUndirected :: Ord a => a -> AM.AdjacencyMap a -> Set a-reachableUndirected v =- Set.fromList . Algo.reachable v . toUndirected- where- toUndirected g = AM.overlay g $ AM.transpose g+ -- Vertices reachable from `v` regardless of direction.+ reachableUndirected v =+ Set.fromList $ Algo.reachable v gUndirected+ -- The undirected version of g+ gUndirected = AM.overlay g $ AM.transpose g motherVertices :: Ord a => AM.AdjacencyMap a -> [a] motherVertices =
src/lib/Data/Graph/Labelled/Type.hs view
@@ -1,4 +1,7 @@+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeFamilies #-}@@ -8,6 +11,8 @@ module Data.Graph.Labelled.Type where import qualified Algebra.Graph.Labelled.AdjacencyMap as LAM+import Data.Aeson+import qualified Data.Map.Strict as Map import Relude -- | Instances of this class can be used as a vertex in a graph.@@ -27,5 +32,32 @@ { graph :: LAM.AdjacencyMap e (VertexID v), vertices :: Map (VertexID v) v }+ deriving (Generic) -deriving instance (Ord e, Show e, Show v, Ord (VertexID v), Show (VertexID v)) => Show (LabelledGraph v e)+deriving instance (Eq e, Eq v, Eq (VertexID v)) => Eq (LabelledGraph v e)++deriving instance+ ( Ord e,+ Show e,+ Show v,+ Ord (VertexID v),+ Show (VertexID v)+ ) =>+ Show (LabelledGraph v e)++instance (ToJSONKey (VertexID v), ToJSON v, ToJSON e) => ToJSON (LabelledGraph v e) where+ toJSON (LabelledGraph g vs) =+ toJSON $+ object+ [ "adjacencyMap" .= LAM.adjacencyMap g,+ "vertices" .= vs+ ]++instance (FromJSONKey (VertexID v), Ord (VertexID v), Eq e, Monoid e, FromJSON v, FromJSON e) => FromJSON (LabelledGraph v e) where+ parseJSON =+ withObject "LabelledGraph" $ \lg ->+ LabelledGraph+ <$> (fmap mkGraph $ lg .: "adjacencyMap")+ <*> lg .: "vertices"+ where+ mkGraph = LAM.fromAdjacencyMaps . Map.toList
src/lib/Data/TagTree.hs view
@@ -23,6 +23,7 @@ import Data.PathTree (annotatePathsWith, foldSingleParentsWith, mkTreeFromPaths) import qualified Data.Text as T import Data.Tree (Forest)+import Data.YAML (FromYAML, ToYAML) import Relude import System.FilePattern import qualified Text.Megaparsec as M@@ -31,7 +32,7 @@ -- | Tag metadata field in Zettel notes newtype Tag = Tag {unTag :: Text}- deriving (Eq, Ord, Show, ToJSON, FromJSON)+ deriving (Eq, Ord, Show, ToJSON, FromJSON, FromYAML, ToYAML) -------------- -- Tag Pattern@@ -41,7 +42,7 @@ -- -- Eg.: "foo/**" matches both "foo/bar/baz" and "foo/baz" newtype TagPattern = TagPattern {unTagPattern :: FilePattern}- deriving (Eq, Show, ToJSON)+ deriving (Eq, Show, ToJSON, FromJSON) mkTagPattern :: Text -> TagPattern mkTagPattern =
+ src/lib/Neuron/Config/Type.hs view
@@ -0,0 +1,77 @@+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE NoImplicitPrelude #-}++module Neuron.Config.Type+ ( Config (..),+ configFile,+ defaultConfig,+ mergeWithDefault,+ getZettelFormats,+ )+where++import Data.Aeson+import Neuron.Reader.Type (ZettelFormat)+import Relude hiding (readEither)+import Text.Read (readEither)++configFile :: FilePath+configFile = "neuron.dhall"++-- | Config type for @neuron.dhall@+--+-- See <https://neuron.zettel.page/2011701.html guide> for description of the fields.+--+-- TODO: Implement custom `FromDhall` instance, while using original field types+data Config = Config+ { aliases :: [Text],+ author :: Maybe Text,+ editUrl :: Maybe Text,+ mathJaxSupport :: Bool,+ -- TODO: This should use `NonEmpty`.+ formats :: [Text],+ minVersion :: Text,+ siteBaseUrl :: Maybe Text,+ siteTitle :: Text,+ theme :: Text+ }+ deriving (Eq, Show, Generic, FromJSON, ToJSON)++getZettelFormats :: MonadFail m => Config -> m (NonEmpty ZettelFormat)+getZettelFormats Config {..} = do+ formats' <- maybe (fail "Empty formats") pure $ nonEmpty formats+ traverse (either (fail . toString) pure . readEither . toString) formats'++defaultConfig :: Text+defaultConfig =+ "{ siteTitle =\+ \ \"My Zettelkasten\" \+ \, author =\+ \ None Text\+ \, siteBaseUrl =\+ \ None Text\+ \, editUrl =\+ \ None Text\+ \, theme =\+ \ \"blue\"\+ \, aliases =\+ \ [] : List Text\+ \, formats =\+ \ [ \"markdown\" ]\+ \, mathJaxSupport =\+ \ True\+ \, minVersion =\+ \ \"0.5\" \+ \}"++-- Dhall's combine operator (`//`) allows us to merge two records,+-- effectively merging the record with defaults with the user record.+mergeWithDefault :: Text -> Text+mergeWithDefault userConfig =+ defaultConfig <> " // " <> userConfig
+ src/lib/Neuron/Orphans.hs view
@@ -0,0 +1,16 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++module Neuron.Orphans where++import Data.Aeson+import Relude+import Text.URI (URI, mkURI, render)++instance ToJSON URI where+ toJSON = toJSON @Text . render++instance FromJSON URI where+ parseJSON = (either (fail . displayException) pure) . mkURI <=< parseJSON @Text
+ src/lib/Neuron/Reader/Markdown.hs view
@@ -0,0 +1,182 @@+{-# LANGUAGE GADTs #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE NoImplicitPrelude #-}++module Neuron.Reader.Markdown+ ( parseMarkdown,+ )+where++import qualified Commonmark as CM+import qualified Commonmark.Blocks as CM+import qualified Commonmark.Extensions as CE+import qualified Commonmark.Inlines as CM+import qualified Commonmark.Pandoc as CP+import qualified Commonmark.Tag+import Commonmark.TokParsers (noneOfToks, symbol)+import Commonmark.Tokens (TokType (..))+import Control.Monad.Combinators (manyTill)+import Control.Monad.Except+import Data.Tagged (Tagged (..))+import qualified Data.YAML as YAML+import Neuron.Orphans ()+import Neuron.Reader.Type (ZettelParseError, ZettelReader)+import Neuron.Zettelkasten.Zettel.Meta (Meta)+import Relude hiding (show, traceShowId)+import qualified Text.Megaparsec as M+import qualified Text.Megaparsec.Char as M+import Text.Megaparsec.Simple+import qualified Text.Pandoc.Builder as B+import Text.Pandoc.Definition (Pandoc (..))+import qualified Text.Parsec as P+import Text.Show++-- | Parse Markdown document, along with the YAML metadata block in it.+--+-- We are not using the Pandoc AST "metadata" field (as it is not clear whether+-- we actually need it), and instead directly decoding the metadata as Haskell+-- object.+parseMarkdown :: ZettelReader+parseMarkdown fn s = do+ (metaVal, markdown) <-+ first (Tagged . ("Unable to determine YAML region: " <>)) $+ partitionMarkdown fn s+ v <-+ first (Tagged . toText . show) $+ commonmarkPandocWith neuronSpec fn markdown+ meta <- traverse (parseMeta fn) metaVal+ pure (meta, Pandoc mempty $ B.toList (CP.unCm v))+ where+ -- NOTE: HsYAML parsing is rather slow due to its use of DList.+ -- See https://github.com/haskell-hvr/HsYAML/issues/40+ parseMeta :: FilePath -> Text -> Either ZettelParseError Meta+ parseMeta n v = do+ let raw = encodeUtf8 v+ let mkError (loc, emsg) =+ Tagged $ toText $ n <> ":" <> YAML.prettyPosWithSource loc raw " error" <> emsg+ first mkError $ YAML.decode1 raw+ -- Like commonmarkWith, but parses directly into the Pandoc AST.+ commonmarkPandocWith ::+ CM.SyntaxSpec (Either P.ParseError) (CP.Cm () B.Inlines) (CP.Cm () B.Blocks) ->+ String ->+ Text ->+ Either P.ParseError (CP.Cm () B.Blocks)+ commonmarkPandocWith spec n =+ join . CM.commonmarkWith spec n++-- | Identify metadata block at the top, and split it from markdown body.+partitionMarkdown :: FilePath -> Text -> Either Text (Maybe Text, Text)+partitionMarkdown fn =+ parse (M.try splitP <|> fmap (Nothing,) M.takeRest) fn+ where+ separatorP :: Parser ()+ separatorP =+ void $ M.string "---" <* M.eol+ splitP :: Parser (Maybe Text, Text)+ splitP = do+ separatorP+ a <- toText <$> manyTill M.anySingle (M.try $ M.eol *> separatorP)+ b <- M.takeRest+ pure (Just a, b)++neuronSpec ::+ ( Monad m,+ CM.IsBlock il bl,+ CM.IsInline il,+ Typeable m,+ Typeable il,+ Typeable bl,+ CE.HasEmoji il,+ CE.HasStrikethrough il,+ CE.HasPipeTable il bl,+ CE.HasTaskList il bl,+ CM.ToPlainText il,+ CE.HasFootnote il bl,+ CE.HasMath il,+ CE.HasDefinitionList il bl,+ CE.HasDiv bl+ ) =>+ CM.SyntaxSpec m il bl+neuronSpec =+ mconcat+ [ wrappedLinkSpec angleBracketLinkP,+ wrappedLinkSpec wikiLinkP,+ gfmExtensionsSansEmoji,+ CE.footnoteSpec,+ CE.mathSpec,+ CE.smartPunctuationSpec,+ CE.definitionListSpec,+ CE.attributesSpec,+ CE.rawAttributeSpec,+ CE.fencedDivSpec,+ CM.defaultSyntaxSpec {CM.syntaxBlockSpecs = defaultBlockSpecsSansRawHtml}+ ]+ where+ -- Emoji extension introduces ghcjs linker issues+ gfmExtensionsSansEmoji =+ CE.strikethroughSpec+ <> CE.pipeTableSpec+ <> CE.autoIdentifiersSpec+ <> CE.taskListSpec++-- | Convert the given wrapped link to a `B.Link`.+wrappedLinkSpec ::+ (Monad m, CM.IsBlock il bl, CM.IsInline il) =>+ (P.ParsecT [CM.Tok] (CM.IPState m) (StateT Commonmark.Tag.Enders m) [CM.Tok]) ->+ CM.SyntaxSpec m il bl+wrappedLinkSpec linkP =+ mempty+ { CM.syntaxInlineParsers = [pLink linkP]+ }+ where+ pLink ::+ (Monad m, CM.IsInline il) =>+ (P.ParsecT [CM.Tok] (CM.IPState m) (StateT Commonmark.Tag.Enders m) [CM.Tok]) ->+ CM.InlineParser m il+ pLink p = P.try $ do+ x <- p+ let url = CM.untokenize x+ title = ""+ pure $! CM.link url title $ CM.str url++angleBracketLinkP :: Monad m => P.ParsecT [CM.Tok] s m [CM.Tok]+angleBracketLinkP = do+ void $ symbol '<'+ x <- some (noneOfToks [Symbol '>', Spaces, UnicodeSpace, LineEnd])+ void $ symbol '>'+ pure x++wikiLinkP :: Monad m => P.ParsecT [CM.Tok] s m [CM.Tok]+wikiLinkP = do+ void $ symbol '[' >> symbol '['+ x <- some (noneOfToks [Symbol ']', Spaces, UnicodeSpace, LineEnd])+ void $ symbol ']' >> symbol ']'+ pure x++-- rawHtmlSpec eats angle bracket links as html tags+defaultBlockSpecsSansRawHtml :: (Monad m, CM.IsBlock il bl) => [CM.BlockSpec m il bl]+defaultBlockSpecsSansRawHtml =+ [ CM.indentedCodeSpec,+ CM.fencedCodeSpec,+ CM.blockQuoteSpec,+ CM.atxHeadingSpec,+ CM.setextHeadingSpec,+ CM.thematicBreakSpec,+ CM.listItemSpec (CM.bulletListMarker <|> CM.orderedListMarker),+ myRawHtmlSpec,+ CM.attributeSpec+ ]++-- | Like `CM.rawHtmlSpec` but lets zettel style links pass through.+myRawHtmlSpec ::+ (Monad m, CM.IsBlock il bl) =>+ CM.BlockSpec m il bl+myRawHtmlSpec =+ -- TODO: Ideally we should use a more restrictive parsers; one that allows known safe HTML tags+ -- Although, this prevents the user from naming their zettels say "div.md"+ CM.rawHtmlSpec {CM.blockStart = P.notFollowedBy angleBracketLinkP >> CM.blockStart CM.rawHtmlSpec}
+ src/lib/Neuron/Reader/Type.hs view
@@ -0,0 +1,60 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE NoImplicitPrelude #-}++module Neuron.Reader.Type+ ( ZettelReader,+ ZettelParseError,+ ZettelFormat (..),+ zettelFormatToExtension,+ )+where++import Data.Aeson+import Data.Tagged+import Neuron.Zettelkasten.Zettel.Meta+import Relude hiding (readEither, show)+import Text.Pandoc.Definition (Pandoc)+import Text.Read+import Prelude (show)++type ZettelReader = FilePath -> Text -> Either ZettelParseError (Maybe Meta, Pandoc)++type ZettelParseError = Tagged "ZettelParserError" Text++data ZettelFormat+ = ZettelFormat_Markdown+ | ZettelFormat_Org+ deriving (Eq, Ord, Generic)++instance FromJSON ZettelFormat where+ parseJSON =+ either fail pure . readEither <=< parseJSON++instance ToJSON ZettelFormat where+ toJSON =+ toJSON . show++instance Show ZettelFormat where+ show ZettelFormat_Markdown = "markdown"+ show ZettelFormat_Org = "org"++instance Read ZettelFormat where+ readPrec =+ choice+ [ do+ Ident "org" <- lexP+ pure ZettelFormat_Org,+ do+ Ident "markdown" <- lexP+ pure ZettelFormat_Markdown+ ]++zettelFormatToExtension :: ZettelFormat -> Text+zettelFormatToExtension = \case+ ZettelFormat_Markdown -> ".md"+ ZettelFormat_Org -> ".org"
+ src/lib/Neuron/Web/Common.hs view
@@ -0,0 +1,30 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE NoImplicitPrelude #-}++module Neuron.Web.Common where++import Clay ((?), Css)+import qualified Clay as C+import Relude++neuronCommonStyle :: Css+neuronCommonStyle = do+ C.important $ C.backgroundColor "#eee"+ C.important $ C.fontFamily [bodyFont] [C.serif]+ "h1, h2, h3, h4, h5, h6, .ui.header, .headerFont" ? do+ C.important $ C.fontFamily [headerFont] [C.sansSerif]+ "code, pre, tt, .monoFont" ? do+ C.important $ C.fontFamily [monoFont, "SFMono-Regular", "Menlo", "Monaco", "Consolas", "Liberation Mono", "Courier New"] [C.monospace]++neuronFonts :: [Text]+neuronFonts = [headerFont, bodyFont, monoFont]++headerFont :: Text+headerFont = "DM Serif Text"++bodyFont :: Text+bodyFont = "DM Sans"++monoFont :: Text+monoFont = "DM Mono"
+ src/lib/Neuron/Web/Manifest.hs view
@@ -0,0 +1,94 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE NoImplicitPrelude #-}++module Neuron.Web.Manifest+ ( Manifest,+ manifestPatterns,+ mkManifest,+ renderManifest,+ )+where++import qualified Data.Set as Set+import Reflex.Dom.Core+import Relude++data Manifest = Manifest+ { manifestFavicons :: Maybe Favicons,+ manifestWebAppManifest :: Maybe FilePath+ }+ deriving (Eq)++data Favicons = Favicons+ { faviconsDefault :: FilePath,+ faviconsAlts :: [FilePath],+ faviconsAppleTouch :: Maybe FilePath+ }+ deriving (Eq)++mkManifest :: [FilePath] -> Manifest+mkManifest (Set.fromList -> files) =+ Manifest+ { manifestFavicons = mkFavicons,+ manifestWebAppManifest = lookupSet webmanifestFile files+ }+ where+ mkFavicons =+ case filter (`Set.member` files) favicons of+ (ico : alts) ->+ Just $+ Favicons+ { faviconsDefault = ico,+ faviconsAlts = alts,+ faviconsAppleTouch = lookupSet appleTouchIcon files+ }+ [] ->+ Nothing+ lookupSet x s =+ if Set.member x s+ then Just x+ else Nothing++renderManifest :: DomBuilder t m => Manifest -> m ()+renderManifest Manifest {..} = do+ linkRel "manifest" `mapM_` manifestWebAppManifest+ case manifestFavicons of+ Nothing ->+ linkRel "icon" defaultFaviconUrl+ Just Favicons {..} -> do+ linkRel "icon" faviconsDefault+ linkRel "alternate icon" `mapM_` faviconsAlts+ linkRel "apple-touch-icon" `mapM_` faviconsAppleTouch+ where+ defaultFaviconUrl :: String+ defaultFaviconUrl =+ "https://raw.githubusercontent.com/srid/neuron/master/assets/neuron.svg"+ linkRel rel path =+ -- crossorigin="use-credentials"+ elAttr+ "link"+ ( "rel" =: rel+ <> "href" =: toText path+ -- The use-credentials value must be used when fetching a manifest that requires credentials, even if the file is from the same origin.+ -- cf. https://developer.mozilla.org/en-US/docs/Web/HTML/Attributes/crossorigin+ -- cf. https://thatemil.com/blog/2018/02/21/pwa-basic-auth/+ <> (if rel == "manifest" then "crossorigin" =: "use-credentials" else mempty)+ )+ blank++manifestPatterns :: [FilePath]+manifestPatterns =+ favicons <> [appleTouchIcon, webmanifestFile]++-- | Supported favicons, in order of preference+favicons :: [FilePath]+favicons = fmap ("static/favicon." <>) ["svg", "png", "ico", "jpg", "jpeg"]++appleTouchIcon :: FilePath+appleTouchIcon = "static/apple-touch-icon.png"++webmanifestFile :: FilePath+webmanifestFile = "static/manifest.webmanifest"
+ src/lib/Neuron/Web/Query/View.hs view
@@ -0,0 +1,205 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE Rank2Types #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE NoImplicitPrelude #-}++module Neuron.Web.Query.View+ ( renderQueryResult,+ renderZettelLink,+ renderZettelLinkIDOnly,+ zettelUrl,+ tagUrl,+ style,+ )+where++import qualified Clay as C+import Clay ((?), Css, em)+import Control.Monad.Except+import Data.Default+import Data.Dependent.Sum+import qualified Data.Map.Strict as Map+import Data.Some+import Data.TagTree (Tag (..), TagNode (..), TagPattern (..), constructTag, foldTagTree, tagMatchAny, tagTree)+import qualified Data.Text as T+import Data.Tree+import Neuron.Web.Route+import Neuron.Web.Widget+import Neuron.Zettelkasten.Connection+import Neuron.Zettelkasten.ID+import Neuron.Zettelkasten.Query.Theme (LinkView (..), ZettelsView (..))+import Neuron.Zettelkasten.Zettel+import Reflex.Dom.Core hiding (count, tag)+import Relude++-- | Render the query results.+renderQueryResult ::+ DomBuilder t m => DSum ZettelQuery Identity -> NeuronWebT t m ()+renderQueryResult = \case+ ZettelQuery_ZettelByID _zid (fromMaybe def -> conn) :=> Identity target -> do+ renderZettelLink (Just conn) Nothing target+ q@(ZettelQuery_ZettelsByTag pats (fromMaybe def -> conn) view) :=> Identity res -> do+ el "section" $ do+ renderQuery $ Some q+ case zettelsViewGroupByTag view of+ False ->+ el "ul" $ forM_ res $ \z -> do+ el "li" $+ renderZettelLink (Just conn) (Just $ zettelsViewLinkView view) z+ True ->+ forM_ (Map.toList $ groupZettelsByTagsMatching pats res) $ \(tag, zettelGrp) -> do+ el "section" $ do+ elClass "span" "ui basic pointing below grey label" $ do+ semanticIcon "tag"+ text $ unTag tag+ el "ul" $ forM_ zettelGrp $ \z ->+ el "li" $+ renderZettelLink (Just conn) (Just $ zettelsViewLinkView view) z+ q@(ZettelQuery_Tags _) :=> Identity res -> do+ el "section" $ do+ renderQuery $ Some q+ renderTagTree $ foldTagTree $ tagTree res+ where+ -- TODO: Instead of doing this here, group the results in runQuery itself.+ groupZettelsByTagsMatching pats matches =+ fmap sortZettelsReverseChronological $ Map.fromListWith (<>) $ flip concatMap matches $ \z ->+ flip concatMap (zettelTags z) $ \t -> [(t, [z]) | tagMatchAny pats t]++renderQuery :: DomBuilder t m => Some ZettelQuery -> m ()+renderQuery someQ =+ elAttr "div" ("class" =: "ui horizontal divider" <> "title" =: "Neuron ZettelQuery") $ do+ case someQ of+ Some (ZettelQuery_ZettelByID _ _) ->+ blank+ Some (ZettelQuery_ZettelsByTag [] _mconn _mview) ->+ text "All zettels"+ Some (ZettelQuery_ZettelsByTag (fmap unTagPattern -> pats) _mconn _mview) -> do+ let qs = toText $ intercalate ", " pats+ desc = toText $ "Zettels tagged '" <> qs <> "'"+ elAttr "span" ("class" =: "ui basic pointing below black label" <> "title" =: desc) $ do+ semanticIcon "tags"+ text qs+ Some (ZettelQuery_Tags []) ->+ text "All tags"+ Some (ZettelQuery_Tags (fmap unTagPattern -> pats)) -> do+ let qs = toText $ intercalate ", " pats+ text $ "Tags matching '" <> qs <> "'"++-- | Render a link to an individual zettel.+renderZettelLink :: DomBuilder t m => Maybe Connection -> Maybe LinkView -> Zettel -> NeuronWebT t m ()+renderZettelLink conn (fromMaybe def -> linkView) Zettel {..} = do+ let connClass = show <$> conn+ rawClass = either (const $ Just "raw") (const Nothing) zettelError+ mextra =+ case linkView of+ LinkView_Default ->+ Nothing+ LinkView_ShowDate ->+ elTime <$> zettelDay+ LinkView_ShowID ->+ Just $ el "tt" $ text $ zettelIDText zettelID+ classes :: [Text] = catMaybes $ [Just "zettel-link-container"] <> [connClass, rawClass]+ elClass "span" (T.intercalate " " classes) $ do+ forM_ mextra $ \extra ->+ elAttr "span" ("class" =: "extra monoFont" <> noSnippet) $ do+ extra+ -- The extra space is so that double clicking on this extra text+ -- doesn't select the title next.+ text " "+ let linkTooltip =+ if null zettelTags+ then Nothing+ else Just $ "Tags: " <> T.intercalate "; " (unTag <$> zettelTags)+ elAttr "span" ("class" =: "zettel-link" <> withTooltip linkTooltip) $ do+ neuronRouteLink (Some $ Route_Zettel zettelID) mempty $ text zettelTitle+ where+ -- Prevent this element from appearing in Google search results+ -- https://developers.google.com/search/reference/robots_meta_tag#data-nosnippet-attr+ noSnippet :: Map Text Text+ noSnippet = "data-nosnippet" =: ""+ withTooltip :: Maybe Text -> Map Text Text+ withTooltip = \case+ Nothing -> mempty+ Just s ->+ ( "data-tooltip" =: s+ <> "data-inverted" =: ""+ <> "data-position" =: "right center"+ )++-- | Like `renderZettelLink` but when we only have ID in hand.+renderZettelLinkIDOnly :: DomBuilder t m => ZettelID -> NeuronWebT t m ()+renderZettelLinkIDOnly zid =+ elClass "span" "zettel-link-container" $ do+ elClass "span" "zettel-link" $ do+ neuronRouteLink (Some $ Route_Zettel zid) mempty $ text $ zettelIDText zid++renderTagTree :: forall t m. DomBuilder t m => Forest (NonEmpty TagNode, Natural) -> m ()+renderTagTree t =+ divClass "tag-tree" $+ renderForest mempty t+ where+ renderForest :: [TagNode] -> Forest (NonEmpty TagNode, Natural) -> m ()+ renderForest ancestors forest =+ el "ul" $ do+ forM_ forest $ \tree ->+ el "li" $ renderTree ancestors tree+ renderTree :: [TagNode] -> Tree (NonEmpty TagNode, Natural) -> m ()+ renderTree ancestors (Node (tagNode, count) children) = do+ renderTag ancestors (tagNode, count)+ renderForest (ancestors <> toList tagNode) $ toList children+ renderTag :: [TagNode] -> (NonEmpty TagNode, Natural) -> m ()+ renderTag ancestors (tagNode, count) = do+ let tag = constructTag $ maybe tagNode (<> tagNode) $ nonEmpty ancestors+ tit = show count <> " zettels tagged"+ cls = bool "" "inactive" $ count == 0+ divClass "node" $ do+ elAttr "a" ("class" =: cls <> "title" =: tit <> "href" =: tagUrl tag) $ do+ text $ renderTagNode tagNode+ renderTagNode :: NonEmpty TagNode -> Text+ renderTagNode = \case+ n :| (nonEmpty -> mrest) ->+ case mrest of+ Nothing ->+ unTagNode n+ Just rest ->+ unTagNode n <> "/" <> renderTagNode rest++-- TODO: not using Rib for ghcjs, but factorize this+zettelUrl :: ZettelID -> Text+zettelUrl zid =+ zettelIDText zid <> ".html"++tagUrl :: Tag -> Text+tagUrl (Tag s) =+ "search.html?tag=" <> s++style :: Css+style = do+ zettelLinkCss+ "div.tag-tree" ? do+ "div.node" ? do+ C.fontWeight C.bold+ "a.inactive" ? do+ C.color "#555"++zettelLinkCss :: Css+zettelLinkCss = do+ "span.zettel-link-container span.zettel-link a" ? do+ C.fontWeight C.bold+ C.textDecoration C.none+ "span.zettel-link-container span.extra" ? do+ C.color C.auto+ "span.zettel-link-container.folgezettel::after" ? do+ C.paddingLeft $ em 0.3+ C.content $ C.stringContent "ᛦ"+ "span.zettel-link-container.raw" ? do+ C.border C.solid (C.px 1) C.red+ "[data-tooltip]:after" ? do+ C.fontSize $ em 0.7
+ src/lib/Neuron/Web/Route.hs view
@@ -0,0 +1,62 @@+{-# LANGUAGE GADTs #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE NoImplicitPrelude #-}++-- | Neuron's route and its config+module Neuron.Web.Route where++import Control.Monad.Reader+import Data.Some+import Neuron.Zettelkasten.ID+import Neuron.Zettelkasten.Zettel+import Reflex.Dom.Core+import Relude++data Route a where+ Route_Redirect :: ZettelID -> Route ZettelID+ -- ZIndex takes a report of all errors in the zettelkasten.+ -- `Left` is skipped zettels; and Right is valid zettels with invalid query links.+ Route_ZIndex :: Route (Map ZettelID ZettelError)+ -- | Takes search JS code as render data+ Route_Search :: Route Text+ Route_Zettel :: ZettelID -> Route ZettelC++data RouteConfig t m = RouteConfig+ { -- | Whether the view is being rendered for static HTML generation+ routeConfigStaticallyGenerated :: Bool,+ -- | How to render a web route.+ routeConfigRouteLink :: DomBuilder t m => Some Route -> Map Text Text -> m () -> m (),+ -- | Get the URL for a web route as plain text+ routeConfigRouteURL :: Some Route -> Text+ }++type NeuronWebT t m = ReaderT (RouteConfig t m) m++runNeuronWeb :: RouteConfig t m -> NeuronWebT t m a -> m a+runNeuronWeb cfg = flip runReaderT cfg++whenStaticallyGenerated :: Monad m => NeuronWebT t m () -> NeuronWebT t m ()+whenStaticallyGenerated f = do+ staticGen <- asks routeConfigStaticallyGenerated+ when staticGen f++neuronRouteLink :: DomBuilder t m => Some Route -> Map Text Text -> m () -> NeuronWebT t m ()+neuronRouteLink someR attrs w = do+ f <- asks routeConfigRouteLink+ lift $ f someR attrs w++neuronRouteURL :: Monad m => Some Route -> NeuronWebT t m Text+neuronRouteURL someR = do+ f <- asks routeConfigRouteURL+ pure $ f someR++routeTitle' :: a -> Route a -> Text+routeTitle' v = \case+ Route_Redirect _ -> "Redirecting..."+ Route_ZIndex -> "Zettel Index"+ Route_Search -> "Search"+ Route_Zettel _ ->+ either zettelTitle zettelTitle v
+ src/lib/Neuron/Web/Theme.hs view
@@ -0,0 +1,112 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE NoImplicitPrelude #-}++-- | HTML & CSS+module Neuron.Web.Theme+ ( Theme (..),+ mkTheme,+ themeCss,+ semanticColor,+ themeIdentifier,+ )+where++import Clay ((?), Css, rgb, rgba)+import qualified Clay as C+import Data.Text (toLower)+import Relude++-- | Neuron color theme+--+-- Each theme corresponds to the color supported by Semantic UI+-- https://semantic-ui.com/usage/theming.html#sitewide-defaults+data Theme+ = Teal+ | Brown+ | Red+ | Orange+ | Yellow+ | Olive+ | Green+ | Blue+ | Violet+ | Purple+ | Pink+ | Grey+ | Black+ deriving (Eq, Show, Enum, Bounded)++-- | Make Theme from Semantic UI color name+mkTheme :: Text -> Theme+mkTheme s =+ fromMaybe (error $ "Unsupported theme: " <> s)+ $ listToMaybe+ $ catMaybes+ $ flip fmap [minBound .. maxBound]+ $ \theme ->+ if s == semanticColor theme+ then Just theme+ else Nothing++-- | Convert Theme to Semantic UI color name+semanticColor :: Theme -> Text+semanticColor = toLower . show @Text++themeIdentifier :: Theme -> String+themeIdentifier theme =+ "neuron-theme-default-" <> toString (semanticColor theme)++themeCss :: Css+themeCss = do+ forM_ [minBound .. maxBound] $ \(theme :: Theme) -> do+ let selector = fromString $ "div#" <> themeIdentifier theme+ textColor = withRgb theme rgb+ backgroundColor = withRgb theme rgba 0.1+ selector ? do+ -- Zettel heading's background color+ ".zettel-content h1" ? do+ C.backgroundColor backgroundColor+ -- Zettel links+ "span.zettel-link-container span.zettel-link a" ? do+ C.color textColor+ "span.zettel-link-container span.zettel-link a:hover" ? do+ C.color C.white+ C.backgroundColor textColor+ -- Deemphasized items in uptree; restore link colors+ ".deemphasized:hover" ? do+ "div.item a:hover" ? C.important (C.color textColor)+ -- Zettel footnote's top marging line+ "div#footnotes" ? do+ C.borderTopColor textColor++withRgb :: Theme -> (Integer -> Integer -> Integer -> a) -> a+withRgb theme f =+ case theme of+ Teal ->+ f 0 181 173+ Brown ->+ f 165 103 63+ Red ->+ f 219 40 40+ Orange ->+ f 242 113 28+ Yellow ->+ f 251 189 8+ Olive ->+ f 181 204 24+ Green ->+ f 33 186 69+ Blue ->+ f 33 133 208+ Violet ->+ f 100 53 201+ Purple ->+ f 163 51 200+ Pink ->+ f 224 57 151+ Grey ->+ f 118 118 118+ Black ->+ f 27 28 29
+ src/lib/Neuron/Web/Widget.hs view
@@ -0,0 +1,27 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE NoImplicitPrelude #-}++module Neuron.Web.Widget where++import qualified Data.Text as T+import Data.Time+import Neuron.Zettelkasten.Zettel.Meta (formatZettelDate)+import Reflex.Dom.Core+import Relude++-- | <time> element+elTime :: DomBuilder t m => Day -> m ()+elTime t = do+ let s = formatZettelDate t+ -- cf. https://developer.mozilla.org/en-US/docs/Web/HTML/Element/time#Attributes+ elAttr "time" ("datetime" =: s) $ text s++semanticIcon :: DomBuilder t m => Text -> m ()+semanticIcon name = elClass "i" (name <> " icon") blank++elLinkGoogleFonts :: DomBuilder t m => [Text] -> m ()+elLinkGoogleFonts fs =+ let fsEncoded = T.intercalate "|" $ T.replace " " "+" <$> fs+ fsUrl = "https://fonts.googleapis.com/css?family=" <> fsEncoded <> "&display=swap"+ in elAttr "link" ("rel" =: "stylesheet" <> "href" =: fsUrl) blank
+ src/lib/Neuron/Web/Widget/AutoScroll.hs view
@@ -0,0 +1,28 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE NoImplicitPrelude #-}++module Neuron.Web.Widget.AutoScroll where++import Data.Tagged+import Reflex.Dom.Core hiding ((&))+import Relude++type AutoScroll = Tagged "autoScroll" (Maybe Text)++-- | Hidden element to scroll to.+-- cf. https://stackoverflow.com/a/49968820/55246+marker :: DomBuilder t m => Text -> Int -> m ()+marker elemId offsetPx = do+ let style = "position: absolute; top: " <> show offsetPx <> "px; left: 0"+ elAttr "div" ("id" =: elemId <> "style" =: style) blank++-- | Place this at the bottom of the page, to have it auto scroll to the marker.+--+-- FIXME: This may not scroll sufficiently if the images in the zettel haven't+-- loaded (thus the browser doesn't known the final height yet.)+script :: DomBuilder t m => Text -> m ()+script markerId = do+ let s =+ "if (window.scrollY == 0) { document.getElementById(\"" <> markerId <> "\").scrollIntoView({behavior: \"smooth\", block: \"start\"}); }"+ el "script" $ text s
+ src/lib/Neuron/Web/Widget/InvertedTree.hs view
@@ -0,0 +1,144 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE NoImplicitPrelude #-}++module Neuron.Web.Widget.InvertedTree+ ( renderInvertedHeadlessTree,+ style,+ )+where++import Clay hiding (id, ms, not, object, reverse, s, style, type_)+import qualified Clay as C+import Data.List (maximum)+import Data.Tree+import Reflex.Dom.Core hiding ((&))+import Relude hiding ((&))++style :: Css+style = pureCssTreeDiagram++renderInvertedHeadlessTree ::+ (DomBuilder t m, Ord a) =>+ -- Element ID+ Text ->+ -- Element Class+ Text ->+ [Tree a] ->+ (a -> m ()) ->+ m ()+renderInvertedHeadlessTree elemId elemCls tree w = do+ let attrs =+ "class" =: ("flipped tree " <> elemCls)+ <> "id" =: elemId+ <> "style" =: "transform-origin: 50%"+ elAttr "nav" attrs $ do+ elClass "ul" "root" $ do+ -- Headless tree will still need a head element (li).+ el "li" $ do+ el "ul" $ do+ renderInvertedForest w tree++renderInvertedForest ::+ (DomBuilder t m, Ord a) =>+ (a -> m ()) ->+ [Tree a] ->+ m ()+renderInvertedForest w trees = do+ forM_ (sortForest trees) $ \(Node x subtrees) ->+ el "li" $ do+ divClass "forest-link" $+ w x+ when (length subtrees > 0) $ do+ el "ul" $ renderInvertedForest w subtrees+ where+ -- Sort trees so that trees containing the most recent zettel (by ID) come first.+ sortForest = reverse . sortOn maximum++-- https://codepen.io/philippkuehn/pen/QbrOaN+pureCssTreeDiagram :: Css+pureCssTreeDiagram = do+ let cellBorderWidth = px 2+ flipTree = False+ rotateDeg = deg 180+ ".tree.flipped" ? do+ C.transform $ C.rotate rotateDeg+ ".tree" ? do+ C.overflow auto+ when flipTree $ do+ C.transform $ C.rotate rotateDeg+ -- Clay does not support this; doing it inline in div style.+ -- C.transformOrigin $ pct 50+ "ul.root" ? do+ -- Make the tree attach to zettel segment+ C.paddingTop $ px 0+ C.marginTop $ px 0+ "ul" ? do+ C.position relative+ C.padding (em 1) 0 0 0+ C.whiteSpace nowrap+ sym2 C.margin (px 0) auto+ C.textAlign center+ C.after & do+ C.content $ stringContent ""+ C.display C.displayTable+ C.clear both+ C.lastChild & do+ C.paddingBottom $ em 0.1+ "li" ? do+ C.display C.inlineBlock+ C.verticalAlign C.vAlignTop+ C.textAlign C.center+ C.listStyleType none+ C.position relative+ C.padding (em 1) (em 0.5) (em 0) (em 0.5)+ forM_ [C.before, C.after] $ \sel -> sel & do+ C.content $ stringContent ""+ C.position absolute+ C.top $ px 0+ C.right $ pct 50+ C.borderTop solid cellBorderWidth "#ccc"+ C.width $ pct 50+ C.height $ em 1.2+ C.after & do+ C.right auto+ C.left $ pct 50+ C.borderLeft solid cellBorderWidth "#ccc"+ C.onlyChild & do+ C.paddingTop $ em 0+ forM_ [C.after, C.before] $ \sel -> sel & do+ C.display none+ C.firstChild & do+ C.before & do+ C.borderStyle none+ C.borderWidth $ px 0+ C.after & do+ C.borderRadius (px 5) 0 0 0+ C.lastChild & do+ C.after & do+ C.borderStyle none+ C.borderWidth $ px 0+ C.before & do+ C.borderRight solid cellBorderWidth "#ccc"+ C.borderRadius 0 (px 5) 0 0+ "ul ul::before" ? do+ C.content $ stringContent ""+ C.position absolute+ C.top $ px 0+ C.left $ pct 50+ C.borderLeft solid cellBorderWidth "#ccc"+ C.width $ px 0+ C.height $ em 1.2+ "li" ? do+ "div.forest-link" ? do+ border solid cellBorderWidth "#ccc"+ sym2 C.padding (em 0.2) (em 0.3)+ C.textDecoration none+ C.display inlineBlock+ sym C.borderRadius (px 5)+ C.color "#333"+ C.position relative+ C.top cellBorderWidth+ when flipTree $ do+ C.transform $ C.rotate rotateDeg+ ".tree.flipped li div.forest-link" ? do+ C.transform $ C.rotate rotateDeg
+ src/lib/Neuron/Web/ZIndex.hs view
@@ -0,0 +1,162 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE NoImplicitPrelude #-}++module Neuron.Web.ZIndex+ ( renderZIndex,+ buildZIndex,+ ZIndex (..),+ style,+ )+where++import Clay ((?), Css, em)+import qualified Clay as C+import Data.Foldable (maximum)+import qualified Data.Map.Strict as Map+import Data.TagTree (mkTagPattern)+import Data.Tree+import qualified Neuron.Web.Query.View as QueryView+import Neuron.Web.Route+import qualified Neuron.Web.Theme as Theme+import Neuron.Zettelkasten.Connection+import Neuron.Zettelkasten.Graph (ZettelGraph)+import qualified Neuron.Zettelkasten.Graph as G+import Neuron.Zettelkasten.ID+import Neuron.Zettelkasten.Query (zettelsByTag)+import Neuron.Zettelkasten.Query.Error (showQueryError)+import Neuron.Zettelkasten.Zettel+import Reflex.Dom.Core hiding ((&))+import Relude hiding ((&))++-- | The value needed to render the z-index+--+-- All heavy graph computations are decoupled from rendering, producing this+-- value, that is in turn used for instant rendering.+data ZIndex = ZIndex+ { -- | Clusters on the folgezettel graph.+ zIndexClusters :: [Forest (Zettel, [Zettel])],+ -- | All zettel errors+ zIndexErrors :: Map ZettelID ZettelError,+ zIndexStats :: Stats,+ zPinned :: [Zettel]+ }++data Stats = Stats+ { statsZettelCount :: Int,+ statsZettelConnectionCount :: Int+ }+ deriving (Eq, Show)++buildZIndex :: ZettelGraph -> Map ZettelID ZettelError -> ZIndex+buildZIndex graph errors =+ let clusters = G.categoryClusters graph+ clusters' :: [Forest (Zettel, [Zettel])] =+ flip fmap clusters $ \(zs :: [Tree Zettel]) ->+ G.backlinksMulti Folgezettel zs graph+ stats = Stats (length $ G.getZettels graph) (G.connectionCount graph)+ pinnedZettels = zettelsByTag (G.getZettels graph) [mkTagPattern "pinned"]+ in ZIndex (fmap sortCluster clusters') errors stats pinnedZettels+ where+ -- TODO: Either optimize or get rid of this (or normalize the sorting somehow)+ sortCluster fs =+ sortZettelForest $ flip fmap fs $ \Node {..} ->+ Node rootLabel $ sortZettelForest subForest+ -- Sort zettel trees so that trees containing the most recent zettel (by ID) come first.+ sortZettelForest = reverse . sortOn maximum++renderZIndex ::+ DomBuilder t m =>+ Theme.Theme ->+ ZIndex ->+ NeuronWebT t m ()+renderZIndex (Theme.semanticColor -> themeColor) ZIndex {..} = do+ elClass "h1" "header" $ text "Zettel Index"+ renderErrors zIndexErrors+ divClass "z-index" $ do+ el "p" $ do+ text $+ "The zettelkasten has "+ <> countNounBe "zettel" "zettels" (statsZettelCount zIndexStats)+ <> " and "+ <> countNounBe "link" "links" (statsZettelConnectionCount zIndexStats)+ text $ ". It has " <> countNounBe "cluster" "clusters" (length zIndexClusters) <> " in its folgezettel graph. "+ text "Each cluster's "+ elAttr "a" ("href" =: "https://neuron.zettel.page/2017401.html") $ text "folgezettel heterarchy"+ text " is rendered as a forest."+ forM_ (nonEmpty zPinned) $ \zs ->+ divClass "ui message pinned raised segment" $ do+ el "ul" $ forM_ zs $ \z ->+ el "li" $ QueryView.renderZettelLink Nothing def z+ forM_ zIndexClusters $ \forest ->+ divClass ("ui " <> themeColor <> " segment") $ do+ el "ul" $ renderForest forest+ where+ countNounBe noun nounPlural = \case+ 1 -> "1 " <> noun+ n -> show n <> " " <> nounPlural++renderErrors :: DomBuilder t m => Map ZettelID ZettelError -> NeuronWebT t m ()+renderErrors errors = do+ let severity = \case+ ZettelError_ParseError _ -> "negative"+ ZettelError_QueryErrors _ -> "warning"+ ZettelError_AmbiguousFiles _ -> "negative"+ errorMessageHeader zid = \case+ ZettelError_ParseError _ -> do+ text "Zettel "+ QueryView.renderZettelLinkIDOnly zid+ text " failed to parse"+ ZettelError_QueryErrors _ -> do+ text "Zettel "+ QueryView.renderZettelLinkIDOnly zid+ text " has malformed queries"+ ZettelError_AmbiguousFiles _ -> do+ text $+ "More than one file define the same zettel ID ("+ <> zettelIDText zid+ <> "):"+ forM_ (Map.toList errors) $ \(zid, zError) ->+ divClass ("ui tiny message " <> severity zError) $ do+ divClass "header" $ errorMessageHeader zid zError+ el "p" $ do+ case zError of+ ZettelError_ParseError parseError ->+ el "pre" $ text $ show parseError+ ZettelError_QueryErrors queryErrors ->+ el "ol" $ do+ forM_ queryErrors $ \qe ->+ el "li" $ el "pre" $ text $ showQueryError qe+ ZettelError_AmbiguousFiles filePaths ->+ el "ul" $ do+ forM_ filePaths $ \fp ->+ el "li" $ el "tt" $ text $ toText fp++renderForest ::+ DomBuilder t m =>+ [Tree (Zettel, [Zettel])] ->+ NeuronWebT t m ()+renderForest trees = do+ forM_ trees $ \(Node (zettel, uplinks) subtrees) ->+ el "li" $ do+ QueryView.renderZettelLink Nothing def zettel+ when (length uplinks >= 2) $ do+ elClass "span" "uplinks" $ do+ forM_ uplinks $ \z2 -> do+ el "small" $+ elAttr "i" ("class" =: "linkify icon" <> "title" =: zettelTitle z2) blank+ unless (null subtrees) $ do+ el "ul" $ renderForest subtrees++style :: Css+style = do+ "div.z-index" ? do+ C.ul ? do+ C.listStyleType C.square+ C.paddingLeft $ em 1.5+ ".uplinks" ? do+ C.marginLeft $ em 0.3
+ src/lib/Neuron/Web/Zettel/CSS.hs view
@@ -0,0 +1,126 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE NoImplicitPrelude #-}++module Neuron.Web.Zettel.CSS+ ( zettelCss,+ )+where++import Clay hiding (id, ms, not, object, reverse, s, style, type_)+import qualified Clay as C+import qualified Clay.Media as CM+import qualified Neuron.Web.Theme as Theme+import Neuron.Web.Widget.InvertedTree as IT+import Relude hiding ((&))++zettelCss :: Css+zettelCss = do+ Theme.themeCss+ zettelCommonCss+ C.queryOnly CM.screen [CM.maxWidth $ px 768] $ do+ "div#zettel-container" ? do+ -- Fix too big of margin on mobile.+ C.important $ do+ C.marginLeft $ em 0.4+ C.marginRight $ em 0.4+ "div.zettel-view" ? do+ -- This list styling applies both to zettel content, and the rest of the+ -- view (eg: connections pane)+ C.ul ? do+ C.paddingLeft $ em 1.5+ C.listStyleType C.square+ C.li ? do+ mempty -- C.paddingBottom $ em 1+ zettelContentCss+ IT.style+ ".ui.label.zettel-tag a.tag-inner" ? do+ C.color black+ "a" ? do+ C.color black++zettelContentCss :: Css+zettelContentCss = do+ ".zettel-content" ? do+ -- All of these apply to the zettel content card only.+ "div.date" ? do+ C.textAlign C.center+ C.color C.gray+ C.h1 ? do+ C.paddingTop $ em 0.2+ C.paddingBottom $ em 0.2+ C.textAlign C.center+ C.h2 ? do+ C.borderBottom C.solid (px 1) C.steelblue+ C.marginBottom $ em 0.5+ C.h3 ? do+ C.margin (px 0) (px 0) (em 0.4) (px 0)+ C.h4 ? do+ C.opacity 0.8+ "div#footnotes" ? do+ C.marginTop $ em 4+ C.borderTopStyle C.groove+ C.borderTopWidth $ px 2+ C.fontSize $ em 0.9+ -- reflex-dom-pandoc footnote aside elements+ -- (only used for footnotes defined inside footnotes)+ "aside.footnote-inline" ? do+ C.width $ pct 30+ C.paddingLeft $ px 15+ C.marginLeft $ px 15+ C.float C.floatRight+ C.backgroundColor C.lightgray+ -- CSS library for users to use in their Pandoc attributes blocks+ ".overflows" ? do+ C.overflow auto+ -- End of div.zettel-content+ codeStyle+ definitionListStyle+ blockquoteStyle+ ".zettel-content.raw" ? do+ C.backgroundColor "#ddd"+ where+ definitionListStyle = do+ C.dl ? do+ C.dt ? do+ C.fontWeight C.bold+ C.dd ? do+ mempty+ codeStyle = do+ C.code ? do+ sym C.margin auto+ C.fontSize $ pct 100+ -- This pretty much selects inline code elements+ "p code, li code, ol code" ? do+ sym C.padding $ em 0.2+ C.backgroundColor "#f8f8f8"+ -- This selects block code elements+ pre ? do+ sym C.padding $ em 0.5+ C.overflow auto+ C.maxWidth $ pct 100+ "div.pandoc-code" ? do+ C.marginLeft auto+ C.marginRight auto+ pre ? do+ C.backgroundColor "#f8f8f8"+ -- https://css-tricks.com/snippets/css/simple-and-nice-blockquote-styling/+ blockquoteStyle =+ C.blockquote ? do+ C.backgroundColor "#f9f9f9"+ C.borderLeft C.solid (px 10) "#ccc"+ sym2 C.margin (em 1.5) (px 0)+ sym2 C.padding (em 0.5) (px 10)++zettelCommonCss :: Css+zettelCommonCss = do+ "p" ? do+ C.lineHeight $ pct 150+ "img" ? do+ C.maxWidth $ pct 100 -- Prevents large images from overflowing beyond zettel borders+ ".deemphasized" ? do+ fontSize $ em 0.85+ ".deemphasized:hover" ? do+ opacity 1+ ".deemphasized:not(:hover)" ? do+ opacity 0.7+ "span.zettel-link a, div.item a" ? important (color gray)
+ src/lib/Neuron/Web/Zettel/View.hs view
@@ -0,0 +1,149 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE NoImplicitPrelude #-}++module Neuron.Web.Zettel.View+ ( renderZettel,+ renderZettelContentCard,+ )+where++import Data.TagTree+import qualified Neuron.Web.Query.View as Q+import Neuron.Web.Route+import Neuron.Web.Widget+import qualified Neuron.Web.Widget.AutoScroll as AS+import qualified Neuron.Web.Widget.InvertedTree as IT+import Neuron.Zettelkasten.Connection+import Neuron.Zettelkasten.Graph (ZettelGraph)+import qualified Neuron.Zettelkasten.Graph as G+import Neuron.Zettelkasten.Query.Error (QueryError, showQueryError)+import qualified Neuron.Zettelkasten.Query.Eval as Q+import Neuron.Zettelkasten.Zettel+import Reflex.Dom.Core hiding ((&))+import Reflex.Dom.Pandoc+import Relude hiding ((&))+import Text.Pandoc.Definition (Pandoc)++renderZettel ::+ PandocBuilder t m =>+ (ZettelGraph, ZettelC) ->+ NeuronWebT t m ()+renderZettel (graph, zc@(sansContent -> z)) = do+ let upTree = G.backlinkForest Folgezettel z graph+ unless (null upTree) $ do+ IT.renderInvertedHeadlessTree "zettel-uptree" "deemphasized" upTree $ \z2 ->+ Q.renderZettelLink (G.getConnection z z2 graph) def z2+ -- Main content+ elAttr "div" ("class" =: "ui text container" <> "id" =: "zettel-container" <> "style" =: "position: relative") $ do+ whenStaticallyGenerated $ do+ -- We use -24px (instead of -14px) here so as to not scroll all the way to+ -- title, and as to leave some of the tree visible as "hint" to the user.+ lift $ AS.marker "zettel-container-anchor" (-24)+ divClass "zettel-view" $ do+ renderZettelContentCard (graph, zc)+ renderZettelBottomPane graph z+ -- Because the tree above can be pretty large, we scroll past it+ -- automatically when the page loads.+ whenStaticallyGenerated $ do+ unless (null upTree) $ do+ AS.script "zettel-container-anchor"++renderZettelContentCard ::+ PandocBuilder t m =>+ (ZettelGraph, ZettelC) ->+ NeuronWebT t m ()+renderZettelContentCard (graph, zc) =+ case zc of+ Right z ->+ renderZettelContent (evalAndRenderZettelQuery graph) z+ Left z -> do+ renderZettelRawContent z++renderZettelBottomPane :: DomBuilder t m => ZettelGraph -> Zettel -> NeuronWebT t m ()+renderZettelBottomPane graph z@Zettel {..} = do+ let cfBacklinks = nonEmpty $ fmap snd $ G.backlinks (== Just OrdinaryConnection) z graph+ tags = nonEmpty zettelTags+ when (isJust cfBacklinks || isJust tags)+ $ elClass "nav" "ui bottom attached segment deemphasized"+ $ do+ divClass "ui two column grid" $ do+ divClass "column" $ do+ whenJust cfBacklinks $ \links -> do+ elAttr "div" ("class" =: "ui header" <> "title" =: "Zettels that link here, but without branching") $+ text "More backlinks"+ el "ul" $ do+ forM_ links $ \zl ->+ el "li" $ Q.renderZettelLink Nothing def zl+ whenJust tags $+ divClass "column" . renderTags++evalAndRenderZettelQuery ::+ PandocBuilder t m =>+ ZettelGraph ->+ NeuronWebT t m [QueryError] ->+ URILink ->+ NeuronWebT t m [QueryError]+evalAndRenderZettelQuery graph oldRender uriLink = do+ case flip runReaderT (G.getZettels graph) (Q.runQueryURILink uriLink) of+ Left e -> do+ -- Error parsing or running the query.+ fmap (e :) oldRender <* elInlineError e+ Right Nothing -> do+ -- This is not a query link; pass through.+ oldRender+ Right (Just res) -> do+ Q.renderQueryResult res+ pure mempty+ where+ elInlineError e =+ elClass "span" "ui left pointing red basic label" $ do+ text $ showQueryError e++renderZettelContent ::+ forall t m a.+ (PandocBuilder t m, Monoid a) =>+ (NeuronWebT t m a -> URILink -> NeuronWebT t m a) ->+ ZettelT Pandoc ->+ NeuronWebT t m ()+renderZettelContent handleLink Zettel {..} = do+ elClass "article" "ui raised attached segment zettel-content" $ do+ unless zettelTitleInBody $ do+ el "h1" $ text zettelTitle+ void $ elPandoc (Config handleLink) zettelContent+ whenJust zettelDay $ \day ->+ elAttr "div" ("class" =: "date" <> "title" =: "Zettel creation date") $ do+ text "Created on: "+ elTime day++renderZettelRawContent :: (DomBuilder t m) => ZettelT Text -> m ()+renderZettelRawContent Zettel {..} = do+ divClass "ui error message" $ do+ elClass "h2" "header" $ text "Zettel failed to parse"+ el "p" $ el "pre" $ text $ show zettelError+ elClass "article" "ui raised attached segment zettel-content raw" $ do+ el "pre" $ text $ zettelContent++renderTags :: DomBuilder t m => NonEmpty Tag -> m ()+renderTags tags = do+ forM_ tags $ \t -> do+ -- NOTE(ui): Ideally this should be at the top, not bottom. But putting it at+ -- the top pushes the zettel content down, introducing unnecessary white+ -- space below the title. So we put it at the bottom for now.+ elAttr "span" ("class" =: "ui right ribbon label zettel-tag" <> "title" =: "Tag") $ do+ elAttr+ "a"+ ( "href" =: (Q.tagUrl t)+ <> "class" =: "tag-inner"+ <> "title" =: ("See all zettels tagged '" <> unTag t <> "'")+ )+ $ text+ $ unTag t+ el "p" blank
+ src/lib/Neuron/Zettelkasten/Connection.hs view
@@ -0,0 +1,34 @@+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE NoImplicitPrelude #-}++module Neuron.Zettelkasten.Connection where++import Data.Aeson (FromJSON, ToJSON)+import Data.Default+import Relude hiding (show)+import Text.Show++-- | Represent the connection between zettels+data Connection+ = -- | A folgezettel points to a zettel that is conceptually a *part* of the+ -- parent zettel.+ Folgezettel+ | -- | Any other ordinary connection (eg: "See also")+ OrdinaryConnection+ deriving (Eq, Ord, Enum, Bounded, Generic, ToJSON, FromJSON)++instance Semigroup Connection where+ -- A folgezettel link trumps all other kinds in that zettel.+ Folgezettel <> _ = Folgezettel+ _ <> Folgezettel = Folgezettel+ OrdinaryConnection <> OrdinaryConnection = OrdinaryConnection++instance Default Connection where+ def = Folgezettel++instance Show Connection where+ show = \case+ Folgezettel -> "folgezettel"+ OrdinaryConnection -> "cf"
+ src/lib/Neuron/Zettelkasten/Graph.hs view
@@ -0,0 +1,108 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE NoImplicitPrelude #-}++module Neuron.Zettelkasten.Graph+ ( -- * Graph type+ ZettelGraph,++ -- * Graph functions+ getZettels,+ getZettel,+ getConnection,+ topSort,+ frontlinkForest,+ backlinkForest,+ backlinks,+ backlinksMulti,+ clusters,+ categoryClusters,+ connectionCount,+ )+where++import qualified Algebra.Graph.Labelled.AdjacencyMap as LAM+import Data.Default+import Data.Foldable (maximum)+import qualified Data.Graph.Labelled as G+import Data.Tree+import Neuron.Zettelkasten.Connection+import Neuron.Zettelkasten.Graph.Type+import Neuron.Zettelkasten.ID+import Neuron.Zettelkasten.Zettel+import Relude++frontlinkForest :: Connection -> Zettel -> ZettelGraph -> Forest Zettel+frontlinkForest conn z =+ G.obviateRootUnlessForest z+ . G.bfsForestFrom [z]+ . G.induceOnEdge (== Just conn)++backlinkForest :: Connection -> Zettel -> ZettelGraph -> Forest Zettel+backlinkForest conn z =+ G.obviateRootUnlessForest z+ . G.bfsForestBackwards z+ . G.induceOnEdge (== Just conn)++backlinks ::+ (Maybe Connection -> Bool) ->+ Zettel ->+ ZettelGraph ->+ [(Connection, Zettel)]+backlinks f z g =+ mapMaybe (\(e, v) -> (,v) <$> e) $+ G.preSetWithEdgeLabel f z g++-- | Like backlinks but for multiple zettels. More performant than calling+-- `backlinks` in a loop.+backlinksMulti ::+ (Functor f, Functor g) =>+ Connection ->+ f (g Zettel) ->+ ZettelGraph ->+ f (g (Zettel, [Zettel]))+backlinksMulti conn zs g =+ let f = G.preSetWithEdgeLabelMany (Just conn) g+ in flip fmap zs $ \x ->+ flip fmap x $ \y ->+ (y, f y)++categoryClusters :: ZettelGraph -> [Forest Zettel]+categoryClusters (categoryGraph -> g) =+ let cs :: [[Zettel]] = sortMothers $ clusters g+ in flip fmap cs $ \zs -> G.bfsForestFrom zs g+ where+ -- Sort clusters with newer mother zettels appearing first.+ sortMothers :: [NonEmpty Zettel] -> [[Zettel]]+ sortMothers = sortOn (Down . maximum) . fmap (sortOn Down . toList)++clusters :: ZettelGraph -> [NonEmpty Zettel]+clusters g =+ case (G.clusters $ categoryGraph g) of+ [] ->+ maybe [] pure $ nonEmpty $ G.getVertices g+ cs ->+ cs++topSort :: ZettelGraph -> Either (NonEmpty Zettel) [Zettel]+topSort = G.topSort . categoryGraph++categoryGraph :: ZettelGraph -> ZettelGraph+categoryGraph = G.induceOnEdge (== Just Folgezettel)++getZettels :: ZettelGraph -> [Zettel]+getZettels = G.getVertices++getZettel :: ZettelID -> ZettelGraph -> Maybe Zettel+getZettel = G.findVertex++-- | If no connection exists, this returns Nothing.+getConnection :: Zettel -> Zettel -> ZettelGraph -> Maybe Connection+getConnection z1 z2 g = fmap (fromMaybe def) $ G.edgeLabel g z1 z2++connectionCount :: ZettelGraph -> Int+connectionCount = LAM.edgeCount . G.getGraph
+ src/lib/Neuron/Zettelkasten/Graph/Build.hs view
@@ -0,0 +1,72 @@+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE NoImplicitPrelude #-}++module Neuron.Zettelkasten.Graph.Build+ ( buildZettelkasten,+ )+where++import Control.Monad.Writer (runWriterT)+import qualified Data.Graph.Labelled as G+import qualified Data.Map.Strict as Map+import Neuron.Reader.Type+import Neuron.Zettelkasten.Connection+import Neuron.Zettelkasten.Graph.Type+import Neuron.Zettelkasten.ID+import Neuron.Zettelkasten.Query.Error (QueryError)+import Neuron.Zettelkasten.Query.Eval (queryConnections)+import Neuron.Zettelkasten.Zettel+import Neuron.Zettelkasten.Zettel.Parser+import Relude++buildZettelkasten ::+ [((ZettelFormat, ZettelReader), [(ZettelID, FilePath, Text)])] ->+ ( ZettelGraph,+ [ZettelC],+ Map ZettelID ZettelError+ )+buildZettelkasten fs =+ let zs = parseZettels fs+ (g, queryErrors) = mkZettelGraph $ sansContent <$> zs+ errors =+ Map.unions+ [ fmap ZettelError_ParseError+ $ Map.fromList+ $ lefts zs <&> (zettelID &&& zettelError),+ fmap ZettelError_QueryErrors queryErrors+ ]+ in (g, zs, errors)++-- | Build the Zettelkasten graph from a list of zettels+--+-- If there are any errors during parsing of queries (to determine connections),+-- return them as well.+mkZettelGraph ::+ [Zettel] ->+ ( ZettelGraph,+ Map ZettelID (NonEmpty QueryError)+ )+mkZettelGraph zettels =+ let res :: [(Zettel, ([(Maybe Connection, Zettel)], [QueryError]))] =+ flip fmap zettels $ \z ->+ (z, runQueryConnections zettels z)+ g :: ZettelGraph = G.mkGraphFrom zettels $ flip concatMap res $ \(z1, fst -> conns) ->+ edgeFromConnection z1 <$> conns+ errors = Map.fromList $ flip mapMaybe res $ \(z, (nonEmpty . snd -> merrs)) ->+ (zettelID z,) <$> merrs+ in (g, errors)++runQueryConnections :: [Zettel] -> Zettel -> ([(Maybe Connection, Zettel)], [QueryError])+runQueryConnections zettels z =+ flip runReader zettels $ do+ runWriterT $ queryConnections z++edgeFromConnection :: Zettel -> (Maybe Connection, Zettel) -> (Maybe Connection, Zettel, Zettel)+edgeFromConnection z (c, z2) =+ (connectionMonoid $ fromMaybe Folgezettel c, z, z2)+ where+ -- Our connection monoid will never be Nothing (mempty); see the note in+ -- type `ZettelGraph`.+ connectionMonoid = Just
+ src/lib/Neuron/Zettelkasten/Graph/Type.hs view
@@ -0,0 +1,23 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE NoImplicitPrelude #-}++module Neuron.Zettelkasten.Graph.Type+ ( -- * Graph type+ ZettelGraph,+ )+where++import Data.Graph.Labelled+import Neuron.Zettelkasten.Connection+import Neuron.Zettelkasten.Zettel+import Relude++-- | The Zettelkasten graph+--+-- Edges are labelled with `Connection`; Maybe is used to provide the+-- `Algebra.Graph.Label.zero` value for the edge label, which is `Nothing` in+-- our case, and is effectively the same as there not being an edge between+-- those vertices.+type ZettelGraph = LabelledGraph Zettel (Maybe Connection)
src/lib/Neuron/Zettelkasten/ID.hs view
@@ -1,3 +1,5 @@+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-}@@ -12,15 +14,17 @@ parseZettelID, parseZettelID', idParser,- mkZettelID,+ getZettelID, zettelIDSourceFileName, customIDParser, ) where -import Data.Aeson (ToJSON (toJSON))+import Data.Aeson+import Data.Aeson.Types (toJSONKeyText) import qualified Data.Text as T import Data.Time+import Neuron.Reader.Type (ZettelFormat, zettelFormatToExtension) import Relude import System.FilePath import qualified Text.Megaparsec as M@@ -34,12 +38,28 @@ ZettelDateID Day Int | -- | Arbitrary alphanumeric ID. ZettelCustomID Text- deriving (Eq, Show, Ord)+ deriving (Eq, Show, Ord, Generic) instance Show InvalidID where show (InvalidIDParseError s) = "Invalid Zettel ID: " <> toString s +instance FromJSON ZettelID where+ parseJSON x = do+ s <- parseJSON x+ case parseZettelID' s of+ Left e -> fail $ show e+ Right zid -> pure zid++instance ToJSONKey ZettelID where+ toJSONKey = toJSONKeyText zettelIDText++instance FromJSONKey ZettelID where+ fromJSONKey = FromJSONKeyTextParser $ \s ->+ case parseZettelID' s of+ Right v -> pure v+ Left e -> fail $ show e+ instance ToJSON ZettelID where toJSON = toJSON . zettelIDText @@ -62,15 +82,15 @@ . T.replace "Sat" "6" . T.replace "Sun" "7" -zettelIDSourceFileName :: ZettelID -> FilePath-zettelIDSourceFileName zid = toString $ zettelIDText zid <> ".md"+zettelIDSourceFileName :: ZettelID -> ZettelFormat -> FilePath+zettelIDSourceFileName zid fmt = toString $ zettelIDText zid <> zettelFormatToExtension fmt --------- -- Parser --------- data InvalidID = InvalidIDParseError Text- deriving (Eq)+ deriving (Eq, Generic, ToJSON, FromJSON) parseZettelID :: HasCallStack => Text -> ZettelID parseZettelID =@@ -107,8 +127,8 @@ customIDParser = do fmap toText $ M.some $ M.alphaNumChar <|> M.char '_' <|> M.char '-' --- | Extract ZettelID from the zettel's filename or path.-mkZettelID :: HasCallStack => FilePath -> ZettelID-mkZettelID fp =+-- | Parse the ZettelID if the given filepath is a zettel.+getZettelID :: FilePath -> Maybe ZettelID+getZettelID fp = let (name, _) = splitExtension $ takeFileName fp- in parseZettelID $ toText name+ in rightToMaybe $ parseZettelID' $ toText name
+ src/lib/Neuron/Zettelkasten/Query.hs view
@@ -0,0 +1,128 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE NoImplicitPrelude #-}++-- | Queries to the Zettel store+module Neuron.Zettelkasten.Query+ ( runZettelQuery,+ runGraphQuery,+ zettelQueryResultJson,+ graphQueryResultJson,+ zettelsByTag,+ )+where++import Control.Monad.Except+import Data.Aeson+import qualified Data.Map.Strict as Map+import Data.TagTree (Tag, TagPattern, tagMatch, tagMatchAny, tagTree)+import Data.Tree (Tree (..))+import Neuron.Zettelkasten.Graph (backlinks, getZettel)+import Neuron.Zettelkasten.Graph.Type+import Neuron.Zettelkasten.ID+import Neuron.Zettelkasten.Query.Error (QueryResultError (..))+import Neuron.Zettelkasten.Query.Graph+import Neuron.Zettelkasten.Zettel+import Relude++runZettelQuery :: [Zettel] -> ZettelQuery r -> Either QueryResultError r+runZettelQuery zs = \case+ ZettelQuery_ZettelByID zid _ ->+ case find ((== zid) . zettelID) zs of+ Nothing ->+ Left $ QueryResultError_NoSuchZettel zid+ Just z ->+ Right z+ ZettelQuery_ZettelsByTag pats _mconn _mview ->+ Right $ zettelsByTag zs pats+ ZettelQuery_Tags [] ->+ Right allTags+ ZettelQuery_Tags pats ->+ Right $ Map.filterWithKey (const . tagMatchAny pats) allTags+ where+ allTags :: Map.Map Tag Natural+ allTags =+ Map.fromListWith (+) $+ concatMap (\Zettel {..} -> (,1) <$> zettelTags) zs++zettelsByTag :: [Zettel] -> [TagPattern] -> [Zettel]+zettelsByTag zs pats =+ sortZettelsReverseChronological $ flip filter zs $ \Zettel {..} ->+ and $ flip fmap pats $ \pat ->+ any (tagMatch pat) zettelTags++runGraphQuery :: ZettelGraph -> GraphQuery r -> Either QueryResultError r+runGraphQuery g = \case+ GraphQuery_Id -> Right g+ GraphQuery_BacklinksOf conn zid ->+ case getZettel zid g of+ Nothing ->+ Left $ QueryResultError_NoSuchZettel zid+ Just z ->+ Right $ backlinks (maybe isJust (const (== conn)) conn) z g++zettelQueryResultJson ::+ forall r.+ (ToJSON (ZettelQuery r)) =>+ ZettelQuery r ->+ Either QueryResultError r ->+ -- Zettels that cannot be parsed by neuron+ Map ZettelID ZettelError ->+ Value+zettelQueryResultJson q er skippedZettels =+ toJSON $+ object+ [ "query" .= toJSON q,+ either+ (\e -> "error" .= toJSON e)+ (\r -> "result" .= toJSON (resultJson r))+ er,+ "skipped" .= skippedZettels+ ]+ where+ resultJson :: r -> Value+ resultJson r = case q of+ ZettelQuery_ZettelByID _ _mconn ->+ toJSON r+ ZettelQuery_ZettelsByTag _ _mconn _mview ->+ toJSON r+ ZettelQuery_Tags _ ->+ toJSON $ fmap treeToJson . tagTree $ r+ treeToJson (Node (tag, count) children) =+ object+ [ "name" .= tag,+ "count" .= count,+ "children" .= fmap treeToJson children+ ]++graphQueryResultJson ::+ forall r.+ (ToJSON (GraphQuery r)) =>+ GraphQuery r ->+ Either QueryResultError r ->+ -- Zettels that cannot be parsed by neuron (and as such are excluded from the graph)+ Map ZettelID ZettelError ->+ Value+graphQueryResultJson q er skippedZettels =+ toJSON $+ object+ [ "query" .= toJSON q,+ either+ (\e -> "error" .= toJSON e)+ (\r -> "result" .= resultJson r)+ er,+ "skipped" .= skippedZettels+ ]+ where+ resultJson :: r -> Value+ resultJson r = case q of+ GraphQuery_Id ->+ toJSON r+ GraphQuery_BacklinksOf _ _ ->+ toJSON r
+ src/lib/Neuron/Zettelkasten/Query/Error.hs view
@@ -0,0 +1,50 @@+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE NoImplicitPrelude #-}++module Neuron.Zettelkasten.Query.Error where++import Data.Aeson+import Neuron.Orphans ()+import Neuron.Zettelkasten.ID (InvalidID, ZettelID, zettelIDText)+import Relude+import Text.URI (URI)+import qualified Text.URI as URI++type QueryError = Either QueryParseError QueryResultError++data QueryParseError+ = QueryParseError_InvalidID URI InvalidID+ | QueryParseError_UnsupportedHost URI+ deriving (Eq, Show, Generic, ToJSON, FromJSON)++-- | This error is only thrown when *using* (eg: in HTML) the query results.+data QueryResultError = QueryResultError_NoSuchZettel ZettelID+ deriving (Eq, Show, Generic, ToJSON, FromJSON)++queryParseErrorUri :: QueryParseError -> URI+queryParseErrorUri = \case+ QueryParseError_InvalidID uri _ -> uri+ QueryParseError_UnsupportedHost uri -> uri++showQueryError :: QueryError -> Text+showQueryError = \case+ Left qe ->+ showQueryParseError qe+ Right re ->+ showQueryResultError re++showQueryParseError :: QueryParseError -> Text+showQueryParseError qe =+ let uri = URI.render (queryParseErrorUri qe)+ in uri <> ": " <> case qe of+ QueryParseError_UnsupportedHost _uri ->+ "unsupported host"+ QueryParseError_InvalidID _uri e'' ->+ "invalidID: " <> show e''++showQueryResultError :: QueryResultError -> Text+showQueryResultError (QueryResultError_NoSuchZettel zid) =+ "links to non-existant zettel: " <> zettelIDText zid
+ src/lib/Neuron/Zettelkasten/Query/Eval.hs view
@@ -0,0 +1,94 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE NoImplicitPrelude #-}++module Neuron.Zettelkasten.Query.Eval+ ( runQueryURILink,+ queryConnections,+ )+where++import Control.Monad.Except+import Control.Monad.Writer+import Data.Dependent.Sum+import Data.Some+import Neuron.Zettelkasten.Connection+import Neuron.Zettelkasten.Query (runZettelQuery)+import Neuron.Zettelkasten.Query.Error+import Neuron.Zettelkasten.Query.Parser (queryFromURILink)+import Neuron.Zettelkasten.Zettel+import Reflex.Dom.Pandoc.URILink (URILink)+import Relude++-- | Evaluate the given query link and return its results.+--+-- Return Nothing if the link is not a query.+--+-- We need the full list of zettels, for running the query against.+runQueryURILink ::+ ( MonadError QueryError m,+ MonadReader [Zettel] m+ ) =>+ URILink ->+ m (Maybe (DSum ZettelQuery Identity))+runQueryURILink ul = do+ mq <- liftEither $ first Left $ queryFromURILink ul+ flip traverse mq $ \q ->+ either (throwError . Right) pure =<< runExceptT (runSomeZettelQuery q)++-- Query connections in the given zettel+--+-- Tell all errors; query parse errors (as already stored in `Zettel`) as well+-- query result errors.+queryConnections ::+ ( -- Errors are written aside, accumulating valid connections.+ MonadWriter [QueryError] m,+ -- Running queries requires the zettels list.+ MonadReader [Zettel] m+ ) =>+ Zettel ->+ m [(Maybe Connection, Zettel)]+queryConnections Zettel {..} = do+ -- Report any query parse errors+ case zettelError of+ Right queryParseErrors ->+ tell $ Left <$> queryParseErrors+ Left _ ->+ pure ()+ fmap concat $ forM zettelQueries $ \someQ ->+ runExceptT (runSomeZettelQuery someQ) >>= \case+ Left e -> do+ tell [Right e]+ pure mempty+ Right res ->+ pure $ getConnections res+ where+ getConnections :: DSum ZettelQuery Identity -> [(Maybe Connection, Zettel)]+ getConnections = \case+ ZettelQuery_ZettelByID _ mconn :=> Identity res ->+ [(mconn, res)]+ ZettelQuery_ZettelsByTag _ mconn _mview :=> Identity res ->+ (mconn,) <$> res+ ZettelQuery_Tags _ :=> _ ->+ mempty++runSomeZettelQuery ::+ ( MonadError QueryResultError m,+ MonadReader [Zettel] m+ ) =>+ Some ZettelQuery ->+ m (DSum ZettelQuery Identity)+runSomeZettelQuery someQ =+ withSome someQ $ \q -> do+ zs <- ask+ case runZettelQuery zs q of+ Left e ->+ throwError e+ Right res ->+ pure $ q :=> Identity res
+ src/lib/Neuron/Zettelkasten/Query/Graph.hs view
@@ -0,0 +1,41 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE NoImplicitPrelude #-}++module Neuron.Zettelkasten.Query.Graph where++import Data.Aeson+import Data.Aeson.GADT.TH+import Data.Dependent.Sum.Orphans ()+import Data.GADT.Compare.TH+import Data.GADT.Show.TH+import Neuron.Zettelkasten.Connection+import Neuron.Zettelkasten.Graph.Type+import Neuron.Zettelkasten.ID+import Neuron.Zettelkasten.Zettel+import Relude++-- | Like `GraphQuery` but focused on the relationship between zettels.+data GraphQuery r where+ -- | Query the entire graph.+ GraphQuery_Id :: GraphQuery ZettelGraph+ -- | Query backlinks.+ GraphQuery_BacklinksOf ::+ Maybe Connection ->+ ZettelID ->+ GraphQuery [(Connection, Zettel)]++deriveJSONGADT ''GraphQuery++deriveGEq ''GraphQuery++deriveGShow ''GraphQuery++deriving instance Show (GraphQuery ZettelGraph)++deriving instance Eq (GraphQuery ZettelGraph)
+ src/lib/Neuron/Zettelkasten/Query/Parser.hs view
@@ -0,0 +1,126 @@+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE NoImplicitPrelude #-}++module Neuron.Zettelkasten.Query.Parser where++import Control.Monad.Except+import Data.Some+import Data.TagTree (mkTagPattern)+import Neuron.Zettelkasten.Connection+import Neuron.Zettelkasten.ID+import Neuron.Zettelkasten.Query.Error+import Neuron.Zettelkasten.Query.Theme+import Neuron.Zettelkasten.Zettel (ZettelQuery (..))+import Reflex.Dom.Pandoc (URILink (..))+import Relude+import qualified Text.URI as URI+import Text.URI.QQ (queryKey)+import Text.URI.Util (getQueryParam, hasQueryFlag)++-- | Parse a query from the given URI.+--+-- This function is used only in the CLI. For handling links in a Markdown file,+-- your want `queryFromMarkdownLink` which allows specifying the link text as+-- well.+queryFromURI :: MonadError QueryParseError m => URI.URI -> m (Maybe (Some ZettelQuery))+queryFromURI uri = do+ -- We are setting markdownLinkText to the URI to support the new short links+ queryFromURILink $ URILink (URI.render uri) uri++queryFromURILink :: MonadError QueryParseError m => URILink -> m (Maybe (Some ZettelQuery))+queryFromURILink (URILink linkText uri) =+ case fmap URI.unRText (URI.uriScheme uri) of+ Just proto | not angleBracketLink && proto `elem` ["z", "zcf"] -> do+ zid <- liftEither $ first (QueryParseError_InvalidID uri) $ parseZettelID' linkText+ let mconn = if proto == "zcf" then Just OrdinaryConnection else Nothing+ pure $ Just $ Some $ ZettelQuery_ZettelByID zid mconn+ Just proto | proto `elem` ["zquery", "zcfquery"] ->+ case uriHost uri of+ Right "search" -> do+ let mconn = if proto == "zcfquery" then Just OrdinaryConnection else Nothing+ pure $ Just $ Some $+ ZettelQuery_ZettelsByTag (tagPatterns "tag") mconn queryView+ Right "tags" ->+ pure $ Just $ Some $ ZettelQuery_Tags (tagPatterns "filter")+ _ ->+ throwError $ QueryParseError_UnsupportedHost uri+ _ -> pure $ do+ -- Modern links:+ -- First, we expect that this is inside <..> (so same link text as link)+ guard angleBracketLink+ -- Then, non-relevant parts of the URI should be empty+ guard $ URI.uriFragment uri == Nothing+ let mconn =+ if hasQueryFlag [queryKey|cf|] uri+ then Just OrdinaryConnection+ else Nothing+ -- Found "z:" without a trailing slash+ noSlash = URI.uriAuthority uri == Left False+ -- Found "z:/" instead of "z:"+ hasSlash = URI.uriAuthority uri == Left True+ case fmap URI.unRText (URI.uriScheme uri) of+ Just "z" -> do+ fmap snd (URI.uriPath uri) >>= \case+ (URI.unRText -> path) :| []+ | hasSlash -> do+ zid <- rightToMaybe $ parseZettelID' path+ pure $ Some $ ZettelQuery_ZettelByID zid mconn+ (URI.unRText -> "zettel") :| [URI.unRText -> path]+ | noSlash -> do+ zid <- rightToMaybe $ parseZettelID' path+ pure $ Some $ ZettelQuery_ZettelByID zid mconn+ (URI.unRText -> "zettels") :| []+ | noSlash -> do+ pure $ Some $ ZettelQuery_ZettelsByTag (tagPatterns "tag") mconn queryView+ (URI.unRText -> "tags") :| []+ | noSlash -> do+ pure $ Some $ ZettelQuery_Tags (tagPatterns "filter")+ _ -> Nothing+ Just _ -> do+ Nothing+ Nothing -> do+ -- Alias to short links+ fmap snd (URI.uriPath uri) >>= \case+ (URI.unRText -> path) :| [] -> do+ zid <- rightToMaybe $ parseZettelID' path+ pure $ Some $ ZettelQuery_ZettelByID zid mconn+ _ ->+ -- Multiple path elements, not supported+ Nothing+ where+ angleBracketLink = URI.render uri == linkText+ tagPatterns k =+ mkTagPattern <$> getParamValues k uri+ queryView =+ let isTimeline =+ -- linkTheme=withDate is legacy format; timeline is current standard.+ getQueryParam [queryKey|linkTheme|] uri == Just "withDate"+ || hasQueryFlag [queryKey|timeline|] uri+ isGrouped = hasQueryFlag [queryKey|grouped|] uri+ linkView =+ if isTimeline+ then LinkView_ShowDate+ else+ if hasQueryFlag [queryKey|showid|] uri+ then LinkView_ShowID+ else LinkView_Default+ in ZettelsView linkView isGrouped+ getParamValues k u =+ flip mapMaybe (URI.uriQuery u) $ \case+ URI.QueryParam (URI.unRText -> key) (URI.unRText -> val) ->+ if key == k+ then Just val+ else Nothing+ _ -> Nothing+ uriHost u =+ fmap (URI.unRText . URI.authHost) (URI.uriAuthority u)
+ src/lib/Neuron/Zettelkasten/Query/Theme.hs view
@@ -0,0 +1,32 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE NoImplicitPrelude #-}++module Neuron.Zettelkasten.Query.Theme where++import Data.Aeson (FromJSON, ToJSON)+import Data.Default+import Relude++data ZettelsView = ZettelsView+ { zettelsViewLinkView :: LinkView,+ zettelsViewGroupByTag :: Bool+ }+ deriving (Eq, Show, Ord, Generic, ToJSON, FromJSON)++type ZettelView = LinkView++data LinkView+ = LinkView_Default+ | LinkView_ShowDate+ | LinkView_ShowID+ deriving (Eq, Show, Ord, Generic, ToJSON, FromJSON)++instance Default LinkView where+ def = LinkView_Default++instance Default ZettelsView where+ def = ZettelsView def False
src/lib/Neuron/Zettelkasten/Zettel.hs view
@@ -1,35 +1,108 @@+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE NoImplicitPrelude #-} module Neuron.Zettelkasten.Zettel where import Data.Aeson+import Data.Aeson.GADT.TH+import Data.Dependent.Sum.Orphans ()+import Data.GADT.Compare.TH+import Data.GADT.Show.TH import Data.Graph.Labelled (Vertex (..))+import Data.Some import Data.TagTree (Tag)+import Data.TagTree (TagPattern (..)) import Data.Time.Calendar+import Neuron.Reader.Type+import Neuron.Zettelkasten.Connection import Neuron.Zettelkasten.ID-import qualified Neuron.Zettelkasten.Zettel.Meta as Meta+import Neuron.Zettelkasten.Query.Error+import Neuron.Zettelkasten.Query.Theme import Relude hiding (show)-import Text.MMark (MMark)-import qualified Text.MMark as MMark-import qualified Text.Megaparsec as M+import Text.Pandoc.Definition (Pandoc (..)) import Text.Show (Show (show)) +-- | ZettelQuery queries individual zettels.+--+-- It does not care about the relationship *between* those zettels; for that use `GraphQuery`.+data ZettelQuery r where+ ZettelQuery_ZettelByID :: ZettelID -> Maybe Connection -> ZettelQuery Zettel+ ZettelQuery_ZettelsByTag :: [TagPattern] -> Maybe Connection -> ZettelsView -> ZettelQuery [Zettel]+ ZettelQuery_Tags :: [TagPattern] -> ZettelQuery (Map Tag Natural)++-- | A zettel note+--+-- The metadata could have been inferred from the content. data ZettelT content = Zettel { zettelID :: ZettelID,+ zettelFormat :: ZettelFormat,+ -- Relative path to this zettel in the zettelkasten directory+ zettelPath :: FilePath, zettelTitle :: Text,+ zettelTitleInBody :: Bool, zettelTags :: [Tag], zettelDay :: Maybe Day,+ zettelQueries :: [Some ZettelQuery],+ zettelError :: ContentError content, zettelContent :: content }+ deriving (Generic) -type Zettel = ZettelT MMark+newtype MetadataOnly = MetadataOnly ()+ deriving (Generic, ToJSON, FromJSON) +type family ContentError c where+-- The list of queries that failed to parse.+ ContentError Pandoc = [QueryParseError]+-- When a zettel fails to parse, we use its raw text along with its parse error.+ ContentError Text = ZettelParseError+-- When working with zettel sans content, we gather both kinds of errors (above)+ ContentError MetadataOnly = Either (ContentError Text) (ContentError Pandoc)++-- | All possible errors in a zettel+--+-- NOTE: Unlike `ContentError MetadataOnly` this also includes QueryResultError+-- (which can be determined only after *evaluating* the queries).+data ZettelError+ = ZettelError_ParseError ZettelParseError+ | ZettelError_QueryErrors (NonEmpty QueryError)+ | ZettelError_AmbiguousFiles (NonEmpty FilePath)+ deriving (Eq, Show, Generic, ToJSON, FromJSON)++-- | Zettel without its content+type Zettel = ZettelT MetadataOnly++-- | Zettel with its content (Pandoc or raw text)+type ZettelC = Either (ZettelT Text) (ZettelT Pandoc)++sansContent :: ZettelC -> Zettel+sansContent = \case+ Left z ->+ z+ { zettelError = Left $ zettelError z,+ zettelContent = MetadataOnly ()+ }+ Right z ->+ z+ { zettelError = Right $ zettelError z,+ zettelContent = MetadataOnly ()+ }+ instance Eq (ZettelT c) where (==) = (==) `on` zettelID @@ -47,31 +120,24 @@ sortZettelsReverseChronological = sortOn (Down . zettelDay) -zettelJson :: forall a c. KeyValue a => ZettelT c -> [a]-zettelJson Zettel {..} =- [ "id" .= toJSON zettelID,- "title" .= zettelTitle,- "tags" .= zettelTags,- "day" .= zettelDay- ]+deriveJSONGADT ''ZettelQuery -mkZettelFromMarkdown ::- ZettelID ->- Text ->- ((Text, MMark) -> content) ->- Either Text (ZettelT content)-mkZettelFromMarkdown zid s selectContent = do- doc <- parseMarkdown (toString $ zettelIDText zid) s- let meta = Meta.getMeta doc- title = maybe "Missing title" Meta.title meta- tags = fromMaybe [] $ Meta.tags =<< meta- day = case zid of- -- We ignore the "data" meta field on legacy Date IDs, which encode the- -- creation date in the ID.- ZettelDateID v _ -> Just v- ZettelCustomID _ -> Meta.date =<< meta- pure $- Zettel zid title tags day (selectContent (s, doc))- where- parseMarkdown k =- first (toText . M.errorBundlePretty) . MMark.parse k+deriveGEq ''ZettelQuery++deriveGShow ''ZettelQuery++deriving instance Show (ZettelQuery (Maybe Zettel))++deriving instance Show (ZettelQuery [Zettel])++deriving instance Show (ZettelQuery (Map Tag Natural))++deriving instance Eq (ZettelQuery (Maybe Zettel))++deriving instance Eq (ZettelQuery [Zettel])++deriving instance Eq (ZettelQuery (Map Tag Natural))++deriving instance ToJSON Zettel++deriving instance FromJSON Zettel
src/lib/Neuron/Zettelkasten/Zettel/Meta.hs view
@@ -1,32 +1,66 @@-{-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TypeApplications #-} {-# LANGUAGE NoImplicitPrelude #-}+{-# OPTIONS_GHC -fno-warn-orphans #-} module Neuron.Zettelkasten.Zettel.Meta ( Meta (..),- getMeta,+ formatZettelDate,+ parseZettelDate, ) where -import Data.Aeson import Data.TagTree (Tag)-import Data.Time.Calendar+import Data.Time+import Data.YAML import Relude-import Text.MMark (MMark, projectYaml) -- | YAML metadata in a zettel markdown file data Meta = Meta- { title :: Text,+ { title :: Maybe Text, tags :: Maybe [Tag], -- | Creation day date :: Maybe Day }- deriving (Eq, Show, Generic, FromJSON)+ deriving (Eq, Show, Generic) -getMeta :: MMark -> Maybe Meta-getMeta src = do- val <- projectYaml src- case fromJSON val of- Error e -> error $ "JSON error: " <> toText e- Success v -> pure v+instance FromYAML Meta where+ parseYAML =+ withMap "Meta" $ \m ->+ Meta+ <$> m .:? "title"+ -- "keywords" is an alias for "tags"+ <*> (liftA2 (<|>) (m .:? "tags") (m .:? "keywords"))+ <*> m .:? "date"++-- NOTE: Not using this instance because it generates "tags: null" when tags is+-- Nothing.+-- instance ToYAML Meta where+-- toYAML Meta {..} =+-- mapping+-- [ "title" .= title,+-- "tags" .= tags,+-- "date" .= date+-- ]++instance FromYAML Day where+ parseYAML =+ parseZettelDate <=< parseYAML @Text++instance ToYAML Day where+ toYAML =+ toYAML . formatZettelDate++-- | The format in which we decode and encode zettel dates.+zettelDateFormat :: String+zettelDateFormat = "%Y-%m-%d"++formatZettelDate :: Day -> Text+formatZettelDate =+ toText . formatTime defaultTimeLocale zettelDateFormat++parseZettelDate :: MonadFail m => Text -> m Day+parseZettelDate =+ parseTimeM False defaultTimeLocale zettelDateFormat . toString
+ src/lib/Neuron/Zettelkasten/Zettel/Parser.hs view
@@ -0,0 +1,68 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE NoImplicitPrelude #-}++module Neuron.Zettelkasten.Zettel.Parser where++import Control.Monad.Writer+import Data.Some+import qualified Data.Text as T+import Neuron.Reader.Type+import Neuron.Zettelkasten.ID+import Neuron.Zettelkasten.Query.Error+import Neuron.Zettelkasten.Query.Parser (queryFromURILink)+import Neuron.Zettelkasten.Zettel+import qualified Neuron.Zettelkasten.Zettel.Meta as Meta+import Reflex.Dom.Pandoc.URILink (queryURILinks)+import Relude+import Text.Pandoc.Definition (Pandoc)+import Text.Pandoc.Util++parseZettel ::+ ZettelFormat ->+ ZettelReader ->+ FilePath ->+ ZettelID ->+ Text ->+ ZettelC+parseZettel format zreader fn zid s = do+ case zreader fn s of+ Left parseErr ->+ Left $ Zettel zid format fn "Unknown" False [] Nothing [] parseErr s+ Right (meta, doc) ->+ let (title, titleInBody) = case Meta.title =<< meta of+ Just tit -> (tit, False)+ Nothing -> fromMaybe ("Untitled", False) $ do+ ((,True) . plainify . snd <$> getH1 doc)+ <|> ((,False) . takeInitial . plainify <$> getFirstParagraphText doc)+ tags = fromMaybe [] $ Meta.tags =<< meta+ day = case zid of+ -- We ignore the "data" meta field on legacy Date IDs, which encode the+ -- creation date in the ID.+ ZettelDateID v _ -> Just v+ ZettelCustomID _ -> Meta.date =<< meta+ (queries, errors) = runWriter $ extractQueries doc+ in Right $ Zettel zid format fn title titleInBody tags day queries errors doc+ where+ -- Extract all (valid) queries from the Pandoc document+ extractQueries :: MonadWriter [QueryParseError] m => Pandoc -> m [Some ZettelQuery]+ extractQueries doc =+ fmap catMaybes $ forM (queryURILinks doc) $ \ul ->+ case queryFromURILink ul of+ Left e -> do+ tell [e]+ pure Nothing+ Right v ->+ pure v+ takeInitial =+ (<> " ...") . T.take 18++-- | Like `parseZettel` but operates on multiple files.+parseZettels ::+ [((ZettelFormat, ZettelReader), [(ZettelID, FilePath, Text)])] ->+ [ZettelC]+parseZettels filesPerFormat =+ flip concatMap filesPerFormat $ \((format, zreader), files) ->+ flip fmap files $ \(zid, path, s) ->+ parseZettel format zreader path zid s
+ src/lib/Text/Pandoc/Util.hs view
@@ -0,0 +1,50 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE NoImplicitPrelude #-}++module Text.Pandoc.Util+ ( getFirstParagraphText,+ getH1,+ plainify,+ )+where++import Relude+import qualified Text.Pandoc.Builder as B+import Text.Pandoc.Definition (Pandoc (..))+import qualified Text.Pandoc.Walk as W++getFirstParagraphText :: Pandoc -> Maybe [B.Inline]+getFirstParagraphText = listToMaybe . W.query go+ where+ go :: B.Block -> [[B.Inline]]+ go = \case+ B.Para inlines ->+ [inlines]+ _ ->+ []++getH1 :: Pandoc -> Maybe (B.Attr, [B.Inline])+getH1 = listToMaybe . W.query go+ where+ go :: B.Block -> [(B.Attr, [B.Inline])]+ go = \case+ B.Header 1 attr inlines ->+ [(attr, inlines)]+ _ ->+ []++-- | Convert Pandoc AST inlines to raw text.+plainify :: [B.Inline] -> Text+plainify = W.query $ \case+ B.Str x -> x+ B.Code _attr x -> x+ B.Space -> " "+ B.SoftBreak -> " "+ B.LineBreak -> " "+ B.RawInline _fmt s -> s+ B.Math _mathTyp s -> s+ -- Ignore the rest of AST nodes, as they are recursively defined in terms of+ -- `Inline` which `W.query` will traverse again.+ _ -> ""
+ src/lib/Text/URI/Util.hs view
@@ -0,0 +1,30 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE NoImplicitPrelude #-}++module Text.URI.Util where++import Relude+import qualified Text.URI as URI++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
test/Neuron/VersionSpec.hs view
@@ -23,15 +23,15 @@ isLesserOrEqual = shouldNotSatisfy it "simple versions" $ do -- If the user requires 0.4, and we are "older than" than that, fail (aka. isGreater)- "0.5" `isGreater` olderThan- "0.4" `isLesserOrEqual` olderThan -- This is current version- "0.2" `isLesserOrEqual` olderThan+ "0.7" `isGreater` olderThan+ "0.6" `isLesserOrEqual` olderThan -- This is current version+ "0.4" `isLesserOrEqual` olderThan it "full versions" $ do- "0.5.1.2" `isGreater` olderThan- "0.4.3" `isGreater` olderThan- "0.4.1.8" `isGreater` olderThan- "0.4.0.0" `isLesserOrEqual` olderThan -- This is current version+ "0.7.1.2" `isGreater` olderThan+ "0.6.12" `isGreater` olderThan+ "0.6.11.8" `isGreater` olderThan+ "0.6.0.0" `isLesserOrEqual` olderThan -- This is current version "0.3.1.0" `isLesserOrEqual` olderThan it "within same major version" $ do- "0.4.1.8" `isGreater` olderThan- "0.4.0.0" `isLesserOrEqual` olderThan -- This is current version+ "0.6.11.8" `isGreater` olderThan+ "0.6.0.0" `isLesserOrEqual` olderThan -- This is current version
test/Neuron/Zettelkasten/IDSpec.hs view
@@ -8,6 +8,7 @@ import qualified Data.Aeson as Aeson import Data.Time.Calendar+import qualified Neuron.Reader.Type as Z import qualified Neuron.Zettelkasten.ID as Z import Relude import Test.Hspec@@ -21,15 +22,15 @@ it "parses a zettel ID" $ do Z.parseZettelID "2011401" `shouldBe` zid it "parses a zettel ID from zettel filename" $ do- Z.mkZettelID "2011401.md" `shouldBe` zid- Z.zettelIDSourceFileName zid `shouldBe` "2011401.md"+ Z.getZettelID "2011401.md" `shouldBe` Just zid+ Z.zettelIDSourceFileName zid Z.ZettelFormat_Markdown `shouldBe` "2011401.md" context "custom id parsing" $ do let zid = Z.ZettelCustomID "20abcde" it "parses a custom zettel ID" $ do Z.parseZettelID' "20abcde" `shouldBe` Right zid it "parses a custom zettel ID from zettel filename" $ do- Z.mkZettelID "20abcde.md" `shouldBe` zid- Z.zettelIDSourceFileName zid `shouldBe` "20abcde.md"+ Z.getZettelID "20abcde.md" `shouldBe` Just zid+ Z.zettelIDSourceFileName zid Z.ZettelFormat_Markdown `shouldBe` "20abcde.md" let deceptiveZid = Z.ZettelCustomID "2136537e" it "parses a custom zettel ID that looks like date ID" $ do Z.parseZettelID' "2136537e" `shouldBe` Right deceptiveZid
test/Neuron/Zettelkasten/Query/ParserSpec.hs view
@@ -12,12 +12,12 @@ import Data.TagTree import Neuron.Zettelkasten.Connection import Neuron.Zettelkasten.ID-import Neuron.Zettelkasten.Query import Neuron.Zettelkasten.Query.Parser import Neuron.Zettelkasten.Query.Theme+import Neuron.Zettelkasten.Zettel+import Reflex.Dom.Pandoc.URILink import Relude import Test.Hspec-import Text.MMark.MarkdownLink import Text.URI spec :: Spec@@ -31,75 +31,81 @@ for_ [("zquery", Nothing), ("zcfquery", Just OrdinaryConnection)] $ \(scheme, mconn) -> do context scheme $ do let zettelsByTag pat mview =- Right $ Just $ Some $ Query_ZettelsByTag (fmap mkTagPattern pat) mconn mview+ Right $ Just $ Some $ ZettelQuery_ZettelsByTag (fmap mkTagPattern pat) mconn mview withScheme s = toText scheme <> s- legacyLink l = mkMarkdownLink "." l+ legacyLink l = mkURILink "." l it "Parse all zettels URI" $ do- queryFromMarkdownLink (legacyLink $ withScheme "://search")+ queryFromURILink (legacyLink $ withScheme "://search") `shouldBe` zettelsByTag [] def it "Parse single tag" $- queryFromMarkdownLink (legacyLink $ withScheme "://search?tag=foo")+ queryFromURILink (legacyLink $ withScheme "://search?tag=foo") `shouldBe` zettelsByTag ["foo"] def it "Parse hierarchical tag" $ do- queryFromMarkdownLink (legacyLink $ withScheme "://search?tag=foo/bar")+ queryFromURILink (legacyLink $ withScheme "://search?tag=foo/bar") `shouldBe` zettelsByTag ["foo/bar"] def it "Parse tag pattern" $ do- queryFromMarkdownLink (legacyLink $ withScheme "://search?tag=foo/**/bar/*/baz")+ queryFromURILink (legacyLink $ withScheme "://search?tag=foo/**/bar/*/baz") `shouldBe` zettelsByTag ["foo/**/bar/*/baz"] def it "Parse multiple tags" $- queryFromMarkdownLink (legacyLink $ withScheme "://search?tag=foo&tag=bar")+ queryFromURILink (legacyLink $ withScheme "://search?tag=foo&tag=bar") `shouldBe` zettelsByTag ["foo", "bar"] def it "Handles ?grouped" $ do- queryFromMarkdownLink (legacyLink $ withScheme "://search?grouped")+ queryFromURILink (legacyLink $ withScheme "://search?grouped") `shouldBe` zettelsByTag [] (ZettelsView def True) it "Handles ?linkTheme=withDate" $ do- queryFromMarkdownLink (legacyLink $ withScheme "://search?linkTheme=withDate")- `shouldBe` zettelsByTag [] (ZettelsView (LinkView True) False)+ queryFromURILink (legacyLink $ withScheme "://search?linkTheme=withDate")+ `shouldBe` zettelsByTag [] (ZettelsView (LinkView_ShowDate) False) describe "Parse zettels by ID URI" $ do let zid = parseZettelID "1234567" it "parses z:/" $- queryFromMarkdownLink (mkMarkdownLink "1234567" "z:/")- `shouldBe` Right (Just $ Some $ Query_ZettelByID zid Nothing)+ queryFromURILink (mkURILink "1234567" "z:/")+ `shouldBe` Right (Just $ Some $ ZettelQuery_ZettelByID zid Nothing) it "parses z:/ ignoring annotation" $- queryFromMarkdownLink (mkMarkdownLink "1234567" "z://foo-bar")- `shouldBe` Right (Just $ Some $ Query_ZettelByID zid Nothing)+ queryFromURILink (mkURILink "1234567" "z://foo-bar")+ `shouldBe` Right (Just $ Some $ ZettelQuery_ZettelByID zid Nothing) it "parses zcf:/" $- queryFromMarkdownLink (mkMarkdownLink "1234567" "zcf:/")- `shouldBe` Right (Just $ Some $ Query_ZettelByID zid (Just OrdinaryConnection))+ queryFromURILink (mkURILink "1234567" "zcf:/")+ `shouldBe` Right (Just $ Some $ ZettelQuery_ZettelByID zid (Just OrdinaryConnection)) describe "Parse tags URI" $ do it "parses zquery://tags" $- queryFromMarkdownLink (mkMarkdownLink "." "zquery://tags?filter=foo/**")- `shouldBe` Right (Just $ Some $ Query_Tags [mkTagPattern "foo/**"])+ queryFromURILink (mkURILink "." "zquery://tags?filter=foo/**")+ `shouldBe` Right (Just $ Some $ ZettelQuery_Tags [mkTagPattern "foo/**"]) shortLinks :: Spec shortLinks = do describe "short links" $ do- let shortLink s = mkMarkdownLink s s+ let shortLink s = mkURILink s s it "parses date ID" $ do- queryFromMarkdownLink (shortLink "1234567")- `shouldBe` Right (Just $ Some $ Query_ZettelByID (parseZettelID "1234567") Nothing)+ queryFromURILink (shortLink "1234567")+ `shouldBe` Right (Just $ Some $ ZettelQuery_ZettelByID (parseZettelID "1234567") Nothing) it "parses custom/hash ID" $ do- queryFromMarkdownLink (shortLink "foo-bar")- `shouldBe` Right (Just $ Some $ Query_ZettelByID (parseZettelID "foo-bar") Nothing)+ queryFromURILink (shortLink "foo-bar")+ `shouldBe` Right (Just $ Some $ ZettelQuery_ZettelByID (parseZettelID "foo-bar") Nothing) it "even with ?cf" $ do- queryFromMarkdownLink (shortLink "foo-bar?cf")- `shouldBe` Right (Just $ Some $ Query_ZettelByID (parseZettelID "foo-bar") (Just OrdinaryConnection))+ queryFromURILink (shortLink "foo-bar?cf")+ `shouldBe` Right (Just $ Some $ ZettelQuery_ZettelByID (parseZettelID "foo-bar") (Just OrdinaryConnection))+ it "parses prefixed short link" $ do+ queryFromURILink (shortLink "z:/foo-bar")+ `shouldBe` Right (Just $ Some $ ZettelQuery_ZettelByID (parseZettelID "foo-bar") Nothing)+ it "resolves ambiguity using absolute URI" $ do+ queryFromURILink (shortLink "z:/tags")+ `shouldBe` Right (Just $ Some $ ZettelQuery_ZettelByID (parseZettelID "tags") Nothing) it "z:zettels" $ do- queryFromMarkdownLink (shortLink "z:zettels")- `shouldBe` Right (Just $ Some $ Query_ZettelsByTag [] Nothing def)+ queryFromURILink (shortLink "z:zettels")+ `shouldBe` Right (Just $ Some $ ZettelQuery_ZettelsByTag [] Nothing def) it "z:zettels?tag=foo" $ do- queryFromMarkdownLink (shortLink "z:zettels?tag=foo")- `shouldBe` Right (Just $ Some $ Query_ZettelsByTag [mkTagPattern "foo"] Nothing def)+ queryFromURILink (shortLink "z:zettels?tag=foo")+ `shouldBe` Right (Just $ Some $ ZettelQuery_ZettelsByTag [mkTagPattern "foo"] Nothing def) it "z:zettels?cf" $ do- queryFromMarkdownLink (shortLink "z:zettels?cf")- `shouldBe` Right (Just $ Some $ Query_ZettelsByTag [] (Just OrdinaryConnection) def)+ queryFromURILink (shortLink "z:zettels?cf")+ `shouldBe` Right (Just $ Some $ ZettelQuery_ZettelsByTag [] (Just OrdinaryConnection) def) it "z:tags" $ do- queryFromMarkdownLink (shortLink "z:tags")- `shouldBe` Right (Just $ Some $ Query_Tags [])+ queryFromURILink (shortLink "z:tags")+ `shouldBe` Right (Just $ Some $ ZettelQuery_Tags []) it "z:tags?filter=foo" $ do- queryFromMarkdownLink (shortLink "z:tags?filter=foo")- `shouldBe` Right (Just $ Some $ Query_Tags [mkTagPattern "foo"])+ queryFromURILink (shortLink "z:tags?filter=foo")+ `shouldBe` Right (Just $ Some $ ZettelQuery_Tags [mkTagPattern "foo"]) -mkMarkdownLink :: Text -> Text -> MarkdownLink-mkMarkdownLink s l =- MarkdownLink s $ either (error . toText . displayException) id $ mkURI l+mkURILink :: Text -> Text -> URILink+mkURILink s l =+ URILink s $ either (error . toText . displayException) id $ mkURI l
test/Neuron/Zettelkasten/ZettelSpec.hs view
@@ -7,37 +7,37 @@ ) where -import Data.Aeson import Data.TagTree import Data.Time.Calendar+import Neuron.Reader.Markdown+import Neuron.Reader.Type import Neuron.Zettelkasten.ID import Neuron.Zettelkasten.Zettel+import Neuron.Zettelkasten.Zettel.Meta (Meta) import Relude-import Rib.Parser.MMark (parsePure) import Test.Hspec spec :: Spec spec = do+ let noQueries = mempty -- TODO: test queries+ noError = Right mempty+ noContent = MetadataOnly () describe "sortZettelsReverseChronological" $ do let mkDay = fromGregorian 2020 3- dummyContent = either error id $ parsePure "<spec>" "Dummy"+ (_ :: Maybe Meta, _dummyContent) = either (error . show) id $ parseMarkdown "<spec>" "Dummy" mkZettel day idx =- Zettel (ZettelDateID (mkDay day) idx) "Some title" [Tag "science", Tag "journal/class"] (Just $ mkDay day) dummyContent+ Zettel+ (ZettelDateID (mkDay day) idx)+ ZettelFormat_Markdown+ "<spec>.md"+ "Some title"+ False+ [Tag "science", Tag "journal/class"]+ (Just $ mkDay day)+ noQueries+ noError+ noContent it "sorts correctly" $ do let zs = [mkZettel 3 2, mkZettel 5 1] sortZettelsReverseChronological zs `shouldBe` [mkZettel 5 1, mkZettel 3 2]- describe "Zettel JSON" $ do- let day = fromGregorian 2020 3 19- zid = ZettelCustomID "Foo-Bar"- dummyContent = either error id $ parsePure "<spec>" "Dummy"- zettel = Zettel zid "Some title" [Tag "science", Tag "journal/class"] (Just day) dummyContent- it "Produces expected json" $ do- -- "{\"id\":\"2011401\",\"title\":\"Some title\",\"tags\":[\"science\"]}"- object (zettelJson zettel)- `shouldBe` object- [ "id" .= ("Foo-Bar" :: Text),- "title" .= ("Some title" :: Text),- "tags" .= (["science", "journal/class"] :: [Text]),- "day" .= day- ]