diff --git a/CHANGELOG.md b/CHANGELOG.md
new file mode 100644
--- /dev/null
+++ b/CHANGELOG.md
@@ -0,0 +1,5 @@
+# Change Log for neuron
+
+## 0.2.0.0
+
+- Initial public release
diff --git a/README.md b/README.md
new file mode 100644
--- /dev/null
+++ b/README.md
@@ -0,0 +1,44 @@
+
+
+# neuron
+
+[](https://en.wikipedia.org/wiki/BSD_License)
+[](https://builtwithnix.org)
+[](https://funprog.zulipchat.com/#narrow/stream/231929-Neuron)
+
+neuron is a system for managing your plain-text [Zettelkasten](https://neuron.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
+```
diff --git a/neuron.cabal b/neuron.cabal
new file mode 100644
--- /dev/null
+++ b/neuron.cabal
@@ -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
diff --git a/src-bin/Main.hs b/src-bin/Main.hs
new file mode 100644
--- /dev/null
+++ b/src-bin/Main.hs
@@ -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
diff --git a/src/Neuron/Zettelkasten.hs b/src/Neuron/Zettelkasten.hs
new file mode 100644
--- /dev/null
+++ b/src/Neuron/Zettelkasten.hs
@@ -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
diff --git a/src/Neuron/Zettelkasten/Config.hs b/src/Neuron/Zettelkasten/Config.hs
new file mode 100644
--- /dev/null
+++ b/src/Neuron/Zettelkasten/Config.hs
@@ -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 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
new file mode 100644
--- /dev/null
+++ b/src/Neuron/Zettelkasten/Graph.hs
@@ -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)
diff --git a/src/Neuron/Zettelkasten/ID.hs b/src/Neuron/Zettelkasten/ID.hs
new file mode 100644
--- /dev/null
+++ b/src/Neuron/Zettelkasten/ID.hs
@@ -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)
diff --git a/src/Neuron/Zettelkasten/Link.hs b/src/Neuron/Zettelkasten/Link.hs
new file mode 100644
--- /dev/null
+++ b/src/Neuron/Zettelkasten/Link.hs
@@ -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
diff --git a/src/Neuron/Zettelkasten/Link/Action.hs b/src/Neuron/Zettelkasten/Link/Action.hs
new file mode 100644
--- /dev/null
+++ b/src/Neuron/Zettelkasten/Link/Action.hs
@@ -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
+ _ -> []
diff --git a/src/Neuron/Zettelkasten/Link/View.hs b/src/Neuron/Zettelkasten/Link/View.hs
new file mode 100644
--- /dev/null
+++ b/src/Neuron/Zettelkasten/Link/View.hs
@@ -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 $ ""
+ 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
new file mode 100644
--- /dev/null
+++ b/src/Neuron/Zettelkasten/Markdown.hs
@@ -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
+ ]
diff --git a/src/Neuron/Zettelkasten/Meta.hs b/src/Neuron/Zettelkasten/Meta.hs
new file mode 100644
--- /dev/null
+++ b/src/Neuron/Zettelkasten/Meta.hs
@@ -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
diff --git a/src/Neuron/Zettelkasten/Query.hs b/src/Neuron/Zettelkasten/Query.hs
new file mode 100644
--- /dev/null
+++ b/src/Neuron/Zettelkasten/Query.hs
@@ -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
diff --git a/src/Neuron/Zettelkasten/Route.hs b/src/Neuron/Zettelkasten/Route.hs
new file mode 100644
--- /dev/null
+++ b/src/Neuron/Zettelkasten/Route.hs
@@ -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
+ }
diff --git a/src/Neuron/Zettelkasten/Store.hs b/src/Neuron/Zettelkasten/Store.hs
new file mode 100644
--- /dev/null
+++ b/src/Neuron/Zettelkasten/Store.hs
@@ -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
diff --git a/src/Neuron/Zettelkasten/Type.hs b/src/Neuron/Zettelkasten/Type.hs
new file mode 100644
--- /dev/null
+++ b/src/Neuron/Zettelkasten/Type.hs
@@ -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
diff --git a/src/Neuron/Zettelkasten/View.hs b/src/Neuron/Zettelkasten/View.hs
new file mode 100644
--- /dev/null
+++ b/src/Neuron/Zettelkasten/View.hs
@@ -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
diff --git a/test/Spec.hs b/test/Spec.hs
new file mode 100644
--- /dev/null
+++ b/test/Spec.hs
@@ -0,0 +1,1 @@
+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}