packages feed

neuron 0.2.0.0 → 0.4.0.0

raw patch · 70 files changed

+3598/−1421 lines, 70 filesdep +aeson-gadt-thdep +data-defaultdep +dependent-sumdep −pathdep −path-iodep ~basedep ~rib

Dependencies added: aeson-gadt-th, data-default, dependent-sum, dependent-sum-template, megaparsec, mtl, parser-combinators, uuid

Dependencies removed: path, path-io

Dependency ranges changed: base, rib

Files

CHANGELOG.md view
@@ -1,5 +1,41 @@ # 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 view
@@ -3,10 +3,10 @@ # neuron  [![BSD3](https://img.shields.io/badge/License-BSD-blue.svg)](https://en.wikipedia.org/wiki/BSD_License)-[![built with nix](https://img.shields.io/badge/builtwith-nix-purple.svg)](https://builtwithnix.org)+[![built with nix](https://img.shields.io/badge/Built_With-Nix-5277C3.svg?logo=nixos&labelColor=73C3D5)](https://builtwithnix.org) [![Zulip chat](https://img.shields.io/badge/zulip-join_chat-brightgreen.svg)](https://funprog.zulipchat.com/#narrow/stream/231929-Neuron) -neuron is a system for managing your plain-text [Zettelkasten](https://neuron.srid.ca/2011401.html) notes. +neuron is a system for managing your plain-text [Zettelkasten](https://neuron.zettel.page/2011401.html) notes.   **Features** @@ -17,7 +17,7 @@  ## Getting started -See [neuron.srid.ca](https://neuron.srid.ca/) for the full guide to installing and using neuron.+See [neuron.zettel.page](https://neuron.zettel.page/) for the full guide to installing and using neuron.  ## Developing @@ -30,7 +30,7 @@ You can test your changes by running it on the `./guide` (or any) zettelkasten as follows:  ```bash-bin/run ./guide rib serve+bin/run -d ./guide rib -wS ```  This command will also automatically recompile and restart when you change any of the Haskell source files.
neuron.cabal view
@@ -1,13 +1,13 @@ cabal-version: 2.4 name: neuron -- This version must be in sync with what's in Default.dhall-version: 0.2.0.0+version: 0.4.0.0 license: BSD-3-Clause copyright: 2020 Sridhar Ratnakumar maintainer: srid@srid.ca author: Sridhar Ratnakumar category: Web-homepage: https://neuron.srid.ca+homepage: https://neuron.zettel.page bug-reports: https://github.com/srid/neuron/issues synopsis:   Haskell meets Zettelkasten, for your plain-text delight.@@ -16,11 +16,19 @@ extra-source-files:   README.md   CHANGELOG.md+data-files:+  src-js/search.js+  src-bash/neuron-search+  src-dhall/Config/*.dhall  source-repository head     type: git     location: https://github.com/srid/neuron +flag ghcid+    default: False+    manual: True+ common ghc-common   ghc-options:     -Wall@@ -29,12 +37,48 @@  common library-common   import: ghc-common-  hs-source-dirs: src    default-language: Haskell2010   build-depends:-    base >=4.7 && <5,+    base >=4.12 && < 4.14,     aeson,+    mtl,+    text,+    time,+    relude,+    filepath,+    algebraic-graphs >= 0.5,+    parser-combinators,+    containers,+    filepattern,+    mmark,+    megaparsec++library+  import: library-common+  hs-source-dirs: src/lib+  exposed-modules:+    Neuron.Zettelkasten.ID+    Neuron.Zettelkasten.Zettel+    Neuron.Zettelkasten.Zettel.Meta+    Text.Megaparsec.Simple+    Data.TagTree+    Data.PathTree+    Data.Graph.Labelled+    Data.Graph.Labelled.Type+    Data.Graph.Labelled.Algorithm+    Data.Graph.Labelled.Build++-- A trick to make ghcid reload if library dependencies change+-- https://haskell.zettel.page/2012605.html+common app-common+  import: library-common+  hs-source-dirs: src/app src/lib+  default-language: Haskell2010+  build-depends:+    base >=4.12 && < 4.14,+    aeson,     clay -any,+    mtl,     containers,     directory,     exceptions,@@ -43,10 +87,8 @@     lucid -any,     optparse-applicative,     pandoc,-    path,-    path-io,     relude,-    rib ^>=0.8,+    rib ^>=0.10,     shake -any,     time,     text,@@ -54,56 +96,88 @@     mmark-ext,     modern-uri,     foldl,-    filepattern,     filepath,-    algebraic-graphs >= 0.5,     dhall >= 1.30,     which,-    unix--library-  import: library-common-  exposed-modules:-    Neuron.Zettelkasten-    Neuron.Zettelkasten.Route-    Neuron.Zettelkasten.Store-    Neuron.Zettelkasten.Query-    Neuron.Zettelkasten.Graph-    Neuron.Zettelkasten.View-    Neuron.Zettelkasten.Link-    Neuron.Zettelkasten.Link.View-    Neuron.Zettelkasten.Link.Action-    Neuron.Zettelkasten.Markdown-    Neuron.Zettelkasten.Meta-    Neuron.Zettelkasten.Type-    Neuron.Zettelkasten.Config-    Neuron.Zettelkasten.ID---executable neuron-  -- We include library modules here, so that ghcid knows to reload when they change.-  import: library-common-  hs-source-dirs: src-bin-  main-is: Main.hs-  build-depends:-    base,-    rib,-    relude,-    path,+    unix,+    megaparsec >= 8.0,+    dependent-sum,+    dependent-sum-template,+    aeson-gadt-th,+    data-default,+    uuid,     shake,-    clay,-    lucid,     with-utf8+  if (!flag(ghcid))+    autogen-modules:+      Paths_neuron+    other-modules:+      Data.Graph.Labelled+      Data.Graph.Labelled.Algorithm+      Data.Graph.Labelled.Build+      Data.Graph.Labelled.Type+      Data.PathTree+      Data.Structured.Breadcrumb+      Data.TagTree+      Neuron.CLI+      Neuron.CLI.New+      Neuron.CLI.Rib+      Neuron.CLI.Search+      Neuron.CLI.Types+      Neuron.Config+      Neuron.Config.Alias+      Neuron.Version+      Neuron.Version.RepoVersion+      Neuron.Web.Generate+      Neuron.Web.Route+      Neuron.Web.Theme+      Neuron.Web.View+      Neuron.Zettelkasten.Connection+      Neuron.Zettelkasten.Error+      Neuron.Zettelkasten.Graph+      Neuron.Zettelkasten.Graph.Type+      Neuron.Zettelkasten.ID+      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: library-common +  import: app-common   type: exitcode-stdio-1.0   hs-source-dirs: test   main-is: Spec.hs   build-depends:-    base,+    base >=4.12 && < 4.14,     relude,     hspec,     QuickCheck,     time   default-language:    Haskell2010+  if (!flag(ghcid))+    other-modules:+      Data.PathTreeSpec+      Data.TagTreeSpec+      Neuron.Config.AliasSpec+      Neuron.VersionSpec+      Neuron.Zettelkasten.ID.SchemeSpec+      Neuron.Zettelkasten.IDSpec+      Neuron.Zettelkasten.Query.ParserSpec+      Neuron.Zettelkasten.ZettelSpec++-- The executable stanza should always be at the end. The other project will+-- strip it to avoid non-core dependencies.+executable neuron+  import: app-common+  main-is: Main.hs
@@ -0,0 +1,13 @@+#!/usr/bin/env bash++set -euo pipefail+NOTESDIR=${1}+FILTERBY=${2}+SEARCHFROMFIELD=${3}+OPENCMD=$(envsubst -no-unset -no-empty <<<${4})+cd ${NOTESDIR}+rg --no-heading --no-line-number --with-filename --sort path "${FILTERBY}" *.md \+  | fzf --tac --no-sort -d ':' -n ${SEARCHFROMFIELD}.. \+    --preview 'bat --style=plain --color=always {1}' \+  | awk -F: "{printf \"${NOTESDIR}/%s\", \$1}" \+  | xargs -r ${OPENCMD}
− src-bin/Main.hs 
@@ -1,82 +0,0 @@-{-# LANGUAGE GADTs #-}-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE QuasiQuotes #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeApplications #-}-{-# LANGUAGE NoImplicitPrelude #-}--module Main where--import Clay hiding (s, style, type_)-import qualified Clay as C--- TODO: Don't expose every module--import Development.Shake-import Lucid-import Main.Utf8-import Neuron.Version (neuronVersion, olderThan)-import qualified Neuron.Zettelkasten as Z-import qualified Neuron.Zettelkasten.Config as Z-import qualified Neuron.Zettelkasten.Route as Z-import qualified Neuron.Zettelkasten.View as Z-import Path-import Relude-import qualified Rib-import Rib.Extra.CSS (googleFonts, stylesheet)--main :: IO ()-main = withUtf8 $ Z.run generateSite--generateSite :: Action ()-generateSite = do-  Rib.buildStaticFiles [[relfile|static/**|]]-  config <- Z.getConfig-  when (olderThan $ Z.minVersion config) $ do-    error $ "Require neuron mininum version " <> Z.minVersion config <> ", but your neuron version is " <> neuronVersion-  let writeHtmlRoute :: Z.Route s g () -> (s, g) -> Action ()-      writeHtmlRoute r = Rib.writeRoute r . Lucid.renderText . renderPage config r-  void $ Z.generateSite writeHtmlRoute [[relfile|*.md|]]--renderPage :: Z.Config -> Z.Route s g () -> (s, g) -> Html ()-renderPage config r val = html_ [lang_ "en"] $ do-  head_ $ do-    Z.renderRouteHead config r (fst val)-    case r of-      Z.Route_IndexRedirect ->-        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.render style-        googleFonts $ [headerFont, bodyFont, monoFont]-        when (Z.mathJaxSupport config) $-          with (script_ mempty) [id_ "MathJax-script", src_ "https://cdn.jsdelivr.net/npm/mathjax@3/es5/tex-mml-chtml.js", async_ ""]-  body_ $ do-    div_ [class_ "ui text container", id_ "thesite"] $ do-      Z.renderRouteBody config r val--headerFont :: Text-headerFont = "Oswald"--bodyFont :: Text-bodyFont = "Open Sans"--monoFont :: Text-monoFont = "Roboto Mono"--style :: Css-style = "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 50-    C.display C.block-    C.marginLeft C.auto-    C.marginRight C.auto-  Z.style
+ src-dhall/Config/Default.dhall view
@@ -0,0 +1,17 @@+{ 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 view
@@ -0,0 +1,17 @@+{ 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
@@ -0,0 +1,101 @@+let search = "",+    selectedTags = [];++let searchResults = document.getElementById("search-results"); // ul element+let searchInput = document.getElementById("search-input");+++// Create a zettel link from a zettel object+function makeZettelLink(zettel) {+  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);++  let linkTitle = document.createElement("span");+  linkTitle.classList.add("zettel-link-title");+  linkTitle.innerHTML = zettel.title;+  zettelLink.appendChild(linkTitle);++  return zettelLink;+}++// Renders the results as a list+function renderResults(results) {+  searchResults.innerHTML = "";++  for (var i = 0, length = results.length; i < length; i++) {+    let zettel = results[i];+    let result = document.createElement("li");+    let zettelLink = makeZettelLink(zettel);+    result.appendChild(zettelLink);+    searchResults.appendChild(result);+  }+}++// Rebuild the search, eventually useful for advanced search+function rebuildSearchIndex() {+  search = new JsSearch.Search("id");+  search.tokenizer = new JsSearch.StopWordsTokenizer(+    new JsSearch.SimpleTokenizer()+  );+  search.indexStrategy = new JsSearch.AllSubstringsIndexStrategy();+  search.addIndex("id");+  search.addIndex("title");+  search.addIndex("tags");+  search.addDocuments(index.zettels);+}++function matchSelectedTags(zettel) {+  return selectedTags.every((tag) => {+    return zettel.tags.includes(tag);+  });+}++// Runs and renders the search+function runSearch() {+  let query = searchInput.value;+  let results;+  if (query == "") {+    results = index.zettels;+  } else {+    results = search.search(query);+  }+  results = results.filter(matchSelectedTags);+  renderResults(results);+}++// Initialize selected tags+function initializeTags() {+  $('#search-tags').dropdown('set selected', selectedTags);+}++// Initialize variables with URL parameters+function initializeSearchFromURL() {+  let url = new URL(window.location.href);+  let searchParams = new URLSearchParams(url.search);+  searchInput.value = searchParams.get("q");+  selectedTags = searchParams.getAll("tag");+  initializeTags();+  runSearch();+}++rebuildSearchIndex();+initializeSearchFromURL();++$('#search-input').on("change paste keyup", runSearch)+                  .focus();++$('#search-tags').dropdown({+  onChange: (value) => {+    selectedTags = value.split(',').filter((tag) => tag != "");+    runSearch();+  }+});
− src/Neuron/Zettelkasten.hs 
@@ -1,203 +0,0 @@-{-# LANGUAGE ApplicativeDo #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE QuasiQuotes #-}-{-# LANGUAGE Rank2Types #-}-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE TypeApplications #-}-{-# LANGUAGE NoImplicitPrelude #-}---- | Main module for using neuron as a library, instead of as a CLI tool.-module Neuron.Zettelkasten-  ( -- * CLI-    App (..),-    NewCommand (..),-    commandParser,-    run,-    runWith,--    -- * Rib site generation-    generateSite,--    -- * Etc-    newZettelFile,-  )-where--import qualified Data.Aeson.Text as Aeson-import qualified Data.Map.Strict as Map-import Development.Shake (Action)-import qualified Neuron.Version as Version-import qualified Neuron.Zettelkasten.Graph as Z-import qualified Neuron.Zettelkasten.ID as Z-import qualified Neuron.Zettelkasten.Link.Action as Z-import qualified Neuron.Zettelkasten.Query as Z-import qualified Neuron.Zettelkasten.Route as Z-import qualified Neuron.Zettelkasten.Store as Z-import Options.Applicative-import Path-import Path.IO-import Relude-import qualified Rib-import qualified Rib.App-import qualified System.Directory as Directory-import System.FilePath (addTrailingPathSeparator, dropTrailingPathSeparator)-import qualified System.Posix.Env as Env-import System.Posix.Process-import System.Which-import qualified Text.URI as URI--neuronSearchScript :: FilePath-neuronSearchScript = $(staticWhich "neuron-search")--data App-  = App-      { notesDir :: FilePath,-        cmd :: Command-      }-  deriving (Eq, Show)--data NewCommand = NewCommand {title :: Text, edit :: Bool}-  deriving (Eq, Show)--data Command-  = -- | Create a new zettel file-    New NewCommand-  | -- | Search a zettel by title-    Search-  | -- | Run a query against the Zettelkasten-    Query [Z.Query]-  | -- | Delegate to Rib's command parser-    Rib Rib.App.Command-  deriving (Eq, Show)---- | optparse-applicative parser for neuron CLI-commandParser :: Parser App-commandParser =-  App-    <$> argument (fmap addTrailingPathSeparator str) (metavar "NOTESDIR")-    <*> cmdParser-  where-    cmdParser =-      hsubparser $-        mconcat-          [ command "new" $ info newCommand $ progDesc "Create a new zettel",-            command "search" $ info searchCommand $ progDesc "Search zettels and print the matching filepath",-            command "query" $ info queryCommand $ progDesc "Run a query against the zettelkasten",-            command "rib" $ fmap Rib $ info Rib.App.commandParser $ progDesc "Run a rib command"-          ]-    newCommand = do-      edit <- switch (long "edit" <> short 'e' <> help "Open the newly-created file in $EDITOR")-      title <- argument str (metavar "TITLE" <> help "Title of the new Zettel")-      return (New NewCommand {..})-    queryCommand =-      fmap Query $-        (many (Z.ByTag <$> option str (long "tag" <> short 't')))-          <|> (Z.queryFromUri . mkURIMust <$> option str (long "uri" <> short 'u'))-    searchCommand =-      pure Search-    mkURIMust =-      either (error . toText . displayException) id . URI.mkURI--run :: Action () -> IO ()-run act =-  runWith act =<< execParser opts-  where-    opts =-      info-        (versionOption <*> commandParser <**> helper)-        (fullDesc <> progDesc "Zettelkasten based on Rib")-    versionOption =-      infoOption-        (toString Version.neuronVersionFull)-        (long "version" <> help "Show version")--runWith :: Action () -> App -> IO ()-runWith ribAction App {..} = do-  notesDirAbs <- Directory.makeAbsolute notesDir-  inputDir <- parseAbsDir notesDirAbs-  outputDir <- directoryAside inputDir ".output"-  case cmd of-    New newCommand ->-      newZettelFile inputDir newCommand-    Search ->-      execScript neuronSearchScript [notesDir]-    Query queries -> do-      runRibOneOffShake inputDir outputDir $ do-        store <- Z.mkZettelStore =<< Rib.forEvery [[relfile|*.md|]] pure-        let matches = Z.runQuery store queries-        putLTextLn $ Aeson.encodeToLazyText $ matches-    Rib ribCmd ->-      runRib inputDir outputDir ribCmd ribAction-  where-    execScript scriptPath args =-      -- We must use the low-level execvp (via the unix package's `executeFile`)-      -- here, such that the new process replaces the current one. fzf won't work-      -- otherwise.-      void $ executeFile scriptPath False args Nothing-    -- Run an one-off shake action through rib-    runRibOneOffShake inputDir outputDir =-      runRib inputDir outputDir Rib.App.OneOff-    runRib inputDir outputDir ribCmd act =-      -- CD to the parent of notes directory, because Rib API takes only-      -- relative path-      withCurrentDir (parent inputDir) $ do-        inputDirRel <- makeRelativeToCurrentDir inputDir-        outputDirRel <- makeRelativeToCurrentDir outputDir-        Rib.App.runWith inputDirRel outputDirRel act ribCmd-    directoryAside :: Path Abs Dir -> String -> IO (Path Abs Dir)-    directoryAside fp suffix = do-      let baseName = dropTrailingPathSeparator $ toFilePath $ dirname fp-      newDir <- parseRelDir $ baseName <> suffix-      pure $ parent fp </> newDir---- | Generate the Zettelkasten site-generateSite ::-  (Z.Route Z.ZettelStore Z.ZettelGraph () -> (Z.ZettelStore, Z.ZettelGraph) -> Action ()) ->-  [Path Rel File] ->-  Action (Z.ZettelStore, Z.ZettelGraph)-generateSite writeHtmlRoute' zettelsPat = do-  zettelStore <- Z.mkZettelStore =<< Rib.forEvery zettelsPat pure-  let zettelGraph = Z.mkZettelGraph zettelStore-  let writeHtmlRoute r = writeHtmlRoute' r (zettelStore, zettelGraph)-  -- Generate HTML for every zettel-  (writeHtmlRoute . Z.Route_Zettel) `mapM_` Map.keys zettelStore-  -- Generate the z-index-  writeHtmlRoute Z.Route_ZIndex-  -- Write index.html, unless a index.md zettel exists-  when (isNothing $ Map.lookup (Z.parseZettelID "index") zettelStore) $-    writeHtmlRoute Z.Route_IndexRedirect-  pure (zettelStore, zettelGraph)---- | Create a new zettel file and open it in editor if requested------ As well as print the path to the created file.-newZettelFile :: Path b Dir -> NewCommand -> IO ()-newZettelFile inputDir NewCommand {..} = do-  -- TODO: refactor this function-  zId <- Z.zettelNextIdForToday inputDir-  zettelFileName <- parseRelFile $ toString $ Z.zettelIDSourceFileName zId-  let srcPath = inputDir </> zettelFileName-  doesFileExist srcPath >>= \case-    True ->-      fail $ "File already exists: " <> show srcPath-    False -> do-      writeFile (toFilePath srcPath) $ "---\ntitle: " <> toString title <> "\n---\n\n"-      let path = toFilePath srcPath-      putStrLn path-      when edit $ do-        getEnvNonEmpty "EDITOR" >>= \case-          Nothing -> do-            die "\nCan't open file; you must set the EDITOR environment variable"-          Just editor -> do-            executeFile editor True [path] Nothing-  where-    getEnvNonEmpty name =-      Env.getEnv name >>= \case-        Nothing -> pure Nothing-        Just "" -> pure Nothing-        Just v -> pure $ Just v
− src/Neuron/Zettelkasten/Config.hs 
@@ -1,58 +0,0 @@-{-# LANGUAGE DeriveAnyClass #-}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE DerivingStrategies #-}-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE QuasiQuotes #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE StandaloneDeriving #-}-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE TypeApplications #-}-{-# LANGUAGE NoImplicitPrelude #-}--module Neuron.Zettelkasten.Config-  ( Config (..),-    getConfig,-  )-where--import Data.FileEmbed (embedFile)-import Development.Shake (Action, readFile')-import Dhall (FromDhall)-import qualified Dhall-import Dhall.TH-import Path-import Path.IO (doesFileExist)-import Relude-import qualified Rib---- | Config type for @neuron.dhall@------ See <https://neuron.srid.ca/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--defaultConfig :: ByteString-defaultConfig = $(embedFile "./src-dhall/Config/Default.dhall")---- | Read the optional @neuron.dhall@ config file from the zettelksaten-getConfig :: Action Config-getConfig = do-  inputDir <- Rib.ribInputDir-  let configPath = inputDir </> configFile-  configVal :: Text <- doesFileExist configPath >>= \case-    True -> do-      userConfig <- fmap toText $ readFile' $ toFilePath 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-    False ->-      pure $ decodeUtf8 @Text defaultConfig-  liftIO $ Dhall.detailed $ Dhall.input Dhall.auto configVal-  where-    configFile = [relfile|neuron.dhall|]
− src/Neuron/Zettelkasten/Graph.hs 
@@ -1,159 +0,0 @@-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE QuasiQuotes #-}-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TupleSections #-}-{-# LANGUAGE TypeApplications #-}-{-# LANGUAGE ViewPatterns #-}-{-# LANGUAGE NoImplicitPrelude #-}--module Neuron.Zettelkasten.Graph-  ( -- * Graph type-    ZettelGraph,--    -- * Construction-    mkZettelGraph,--    -- * Algorithms-    backlinks,-    topSort,-    zettelClusters,-    dfsForestFrom,-    dfsForestBackwards,-    obviateRootUnlessForest,-  )-where--import qualified Algebra.Graph.AdjacencyMap as AM-import qualified Algebra.Graph.AdjacencyMap.Algorithm as Algo-import qualified Algebra.Graph.Labelled.AdjacencyMap as LAM-import qualified Data.Map.Strict as Map-import qualified Data.Set as Set-import Data.Tree (Forest, Tree (..))-import Neuron.Zettelkasten.ID-import Neuron.Zettelkasten.Link.Action (extractLinks, linkActionConnections)-import Neuron.Zettelkasten.Store (ZettelStore)-import Neuron.Zettelkasten.Type-import Relude---- | The Zettelkasten graph-type ZettelGraph = LAM.AdjacencyMap [Connection] ZettelID---- | Build the Zettelkasten graph from the given list of note files.-mkZettelGraph :: ZettelStore -> ZettelGraph-mkZettelGraph store =-  mkGraphFrom (Map.elems store) zettelID zettelEdges connectionWhitelist-  where-    -- Exclude ordinary connection when building the graph-    ---    -- TODO: Build the graph with all connections, but induce a subgraph when-    -- building category forests. This way we can still show ordinary-    -- connetions in places (eg: a "backlinks" section) where they are-    -- relevant. See #34-    connectionWhitelist cs =-      not $ OrdinaryConnection `elem` cs-    -- Get the outgoing edges from this zettel-    ---    -- TODO: Handle conflicts in edge monoid operation (same link but with-    -- different connection type), and consequently use a sensible type other-    -- than list.-    zettelEdges :: Zettel -> [([Connection], ZettelID)]-    zettelEdges Zettel {..} =-      let outgoingLinks = linkActionConnections store `concatMap` extractLinks zettelContent-       in first pure <$> outgoingLinks---- | Return the backlinks to the given zettel-backlinks :: ZettelID -> ZettelGraph -> [ZettelID]-backlinks zid =-  toList . LAM.preSet zid--topSort :: ZettelGraph -> Either (NonEmpty ZettelID) [ZettelID]-topSort = Algo.topSort . LAM.skeleton---- | Get the graph without the "index" zettel.--- This is unused, but left for posterity.-_withoutIndex :: ZettelGraph -> ZettelGraph-_withoutIndex = LAM.induce ((/= "index") . unZettelID)--zettelClusters :: ZettelGraph -> [NonEmpty ZettelID]-zettelClusters = mothers . LAM.skeleton---- | Compute the dfsForest from the given zettels.-dfsForestFrom :: [ZettelID] -> ZettelGraph -> Forest ZettelID-dfsForestFrom zids g =-  Algo.dfsForestFrom zids $ LAM.skeleton g---- | Compute the dfsForest ending in the given zettel.------ Return the forest flipped, such that the given zettel is the root.-dfsForestBackwards :: ZettelID -> ZettelGraph -> Forest ZettelID-dfsForestBackwards fromZid =-  dfsForestFrom [fromZid] . LAM.transpose---- ---------------- Graph Helpers--- ----------------- | Get the clusters in a graph, as a list of the mother vertices in each--- cluster.-mothers :: Ord a => AM.AdjacencyMap a -> [NonEmpty a]-mothers g =-  go [] $ motherVertices g-  where-    go acc = \case-      [] -> acc-      v : (Set.fromList -> vs) ->-        let reach = reachableUndirected v g-            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--motherVertices :: Ord a => AM.AdjacencyMap a -> [a]-motherVertices =-  mapMaybe (\(v, es) -> if null es then Just v else Nothing)-    . AM.adjacencyList-    . AM.transpose---- | If the input is a tree with the given root node, return its children (as--- forest). Otherwise return the input as is.-obviateRootUnlessForest :: (Show a, Eq a) => a -> [Tree a] -> [Tree a]-obviateRootUnlessForest root = \case-  [Node v ts] ->-    if v == root-      then ts-      else error "Root mismatch"-  nodes ->-    nodes---- Build a graph from a list objects that contains information about the--- corresponding vertex as well as the outgoing edges.-mkGraphFrom ::-  (Eq e, Monoid e, Ord v) =>-  -- | List of objects corresponding to vertexes-  [a] ->-  -- | Make vertex from an object-  (a -> v) ->-  -- | Outgoing edges, and their vertex, for an object-  (a -> [(e, v)]) ->-  -- | A function to filter relevant edges-  (e -> Bool) ->-  LAM.AdjacencyMap e v-mkGraphFrom xs vertexFor edgesFor edgeWhitelist =-  let vertices =-        vertexFor <$> xs-      edges =-        flip concatMap xs $ \x ->-          edgesFor x-            <&> \(edge, v2) ->-              (edge, vertexFor x, v2)-   in LAM.overlay-        (LAM.vertices vertices)-        (LAM.edges $ filter (\(e, _, _) -> edgeWhitelist e) edges)
− src/Neuron/Zettelkasten/ID.hs 
@@ -1,108 +0,0 @@-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeApplications #-}-{-# LANGUAGE NoImplicitPrelude #-}--module Neuron.Zettelkasten.ID-  ( ZettelID (..),-    Connection (..),-    ZettelConnection,-    zettelIDDate,-    parseZettelID,-    mkZettelID,-    zettelNextIdForToday,-    zettelIDSourceFileName,-  )-where--import Data.Aeson (ToJSON)-import qualified Data.Text as T-import Data.Time-import Lucid-import Path-import Relude-import System.Directory (listDirectory)-import qualified System.FilePattern as FP-import Text.Printf---- | Short Zettel ID encoding `Day` and a numeric index (on that day).------ Based on https://old.reddit.com/r/Zettelkasten/comments/fa09zw/shorter_zettel_ids/-newtype ZettelID = ZettelID {unZettelID :: Text}-  deriving (Eq, Show, Ord, ToJSON)--instance ToHtml ZettelID where-  toHtmlRaw = toHtml-  toHtml = toHtml . unZettelID--zettelIDSourceFileName :: ZettelID -> Text-zettelIDSourceFileName zid = unZettelID zid <> ".md"---- TODO: sync/DRY with zettelNextIdForToday-zettelIDDate :: ZettelID -> Day-zettelIDDate =-  parseTimeOrError False defaultTimeLocale "%y%W%a"-    . toString-    . uncurry mappend-    . second (dayFromIndex . readMaybe . toString)-    . (T.dropEnd 1 &&& T.takeEnd 1)-    . T.dropEnd 2-    . unZettelID-  where-    dayFromIndex :: Maybe Int -> Text-    dayFromIndex = \case-      Just n ->-        case n of-          1 -> "Mon"-          2 -> "Tue"-          3 -> "Wed"-          4 -> "Thu"-          5 -> "Fri"-          6 -> "Sat"-          7 -> "Sun"-          _ -> error "> 7"-      Nothing ->-        error "Bad day"--zettelNextIdForToday :: Path b Dir -> IO ZettelID-zettelNextIdForToday inputDir = ZettelID <$> do-  zIdPartial <- dayIndex . toText . formatTime defaultTimeLocale "%y%W%a" <$> getCurrentTime-  zettelFiles <- listDirectory $ toFilePath $ inputDir-  let nums :: [Int] = sort $ catMaybes $ fmap readMaybe $ catMaybes $ catMaybes $ fmap (fmap listToMaybe . FP.match (toString zIdPartial <> "*.md")) zettelFiles-  case fmap last (nonEmpty nums) of-    Just lastNum ->-      pure $ zIdPartial <> toText @String (printf "%02d" $ lastNum + 1)-    Nothing ->-      pure $ zIdPartial <> "01"-  where-    dayIndex =-      T.replace "Mon" "1"-        . T.replace "Tue" "2"-        . T.replace "Wed" "3"-        . T.replace "Thu" "4"-        . T.replace "Fri" "5"-        . T.replace "Sat" "6"-        . T.replace "Sun" "7"---- TODO: Actually parse and validate-parseZettelID :: Text -> ZettelID-parseZettelID = ZettelID---- | Extract ZettelID from the zettel's filename or path.-mkZettelID :: Path Rel File -> ZettelID-mkZettelID fp = either (error . toText . displayException) id $ do-  (name, _) <- splitExtension $ filename fp-  pure $ ZettelID $ toText $ toFilePath name--type ZettelConnection = (Connection, ZettelID)---- | 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)
− src/Neuron/Zettelkasten/Link.hs 
@@ -1,36 +0,0 @@-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE QuasiQuotes #-}-{-# LANGUAGE Rank2Types #-}-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TupleSections #-}-{-# LANGUAGE TypeApplications #-}-{-# LANGUAGE ViewPatterns #-}-{-# LANGUAGE NoImplicitPrelude #-}---- | Special Zettel links in Markdown-module Neuron.Zettelkasten.Link where--import Neuron.Zettelkasten.Link.Action-import Neuron.Zettelkasten.Link.View-import Neuron.Zettelkasten.Store-import Relude-import qualified Text.MMark.Extension as Ext-import Text.MMark.Extension (Extension, Inline (..))---- | MMark extension to transform @z:/@ links in Markdown-linkActionExt :: ZettelStore -> Extension-linkActionExt store =-  Ext.inlineRender $ \f -> \case-    inline@(Link inner uri _title) ->-      case linkActionFromUri uri of-        Just lact ->-          let mlink = MarkdownLink (Ext.asPlainText inner) uri-           in linkActionRender store mlink lact-        Nothing ->-          f inline-    inline ->-      f inline
− src/Neuron/Zettelkasten/Link/Action.hs 
@@ -1,113 +0,0 @@-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE QuasiQuotes #-}-{-# LANGUAGE Rank2Types #-}-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TupleSections #-}-{-# LANGUAGE TypeApplications #-}-{-# LANGUAGE ViewPatterns #-}-{-# LANGUAGE NoImplicitPrelude #-}---- | Special Zettel links in Markdown-module Neuron.Zettelkasten.Link.Action where--import Control.Foldl (Fold (..))-import qualified Data.Set as Set-import Neuron.Zettelkasten.ID-import Neuron.Zettelkasten.Query-import Neuron.Zettelkasten.Store-import Relude-import Text.MMark (MMark, runScanner)-import qualified Text.MMark.Extension as Ext-import Text.MMark.Extension (Inline (..))-import qualified Text.URI as URI--data LinkTheme-  = LinkTheme_Default-  | LinkTheme_Simple-  | LinkTheme_WithDate-  deriving (Eq, Show, Ord)--data LinkAction-  = LinkAction_ConnectZettel Connection-  | -- | Render a list (or should it be tree?) of links to queries zettels-    -- TODO: Should this automatically establish a connection in graph??-    LinkAction_QueryZettels Connection LinkTheme [Query]-  deriving (Eq, Show)--linkActionFromUri :: URI.URI -> Maybe LinkAction-linkActionFromUri uri =-  -- NOTE: We should probably drop the 'cf' variants in favour of specifying-  -- the connection type as a query param or something.-  case fmap URI.unRText (URI.uriScheme uri) of-    Just "z" ->-      Just $ LinkAction_ConnectZettel Folgezettel-    Just "zcf" ->-      Just $ LinkAction_ConnectZettel OrdinaryConnection-    Just "zquery" ->-      Just $ LinkAction_QueryZettels Folgezettel (fromMaybe LinkTheme_Default $ linkThemeFromUri uri) (queryFromUri uri)-    Just "zcfquery" ->-      Just $ LinkAction_QueryZettels OrdinaryConnection (fromMaybe LinkTheme_Default $ linkThemeFromUri uri) (queryFromUri uri)-    _ ->-      Nothing--queryFromUri :: URI.URI -> [Query]-queryFromUri uri =-  flip mapMaybe (URI.uriQuery uri) $ \case-    URI.QueryParam (URI.unRText -> key) (URI.unRText -> val) ->-      case key of-        "tag" -> Just $ ByTag val-        _ -> Nothing-    _ -> Nothing--linkThemeFromUri :: URI.URI -> Maybe LinkTheme-linkThemeFromUri uri =-  listToMaybe $ flip mapMaybe (URI.uriQuery uri) $ \case-    URI.QueryFlag _ -> Nothing-    URI.QueryParam (URI.unRText -> key) (URI.unRText -> val) ->-      case key of-        "linkTheme" ->-          case val of-            "default" -> Just LinkTheme_Default-            "simple" -> Just LinkTheme_Simple-            "withDate" -> Just LinkTheme_WithDate-            _ -> error $ "Unknown link theme: " <> val-        _ -> Nothing--data MarkdownLink-  = MarkdownLink-      { markdownLinkText :: Text,-        markdownLinkUri :: URI.URI-      }-  deriving (Eq, Ord)--linkActionConnections :: ZettelStore -> MarkdownLink -> [ZettelConnection]-linkActionConnections store MarkdownLink {..} =-  case linkActionFromUri markdownLinkUri of-    Just (LinkAction_ConnectZettel conn) ->-      let zid = parseZettelID markdownLinkText-       in [(conn, zid)]-    Just (LinkAction_QueryZettels conn _linkTheme q) ->-      (conn,) . matchID <$> runQuery store q-    Nothing ->-      []---- | 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 <> concat (fmap 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.OrderedList _ xs -> concat $ concat $ fmap (fmap relevantInlines) xs-      Ext.UnorderedList xs -> concat $ concat $ fmap (fmap relevantInlines) xs-      _ -> []
− src/Neuron/Zettelkasten/Link/View.hs 
@@ -1,66 +0,0 @@-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE QuasiQuotes #-}-{-# LANGUAGE Rank2Types #-}-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TupleSections #-}-{-# LANGUAGE TypeApplications #-}-{-# LANGUAGE ViewPatterns #-}-{-# LANGUAGE NoImplicitPrelude #-}---- | Special Zettel links in Markdown-module Neuron.Zettelkasten.Link.View where--import Lucid-import Neuron.Zettelkasten.ID-import Neuron.Zettelkasten.Link.Action-import Neuron.Zettelkasten.Query-import Neuron.Zettelkasten.Route (Route (..))-import Neuron.Zettelkasten.Store-import Neuron.Zettelkasten.Type-import Relude-import qualified Rib--linkActionRender :: Monad m => ZettelStore -> MarkdownLink -> LinkAction -> HtmlT m ()-linkActionRender store MarkdownLink {..} = \case-  LinkAction_ConnectZettel _conn -> do-    -- The inner link text is supposed to be the zettel ID-    let zid = parseZettelID markdownLinkText-    renderZettelLink LinkTheme_Default store zid-  LinkAction_QueryZettels _conn linkTheme q -> do-    toHtmlRaw @Text $ "<!--" <> show q <> "-->"-    let zettels = reverse $ sort $ matchID <$> runQuery store q-    ul_ $ do-      forM_ zettels $ \zid -> do-        li_ $ renderZettelLink linkTheme store zid--renderZettelLink :: forall m. Monad m => LinkTheme -> ZettelStore -> ZettelID -> HtmlT m ()-renderZettelLink ltheme store zid = do-  let Zettel {..} = lookupStore zid store-      zurl = Rib.routeUrlRel $ Route_Zettel zid-      renderDefault :: ToHtml a => a -> HtmlT m ()-      renderDefault linkInline = do-        span_ [class_ "zettel-link"] $ do-          span_ [class_ "zettel-link-idlink"] $ do-            a_ [href_ zurl] $ toHtml linkInline-          span_ [class_ "zettel-link-title"] $ do-            toHtml $ zettelTitle-  case ltheme of-    LinkTheme_Default -> do-      -- Special consistent styling for Zettel links-      -- Uses ZettelID as link text. Title is displayed aside.-      renderDefault zid-    LinkTheme_WithDate -> do-      renderDefault $ show @Text $ zettelIDDate zid-    LinkTheme_Simple -> do-      renderZettelLinkSimpleWith zurl (unZettelID zid) zettelTitle---- | Render a normal looking zettel link with a custom body.-renderZettelLinkSimpleWith :: forall m a. (Monad m, ToHtml a) => Text -> Text -> a -> HtmlT m ()-renderZettelLinkSimpleWith url title body =-  a_ [class_ "zettel-link item", href_ url, title_ title] $ do-    span_ [class_ "zettel-link-title"] $ do-      toHtml body
− src/Neuron/Zettelkasten/Markdown.hs 
@@ -1,28 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE NoImplicitPrelude #-}--module Neuron.Zettelkasten.Markdown-  ( neuronMMarkExts,-  )-where--import Neuron.Zettelkasten.Config (Config (..))-import Relude-import qualified Text.MMark as MMark-import qualified Text.MMark.Extension.Common as Ext--neuronMMarkExts :: Config -> [MMark.Extension]-neuronMMarkExts Config {..} =-  defaultExts-    <> bool [] [Ext.mathJax (Just '$')] mathJaxSupport--defaultExts :: [MMark.Extension]-defaultExts =-  [ Ext.fontAwesome,-    Ext.footnotes,-    Ext.kbd,-    Ext.linkTarget,-    Ext.punctuationPrettifier,-    Ext.skylighting-  ]
− src/Neuron/Zettelkasten/Meta.hs 
@@ -1,29 +0,0 @@-{-# LANGUAGE DeriveAnyClass #-}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE NoImplicitPrelude #-}--module Neuron.Zettelkasten.Meta-  ( Meta (..),-    getMeta,-  )-where--import Data.Aeson-import Relude-import Text.MMark (MMark, projectYaml)---- | YAML metadata in a zettel markdown file-data Meta-  = Meta-      { title :: Text,-        tags :: Maybe [Text]-      }-  deriving (Eq, Show, Generic, FromJSON)--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
− src/Neuron/Zettelkasten/Query.hs 
@@ -1,63 +0,0 @@-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE QuasiQuotes #-}-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TupleSections #-}-{-# LANGUAGE TypeApplications #-}-{-# LANGUAGE NoImplicitPrelude #-}---- | Queries to the Zettel store-module Neuron.Zettelkasten.Query where--import Data.Aeson-import qualified Data.Map.Strict as Map-import Neuron.Zettelkasten.ID-import qualified Neuron.Zettelkasten.Meta as Meta-import Neuron.Zettelkasten.Store-import Neuron.Zettelkasten.Type-import Relude---- TODO: Support querying connections, a la:---   LinksTo ZettelID---   LinksFrom ZettelID-data Query-  = ByTag Text-  deriving (Eq, Show)--data Match-  = Match-      { matchID :: ZettelID,-        matchTitle :: Text,-        matchTags :: [Text]-      }---- TODO: Use generic deriving use field label modifier.-instance ToJSON Match where-  toJSON Match {..} =-    object-      [ "id" .= toJSON matchID,-        "title" .= matchTitle,-        "tags" .= matchTags-      ]--matchQuery :: Match -> Query -> Bool-matchQuery Match {..} = \case-  ByTag tag -> tag `elem` matchTags--extractMatch :: Zettel -> Maybe Match-extractMatch Zettel {..} = do-  Meta.Meta {..} <- Meta.getMeta zettelContent-  pure-    Match-      { matchID = zettelID,-        matchTitle = zettelTitle,-        matchTags = fromMaybe [] tags-      }--runQuery :: ZettelStore -> [Query] -> [Match]-runQuery store queries =-  flip filter database $ \match -> and $ matchQuery match <$> queries-  where-    database = catMaybes $ extractMatch <$> Map.elems store
− src/Neuron/Zettelkasten/Route.hs 
@@ -1,88 +0,0 @@-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE QuasiQuotes #-}-{-# LANGUAGE Rank2Types #-}-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE ViewPatterns #-}-{-# LANGUAGE NoImplicitPrelude #-}---- | Zettel site's routes-module Neuron.Zettelkasten.Route where--import qualified Data.Text as T-import Neuron.Zettelkasten.Config-import Neuron.Zettelkasten.Graph-import Neuron.Zettelkasten.ID-import Neuron.Zettelkasten.Store-import Neuron.Zettelkasten.Type-import Path-import Relude-import Rib (IsRoute (..))-import Rib.Extra.OpenGraph-import qualified Rib.Parser.MMark as MMark-import qualified Text.URI as URI--data Route store graph a where-  Route_IndexRedirect :: Route ZettelStore ZettelGraph ()-  Route_ZIndex :: Route ZettelStore ZettelGraph ()-  Route_Zettel :: ZettelID -> Route ZettelStore ZettelGraph ()--instance IsRoute (Route store graph) where-  routeFile = \case-    Route_IndexRedirect ->-      pure [relfile|index.html|]-    Route_ZIndex ->-      pure [relfile|z-index.html|]-    Route_Zettel (unZettelID -> zid) ->-      parseRelFile $ toString zid <> ".html"---- | Return short name corresponding to the route-routeName :: Route store graph a -> Text-routeName = \case-  Route_IndexRedirect -> "Index"-  Route_ZIndex -> "Zettels"-  Route_Zettel zid -> unZettelID zid---- | Return full title for a route-routeTitle :: Config -> store -> Route store graph a -> Text-routeTitle Config {..} store =-  withSuffix siteTitle . routeTitle' store-  where-    withSuffix suffix x =-      if x == suffix-        then x-        else x <> " - " <> suffix---- | Return the title for a route-routeTitle' :: store -> Route store graph a -> Text-routeTitle' store = \case-  Route_IndexRedirect -> "Index"-  Route_ZIndex -> "Zettel Index"-  Route_Zettel (flip lookupStore store -> Zettel {..}) ->-    zettelTitle--routeOpenGraph :: Config -> store -> Route store graph a -> OpenGraph-routeOpenGraph Config {..} store r =-  OpenGraph-    { _openGraph_title = routeTitle' store r,-      _openGraph_siteName = siteTitle,-      _openGraph_description = case r of-        Route_IndexRedirect -> Nothing-        Route_ZIndex -> Just "Zettelkasten Index"-        Route_Zettel (flip lookupStore store -> Zettel {..}) ->-          T.take 300 <$> MMark.getFirstParagraphText zettelContent,-      _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 (flip lookupStore store -> Zettel {..}) -> do-          img <- MMark.getFirstImg zettelContent-          baseUrl <- URI.mkURI =<< siteBaseUrl-          URI.relativeTo img baseUrl-        _ -> Nothing,-      _openGraph_url = Nothing-    }
− src/Neuron/Zettelkasten/Store.hs 
@@ -1,40 +0,0 @@-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE QuasiQuotes #-}-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TupleSections #-}-{-# LANGUAGE TypeApplications #-}-{-# LANGUAGE NoImplicitPrelude #-}---- | Zettel store datastructure-module Neuron.Zettelkasten.Store where--import qualified Data.Map.Strict as Map-import Development.Shake (Action)-import Neuron.Zettelkasten.ID-import qualified Neuron.Zettelkasten.Meta as Meta-import Neuron.Zettelkasten.Type-import Path-import Relude-import qualified Rib.Parser.MMark as RibMMark--type ZettelStore = Map ZettelID Zettel---- | Load all zettel files-mkZettelStore :: [Path Rel File] -> Action ZettelStore-mkZettelStore files = do-  zettels <- forM files $ \file -> do-    -- Extensions are computed and applied during rendering, not here.-    let mmarkExts = []-    doc <- RibMMark.parseWith mmarkExts file-    let zid = mkZettelID file-        meta = Meta.getMeta doc-        title = maybe ("No title for " <> show file) Meta.title meta-        zettel = Zettel zid title doc-    pure zettel-  pure $ Map.fromList $ zettels <&> zettelID &&& id--lookupStore :: ZettelID -> ZettelStore -> Zettel-lookupStore zid = fromMaybe (error $ "No such zettel: " <> unZettelID zid) . Map.lookup zid
− src/Neuron/Zettelkasten/Type.hs 
@@ -1,31 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE NoImplicitPrelude #-}--module Neuron.Zettelkasten.Type where--import Neuron.Zettelkasten.ID-import qualified Neuron.Zettelkasten.Meta as Z-import Relude hiding (show)-import Text.MMark (MMark)-import Text.Show (Show (show))--data Zettel-  = Zettel-      { zettelID :: ZettelID,-        zettelTitle :: Text,-        zettelContent :: MMark-      }--instance Eq Zettel where-  (==) = (==) `on` zettelID--instance Ord Zettel where-  compare = compare `on` zettelID--instance Show Zettel where-  show Zettel {..} = "Zettel:" <> show zettelID--hasTag :: Text -> Zettel -> Bool-hasTag t =-  isJust . (find (== t) <=< Z.tags <=< Z.getMeta) . zettelContent
− src/Neuron/Zettelkasten/View.hs 
@@ -1,269 +0,0 @@-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE QuasiQuotes #-}-{-# LANGUAGE Rank2Types #-}-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TupleSections #-}-{-# LANGUAGE TypeApplications #-}-{-# LANGUAGE ViewPatterns #-}-{-# LANGUAGE NoImplicitPrelude #-}---- | HTML & CSS-module Neuron.Zettelkasten.View where--import Clay hiding (head, id, ms, reverse, s, type_)-import qualified Clay as C-import Data.Foldable (maximum)-import Data.Tree (Tree (..))-import Lucid-import Neuron.Version (neuronVersionFull)-import Neuron.Zettelkasten.Config-import Neuron.Zettelkasten.Graph-import Neuron.Zettelkasten.ID (ZettelID (..), zettelIDSourceFileName)-import Neuron.Zettelkasten.Link (linkActionExt)-import Neuron.Zettelkasten.Link.Action (LinkTheme (..))-import Neuron.Zettelkasten.Link.View (renderZettelLink)-import Neuron.Zettelkasten.Markdown (neuronMMarkExts)-import Neuron.Zettelkasten.Meta-import Neuron.Zettelkasten.Route-import Neuron.Zettelkasten.Store-import Neuron.Zettelkasten.Type-import Relude-import qualified Rib-import Rib.Extra.CSS (mozillaKbdStyle)-import qualified Rib.Parser.MMark as MMark-import Text.MMark (useExtensions)-import Text.Pandoc.Highlighting (styleToCss, tango)--renderRouteHead :: Monad m => Config -> Route store graph a -> store -> 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 val r-  link_ [rel_ "shortcut icon", href_ "https://raw.githubusercontent.com/srid/neuron/master/assets/logo.ico"]-  case r of-    Route_IndexRedirect ->-      mempty-    _ -> do-      toHtml $ routeOpenGraph config val r-      style_ [type_ "text/css"] $ styleToCss tango--renderRouteBody :: Monad m => Config -> Route store graph a -> (store, graph) -> HtmlT m ()-renderRouteBody config r val = do-  case r of-    Route_ZIndex ->-      renderIndex val-    Route_Zettel zid ->-      renderZettel config val zid-    Route_IndexRedirect ->-      meta_ [httpEquiv_ "Refresh", content_ $ "0; url=" <> Rib.routeUrlRel Route_ZIndex]--renderIndex :: Monad m => (ZettelStore, ZettelGraph) -> HtmlT m ()-renderIndex (store, graph) = do-  h1_ [class_ "header"] $ "Zettel Index"-  div_ [class_ "z-index"] $ do-    -- Cycle detection.-    case topSort graph of-      Left (toList -> cyc) -> div_ [class_ "ui orange segment"] $ do-        h2_ "Cycle detected"-        forM_ cyc $ \zid ->-          li_ $ renderZettelLink LinkTheme_Default store zid-      _ -> mempty-    let clusters = sortMothers $ zettelClusters 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 $ \zids ->-      div_ [class_ "ui piled segment"] $ do-        let forest = dfsForestFrom zids graph-        -- Forest of zettels, beginning with mother vertices.-        ul_ $ renderForest True Nothing LinkTheme_Default store graph forest-  where-    -- Sort clusters with newer mother zettels appearing first.-    sortMothers ms = reverse $ sortOn maximum $ fmap (reverse . sort . toList) ms-    countNounBe noun nounPlural = \case-      1 -> "is 1 " <> noun-      n -> "are " <> show n <> " " <> nounPlural--renderZettel :: forall m. Monad m => Config -> (ZettelStore, ZettelGraph) -> ZettelID -> HtmlT m ()-renderZettel config@Config {..} (store, graph) zid = do-  let Zettel {..} = lookupStore zid store-      zettelTags = getMeta zettelContent >>= tags-  div_ [class_ "zettel-view"] $ do-    div_ [class_ "ui raised segment"] $ do-      h1_ [class_ "header"] $ toHtml zettelTitle-      renderTags `mapM_` zettelTags-      let mmarkExts = neuronMMarkExts config-      MMark.render $ useExtensions (linkActionExt store : mmarkExts) zettelContent-    div_ [class_ "ui inverted teal top attached connections segment"] $ do-      div_ [class_ "ui two column grid"] $ do-        div_ [class_ "column"] $ do-          div_ [class_ "ui header"] "Connections"-          let forest = obviateRootUnlessForest zid $ dfsForestFrom [zid] graph-          ul_ $ renderForest True (Just 2) LinkTheme_Simple store graph forest-        div_ [class_ "column"] $ do-          div_ [class_ "ui header"] "Navigate up"-          let forestB = obviateRootUnlessForest zid $ dfsForestBackwards zid graph-          ul_ $ do-            renderForest True Nothing LinkTheme_Simple store graph forestB-    div_ [class_ "ui inverted black bottom attached footer segment"] $ do-      div_ [class_ "ui three column grid"] $ do-        div_ [class_ "center aligned column"] $ do-          a_ [href_ ".", title_ "/"] $ fa "fas fa-home"-        div_ [class_ "center aligned column"] $ do-          whenJust editUrl $ \urlPrefix ->-            a_ [href_ $ urlPrefix <> zettelIDSourceFileName zid, title_ "Edit this Zettel"] $ fa "fas fa-edit"-        div_ [class_ "center aligned column"] $ do-          a_ [href_ (Rib.routeUrlRel Route_ZIndex), title_ "All Zettels (z-index)"] $-            fa "fas fa-tree"-    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"-          " "-          code_ $ toHtml @Text neuronVersionFull--renderTags :: Monad m => [Text] -> HtmlT m ()-renderTags tags = do-  div_ [class_ "ui tiny labels"] $ do-    forM_ tags $ \tag -> do-      div_ [class_ "ui lightgrey label"] $ toHtml @Text tag-  div_ [class_ "ui divider"] $ mempty---- | Font awesome element-fa :: Monad m => Text -> HtmlT m ()-fa k = with i_ [class_ k] mempty--renderForest ::-  Monad m =>-  Bool ->-  Maybe Int ->-  LinkTheme ->-  ZettelStore ->-  ZettelGraph ->-  [Tree ZettelID] ->-  HtmlT m ()-renderForest isRoot maxLevel ltheme s g trees =-  case maxLevel of-    Just 0 -> mempty-    _ -> do-      forM_ (sortForest trees) $ \(Node zid subtrees) ->-        li_ $ do-          let zettelDiv =-                div_-                  [class_ $ bool "" "ui black label" $ ltheme == LinkTheme_Default]-          bool id zettelDiv isRoot $-            renderZettelLink ltheme s zid-          when (ltheme == LinkTheme_Default) $ do-            " "-            case backlinks zid g of-              conns@(_ : _ : _) ->-                -- Has two or more backlinks-                forM_ conns $ \zid2 -> do-                  let z2 = lookupStore zid2 s-                  i_ [class_ "fas fa-link", title_ $ unZettelID zid2 <> " " <> zettelTitle z2] mempty-              _ -> mempty-          when (length subtrees > 0) $ do-            ul_ $ renderForest False ((\n -> n - 1) <$> maxLevel) ltheme s g subtrees-  where-    -- Sort trees so that trees containing the most recent zettel (by ID) come first.-    sortForest = reverse . sortOn maximum--style :: Css-style = do-  let linkColor = C.mediumaquamarine-      linkTitleColor = C.auto-  "span.zettel-link span.zettel-link-idlink a" ? do-    C.fontFamily [] [C.monospace]-    C.fontWeight C.bold-    C.color linkColor-    C.textDecoration C.none-  "span.zettel-link span.zettel-link-idlink a:hover" ? do-    C.backgroundColor linkColor-    C.color C.white-  ".zettel-link .zettel-link-title" ? do-    C.paddingLeft $ em 0.3-    C.fontWeight C.bold-    C.color linkTitleColor-  "div.z-index" ? do-    C.ul ? do-      C.listStyleType C.square-      C.paddingLeft $ em 1.5-  "div.zettel-view" ? do-    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.color C.midnightblue-      C.fontWeight C.bold-      C.backgroundColor C.whitesmoke-    C.h2 ? do-      C.fontColor C.darkslategray-      C.fontWeight C.bold-      C.borderBottom C.solid (px 1) C.steelblue-      C.marginBottom $ em 0.5-    C.h3 ? do-      C.fontColor C.slategray-      C.fontWeight C.bold-      C.margin (px 0) (px 0) (em 0.4) (px 0)-    codeStyle-    blockquoteStyle-    kbd ? mozillaKbdStyle-  "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-  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-        maxWidth $ pct 80-        pre ? do-          backgroundColor "#f8f8f8"-    -- https://css-tricks.com/snippets/css/simple-and-nice-blockquote-styling/-    blockquoteStyle = do-      C.blockquote ? do-        -- TODO: quotes in clay?-        C.backgroundColor "#f9f9f9"-        C.borderLeft C.solid (px 10) "#ccc"-        sym2 C.margin (em 1.5) (px 10)-        sym2 C.padding (em 0.5) (px 10)-        C.p ? do-          C.display C.inline-      "blockquote:before" ? do-        C.color "#ccc"-        C.content C.openQuote-        C.fontSize $ em 4-        C.lineHeight $ em 0.1-        C.marginRight $ em 0.25-        C.verticalAlign $ em $ -0.4
+ src/app/Data/Structured/Breadcrumb.hs view
@@ -0,0 +1,97 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE NoImplicitPrelude #-}++-- | JSON for Google's structured data breadcrumbs+--+-- https://developers.google.com/search/docs/data-types/breadcrumb+module Data.Structured.Breadcrumb where++import Data.Aeson+import Data.Tree+import Lucid+import Relude+import Text.URI (URI)+import qualified Text.URI as URI++data Item = Item+  { name :: Text,+    url :: Maybe URI+  }+  deriving (Eq, Show, Generic)++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++instance ToJSON Breadcrumb where+  toJSON (Breadcrumb (toList -> crumbs)) =+    toJSON $+      object+        [ "@context" .= toJSON context,+          "@type" .= ("BreadcrumbList" :: Text),+          "itemListElement" .= toJSON (uncurry itemJson <$> zip [1 :: Int ..] crumbs)+        ]+    where+      context = "https://schema.org" :: Text+      itemJson pos Item {..} =+        object+          [ "@type" .= toJSON ("ListItem" :: Text),+            "position" .= toJSON pos,+            "name" .= toJSON name,+            "item" .= toJSON (fmap URI.render url)+          ]++fromForest :: Forest Item -> [Breadcrumb]+fromForest =+  fmap Breadcrumb . mapMaybe (nonEmpty . reverse) . concatMap (foldTree f)+  where+    f :: Item -> [[[Item]]] -> [[Item]]+    f parent = \case+      [] -> [[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
@@ -0,0 +1,72 @@+{-# LANGUAGE GADTs #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE NoImplicitPrelude #-}++module Main where++import Clay hiding (s, style, type_)+import qualified Clay as C+import Development.Shake+import Lucid+import Main.Utf8+import Neuron.CLI (run)+import Neuron.Config (Config)+import qualified Neuron.Config as Config+import Neuron.Web.Generate (generateSite)+import Neuron.Web.Route (Route (..))+import Neuron.Web.View (renderRouteBody, renderRouteHead, style)+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+  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
@@ -0,0 +1,68 @@+{-# LANGUAGE GADTs #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE NoImplicitPrelude #-}++module Neuron.CLI+  ( run,+  )+where++import qualified Data.Aeson.Text as Aeson+import Data.Some+import Data.Time+import Development.Shake (Action)+import Neuron.CLI.New (newZettelFile)+import Neuron.CLI.Rib+import Neuron.CLI.Search (interactiveSearch)+import qualified Neuron.Version as Version+import qualified Neuron.Zettelkasten.Graph as G+import qualified Neuron.Zettelkasten.Query as Q+import Options.Applicative+import Relude+import qualified Rib+import System.Directory+import System.FilePath+import System.Info (os)+import System.Posix.Process++run :: Action () -> IO ()+run act = do+  today <- utctDay <$> liftIO getCurrentTime+  defaultNotesDir <- (</> "zettelkasten") <$> getHomeDirectory+  let cliParser = commandParser defaultNotesDir today+  app <-+    execParser $+      info+        (versionOption <*> cliParser <**> helper)+        (fullDesc <> progDesc "Neuron, a Zettelkasten CLI <https://neuron.zettel.page/>")+  runWith act app+  where+    versionOption =+      infoOption+        (toString Version.neuronVersionFull)+        (long "version" <> help "Show version")++runWith :: Action () -> App -> IO ()+runWith act App {..} =+  case cmd of+    Rib ribCfg ->+      runRib act notesDir ribCfg+    New newCommand ->+      runRibOnceQuietly notesDir $ do+        newZettelFile newCommand+    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 ->+      runRibOnceQuietly notesDir $ do+        withSome someQ $ \q -> do+          result <- flip Q.runQuery q <$> G.loadZettels+          putLTextLn $ Aeson.encodeToLazyText $ Q.queryResultJson notesDir q result+    Search searchCmd ->+      interactiveSearch notesDir searchCmd
+ src/app/Neuron/CLI/New.hs view
@@ -0,0 +1,81 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE NoImplicitPrelude #-}++module Neuron.CLI.New+  ( newZettelFile,+  )+where++import qualified Data.Set as Set+import Data.Some+import Data.Text (strip)+import qualified Data.Text as T+import Development.Shake (Action)+import Neuron.CLI.Types+import qualified Neuron.Zettelkasten.Graph as G+import Neuron.Zettelkasten.ID (ZettelID, zettelIDSourceFileName)+import qualified Neuron.Zettelkasten.ID.Scheme as IDScheme+import Neuron.Zettelkasten.Zettel (zettelID)+import Options.Applicative+import Relude+import qualified Rib+import System.FilePath+import qualified System.Posix.Env as Env+import System.Posix.Process++-- | 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+  mzid <- withSome idScheme $ \scheme -> do+    val <- liftIO $ IDScheme.genVal scheme+    pure $ IDScheme.nextAvailableZettelID (Set.fromList $ fmap zettelID zettels) val scheme+  case mzid of+    Left e -> die $ show e+    Right zid -> do+      path <- zettelPath zid+      liftIO $ do+        fileAction :: FilePath -> IO () <-+          bool (pure showAction) mkEditActionFromEnv edit+        writeFileText path $+          T.intercalate+            "\n"+            [ "---",+              "title: " <> title,+              "date: " <> show day,+              "---",+              "",+              ""+            ]+        fileAction path+  where+    mkEditActionFromEnv :: IO (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+    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
+ src/app/Neuron/CLI/Rib.hs view
@@ -0,0 +1,60 @@+{-# LANGUAGE ApplicativeDo #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE NoImplicitPrelude #-}++module Neuron.CLI.Rib+  ( -- * CLI+    App (..),+    Command (..),+    NewCommand (..),+    SearchBy (..),+    SearchCommand (..),+    commandParser,+    runRib,+    runRibOnceQuietly,+  )+where++import Development.Shake (Action, Verbosity (Silent, Verbose))+import Neuron.CLI.Types+import Options.Applicative+import Relude+import qualified Rib.App+import qualified Rib.Cli+import System.Directory+import System.FilePath++runRib :: Action () -> FilePath -> RibConfig -> IO ()+runRib act notesDir ribCfg =+  Rib.App.runWith act =<< mkRibCliConfig notesDir ribCfg+  where+    mkRibCliConfig :: FilePath -> RibConfig -> IO Rib.Cli.CliConfig+    mkRibCliConfig inputDir cfg = do+      unlessM (doesDirectoryExist inputDir) $ do+        fail $ "Zettelkasten directory " <> inputDir <> " does not exist."+      let neuronDir = inputDir </> ".neuron"+          outputDir = fromMaybe (neuronDir </> "output") $ ribOutputDir cfg+          rebuildAll = False+          watch = ribWatch cfg+          serve = ribServe cfg+          verbosity = bool Verbose Silent $ ribQuiet cfg+          shakeDbDir = fromMaybe (neuronDir </> ".shake") $ ribShakeDbDir cfg+          watchIgnore = [".neuron", ".git"]+      pure Rib.Cli.CliConfig {..}++runRibOnceQuietly :: FilePath -> Action () -> IO ()+runRibOnceQuietly notesDir act =+  runRib act notesDir ribOneOffConfig+  where+    ribOneOffConfig :: RibConfig+    ribOneOffConfig =+      RibConfig+        { ribOutputDir = Nothing, -- Ignoring CLI's output dir. So don't use this within `neuron rib ...`.+          ribWatch = False,+          ribServe = Nothing,+          ribQuiet = True,+          -- Don't want to conflict with a long-running shake build action (eg: rib -wS)+          ribShakeDbDir = Just "/dev/null"+        }
+ src/app/Neuron/CLI/Search.hs view
@@ -0,0 +1,40 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE NoImplicitPrelude #-}++module Neuron.CLI.Search+  ( interactiveSearch,+  )+where++import Neuron.CLI.Rib+import Relude+import System.Posix.Process+import System.Which++neuronSearchScript :: FilePath+neuronSearchScript = $(staticWhich "neuron-search")++searchScriptArgs :: SearchCommand -> [String]+searchScriptArgs SearchCommand {..} =+  let searchByArgs =+        case searchBy of+          SearchByTitle -> ["title: ", "3"]+          SearchByContent -> ["", "2"]+      editArg =+        bool "echo" "$EDITOR" searchEdit+   in searchByArgs <> [editArg]++interactiveSearch :: FilePath -> SearchCommand -> IO ()+interactiveSearch notesDir searchCmd =+  execScript neuronSearchScript $ notesDir : searchScriptArgs searchCmd+  where+    execScript scriptPath args =+      -- We must use the low-level execvp (via the unix package's `executeFile`)+      -- here, such that the new process replaces the current one. fzf won't work+      -- otherwise.+      void $ executeFile scriptPath False args Nothing
+ src/app/Neuron/CLI/Types.hs view
@@ -0,0 +1,167 @@+{-# LANGUAGE ApplicativeDo #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE NoImplicitPrelude #-}++module Neuron.CLI.Types+  ( -- * CLI+    App (..),+    Command (..),+    NewCommand (..),+    SearchBy (..),+    SearchCommand (..),+    RibConfig (..),+    commandParser,+  )+where++import Data.Default (def)+import Data.Some+import Data.TagTree (mkTagPattern)+import qualified Data.Text as T+import Data.Time+import Neuron.Zettelkasten.ID (ZettelID, parseZettelID')+import Neuron.Zettelkasten.ID.Scheme (IDScheme (..))+import Neuron.Zettelkasten.Query as Q+import qualified Neuron.Zettelkasten.Query.Parser as Q+import Options.Applicative+import Relude+import qualified Rib.Cli+import qualified Text.URI as URI++data App = App+  { notesDir :: FilePath,+    cmd :: Command+  }++data NewCommand = NewCommand+  { title :: Text,+    day :: Day,+    idScheme :: Some IDScheme,+    edit :: Bool+  }+  deriving (Eq, Show)++data SearchCommand = SearchCommand+  { searchBy :: SearchBy,+    searchEdit :: Bool+  }+  deriving (Eq, Show)++data SearchBy+  = SearchByTitle+  | SearchByContent+  deriving (Eq, Show)++data Command+  = -- | Create a new zettel file+    New NewCommand+  | -- | Open the locally generated Zettelkasten+    Open+  | -- | Search a zettel by title+    Search SearchCommand+  | -- | Run a query against the Zettelkasten+    Query (Some Q.Query)+  | -- | Delegate to Rib's command parser+    Rib RibConfig++data RibConfig = RibConfig+  { ribOutputDir :: Maybe FilePath,+    ribWatch :: Bool,+    ribServe :: Maybe (Text, Int),+    ribQuiet :: Bool,+    ribShakeDbDir :: Maybe FilePath+  }+  deriving (Eq, Show)++-- | optparse-applicative parser for neuron CLI+commandParser :: FilePath -> Day -> Parser App+commandParser defaultNotesDir today = do+  notesDir <-+    option+      Rib.Cli.directoryReader+      ( long "zettelkasten-dir" <> short 'd' <> metavar "NOTESDIR" <> value defaultNotesDir <> showDefault+          <> help "Your zettelkasten directory containing the zettel files"+      )+  cmd <- cmdParser+  pure $ App {..}+  where+    cmdParser =+      hsubparser $+        mconcat+          [ command "new" $ info newCommand $ progDesc "Create a new zettel",+            command "open" $ info openCommand $ progDesc "Open the locally generated Zettelkasten website",+            command "search" $ info searchCommand $ progDesc "Search zettels and print the matching filepath",+            command "query" $ info queryCommand $ progDesc "Run a query against the zettelkasten",+            command "rib" $ info ribCommand $ progDesc "Generate static site via rib"+          ]+    newCommand = do+      title <- argument nonEmptyTextReader (metavar "TITLE" <> help "Title of the new Zettel")+      edit <- switch (long "edit" <> short 'e' <> help "Open the newly-created zettel in $EDITOR")+      day <-+        option dayReader $+          long "day"+            <> metavar "DAY"+            <> value today+            <> showDefault+            <> help "Zettel creation date in UTC"+      -- NOTE: optparse-applicative picks the first option as the default.+      idSchemeF <-+        fmap+          (const $ const $ Some IDSchemeHash)+          (switch (long "id-hash" <> help "Use random hash ID (default)"))+          <|> fmap+            (const $ Some . IDSchemeDate)+            (switch (long "id-date" <> help "Use date encoded ID"))+          <|> fmap+            (const . Some . IDSchemeCustom)+            (option str (long "id" <> help "Use a custom ID" <> metavar "IDNAME"))+      pure $ New $ NewCommand title 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')+    searchCommand = do+      searchBy <-+        bool SearchByTitle SearchByContent+          <$> switch (long "full-text" <> short 'a' <> help "Full-text search")+      edit <- switch (long "edit" <> short 'e' <> help "Open the matching zettel in $EDITOR")+      pure $ Search $ SearchCommand searchBy edit+    ribCommand = fmap Rib $ do+      let ribQuiet = False+          ribShakeDbDir = Nothing+      ribOutputDir <-+        optional $+          option+            Rib.Cli.directoryReader+            ( long "output-dir" <> short 'o' <> metavar "OUTPUTDIR" <> showDefault+                <> help "The directory where HTML will be generated"+            )+      ribWatch <- Rib.Cli.watchOption+      ribServe <- Rib.Cli.serveOption+      pure RibConfig {..}+    zettelIDReader :: ReadM ZettelID+    zettelIDReader =+      eitherReader $ first show . parseZettelID' . toText+    queryReader :: ReadM (Some Q.Query)+    queryReader =+      eitherReader $ \(toText -> s) -> case URI.mkURI s of+        Right uri ->+          either (Left . show) (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"
+ src/app/Neuron/Config.hs view
@@ -0,0 +1,94 @@+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE NoImplicitPrelude #-}++module Neuron.Config+  ( Config (..),+    configFile,+    getConfig,+    BaseUrlError (..),+    getMarkdownExtensions,+  )+where++import Control.Monad.Except+import Data.FileEmbed (embedFile)+import Development.Shake (Action, readFile')+import Dhall (FromDhall)+import qualified Dhall+import Dhall.TH+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+getConfig :: Action Config+getConfig = do+  inputDir <- Rib.ribInputDir+  let configPath = inputDir </> 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+    False ->+      pure $ decodeUtf8 @Text defaultConfig+  parseConfig configVal++parseConfig :: MonadIO m => Text -> m Config+parseConfig s =+  liftIO $ Dhall.input Dhall.auto s++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"+      ]
+ src/app/Neuron/Config/Alias.hs view
@@ -0,0 +1,51 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE NoImplicitPrelude #-}++module Neuron.Config.Alias where++import Control.Monad.Except+import Neuron.Config+import qualified Neuron.Zettelkasten.Graph as G+import Neuron.Zettelkasten.Graph.Type (ZettelGraph)+import Neuron.Zettelkasten.ID+import Relude+import qualified Text.Megaparsec.Char as M+import Text.Megaparsec.Simple++data Alias = Alias+  { aliasZettel :: ZettelID,+    targetZettel :: ZettelID+  }+  deriving (Eq, Show)++getAliases :: MonadFail m => Config -> ZettelGraph -> m [Alias]+getAliases Config {..} graph = do+  let aliasSpecs = case aliases of+        -- In the absence of an index zettel, create an an alias to the z-index+        [] -> bool ["index:z-index"] [] $ hasIndexZettel graph+        as -> as+  case mkAliases aliasSpecs graph of+    Left err ->+      fail $ "Bad aliases in config: " <> toString err+    Right v ->+      pure v+  where+    hasIndexZettel =+      isJust . G.getZettel (parseZettelID "index")++mkAliases :: [Text] -> ZettelGraph -> Either Text [Alias]+mkAliases aliasSpecs graph =+  sequence $ flip fmap aliasSpecs $ \aliasSpec -> runExcept $ do+    alias@Alias {..} <- liftEither $ parse aliasParser configFile aliasSpec+    when (isJust $ G.getZettel aliasZettel graph) $ do+      throwError $+        "Cannot create redirect from '" <> zettelIDText aliasZettel <> "', because a zettel with that ID already exists"+    when (zettelIDText targetZettel /= "z-index" && isNothing (G.getZettel targetZettel graph)) $ do+      throwError $+        "Target zettel '" <> zettelIDText targetZettel <> "' does not exist"+    pure alias++aliasParser :: Parser Alias+aliasParser =+  Alias <$> (idParser <* M.char ':') <*> idParser
+ src/app/Neuron/Version.hs view
@@ -0,0 +1,29 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE NoImplicitPrelude #-}++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)++-- | 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+olderThan s =+  case reverse (readP_to_S parseVersion (toString s)) of+    (v2, _) : _ -> version < v2+    x -> error $ "Version parse error: " <> show x
+ src/app/Neuron/Version/RepoVersion.hs view
@@ -0,0 +1,21 @@+{-# 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
@@ -0,0 +1,48 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE NoImplicitPrelude #-}++-- | Main module for using neuron as a library, instead of as a CLI tool.+module Neuron.Web.Generate+  ( generateSite,+  )+where++import Development.Shake (Action)+import Neuron.Config (Config (..))+import Neuron.Config.Alias (Alias (..), getAliases)+import Neuron.Version (neuronVersion, olderThan)+import qualified Neuron.Web.Route as Z+import qualified Neuron.Zettelkasten.Graph as G+import qualified Neuron.Zettelkasten.Zettel as Z+import Options.Applicative+import Relude++-- | Generate the Zettelkasten site+generateSite ::+  Config ->+  (forall a. Z.Route G.ZettelGraph a -> (G.ZettelGraph, a) -> Action ()) ->+  Action G.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)+  -- 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)+  -- Generate the z-index+  writeHtmlRoute () Z.Route_ZIndex+  -- Generate search page+  writeHtmlRoute () 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)+  pure zettelGraph
+ src/app/Neuron/Web/Route.hs view
@@ -0,0 +1,105 @@+{-# 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/Theme.hs view
@@ -0,0 +1,79 @@+{-# 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
@@ -0,0 +1,344 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE Rank2Types #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE NoImplicitPrelude #-}++-- | HTML & CSS+module Neuron.Web.View+  ( renderRouteHead,+    renderRouteBody,+    style,+  )+where++import Clay hiding (id, ms, object, reverse, s, style, type_)+import qualified Clay as C+import Data.Aeson ((.=), object)+import qualified Data.Aeson.Text as Aeson+import Data.Default (def)+import Data.FileEmbed (embedStringFile)+import Data.Foldable (maximum)+import qualified Data.Set as Set+import Data.Structured.Breadcrumb (Breadcrumb)+import qualified Data.Structured.Breadcrumb as Breadcrumb+import Data.TagTree (Tag (..))+import Data.Tree (Tree (..))+import Lucid+import Neuron.Config+import Neuron.Version (neuronVersionFull)+import Neuron.Web.Route+import qualified Neuron.Web.Theme as Theme+import Neuron.Zettelkasten.Connection+import qualified Neuron.Zettelkasten.Graph as G+import Neuron.Zettelkasten.Graph (ZettelGraph)+import Neuron.Zettelkasten.ID (ZettelID (..), zettelIDSourceFileName, zettelIDText)+import Neuron.Zettelkasten.Query.View (renderZettelLink)+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++searchScript :: Text+searchScript = $(embedStringFile "./src-js/search.js")++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+    Route_Redirect _ ->+      mempty+    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"]+    _ -> do+      toHtml $ routeOpenGraph config (snd val) r+      toHtml $ routeStructuredData config val r+      style_ [type_ "text/css"] $ styleToCss 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)]++renderIndex :: Monad m => Config -> ZettelGraph -> HtmlT m ()+renderIndex Config {..} graph = 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++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"]+    fa "search icon fas fa-search"+  div_ [class_ "ui hidden divider"] mempty+  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++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++-- | Font awesome element+fa :: Monad m => Text -> HtmlT m ()+fa k = with i_ [class_ k] mempty++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++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+  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)
+ src/app/Neuron/Zettelkasten/Connection.hs view
@@ -0,0 +1,23 @@+{-# 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 view
@@ -0,0 +1,40 @@+{-# 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 view
@@ -0,0 +1,131 @@+{-# 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 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/app/Neuron/Zettelkasten/ID/Scheme.hs view
@@ -0,0 +1,93 @@+{-# LANGUAGE GADTs #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE NoImplicitPrelude #-}++module Neuron.Zettelkasten.ID.Scheme where++import Control.Monad.Except+import Data.GADT.Compare.TH+import Data.GADT.Show.TH+import qualified Data.Set as Set+import qualified Data.Text as T+import Data.Time+import Data.UUID (UUID)+import qualified Data.UUID as UUID+import Data.UUID.V4 (nextRandom)+import Neuron.Zettelkasten.ID+import Relude+import Text.Megaparsec.Simple+import Text.Show++data IDScheme a where+  IDSchemeDate :: Day -> IDScheme ()+  IDSchemeHash :: IDScheme UUID+  IDSchemeCustom :: Text -> IDScheme ()++data IDConflict+  = IDConflict_AlreadyExists+  | IDConflict_DateIDExhausted+  | IDConflict_HashConflict Text+  | IDConflict_BadCustomID Text Text+  deriving (Eq)++instance Show IDConflict where+  show = \case+    IDConflict_AlreadyExists ->+      "A zettel with that ID already exists"+    IDConflict_DateIDExhausted ->+      "Ran out of date ID indices for this day"+    IDConflict_HashConflict s ->+      "Hash conflict on " <> toString s <> "; try again"+    IDConflict_BadCustomID s e ->+      "The custom ID " <> toString s <> " is malformed: " <> toString e++-- | Produce a value that is required to run an ID scheme.+genVal :: forall a. IDScheme a -> IO a+genVal = \case+  IDSchemeHash ->+    nextRandom+  IDSchemeDate _ ->+    pure ()+  IDSchemeCustom _ ->+    pure ()++-- | Create a new zettel ID based on the given scheme without conflicting with+-- the IDs of existing zettels.+nextAvailableZettelID ::+  forall a.+  -- Existing zettels+  Set ZettelID ->+  a ->+  IDScheme a ->+  Either IDConflict ZettelID+nextAvailableZettelID zs val = \case+  IDSchemeDate day -> do+    let dayIndices = nonEmpty $ sort $ flip mapMaybe (Set.toList zs) $ \case+          ZettelDateID d x+            | d == day -> Just x+          _ -> Nothing+    case last <$> dayIndices of+      Nothing -> pure $ ZettelDateID day 1+      Just 99 -> throwError IDConflict_DateIDExhausted+      Just idx -> pure $ ZettelDateID day (idx + 1)+  IDSchemeHash -> do+    let s = T.take 8 $ UUID.toText val+    if s `Set.member` (zettelIDText `Set.map` zs)+      then throwError $ IDConflict_HashConflict s+      else+        either (error . toText) (pure . ZettelCustomID) $+          parse customIDParser "<random-hash>" s+  IDSchemeCustom s -> runExcept $ do+    zid <-+      either (throwError . IDConflict_BadCustomID s) (pure . ZettelCustomID) $+        parse customIDParser "<next-id>" s+    if zid `Set.member` zs+      then throwError IDConflict_AlreadyExists+      else pure zid++deriveGEq ''IDScheme++deriveGShow ''IDScheme
+ src/app/Neuron/Zettelkasten/Query.hs view
@@ -0,0 +1,129 @@+{-# 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 view
@@ -0,0 +1,24 @@+{-# 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 view
@@ -0,0 +1,69 @@+{-# 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 view
@@ -0,0 +1,107 @@+{-# 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 view
@@ -0,0 +1,31 @@+{-# 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 view
@@ -0,0 +1,141 @@+{-# 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 view
@@ -0,0 +1,25 @@+{-# 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 view
@@ -0,0 +1,17 @@+{-# 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 view
@@ -0,0 +1,40 @@+{-# 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 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
+ src/lib/Data/Graph/Labelled.hs view
@@ -0,0 +1,28 @@+{-# LANGUAGE NoImplicitPrelude #-}++module Data.Graph.Labelled+  ( -- * Graph type+    LabelledGraph,+    Vertex (..),++    -- * Graph construction+    mkGraphFrom,++    -- * Querying+    findVertex,+    getVertices,++    -- * Algorithms+    preSet,+    topSort,+    clusters,+    dfsForestFrom,+    dfsForestBackwards,+    obviateRootUnlessForest,+    induceOnEdge,+  )+where++import Data.Graph.Labelled.Algorithm+import Data.Graph.Labelled.Build+import Data.Graph.Labelled.Type
+ src/lib/Data/Graph/Labelled/Algorithm.hs view
@@ -0,0 +1,108 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE NoImplicitPrelude #-}++module Data.Graph.Labelled.Algorithm where++import qualified Algebra.Graph.AdjacencyMap as AM+import qualified Algebra.Graph.AdjacencyMap.Algorithm as Algo+import qualified Algebra.Graph.Labelled.AdjacencyMap as LAM+import Data.Graph.Labelled.Type+import qualified Data.Map.Strict as Map+import qualified Data.Set as Set+import Data.Tree (Forest, Tree (..))+import Relude++findVertex :: Ord (VertexID v) => VertexID v -> LabelledGraph v e -> Maybe v+findVertex v lg@(LabelledGraph g _) = do+  guard $ LAM.hasVertex v g+  pure $ getVertex lg v++getVertex :: (HasCallStack, Ord (VertexID a)) => LabelledGraph a e -> VertexID a -> a+getVertex (LabelledGraph _ vm) x =+  fromMaybe (error "Vertex not in map") $ Map.lookup x vm++getVertices :: LabelledGraph v e -> [v]+getVertices (LabelledGraph _ lm) =+  Map.elems lm++-- | 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++topSort :: (Vertex v, Ord (VertexID v)) => LabelledGraph v e -> Either (NonEmpty v) [v]+topSort g =+  bimap (fmap (getVertex g)) (fmap (getVertex g))+    $ Algo.topSort+    $ LAM.skeleton+    $ graph g++clusters :: (Vertex v, Ord (VertexID v)) => LabelledGraph v e -> [NonEmpty v]+clusters g =+  fmap (fmap $ getVertex g) $ mothers $ LAM.skeleton $ graph g++-- | Compute the dfsForest from the given vertices.+dfsForestFrom :: (Vertex v, Ord (VertexID v)) => [v] -> LabelledGraph v e -> Forest v+dfsForestFrom (fmap vertexID -> vs) g =+  fmap (fmap $ getVertex g) $ Algo.dfsForestFrom vs $ LAM.skeleton $ graph g++-- | Compute the dfsForest ending in the given vertex.+--+-- Return the forest flipped, such that the given vertex is the root.+dfsForestBackwards :: (Monoid e, Vertex v, Ord (VertexID v)) => v -> LabelledGraph v e -> Forest v+dfsForestBackwards fromV (LabelledGraph g' v') =+  dfsForestFrom [fromV] $ LabelledGraph (LAM.transpose g') v'++--------------------------+--- More general utilities+--------------------------++-- | Like `induce` but operates on edges instead of vertices+induceOnEdge :: Ord (VertexID v) => (e -> Bool) -> LabelledGraph v e -> LabelledGraph v e+induceOnEdge f (LabelledGraph g v) =+  LabelledGraph g' v+  where+    g' =+      let es = mapMaybe (\(e, a, b) -> if f e then Nothing else Just (a, b)) $ LAM.edgeList g+       in foldl' (\h (a, b) -> LAM.removeEdge a b h) g es++-- | Get the clusters in a graph, as a list of the mother vertices in each+-- cluster.+mothers :: Ord a => AM.AdjacencyMap a -> [NonEmpty a]+mothers g =+  go [] $ motherVertices g+  where+    go acc = \case+      [] -> acc+      v : (Set.fromList -> vs) ->+        let reach = reachableUndirected v g+            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++motherVertices :: Ord a => AM.AdjacencyMap a -> [a]+motherVertices =+  mapMaybe (\(v, es) -> if null es then Just v else Nothing)+    . AM.adjacencyList+    . AM.transpose++-- | If the input is a tree with the given root node, return its children (as+-- forest). Otherwise return the input as is.+obviateRootUnlessForest :: (HasCallStack, Show a, Eq a) => a -> Forest a -> Forest a+obviateRootUnlessForest root = \case+  [Node v ts] ->+    if v == root+      then ts+      else error "Root mismatch"+  nodes ->+    nodes
+ src/lib/Data/Graph/Labelled/Build.hs view
@@ -0,0 +1,29 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE NoImplicitPrelude #-}++module Data.Graph.Labelled.Build where++import qualified Algebra.Graph.Labelled.AdjacencyMap as LAM+import Data.Graph.Labelled.Type (LabelledGraph (LabelledGraph), Vertex (..))+import qualified Data.Map.Strict as Map+import Relude++-- Build a graph from a list objects that contains information about the+-- corresponding vertex as well as the outgoing edges.+mkGraphFrom ::+  forall e v.+  (Eq e, Monoid e, Ord (VertexID v), Vertex v) =>+  -- | List of known vertices in the graph.+  [v] ->+  [(e, v, v)] ->+  LabelledGraph v e+mkGraphFrom xs es =+  let vertexList = vertexID <$> xs+      vertexMap = Map.fromList $ fmap (vertexID &&& id) xs+      edges = flip fmap es $ \(e, v1, v2) -> (e, vertexID v1, vertexID v2)+      graph =+        LAM.overlay+          (LAM.vertices vertexList)+          (LAM.edges edges)+   in LabelledGraph graph vertexMap
+ src/lib/Data/Graph/Labelled/Type.hs view
@@ -0,0 +1,31 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE NoImplicitPrelude #-}++module Data.Graph.Labelled.Type where++import qualified Algebra.Graph.Labelled.AdjacencyMap as LAM+import Relude++-- | Instances of this class can be used as a vertex in a graph.+class Vertex v where+  type VertexID v :: Type++  -- | Get the vertex ID associated with this vertex.+  --+  -- This relation is expected to be bijective.+  vertexID :: v -> VertexID v++-- | An edge and vertex labelled graph+--+-- The `v` must be an instance of `Vertex`; as such `v` is considered the vertex+-- label, with the actual vertex (bijectively) derived from it.+data LabelledGraph v e = LabelledGraph+  { graph :: LAM.AdjacencyMap e (VertexID v),+    vertices :: Map (VertexID v) v+  }++deriving instance (Ord e, Show e, Show v, Ord (VertexID v), Show (VertexID v)) => Show (LabelledGraph v e)
+ src/lib/Data/PathTree.hs view
@@ -0,0 +1,41 @@+{-# LANGUAGE NoImplicitPrelude #-}++module Data.PathTree+  ( mkTreeFromPaths,+    annotatePathsWith,+    foldSingleParentsWith,+  )+where++import qualified Data.List.NonEmpty as NE+import qualified Data.Map as Map+import Data.Tree+import Relude+import Relude.Extra.Group++mkTreeFromPaths :: Ord a => [[a]] -> Forest a+mkTreeFromPaths paths = uncurry mkNode <$> Map.assocs groups+  where+    groups = fmap tail <$> groupBy head (mapMaybe nonEmpty paths)+    mkNode label children =+      Node label $ mkTreeFromPaths $ toList children++annotatePathsWith :: (NonEmpty a -> ann) -> Tree a -> Tree (a, ann)+annotatePathsWith f = go []+  where+    go ancestors (Node rel children) =+      let path = rel :| ancestors+       in Node (rel, f $ NE.reverse path) $ fmap (go $ toList path) children++-- | Fold nodes with one child using the given function+--+-- The function is called with the parent and the only child. If a Just value is+-- returned, folding happens with that value, otherwise there is no effect.+foldSingleParentsWith :: (a -> a -> Maybe a) -> Tree a -> Tree a+foldSingleParentsWith f = go+  where+    go (Node parent children) =+      case fmap go children of+        [Node child grandChildren]+          | Just new <- f parent child -> Node new grandChildren+        xs -> Node parent xs
+ src/lib/Data/TagTree.hs view
@@ -0,0 +1,99 @@+{-# LANGUAGE GADTs #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE NoImplicitPrelude #-}++module Data.TagTree+  ( Tag (..),+    TagPattern (unTagPattern),+    TagNode (..),+    mkTagPattern,+    tagMatch,+    tagMatchAny,+    tagTree,+    foldTagTree,+    constructTag,+  )+where++import Control.Monad.Combinators.NonEmpty (sepBy1)+import Data.Aeson+import qualified Data.Map.Strict as Map+import Data.PathTree (annotatePathsWith, foldSingleParentsWith, mkTreeFromPaths)+import qualified Data.Text as T+import Data.Tree (Forest)+import Relude+import System.FilePattern+import qualified Text.Megaparsec as M+import qualified Text.Megaparsec.Char as M+import Text.Megaparsec.Simple++-- | Tag metadata field in Zettel notes+newtype Tag = Tag {unTag :: Text}+  deriving (Eq, Ord, Show, ToJSON, FromJSON)++--------------+-- Tag Pattern+---------------++-- | Glob-based pattern matching of tags+--+-- Eg.: "foo/**" matches both "foo/bar/baz" and "foo/baz"+newtype TagPattern = TagPattern {unTagPattern :: FilePattern}+  deriving (Eq, Show, ToJSON)++mkTagPattern :: Text -> TagPattern+mkTagPattern =+  TagPattern . toString++tagMatch :: TagPattern -> Tag -> Bool+tagMatch (TagPattern pat) (Tag tag) =+  pat ?== toString tag++tagMatchAny :: [TagPattern] -> Tag -> Bool+tagMatchAny pats tag =+  -- TODO: Use step from https://hackage.haskell.org/package/filepattern-0.1.2/docs/System-FilePattern.html#v:step+  -- for efficient matching.+  any (`tagMatch` tag) pats++-----------+-- Tag Tree+-----------++-- | A tag like "foo/bar/baz" is split into three nodes "foo", "bar" and "baz."+newtype TagNode = TagNode {unTagNode :: Text}+  deriving (Eq, Show, Ord, ToJSON)++deconstructTag :: HasCallStack => Tag -> NonEmpty TagNode+deconstructTag (Tag s) =+  either error id $ parse tagParser (toString s) s+  where+    tagParser :: Parser (NonEmpty TagNode)+    tagParser =+      nodeParser `sepBy1` M.char '/'+    nodeParser :: Parser TagNode+    nodeParser =+      TagNode . toText <$> M.some (M.anySingleBut '/')++constructTag :: NonEmpty TagNode -> Tag+constructTag (fmap unTagNode . toList -> nodes) =+  Tag $ T.intercalate "/" nodes++-- | Construct a tree from a list of tags+tagTree :: ann ~ Natural => Map Tag ann -> Forest (TagNode, ann)+tagTree tags =+  fmap (annotatePathsWith $ countFor tags)+    $ mkTreeFromPaths+    $ fmap (toList . deconstructTag)+    $ Map.keys tags+  where+    countFor tags' path =+      fromMaybe 0 $ Map.lookup (constructTag path) tags'++foldTagTree :: ann ~ Natural => Forest (TagNode, ann) -> Forest (NonEmpty TagNode, ann)+foldTagTree tree =+  foldSingleParentsWith foldNodes <$> fmap (fmap (first (:| []))) tree+  where+    foldNodes (parent, 0) (child, count) = Just (parent <> child, count)+    foldNodes _ _ = Nothing
+ src/lib/Neuron/Zettelkasten/ID.hs view
@@ -0,0 +1,114 @@+{-# LANGUAGE GADTs #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE NoImplicitPrelude #-}++module Neuron.Zettelkasten.ID+  ( ZettelID (..),+    InvalidID (..),+    zettelIDText,+    parseZettelID,+    parseZettelID',+    idParser,+    mkZettelID,+    zettelIDSourceFileName,+    customIDParser,+  )+where++import Data.Aeson (ToJSON (toJSON))+import qualified Data.Text as T+import Data.Time+import Relude+import System.FilePath+import qualified Text.Megaparsec as M+import qualified Text.Megaparsec.Char as M+import Text.Megaparsec.Simple+import Text.Printf+import qualified Text.Show++data ZettelID+  = -- | Short Zettel ID encoding `Day` and a numeric index (on that day).+    ZettelDateID Day Int+  | -- | Arbitrary alphanumeric ID.+    ZettelCustomID Text+  deriving (Eq, Show, Ord)++instance Show InvalidID where+  show (InvalidIDParseError s) =+    "Invalid Zettel ID: " <> toString s++instance ToJSON ZettelID where+  toJSON = toJSON . zettelIDText++zettelIDText :: ZettelID -> Text+zettelIDText = \case+  ZettelDateID day idx ->+    formatDay day <> toText @String (printf "%02d" idx)+  ZettelCustomID s -> s++formatDay :: Day -> Text+formatDay day =+  subDay $ toText $ formatTime defaultTimeLocale "%y%W%a" day+  where+    subDay =+      T.replace "Mon" "1"+        . T.replace "Tue" "2"+        . T.replace "Wed" "3"+        . T.replace "Thu" "4"+        . T.replace "Fri" "5"+        . T.replace "Sat" "6"+        . T.replace "Sun" "7"++zettelIDSourceFileName :: ZettelID -> FilePath+zettelIDSourceFileName zid = toString $ zettelIDText zid <> ".md"++---------+-- Parser+---------++data InvalidID = InvalidIDParseError Text+  deriving (Eq)++parseZettelID :: HasCallStack => Text -> ZettelID+parseZettelID =+  either (error . show) id . parseZettelID'++parseZettelID' :: Text -> Either InvalidID ZettelID+parseZettelID' =+  first InvalidIDParseError . parse idParser "parseZettelID"++idParser :: Parser ZettelID+idParser =+  M.try (fmap (uncurry ZettelDateID) $ dayParser <* M.eof)+    <|> fmap ZettelCustomID customIDParser++dayParser :: Parser (Day, Int)+dayParser = do+  year <- parseNum 2+  week <- parseNum 2+  dayName <- dayFromIdx =<< parseNum 1+  idx <- parseNum 2+  day <-+    parseTimeM False defaultTimeLocale "%y%W%a" $+      printf "%02d" year <> printf "%02d" week <> dayName+  pure (day, idx)+  where+    parseNum n = readNum =<< M.count n M.digitChar+    readNum = maybe (fail "Not a number") pure . readMaybe+    dayFromIdx :: MonadFail m => Int -> m String+    dayFromIdx idx =+      maybe (fail "Day should be a value from 1 to 7") pure $+        ["Mon", "Tue", "Wed", "Thu", "Fri", "Sat", "Sun"] !!? (idx - 1)++customIDParser :: Parser Text+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 =+  let (name, _) = splitExtension $ takeFileName fp+   in parseZettelID $ toText name
+ src/lib/Neuron/Zettelkasten/Zettel.hs view
@@ -0,0 +1,77 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE NoImplicitPrelude #-}++module Neuron.Zettelkasten.Zettel where++import Data.Aeson+import Data.Graph.Labelled (Vertex (..))+import Data.TagTree (Tag)+import Data.Time.Calendar+import Neuron.Zettelkasten.ID+import qualified Neuron.Zettelkasten.Zettel.Meta as Meta+import Relude hiding (show)+import Text.MMark (MMark)+import qualified Text.MMark as MMark+import qualified Text.Megaparsec as M+import Text.Show (Show (show))++data ZettelT content = Zettel+  { zettelID :: ZettelID,+    zettelTitle :: Text,+    zettelTags :: [Tag],+    zettelDay :: Maybe Day,+    zettelContent :: content+  }++type Zettel = ZettelT MMark++instance Eq (ZettelT c) where+  (==) = (==) `on` zettelID++instance Ord (ZettelT c) where+  compare = compare `on` zettelID++instance Show (ZettelT c) where+  show Zettel {..} = "Zettel:" <> show zettelID++instance Vertex (ZettelT c) where+  type VertexID (ZettelT c) = ZettelID+  vertexID = zettelID++sortZettelsReverseChronological :: [Zettel] -> [Zettel]+sortZettelsReverseChronological =+  sortOn (Down . zettelDay)++zettelJson :: forall a c. KeyValue a => ZettelT c -> [a]+zettelJson Zettel {..} =+  [ "id" .= toJSON zettelID,+    "title" .= zettelTitle,+    "tags" .= zettelTags,+    "day" .= zettelDay+  ]++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
+ src/lib/Neuron/Zettelkasten/Zettel/Meta.hs view
@@ -0,0 +1,32 @@+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE NoImplicitPrelude #-}++module Neuron.Zettelkasten.Zettel.Meta+  ( Meta (..),+    getMeta,+  )+where++import Data.Aeson+import Data.TagTree (Tag)+import Data.Time.Calendar+import Relude+import Text.MMark (MMark, projectYaml)++-- | YAML metadata in a zettel markdown file+data Meta = Meta+  { title :: Text,+    tags :: Maybe [Tag],+    -- | Creation day+    date :: Maybe Day+  }+  deriving (Eq, Show, Generic, FromJSON)++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
+ src/lib/Text/Megaparsec/Simple.hs view
@@ -0,0 +1,19 @@+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE NoImplicitPrelude #-}++-- | A simple API for megaparsec+module Text.Megaparsec.Simple+  ( Parser,+    parse,+  )+where++import Relude+import qualified Text.Megaparsec as M++type Parser a = M.Parsec Void Text a++parse :: Parser a -> String -> Text -> Either Text a+parse p fn s =+  first (toText . M.errorBundlePretty) $+    M.parse (p <* M.eof) fn s
+ test/Data/PathTreeSpec.hs view
@@ -0,0 +1,58 @@+{-# LANGUAGE NoImplicitPrelude #-}++module Data.PathTreeSpec+  ( spec,+  )+where++import Data.Tree (Forest, Tree (..))+import Data.PathTree+import Relude+import System.FilePath ((</>))+import Test.Hspec++spec :: Spec+spec = do+  describe "Path tree" $ do+    context "Tree building" $ do+      forM_ treeCases $ \(name, paths, tree) -> do+        it name $ do+          mkTreeFromPaths paths `shouldBe` tree+    context "Tree folding" $ do+      forM_ foldingCases $ \(name, tree, folded) -> do+        it name $ do+          let mergePaths (p, n) (p', b') = bool Nothing (Just (p </> p', b')) n+              res = fst <$> foldSingleParentsWith mergePaths tree+          res `shouldBe` folded++treeCases :: [(String, [[String]], Forest String)]+treeCases =+  [ ( "works on one level",+      [["journal"], ["science"]],+      [Node "journal" [], Node "science" []]+    ),+    ( "groups paths with common prefix",+      [["math", "algebra"], ["math", "calculus"]],+      [Node "math" [Node "algebra" [], Node "calculus" []]]+    ),+    ( "ignores tag when there is also tag/subtag",+      [["math"], ["math", "algebra"]],+      [Node "math" [Node "algebra" []]]+    )+  ]++foldingCases :: [(String, Tree (String, Bool), Tree String)]+foldingCases =+  [ ( "folds tree on one level",+      Node ("math", True) [Node ("note", False) []],+      Node "math/note" []+    ),+    ( "folds across multiple levels",+      Node ("math", True) [Node ("algebra", True) [Node ("note", False) []]],+      Node "math/algebra/note" []+    ),+    ( "does not fold tree when the predicate is false",+      Node ("math", False) [Node ("note", False) []],+      Node "math" [Node "note" []]+    )+  ]
+ test/Data/TagTreeSpec.hs view
@@ -0,0 +1,70 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE NoImplicitPrelude #-}++module Data.TagTreeSpec+  ( spec,+  )+where++import Data.TagTree+import Relude+import Test.Hspec++spec :: Spec+spec = do+  describe "Tag matching" $ do+    forM_ tagMatchCases $ \(name, mkTagPattern -> pat, fmap Tag -> matching, fmap Tag -> failing) -> do+      it name $ do+        forM_ matching $ \tag -> do+          pat `shouldMatch` tag+        forM_ failing $ \tag -> do+          pat `shouldNotMatch` tag++tagMatchCases :: [(String, Text, [Text], [Text])]+tagMatchCases =+  [ ( "simple tag",+      "journal",+      ["journal"],+      ["science", "journal/work"]+    ),+    ( "simple tag with slash",+      "journal/note",+      ["journal/note"],+      ["science/physics", "journal", "journal/note/foo"]+    ),+    ( "tag pattern with **",+      "journal/**",+      ["journal", "journal/work", "journal/work/clientA"],+      ["math", "science/physics", "jour"]+    ),+    ( "tag pattern with */**",+      "journal/*/**",+      ["journal/foo", "journal/foo/bar"],+      ["science", "journal"]+    ),+    ( "tag pattern with ** in the middle",+      "math/**/note",+      ["math/note", "math/algebra/note", "math/algebra/linear/note"],+      ["math/algebra", "journal/note"]+    ),+    ( "tag pattern with * in the middle",+      "project/*/task",+      ["project/foo/task", "project/bar-baz/task"],+      ["project", "project/foo", "project/task", "project/foo/bar/task"]+    )+  ]++shouldMatch :: TagPattern -> Tag -> Expectation+shouldMatch pat tag+  | tagMatch pat tag = pure ()+  | otherwise =+    expectationFailure $+      unTagPattern pat <> " was expected to match " <> toString (unTag tag) <> " but didn't"++shouldNotMatch :: TagPattern -> Tag -> Expectation+shouldNotMatch pat tag+  | tagMatch pat tag =+    expectationFailure $+      unTagPattern pat <> " wasn't expected to match tag " <> toString (unTag tag) <> " but it did"+  | otherwise = pure ()
+ test/Neuron/Config/AliasSpec.hs view
@@ -0,0 +1,29 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE NoImplicitPrelude #-}++module Neuron.Config.AliasSpec+  ( spec,+  )+where++import Neuron.Config.Alias+import Neuron.Zettelkasten.ID+import Relude+import Test.Hspec+import Text.Megaparsec.Simple++spec :: Spec+spec = do+  describe "Alias parsing" $ do+    itParsesAlias "with z-index" "index:z-index"+    itParsesAlias "with normal id" "foo:2011501"+    itParsesAlias "longish alias" "tis-a-furphy:2011501"++itParsesAlias :: String -> Text -> SpecWith ()+itParsesAlias name s =+  it name $ do+    fmap renderAlias (parse aliasParser "<hspec>" s) `shouldBe` Right s+  where+    renderAlias Alias {..} =+      zettelIDText aliasZettel <> ":" <> zettelIDText targetZettel
+ test/Neuron/VersionSpec.hs view
@@ -0,0 +1,37 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE NoImplicitPrelude #-}++module Neuron.VersionSpec+  ( spec,+  )+where++import qualified Data.Text as T+import Neuron.Version+import Relude+import Test.Hspec++spec :: Spec+spec = do+  describe "Application version" $ do+    it "should have dots" $ do+      neuronVersion `shouldSatisfy` T.isInfixOf "."+  -- TODO: Check minVersion in Default.dhall is same as the one in Paths_neuron+  describe "must compare" $ do+    let isGreater = shouldSatisfy+        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+    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.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
+ test/Neuron/Zettelkasten/ID/SchemeSpec.hs view
@@ -0,0 +1,48 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE NoImplicitPrelude #-}++module Neuron.Zettelkasten.ID.SchemeSpec+  ( spec,+  )+where++import qualified Data.Set as Set+import Data.Time+import Neuron.Zettelkasten.ID+import Neuron.Zettelkasten.ID.Scheme+import Relude+import Test.Hspec++spec :: Spec+spec = do+  describe "nextAvailableZettelID" $ do+    let zettels =+          Set.fromList $+            fmap+              parseZettelID+              [ "ribeye-steak",+                "2015403"+              ]+        day = fromGregorian 2020 4 16+        nextAvail scheme = do+          v <- genVal scheme+          pure $ nextAvailableZettelID zettels v scheme+    context "custom ID" $ do+      it "checks if already exists" $ do+        nextAvail (IDSchemeCustom "ribeye-steak")+          `shouldReturn` Left IDConflict_AlreadyExists+      it "succeeds" $ do+        nextAvail (IDSchemeCustom "sunny-side-eggs")+          `shouldReturn` Right (ZettelCustomID "sunny-side-eggs")+    context "date ID" $ do+      it "should return index 0" $ do+        let otherDay = fromGregorian 2020 5 16+        nextAvail (IDSchemeDate otherDay)+          `shouldReturn` Right (ZettelDateID otherDay 1)+      it "should return correct index" $+        nextAvail (IDSchemeDate day)+          `shouldReturn` Right (ZettelDateID day 4)+    context "hash ID" $ do+      it "should succeed" $+        nextAvail IDSchemeHash+          >>= (`shouldNotSatisfy` isLeft)
+ test/Neuron/Zettelkasten/IDSpec.hs view
@@ -0,0 +1,45 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE NoImplicitPrelude #-}++module Neuron.Zettelkasten.IDSpec+  ( spec,+  )+where++import qualified Data.Aeson as Aeson+import Data.Time.Calendar+import qualified Neuron.Zettelkasten.ID as Z+import Relude+import Test.Hspec++spec :: Spec+spec = do+  describe "ID parsing" $ do+    let day = fromGregorian 2020 3 19+    context "date id parsing" $ do+      let zid = Z.ZettelDateID day 1+      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"+    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"+      let deceptiveZid = Z.ZettelCustomID "2136537e"+      it "parses a custom zettel ID that looks like date ID" $ do+        Z.parseZettelID' "2136537e" `shouldBe` Right deceptiveZid+  describe "ID converstion" $ do+    context "JSON encoding" $ do+      let day = fromGregorian 2020 3 19+          zid = Z.ZettelDateID day 1+      it "Converts ID to text when encoding to JSON" $ do+        Aeson.toJSON (Z.ZettelCustomID "20abcde") `shouldBe` Aeson.String "20abcde"+        Aeson.toJSON zid `shouldBe` Aeson.String "2011401"+    it "Date ID to Text" $ do+      let day = fromGregorian 2020 4 21+      Z.zettelIDText (Z.ZettelDateID day 1) `shouldBe` "2016201"
+ test/Neuron/Zettelkasten/Query/ParserSpec.hs view
@@ -0,0 +1,105 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE NoImplicitPrelude #-}++module Neuron.Zettelkasten.Query.ParserSpec+  ( spec,+  )+where++import Data.Default (def)+import Data.Some+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 Relude+import Test.Hspec+import Text.MMark.MarkdownLink+import Text.URI++spec :: Spec+spec = do+  legacyLinks+  shortLinks++legacyLinks :: Spec+legacyLinks = do+  describe "Parse zettels by tag URIs" $ do+    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+            withScheme s = toText scheme <> s+            legacyLink l = mkMarkdownLink "." l+        it "Parse all zettels URI" $ do+          queryFromMarkdownLink (legacyLink $ withScheme "://search")+            `shouldBe` zettelsByTag [] def+        it "Parse single tag" $+          queryFromMarkdownLink (legacyLink $ withScheme "://search?tag=foo")+            `shouldBe` zettelsByTag ["foo"] def+        it "Parse hierarchical tag" $ do+          queryFromMarkdownLink (legacyLink $ withScheme "://search?tag=foo/bar")+            `shouldBe` zettelsByTag ["foo/bar"] def+        it "Parse tag pattern" $ do+          queryFromMarkdownLink (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")+            `shouldBe` zettelsByTag ["foo", "bar"] def+        it "Handles ?grouped" $ do+          queryFromMarkdownLink (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)+  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)+    it "parses z:/ ignoring annotation" $+      queryFromMarkdownLink (mkMarkdownLink "1234567" "z://foo-bar")+        `shouldBe` Right (Just $ Some $ Query_ZettelByID zid Nothing)+    it "parses zcf:/" $+      queryFromMarkdownLink (mkMarkdownLink "1234567" "zcf:/")+        `shouldBe` Right (Just $ Some $ Query_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/**"])++shortLinks :: Spec+shortLinks = do+  describe "short links" $ do+    let shortLink s = mkMarkdownLink s s+    it "parses date ID" $ do+      queryFromMarkdownLink (shortLink "1234567")+        `shouldBe` Right (Just $ Some $ Query_ZettelByID (parseZettelID "1234567") Nothing)+    it "parses custom/hash ID" $ do+      queryFromMarkdownLink (shortLink "foo-bar")+        `shouldBe` Right (Just $ Some $ Query_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))+    it "z:zettels" $ do+      queryFromMarkdownLink (shortLink "z:zettels")+        `shouldBe` Right (Just $ Some $ Query_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)+    it "z:zettels?cf" $ do+      queryFromMarkdownLink (shortLink "z:zettels?cf")+        `shouldBe` Right (Just $ Some $ Query_ZettelsByTag [] (Just OrdinaryConnection) def)+    it "z:tags" $ do+      queryFromMarkdownLink (shortLink "z:tags")+        `shouldBe` Right (Just $ Some $ Query_Tags [])+    it "z:tags?filter=foo" $ do+      queryFromMarkdownLink (shortLink "z:tags?filter=foo")+        `shouldBe` Right (Just $ Some $ Query_Tags [mkTagPattern "foo"])++mkMarkdownLink :: Text -> Text -> MarkdownLink+mkMarkdownLink s l =+  MarkdownLink s $ either (error . toText . displayException) id $ mkURI l
+ test/Neuron/Zettelkasten/ZettelSpec.hs view
@@ -0,0 +1,43 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE NoImplicitPrelude #-}++module Neuron.Zettelkasten.ZettelSpec+  ( spec,+  )+where++import Data.Aeson+import Data.TagTree+import Data.Time.Calendar+import Neuron.Zettelkasten.ID+import Neuron.Zettelkasten.Zettel+import Relude+import Rib.Parser.MMark (parsePure)+import Test.Hspec++spec :: Spec+spec = do+  describe "sortZettelsReverseChronological" $ do+    let mkDay = fromGregorian 2020 3+        dummyContent = either error id $ parsePure "<spec>" "Dummy"+        mkZettel day idx =+          Zettel (ZettelDateID (mkDay day) idx) "Some title" [Tag "science", Tag "journal/class"] (Just $ mkDay day) dummyContent+    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+          ]