neuron (empty) → 0.2.0.0

raw patch · 19 files changed

+1532/−0 lines, 19 filesdep +QuickCheckdep +aesondep +algebraic-graphs

Dependencies added: QuickCheck, aeson, algebraic-graphs, base, clay, containers, dhall, directory, exceptions, file-embed, filepath, filepattern, foldl, gitrev, hspec, lucid, mmark, mmark-ext, modern-uri, optparse-applicative, pandoc, path, path-io, relude, rib, shake, text, time, unix, which, with-utf8

Files

• CHANGELOG.md +5/−0
• README.md +44/−0
• neuron.cabal +109/−0
• src-bin/Main.hs +82/−0
• src/Neuron/Zettelkasten.hs +203/−0
• src/Neuron/Zettelkasten/Config.hs +58/−0
• src/Neuron/Zettelkasten/Graph.hs +159/−0
• src/Neuron/Zettelkasten/ID.hs +108/−0
• src/Neuron/Zettelkasten/Link.hs +36/−0
• src/Neuron/Zettelkasten/Link/Action.hs +113/−0
• src/Neuron/Zettelkasten/Link/View.hs +66/−0
• src/Neuron/Zettelkasten/Markdown.hs +28/−0
• src/Neuron/Zettelkasten/Meta.hs +29/−0
• src/Neuron/Zettelkasten/Query.hs +63/−0
• src/Neuron/Zettelkasten/Route.hs +88/−0
• src/Neuron/Zettelkasten/Store.hs +40/−0
• src/Neuron/Zettelkasten/Type.hs +31/−0
• src/Neuron/Zettelkasten/View.hs +269/−0
• test/Spec.hs +1/−0

@@ -0,0 +1,5 @@+# Change Log for neuron++## 0.2.0.0++- Initial public release

@@ -0,0 +1,44 @@+<img width="10%" src="./assets/logo.svg">++# 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)+[![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. ++**Features**++- Extended Markdown for easy linking between zettels+- Web interface (auto generated static site)+- Graph view of zettels (organic category tree)+- CLI for creating new zettels with automatic ID++## Getting started++See [neuron.srid.ca](https://neuron.srid.ca/) for the full guide to installing and using neuron.++## Developing++When modifying `src/Neuron`, use ghcid as instructed as follows to monitor compile errors:++```bash+nix-shell --run ghcid+```++You can test your changes by running it on the `./guide` (or any) zettelkasten as follows:++```bash+bin/run ./guide rib serve+```++This command will also automatically recompile and restart when you change any of the Haskell source files.++### Running tests++Unit tests can be run via ghcid as follows:++```+bin/test+```

@@ -0,0 +1,109 @@+cabal-version: 2.4+name: neuron+-- This version must be in sync with what's in Default.dhall+version: 0.2.0.0+license: BSD-3-Clause+copyright: 2020 Sridhar Ratnakumar+maintainer: srid@srid.ca+author: Sridhar Ratnakumar+category: Web+homepage: https://neuron.srid.ca+bug-reports: https://github.com/srid/neuron/issues+synopsis:+  Haskell meets Zettelkasten, for your plain-text delight.+description:+  neuron is a system for managing your plain-text Zettelkasten notes.+extra-source-files:+  README.md+  CHANGELOG.md++source-repository head+    type: git+    location: https://github.com/srid/neuron++common ghc-common+  ghc-options:+    -Wall+    -Wincomplete-record-updates+    -Wincomplete-uni-patterns++common library-common+  import: ghc-common+  hs-source-dirs: src +  default-language: Haskell2010+  build-depends:+    base >=4.7 && <5,+    aeson,+    clay -any,+    containers,+    directory,+    exceptions,+    file-embed,+    gitrev,+    lucid -any,+    optparse-applicative,+    pandoc,+    path,+    path-io,+    relude,+    rib ^>=0.8,+    shake -any,+    time,+    text,+    mmark,+    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,+    shake,+    clay,+    lucid,+    with-utf8++test-suite neuron-test+  import: library-common +  type: exitcode-stdio-1.0+  hs-source-dirs: test+  main-is: Spec.hs+  build-depends:+    base,+    relude,+    hspec,+    QuickCheck,+    time+  default-language:    Haskell2010

