diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,41 @@ # Change Log for neuron +## 0.4.0.0 + +- Notable changes + - More convenient links; `` 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 diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -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. diff --git a/neuron.cabal b/neuron.cabal --- a/neuron.cabal +++ b/neuron.cabal @@ -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 diff --git a/src-bash/neuron-search b/src-bash/neuron-search new file mode 100644 --- /dev/null +++ b/src-bash/neuron-search @@ -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} diff --git a/src-bin/Main.hs b/src-bin/Main.hs deleted file mode 100644 --- a/src-bin/Main.hs +++ /dev/null @@ -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 diff --git a/src-dhall/Config/Default.dhall b/src-dhall/Config/Default.dhall new file mode 100644 --- /dev/null +++ b/src-dhall/Config/Default.dhall @@ -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" +} diff --git a/src-dhall/Config/Type.dhall b/src-dhall/Config/Type.dhall new file mode 100644 --- /dev/null +++ b/src-dhall/Config/Type.dhall @@ -0,0 +1,17 @@ +{ siteTitle : + Text +, author : + Optional Text +, siteBaseUrl : + Optional Text +, editUrl : + Optional Text +, theme : + Text +, aliases : + List Text +, mathJaxSupport : + Bool +, minVersion : + Text +} diff --git a/src-js/search.js b/src-js/search.js new file mode 100644 --- /dev/null +++ b/src-js/search.js @@ -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(); + } +}); diff --git a/src/Neuron/Zettelkasten.hs b/src/Neuron/Zettelkasten.hs deleted file mode 100644 --- a/src/Neuron/Zettelkasten.hs +++ /dev/null @@ -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 diff --git a/src/Neuron/Zettelkasten/Config.hs b/src/Neuron/Zettelkasten/Config.hs deleted file mode 100644 --- a/src/Neuron/Zettelkasten/Config.hs +++ /dev/null @@ -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 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|] diff --git a/src/Neuron/Zettelkasten/Graph.hs b/src/Neuron/Zettelkasten/Graph.hs deleted file mode 100644 --- a/src/Neuron/Zettelkasten/Graph.hs +++ /dev/null @@ -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) diff --git a/src/Neuron/Zettelkasten/ID.hs b/src/Neuron/Zettelkasten/ID.hs deleted file mode 100644 --- a/src/Neuron/Zettelkasten/ID.hs +++ /dev/null @@ -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) diff --git a/src/Neuron/Zettelkasten/Link.hs b/src/Neuron/Zettelkasten/Link.hs deleted file mode 100644 --- a/src/Neuron/Zettelkasten/Link.hs +++ /dev/null @@ -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 diff --git a/src/Neuron/Zettelkasten/Link/Action.hs b/src/Neuron/Zettelkasten/Link/Action.hs deleted file mode 100644 --- a/src/Neuron/Zettelkasten/Link/Action.hs +++ /dev/null @@ -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 - _ -> [] diff --git a/src/Neuron/Zettelkasten/Link/View.hs b/src/Neuron/Zettelkasten/Link/View.hs deleted file mode 100644 --- a/src/Neuron/Zettelkasten/Link/View.hs +++ /dev/null @@ -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 $ "" - 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 diff --git a/src/Neuron/Zettelkasten/Markdown.hs b/src/Neuron/Zettelkasten/Markdown.hs deleted file mode 100644 --- a/src/Neuron/Zettelkasten/Markdown.hs +++ /dev/null @@ -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 - ] diff --git a/src/Neuron/Zettelkasten/Meta.hs b/src/Neuron/Zettelkasten/Meta.hs deleted file mode 100644 --- a/src/Neuron/Zettelkasten/Meta.hs +++ /dev/null @@ -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 diff --git a/src/Neuron/Zettelkasten/Query.hs b/src/Neuron/Zettelkasten/Query.hs deleted file mode 100644 --- a/src/Neuron/Zettelkasten/Query.hs +++ /dev/null @@ -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 diff --git a/src/Neuron/Zettelkasten/Route.hs b/src/Neuron/Zettelkasten/Route.hs deleted file mode 100644 --- a/src/Neuron/Zettelkasten/Route.hs +++ /dev/null @@ -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 - } diff --git a/src/Neuron/Zettelkasten/Store.hs b/src/Neuron/Zettelkasten/Store.hs deleted file mode 100644 --- a/src/Neuron/Zettelkasten/Store.hs +++ /dev/null @@ -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 diff --git a/src/Neuron/Zettelkasten/Type.hs b/src/Neuron/Zettelkasten/Type.hs deleted file mode 100644 --- a/src/Neuron/Zettelkasten/Type.hs +++ /dev/null @@ -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 diff --git a/src/Neuron/Zettelkasten/View.hs b/src/Neuron/Zettelkasten/View.hs deleted file mode 100644 --- a/src/Neuron/Zettelkasten/View.hs +++ /dev/null @@ -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 diff --git a/src/app/Data/Structured/Breadcrumb.hs b/src/app/Data/Structured/Breadcrumb.hs new file mode 100644 --- /dev/null +++ b/src/app/Data/Structured/Breadcrumb.hs @@ -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" + }] + }] +-} diff --git a/src/app/Main.hs b/src/app/Main.hs new file mode 100644 --- /dev/null +++ b/src/app/Main.hs @@ -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 diff --git a/src/app/Neuron/CLI.hs b/src/app/Neuron/CLI.hs new file mode 100644 --- /dev/null +++ b/src/app/Neuron/CLI.hs @@ -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 ") + 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 diff --git a/src/app/Neuron/CLI/New.hs b/src/app/Neuron/CLI/New.hs new file mode 100644 --- /dev/null +++ b/src/app/Neuron/CLI/New.hs @@ -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 diff --git a/src/app/Neuron/CLI/Rib.hs b/src/app/Neuron/CLI/Rib.hs new file mode 100644 --- /dev/null +++ b/src/app/Neuron/CLI/Rib.hs @@ -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" + } diff --git a/src/app/Neuron/CLI/Search.hs b/src/app/Neuron/CLI/Search.hs new file mode 100644 --- /dev/null +++ b/src/app/Neuron/CLI/Search.hs @@ -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 diff --git a/src/app/Neuron/CLI/Types.hs b/src/app/Neuron/CLI/Types.hs new file mode 100644 --- /dev/null +++ b/src/app/Neuron/CLI/Types.hs @@ -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" diff --git a/src/app/Neuron/Config.hs b/src/app/Neuron/Config.hs new file mode 100644 --- /dev/null +++ b/src/app/Neuron/Config.hs @@ -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 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" + ] diff --git a/src/app/Neuron/Config/Alias.hs b/src/app/Neuron/Config/Alias.hs new file mode 100644 --- /dev/null +++ b/src/app/Neuron/Config/Alias.hs @@ -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 diff --git a/src/app/Neuron/Version.hs b/src/app/Neuron/Version.hs new file mode 100644 --- /dev/null +++ b/src/app/Neuron/Version.hs @@ -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 diff --git a/src/app/Neuron/Version/RepoVersion.hs b/src/app/Neuron/Version/RepoVersion.hs new file mode 100644 --- /dev/null +++ b/src/app/Neuron/Version/RepoVersion.hs @@ -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) diff --git a/src/app/Neuron/Web/Generate.hs b/src/app/Neuron/Web/Generate.hs new file mode 100644 --- /dev/null +++ b/src/app/Neuron/Web/Generate.hs @@ -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 diff --git a/src/app/Neuron/Web/Route.hs b/src/app/Neuron/Web/Route.hs new file mode 100644 --- /dev/null +++ b/src/app/Neuron/Web/Route.hs @@ -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 + } diff --git a/src/app/Neuron/Web/Theme.hs b/src/app/Neuron/Web/Theme.hs new file mode 100644 --- /dev/null +++ b/src/app/Neuron/Web/Theme.hs @@ -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 diff --git a/src/app/Neuron/Web/View.hs b/src/app/Neuron/Web/View.hs new file mode 100644 --- /dev/null +++ b/src/app/Neuron/Web/View.hs @@ -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) diff --git a/src/app/Neuron/Zettelkasten/Connection.hs b/src/app/Neuron/Zettelkasten/Connection.hs new file mode 100644 --- /dev/null +++ b/src/app/Neuron/Zettelkasten/Connection.hs @@ -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 diff --git a/src/app/Neuron/Zettelkasten/Error.hs b/src/app/Neuron/Zettelkasten/Error.hs new file mode 100644 --- /dev/null +++ b/src/app/Neuron/Zettelkasten/Error.hs @@ -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 + ] diff --git a/src/app/Neuron/Zettelkasten/Graph.hs b/src/app/Neuron/Zettelkasten/Graph.hs new file mode 100644 --- /dev/null +++ b/src/app/Neuron/Zettelkasten/Graph.hs @@ -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 diff --git a/src/app/Neuron/Zettelkasten/Graph/Type.hs b/src/app/Neuron/Zettelkasten/Graph/Type.hs new file mode 100644 --- /dev/null +++ b/src/app/Neuron/Zettelkasten/Graph/Type.hs @@ -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) diff --git a/src/app/Neuron/Zettelkasten/ID/Scheme.hs b/src/app/Neuron/Zettelkasten/ID/Scheme.hs new file mode 100644 --- /dev/null +++ b/src/app/Neuron/Zettelkasten/ID/Scheme.hs @@ -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 "" s + IDSchemeCustom s -> runExcept $ do + zid <- + either (throwError . IDConflict_BadCustomID s) (pure . ZettelCustomID) $ + parse customIDParser "" s + if zid `Set.member` zs + then throwError IDConflict_AlreadyExists + else pure zid + +deriveGEq ''IDScheme + +deriveGShow ''IDScheme diff --git a/src/app/Neuron/Zettelkasten/Query.hs b/src/app/Neuron/Zettelkasten/Query.hs new file mode 100644 --- /dev/null +++ b/src/app/Neuron/Zettelkasten/Query.hs @@ -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)) diff --git a/src/app/Neuron/Zettelkasten/Query/Error.hs b/src/app/Neuron/Zettelkasten/Query/Error.hs new file mode 100644 --- /dev/null +++ b/src/app/Neuron/Zettelkasten/Query/Error.hs @@ -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 diff --git a/src/app/Neuron/Zettelkasten/Query/Eval.hs b/src/app/Neuron/Zettelkasten/Query/Eval.hs new file mode 100644 --- /dev/null +++ b/src/app/Neuron/Zettelkasten/Query/Eval.hs @@ -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 + _ -> + [] diff --git a/src/app/Neuron/Zettelkasten/Query/Parser.hs b/src/app/Neuron/Zettelkasten/Query/Parser.hs new file mode 100644 --- /dev/null +++ b/src/app/Neuron/Zettelkasten/Query/Parser.hs @@ -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) diff --git a/src/app/Neuron/Zettelkasten/Query/Theme.hs b/src/app/Neuron/Zettelkasten/Query/Theme.hs new file mode 100644 --- /dev/null +++ b/src/app/Neuron/Zettelkasten/Query/Theme.hs @@ -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 diff --git a/src/app/Neuron/Zettelkasten/Query/View.hs b/src/app/Neuron/Zettelkasten/Query/View.hs new file mode 100644 --- /dev/null +++ b/src/app/Neuron/Zettelkasten/Query/View.hs @@ -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 diff --git a/src/app/Text/MMark/Extension/ReplaceLink.hs b/src/app/Text/MMark/Extension/ReplaceLink.hs new file mode 100644 --- /dev/null +++ b/src/app/Text/MMark/Extension/ReplaceLink.hs @@ -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 diff --git a/src/app/Text/MMark/Extension/SetTableClass.hs b/src/app/Text/MMark/Extension/SetTableClass.hs new file mode 100644 --- /dev/null +++ b/src/app/Text/MMark/Extension/SetTableClass.hs @@ -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 diff --git a/src/app/Text/MMark/MarkdownLink.hs b/src/app/Text/MMark/MarkdownLink.hs new file mode 100644 --- /dev/null +++ b/src/app/Text/MMark/MarkdownLink.hs @@ -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 + _ -> [] diff --git a/src/app/Text/URI/Util.hs b/src/app/Text/URI/Util.hs new file mode 100644 --- /dev/null +++ b/src/app/Text/URI/Util.hs @@ -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 diff --git a/src/lib/Data/Graph/Labelled.hs b/src/lib/Data/Graph/Labelled.hs new file mode 100644 --- /dev/null +++ b/src/lib/Data/Graph/Labelled.hs @@ -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 diff --git a/src/lib/Data/Graph/Labelled/Algorithm.hs b/src/lib/Data/Graph/Labelled/Algorithm.hs new file mode 100644 --- /dev/null +++ b/src/lib/Data/Graph/Labelled/Algorithm.hs @@ -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 diff --git a/src/lib/Data/Graph/Labelled/Build.hs b/src/lib/Data/Graph/Labelled/Build.hs new file mode 100644 --- /dev/null +++ b/src/lib/Data/Graph/Labelled/Build.hs @@ -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 diff --git a/src/lib/Data/Graph/Labelled/Type.hs b/src/lib/Data/Graph/Labelled/Type.hs new file mode 100644 --- /dev/null +++ b/src/lib/Data/Graph/Labelled/Type.hs @@ -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) diff --git a/src/lib/Data/PathTree.hs b/src/lib/Data/PathTree.hs new file mode 100644 --- /dev/null +++ b/src/lib/Data/PathTree.hs @@ -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 diff --git a/src/lib/Data/TagTree.hs b/src/lib/Data/TagTree.hs new file mode 100644 --- /dev/null +++ b/src/lib/Data/TagTree.hs @@ -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 diff --git a/src/lib/Neuron/Zettelkasten/ID.hs b/src/lib/Neuron/Zettelkasten/ID.hs new file mode 100644 --- /dev/null +++ b/src/lib/Neuron/Zettelkasten/ID.hs @@ -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 diff --git a/src/lib/Neuron/Zettelkasten/Zettel.hs b/src/lib/Neuron/Zettelkasten/Zettel.hs new file mode 100644 --- /dev/null +++ b/src/lib/Neuron/Zettelkasten/Zettel.hs @@ -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 diff --git a/src/lib/Neuron/Zettelkasten/Zettel/Meta.hs b/src/lib/Neuron/Zettelkasten/Zettel/Meta.hs new file mode 100644 --- /dev/null +++ b/src/lib/Neuron/Zettelkasten/Zettel/Meta.hs @@ -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 diff --git a/src/lib/Text/Megaparsec/Simple.hs b/src/lib/Text/Megaparsec/Simple.hs new file mode 100644 --- /dev/null +++ b/src/lib/Text/Megaparsec/Simple.hs @@ -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 diff --git a/test/Data/PathTreeSpec.hs b/test/Data/PathTreeSpec.hs new file mode 100644 --- /dev/null +++ b/test/Data/PathTreeSpec.hs @@ -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" []] + ) + ] diff --git a/test/Data/TagTreeSpec.hs b/test/Data/TagTreeSpec.hs new file mode 100644 --- /dev/null +++ b/test/Data/TagTreeSpec.hs @@ -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 () diff --git a/test/Neuron/Config/AliasSpec.hs b/test/Neuron/Config/AliasSpec.hs new file mode 100644 --- /dev/null +++ b/test/Neuron/Config/AliasSpec.hs @@ -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 "" s) `shouldBe` Right s + where + renderAlias Alias {..} = + zettelIDText aliasZettel <> ":" <> zettelIDText targetZettel diff --git a/test/Neuron/VersionSpec.hs b/test/Neuron/VersionSpec.hs new file mode 100644 --- /dev/null +++ b/test/Neuron/VersionSpec.hs @@ -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 diff --git a/test/Neuron/Zettelkasten/ID/SchemeSpec.hs b/test/Neuron/Zettelkasten/ID/SchemeSpec.hs new file mode 100644 --- /dev/null +++ b/test/Neuron/Zettelkasten/ID/SchemeSpec.hs @@ -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) diff --git a/test/Neuron/Zettelkasten/IDSpec.hs b/test/Neuron/Zettelkasten/IDSpec.hs new file mode 100644 --- /dev/null +++ b/test/Neuron/Zettelkasten/IDSpec.hs @@ -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" diff --git a/test/Neuron/Zettelkasten/Query/ParserSpec.hs b/test/Neuron/Zettelkasten/Query/ParserSpec.hs new file mode 100644 --- /dev/null +++ b/test/Neuron/Zettelkasten/Query/ParserSpec.hs @@ -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 diff --git a/test/Neuron/Zettelkasten/ZettelSpec.hs b/test/Neuron/Zettelkasten/ZettelSpec.hs new file mode 100644 --- /dev/null +++ b/test/Neuron/Zettelkasten/ZettelSpec.hs @@ -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 "" "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 "" "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 + ]