@@ -0,0 +1,82 @@+{-# 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

@@ -0,0 +1,203 @@+{-# 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

@@ -0,0 +1,58 @@+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE NoImplicitPrelude #-}++module Neuron.Zettelkasten.Config+  ( Config (..),+    getConfig,+  )+where++import Data.FileEmbed (embedFile)+import Development.Shake (Action, readFile')+import Dhall (FromDhall)+import qualified Dhall+import Dhall.TH+import Path+import Path.IO (doesFileExist)+import Relude+import qualified Rib++-- | Config type for @neuron.dhall@+--+-- See <https://neuron.srid.ca/2011701.html guide> for description of the fields.+makeHaskellTypes+  [ SingleConstructor "Config" "Config" "./src-dhall/Config/Type.dhall"+  ]++deriving instance Generic Config++deriving instance FromDhall Config++defaultConfig :: ByteString+defaultConfig = $(embedFile "./src-dhall/Config/Default.dhall")++-- | Read the optional @neuron.dhall@ config file from the zettelksaten+getConfig :: Action Config+getConfig = do+  inputDir <- Rib.ribInputDir+  let configPath = inputDir </> configFile+  configVal :: Text <- doesFileExist configPath >>= \case+    True -> do+      userConfig <- fmap toText $ readFile' $ toFilePath configPath+      -- Dhall's combine operator (`//`) allows us to merge two records,+      -- effectively merging the record with defaults with the user record.+      pure $ decodeUtf8 defaultConfig <> " // " <> userConfig+    False ->+      pure $ decodeUtf8 @Text defaultConfig+  liftIO $ Dhall.detailed $ Dhall.input Dhall.auto configVal+  where+    configFile = [relfile|neuron.dhall|]

@@ -0,0 +1,159 @@+{-# 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)

@@ -0,0 +1,108 @@+{-# 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)

@@ -0,0 +1,36 @@+{-# 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

@@ -0,0 +1,113 @@+{-# 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+      _ -> []

@@ -0,0 +1,66 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE Rank2Types #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE NoImplicitPrelude #-}++-- | Special Zettel links in Markdown+module Neuron.Zettelkasten.Link.View where++import Lucid+import Neuron.Zettelkasten.ID+import Neuron.Zettelkasten.Link.Action+import Neuron.Zettelkasten.Query+import Neuron.Zettelkasten.Route (Route (..))+import Neuron.Zettelkasten.Store+import Neuron.Zettelkasten.Type+import Relude+import qualified Rib++linkActionRender :: Monad m => ZettelStore -> MarkdownLink -> LinkAction -> HtmlT m ()+linkActionRender store MarkdownLink {..} = \case+  LinkAction_ConnectZettel _conn -> do+    -- The inner link text is supposed to be the zettel ID+    let zid = parseZettelID markdownLinkText+    renderZettelLink LinkTheme_Default store zid+  LinkAction_QueryZettels _conn linkTheme q -> do+    toHtmlRaw @Text $ "<!--" <> show q <> "-->"+    let zettels = reverse $ sort $ matchID <$> runQuery store q+    ul_ $ do+      forM_ zettels $ \zid -> do+        li_ $ renderZettelLink linkTheme store zid++renderZettelLink :: forall m. Monad m => LinkTheme -> ZettelStore -> ZettelID -> HtmlT m ()+renderZettelLink ltheme store zid = do+  let Zettel {..} = lookupStore zid store+      zurl = Rib.routeUrlRel $ Route_Zettel zid+      renderDefault :: ToHtml a => a -> HtmlT m ()+      renderDefault linkInline = do+        span_ [class_ "zettel-link"] $ do+          span_ [class_ "zettel-link-idlink"] $ do+            a_ [href_ zurl] $ toHtml linkInline+          span_ [class_ "zettel-link-title"] $ do+            toHtml $ zettelTitle+  case ltheme of+    LinkTheme_Default -> do+      -- Special consistent styling for Zettel links+      -- Uses ZettelID as link text. Title is displayed aside.+      renderDefault zid+    LinkTheme_WithDate -> do+      renderDefault $ show @Text $ zettelIDDate zid+    LinkTheme_Simple -> do+      renderZettelLinkSimpleWith zurl (unZettelID zid) zettelTitle++-- | Render a normal looking zettel link with a custom body.+renderZettelLinkSimpleWith :: forall m a. (Monad m, ToHtml a) => Text -> Text -> a -> HtmlT m ()+renderZettelLinkSimpleWith url title body =+  a_ [class_ "zettel-link item", href_ url, title_ title] $ do+    span_ [class_ "zettel-link-title"] $ do+      toHtml body

@@ -0,0 +1,28 @@+{-# 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+  ]

@@ -0,0 +1,29 @@+{-# 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

@@ -0,0 +1,63 @@+{-# 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

@@ -0,0 +1,88 @@+{-# 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+    }

@@ -0,0 +1,40 @@+{-# 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

@@ -0,0 +1,31 @@+{-# 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

@@ -0,0 +1,269 @@+{-# 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

@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}