neuron 0.6.0.0 → 1.0.0.0
raw patch · 58 files changed
+1656/−965 lines, 58 filesdep +neurondep +rib-coredep +uri-encodedep −ribdep ~commonmarkdep ~commonmark-extensionsdep ~commonmark-pandoc
Dependencies added: neuron, rib-core, uri-encode
Dependencies removed: rib
Dependency ranges changed: commonmark, commonmark-extensions, commonmark-pandoc, dependent-sum, dependent-sum-aeson-orphans, megaparsec, pandoc-types, reflex-dom-pandoc, skylighting-core
Files
- neuron.cabal +68/−47
- src-bash/neuron-search +3/−2
- src/app/Data/Structured/OpenGraph.hs +46/−0
- src/app/Data/Structured/OpenGraph/Render.hs +44/−0
- src/app/Main.hs +0/−41
- src/app/Neuron/CLI.hs +19/−20
- src/app/Neuron/CLI/New.hs +8/−16
- src/app/Neuron/CLI/Open.hs +30/−0
- src/app/Neuron/CLI/Rib.hs +1/−1
- src/app/Neuron/CLI/Search.hs +20/−8
- src/app/Neuron/CLI/Types.hs +106/−72
- src/app/Neuron/Config.hs +24/−17
- src/app/Neuron/Config/Alias.hs +16/−11
- src/app/Neuron/Reader/Org.hs +9/−5
- src/app/Neuron/Web/Cache.hs +53/−0
- src/app/Neuron/Web/Generate.hs +57/−37
- src/app/Neuron/Web/Generate/Route.hs +23/−11
- src/app/Neuron/Web/HeadHtml.hs +38/−0
- src/app/Neuron/Web/StructuredData.hs +21/−43
- src/app/Neuron/Web/View.hs +18/−16
- src/app/Neuron/Zettelkasten/ID/Scheme.hs +24/−25
- src/exe/Main.hs +46/−0
- src/lib/Data/Graph/Labelled.hs +2/−0
- src/lib/Data/Graph/Labelled/Algorithm.hs +17/−4
- src/lib/Data/TagTree.hs +24/−9
- src/lib/Data/Time/DateMayTime.hs +80/−0
- src/lib/Neuron/Config/Type.hs +13/−4
- src/lib/Neuron/Reader/Markdown.hs +110/−31
- src/lib/Neuron/Reader/Type.hs +1/−0
- src/lib/Neuron/Web/Common.hs +7/−4
- src/lib/Neuron/Web/Query/View.hs +89/−55
- src/lib/Neuron/Web/Route.hs +12/−2
- src/lib/Neuron/Web/Theme.hs +9/−9
- src/lib/Neuron/Web/Widget.hs +5/−5
- src/lib/Neuron/Web/Widget/InvertedTree.hs +12/−10
- src/lib/Neuron/Web/ZIndex.hs +40/−19
- src/lib/Neuron/Web/Zettel/CSS.hs +10/−3
- src/lib/Neuron/Web/Zettel/View.hs +28/−28
- src/lib/Neuron/Zettelkasten/Connection.hs +0/−4
- src/lib/Neuron/Zettelkasten/Graph.hs +24/−22
- src/lib/Neuron/Zettelkasten/Graph/Build.hs +14/−12
- src/lib/Neuron/Zettelkasten/ID.hs +65/−74
- src/lib/Neuron/Zettelkasten/Query.hs +9/−3
- src/lib/Neuron/Zettelkasten/Query/Error.hs +7/−4
- src/lib/Neuron/Zettelkasten/Query/Eval.hs +16/−13
- src/lib/Neuron/Zettelkasten/Query/Parser.hs +110/−90
- src/lib/Neuron/Zettelkasten/Zettel.hs +12/−8
- src/lib/Neuron/Zettelkasten/Zettel/Meta.hs +11/−25
- src/lib/Neuron/Zettelkasten/Zettel/Parser.hs +30/−21
- src/lib/Text/URI/Util.hs +17/−12
- test/Data/Graph/Labelled/AlgorithmSpec.hs +42/−0
- test/Neuron/Config/AliasSpec.hs +1/−1
- test/Neuron/VersionSpec.hs +9/−9
- test/Neuron/Zettelkasten/ID/SchemeSpec.hs +2/−12
- test/Neuron/Zettelkasten/IDSpec.hs +19/−21
- test/Neuron/Zettelkasten/Query/ParserSpec.hs +61/−72
- test/Neuron/Zettelkasten/Zettel/ParserSpec.hs +37/−0
- test/Neuron/Zettelkasten/ZettelSpec.hs +37/−7
neuron.cabal view
@@ -1,7 +1,7 @@ cabal-version: 2.4 name: neuron -- This version must be in sync with what's in Default.dhall-version: 0.6.0.0+version: 1.0.0.0 license: AGPL-3.0-only copyright: 2020 Sridhar Ratnakumar maintainer: srid@srid.ca@@ -47,21 +47,21 @@ containers, filepattern, megaparsec,- commonmark ^>= 0.1.0.0,- commonmark-extensions ^>= 0.1.0.0,- commonmark-pandoc ^>= 0.1.0.0,- pandoc-types,+ commonmark ^>= 0.1.0.2,+ commonmark-extensions ^>= 0.2.0.0,+ commonmark-pandoc >= 0.1.0.0 && < 0.3,+ pandoc-types >= 1.21, parsec, modern-uri, HsYAML, aeson-gadt-th, dependent-sum, dependent-sum-template,- dependent-sum-aeson-orphans,+ dependent-sum-aeson-orphans >= 0.2.1.0, data-default, reflex, reflex-dom-core,- reflex-dom-pandoc >= 0.2.0.0,+ reflex-dom-pandoc >= 0.6.0.0, clay, tagged @@ -107,12 +107,10 @@ Data.Graph.Labelled.Type Data.Graph.Labelled.Algorithm Data.Graph.Labelled.Build+ Data.Time.DateMayTime --- A trick to make ghcid reload if library dependencies change--- https://haskell.zettel.page/2012605.html common app-common import: library-common- hs-source-dirs: src/app src/lib default-language: Haskell2010 build-depends: base >=4.12 && < 4.14,@@ -125,10 +123,11 @@ file-embed, optparse-applicative, pandoc,- skylighting-core,+ -- Use skylighting >= 0.9 as they are written in pure Haskell+ skylighting-core >= 0.9, relude, iso8601-time,- rib >=0.12,+ rib-core >=1.0, shake -any, time, text,@@ -139,71 +138,93 @@ which, unix, megaparsec >= 8.0,- dependent-sum,+ dependent-sum >= 0.7, dependent-sum-template, data-default, uuid, shake, with-utf8, shower,- either- if (!flag(ghcid))- autogen-modules:- Paths_neuron- other-modules:- Data.Graph.Labelled- Data.Graph.Labelled.Algorithm- Data.Graph.Labelled.Build- Data.Graph.Labelled.Type- Data.PathTree- Data.Structured.Breadcrumb- Data.TagTree- Neuron.CLI- Neuron.CLI.New- Neuron.CLI.Rib- Neuron.CLI.Search- Neuron.CLI.Types- Neuron.Config- Neuron.Config.Alias- Neuron.Config.Orphans- Neuron.Version- Neuron.Web.Generate- Neuron.Web.Generate.Route- Neuron.Web.View- Neuron.Web.StructuredData- Neuron.Reader- Neuron.Reader.Org- Neuron.Zettelkasten.ID.Scheme- Paths_neuron- Text.Megaparsec.Simple+ either,+ uri-encode +-- Everything below will have to be stripped away, if whoever uses this repo+-- will want to avoid non-core dependencies. Cabal doesn't seem to provide a way+-- to selectively dependent on a library without pulling in every stanza defined+-- here.+-- cf. https://www.srid.ca/2012605.html++library neuron-app-lib+ import: app-common+ hs-source-dirs: src/app+ exposed-modules:+ Data.Structured.Breadcrumb+ Data.Structured.OpenGraph+ Data.Structured.OpenGraph.Render+ Neuron.CLI+ Neuron.CLI.New+ Neuron.CLI.Open+ Neuron.CLI.Rib+ Neuron.CLI.Search+ Neuron.CLI.Types+ Neuron.Config+ Neuron.Config.Alias+ Neuron.Config.Orphans+ Neuron.Version+ Neuron.Web.Cache+ Neuron.Web.HeadHtml+ Neuron.Web.Generate+ Neuron.Web.Generate.Route+ Neuron.Web.View+ Neuron.Web.StructuredData+ Neuron.Reader+ Neuron.Reader.Org+ Neuron.Zettelkasten.ID.Scheme+ autogen-modules:+ Paths_neuron+ other-modules:+ Paths_neuron+ -- A trick to make ghcid reload if library dependencies change+ -- https://www.srid.ca/2012605.html+ if flag(ghcid)+ hs-source-dirs: src/lib+ else+ build-depends: neuron+ test-suite neuron-test import: app-common type: exitcode-stdio-1.0 hs-source-dirs: test main-is: Spec.hs build-depends:- base >=4.12 && < 4.14, relude, hspec, QuickCheck, time default-language: Haskell2010- if (!flag(ghcid))+ if (flag(ghcid))+ hs-source-dirs: src/lib src/app+ else+ build-depends: neuron, neuron-app-lib other-modules: Data.PathTreeSpec Data.TagTreeSpec+ Data.Graph.Labelled.AlgorithmSpec Neuron.Config.AliasSpec Neuron.VersionSpec Neuron.Zettelkasten.ID.SchemeSpec Neuron.Zettelkasten.IDSpec Neuron.Zettelkasten.Query.ParserSpec Neuron.Zettelkasten.ZettelSpec+ Neuron.Zettelkasten.Zettel.ParserSpec --- The executable stanza should always be at the end. The other project will--- strip it to avoid non-core dependencies. -- To profile: ghc-options: -fexternal-interpreter -prof -fprof-auto -rtsopts executable neuron import: app-common+ hs-source-dirs: src/exe main-is: Main.hs ghc-options: -threaded -rtsopts -with-rtsopts=-N+ if (flag(ghcid))+ hs-source-dirs: src/lib src/app+ else+ build-depends: neuron, neuron-app-lib
src-bash/neuron-search view
@@ -4,9 +4,10 @@ NOTESDIR=${1} FILTERBY=${2} SEARCHFROMFIELD=${3}-OPENCMD=$(envsubst -no-unset -no-empty <<<${4})+EXTENSIONS=${4}+OPENCMD=$(envsubst -no-unset -no-empty <<<${5}) cd ${NOTESDIR}-rg --no-heading --no-line-number --with-filename --sort path "${FILTERBY}" *.md \+rg --no-heading --no-line-number --with-filename --sort path "${FILTERBY}" -g "${EXTENSIONS}" \ | fzf --tac --no-sort -d ':' -n ${SEARCHFROMFIELD}.. \ --preview 'bat --style=plain --color=always {1}' \ | awk -F: "{printf \"${NOTESDIR}/%s\", \$1}" \
+ src/app/Data/Structured/OpenGraph.hs view
@@ -0,0 +1,46 @@+{-# LANGUAGE GADTs #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}++-- | Meta tags for The Open Graph protocol: https://ogp.me/+module Data.Structured.OpenGraph+ ( OpenGraph (..),+ OGType (..),+ Article (..),+ )+where++import Data.Time (UTCTime)+import Relude+import qualified Text.URI as URI++-- The OpenGraph metadata+--+-- This type can be directly rendered to HTML using `toHTML`.+data OpenGraph = OpenGraph+ { _openGraph_title :: Text,+ _openGraph_url :: Maybe URI.URI,+ _openGraph_author :: Maybe Text,+ _openGraph_description :: Maybe Text,+ _openGraph_siteName :: Text,+ _openGraph_type :: Maybe OGType,+ _openGraph_image :: Maybe URI.URI+ }+ deriving (Eq, Show)++-- TODO: Remaining ADT values & sub-fields+data OGType+ = OGType_Article Article+ | OGType_Website+ deriving (Eq, Show)++-- TODO: _article_profile :: [Profile]+data Article = Article+ { _article_section :: Maybe Text,+ _article_modifiedTime :: Maybe UTCTime,+ _article_publishedTime :: Maybe UTCTime,+ _article_expirationTime :: Maybe UTCTime,+ _article_tag :: [Text]+ }+ deriving (Eq, Show)
+ src/app/Data/Structured/OpenGraph/Render.hs view
@@ -0,0 +1,44 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE NoImplicitPrelude #-}++module Data.Structured.OpenGraph.Render where++import Data.Structured.OpenGraph+import Data.Time.ISO8601 (formatISO8601)+import Reflex.Dom.Core+import Relude+import qualified Text.URI as URI++renderOpenGraph :: forall t m. DomBuilder t m => OpenGraph -> m ()+renderOpenGraph OpenGraph {..} = do+ meta' "author" `mapM_` _openGraph_author+ meta' "description" `mapM_` _openGraph_description+ requireAbsolute "OGP URL" (\ourl -> elAttr "link" ("rel" =: "canonical" <> "href" =: ourl) blank) `mapM_` _openGraph_url+ metaOg "title" _openGraph_title+ metaOg "site_name" _openGraph_siteName+ whenJust _openGraph_type $ \case+ OGType_Article (Article {..}) -> do+ metaOg "type" "article"+ metaOg "article:section" `mapM_` _article_section+ metaOgTime "article:modified_time" `mapM_` _article_modifiedTime+ metaOgTime "article:published_time" `mapM_` _article_publishedTime+ metaOgTime "article:expiration_time" `mapM_` _article_expirationTime+ metaOg "article:tag" `mapM_` _article_tag+ OGType_Website -> do+ metaOg "type" "website"+ requireAbsolute "OGP image URL" (metaOg "image") `mapM_` _openGraph_image+ where+ meta' k v =+ elAttr "meta" ("name" =: k <> "content" =: v) blank+ metaOg k v =+ elAttr "meta" ("property" =: ("og:" <> k) <> "content" =: v) blank+ metaOgTime k t =+ metaOg k $ toText $ formatISO8601 t+ requireAbsolute :: Text -> (Text -> m ()) -> URI.URI -> m ()+ requireAbsolute description f uri' =+ if isJust (URI.uriScheme uri')+ then f $ URI.render uri'+ else error $ description <> " must be absolute. this URI is not: " <> URI.render uri'
− src/app/Main.hs
@@ -1,41 +0,0 @@-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeApplications #-}-{-# LANGUAGE NoImplicitPrelude #-}--module Main where--import Control.Monad.Reader-import Development.Shake-import Main.Utf8-import Neuron.CLI (run)-import Neuron.Config.Type (Config)-import Neuron.Version (neuronVersion)-import Neuron.Web.Generate (generateSite)-import Neuron.Web.Generate.Route (staticRouteConfig)-import qualified Neuron.Web.Manifest as Manifest-import Neuron.Web.Route (Route (..), runNeuronWeb)-import Neuron.Web.View (renderRoutePage)-import Neuron.Zettelkasten.Graph.Type (ZettelGraph)-import Reflex.Dom.Core-import Relude-import qualified Rib--main :: IO ()-main = withUtf8 $ run generateMainSite--generateMainSite :: Config -> Action ()-generateMainSite config = do- notesDir <- Rib.ribInputDir- Rib.buildStaticFiles ["static/**", ".nojekyll"]- manifest <- fmap Manifest.mkManifest $ getDirectoryFiles notesDir Manifest.manifestPatterns- let writeHtmlRoute :: Route a -> (ZettelGraph, a) -> Action ()- writeHtmlRoute r x = do- html <- liftIO $ fmap snd $ renderStatic $ do- runNeuronWeb staticRouteConfig $- renderRoutePage neuronVersion config manifest r x- -- FIXME: Make rib take bytestrings- Rib.writeRoute r $ decodeUtf8 @Text html- void $ generateSite config writeHtmlRoute
src/app/Neuron/CLI.hs view
@@ -16,41 +16,39 @@ import Data.Time import Development.Shake (Action) import Neuron.CLI.New (newZettelFile)+import Neuron.CLI.Open (openLocallyGeneratedFile) import Neuron.CLI.Rib import Neuron.CLI.Search (interactiveSearch)+import Neuron.CLI.Types (QueryCommand (..)) import Neuron.Config (getConfig) import Neuron.Config.Type (Config) import qualified Neuron.Version as Version+import qualified Neuron.Web.Cache as Cache import qualified Neuron.Web.Generate as Gen import qualified Neuron.Zettelkasten.Graph as G import qualified Neuron.Zettelkasten.Query as Q import Options.Applicative import Relude-import qualified Rib import System.Directory-import System.FilePath-import System.Info (os)-import System.Posix.Process run :: (Config -> Action ()) -> IO () run act = do- cliParser <- commandParser <$> defaultNotesDir <*> today+ defaultNotesDir <- getCurrentDirectory+ cliParser <- commandParser defaultNotesDir <$> now app <- execParser $ info (versionOption <*> cliParser <**> helper)- (fullDesc <> progDesc "Neuron, a Zettelkasten CLI <https://neuron.zettel.page/>")+ (fullDesc <> progDesc "Neuron, future-proof Zettelkasten app <https://neuron.zettel.page/>") runWith act app where versionOption = infoOption (toString Version.neuronVersion) (long "version" <> help "Show version")- defaultNotesDir =- (</> "zettelkasten") <$> getHomeDirectory- today = do+ now = do tz <- getCurrentTimeZone- localDay . utcToLocalTime tz <$> liftIO getCurrentTime+ utcToLocalTime tz <$> liftIO getCurrentTime runWith :: (Config -> Action ()) -> App -> IO () runWith act App {..} =@@ -60,16 +58,16 @@ New newCommand -> runRibOnceQuietly notesDir $ do newZettelFile newCommand =<< getConfig- Open ->+ Open openCommand -> runRibOnceQuietly notesDir $ do- indexHtmlPath <- fmap (</> "index.html") Rib.ribOutputDir- putStrLn indexHtmlPath- let opener = if os == "darwin" then "open" else "xdg-open"- liftIO $ executeFile opener True [indexHtmlPath] Nothing- Query eSomeQ ->+ openLocallyGeneratedFile openCommand+ Query (QueryCommand {..}) -> runRibOnceQuietly notesDir $ do- (graph, _, errors) <- Gen.loadZettelkasten =<< getConfig- case eSomeQ of+ (graph, errors) <-+ if cached+ then Cache.getCache+ else Gen.loadZettelkastenGraph =<< getConfig+ case query of Left someQ -> withSome someQ $ \q -> do let result = Q.runZettelQuery (G.getZettels graph) q@@ -78,5 +76,6 @@ withSome someQ $ \q -> do let result = Q.runGraphQuery graph q putLTextLn $ Aeson.encodeToLazyText $ Q.graphQueryResultJson q result errors- Search searchCmd ->- interactiveSearch notesDir searchCmd+ Search searchCmd -> do+ runRibOnceQuietly notesDir $ do+ interactiveSearch notesDir searchCmd =<< getConfig
src/app/Neuron/CLI/New.hs view
@@ -15,7 +15,7 @@ import Data.Some import Data.Text (strip) import qualified Data.Text as T-import Data.Time+import Data.Time.DateMayTime (DateMayTime, formatDateMayTime) import Development.Shake (Action) import Neuron.CLI.Types import Neuron.Config.Type (Config (..), getZettelFormats)@@ -24,10 +24,9 @@ import Neuron.Zettelkasten.ID (zettelIDSourceFileName) import qualified Neuron.Zettelkasten.ID.Scheme as IDScheme import Neuron.Zettelkasten.Zettel (zettelID)-import Neuron.Zettelkasten.Zettel.Meta (formatZettelDate) import Options.Applicative import Relude-import qualified Rib+import Rib.Shake (ribInputDir) import System.Directory (setCurrentDirectory) import System.FilePath import qualified System.Posix.Env as Env@@ -49,14 +48,14 @@ case mzid of Left e -> die $ show e Right zid -> do- notesDir <- Rib.ribInputDir+ notesDir <- ribInputDir defaultFormat <- head <$> getZettelFormats config let zettelFormat = fromMaybe defaultFormat format zettelFile = zettelIDSourceFileName zid zettelFormat liftIO $ do fileAction :: FilePath -> FilePath -> IO () <- bool (pure showAction) mkEditActionFromEnv edit- writeFileText (notesDir </> zettelFile) $ defaultZettelContent zettelFormat day title+ writeFileText (notesDir </> zettelFile) $ defaultZettelContent zettelFormat date fileAction notesDir zettelFile where mkEditActionFromEnv :: IO (FilePath -> FilePath -> IO ())@@ -82,29 +81,22 @@ Just (toString . strip . toText -> v) -> if null v then pure Nothing else pure (Just v) --- TODO use configurable template files?-defaultZettelContent :: ZettelFormat -> Day -> Maybe Text -> Text-defaultZettelContent format day mtitle = case format of+defaultZettelContent :: ZettelFormat -> DateMayTime -> Text+defaultZettelContent format (formatDateMayTime -> date) = case format of ZettelFormat_Markdown -> T.intercalate "\n" [ "---", "date: " <> date, "---",- "",- "# " <> title,- "\n"+ "" ] ZettelFormat_Org -> T.intercalate "\n"- [ "* " <> title,+ [ "* " <> "Untitled", -- Leaving a title here, only because org seems to require one " :PROPERTIES:", " :Date: " <> date, " :END:", "\n" ]- where- date = formatZettelDate day- defaultTitleName = "Zettel created on " <> date- title = maybe defaultTitleName T.strip mtitle
+ src/app/Neuron/CLI/Open.hs view
@@ -0,0 +1,30 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE RecordWildCards #-}++module Neuron.CLI.Open+ ( openLocallyGeneratedFile,+ )+where++import Data.Some+import qualified Data.Text as T+import Development.Shake (Action, doesFileExist)+import Neuron.CLI.Types (OpenCommand (..))+import Neuron.Web.Generate.Route ()+import Relude+import Rib.Route (routeUrlRel)+import Rib.Shake (ribOutputDir)+import System.FilePath+import System.Info (os)+import System.Posix.Process++openLocallyGeneratedFile :: OpenCommand -> Action ()+openLocallyGeneratedFile OpenCommand {..} = do+ let relHtmlPath = T.unpack $ routeUrlRel `foldSome` route+ opener = if os == "darwin" then "open" else "xdg-open"+ htmlPath <- fmap (</> relHtmlPath) ribOutputDir+ doesFileExist htmlPath >>= \case+ False -> do+ fail "No generated HTML found. Try runing `neuron rib` first."+ True -> do+ liftIO $ executeFile opener True [htmlPath] Nothing
src/app/Neuron/CLI/Rib.hs view
@@ -33,7 +33,7 @@ mkRibCliConfig :: FilePath -> RibConfig -> IO Rib.Cli.CliConfig mkRibCliConfig inputDir cfg = do unlessM (doesDirectoryExist inputDir) $ do- fail $ "Zettelkasten directory " <> inputDir <> " does not exist."+ fail $ "Zettelkasten directory (" <> inputDir <> ") does not exist. You may create it manually using `mkdir " <> inputDir <> "` before running neuron." let neuronDir = inputDir </> ".neuron" outputDir = fromMaybe (neuronDir </> "output") $ ribOutputDir cfg rebuildAll = False
src/app/Neuron/CLI/Search.hs view
@@ -11,7 +11,14 @@ ) where +import qualified Data.Text as Text+import Development.Shake (Action) import Neuron.CLI.Rib+ ( SearchBy (SearchByContent, SearchByTitle),+ SearchCommand (..),+ )+import Neuron.Config.Type (Config, getZettelFormats)+import Neuron.Reader.Type (ZettelFormat (ZettelFormat_Org), zettelFormatToExtension) import Relude import System.Posix.Process import System.Which@@ -19,19 +26,24 @@ neuronSearchScript :: FilePath neuronSearchScript = $(staticWhich "neuron-search") -searchScriptArgs :: SearchCommand -> [String]-searchScriptArgs SearchCommand {..} =- let searchByArgs =+searchScriptArgs :: (NonEmpty ZettelFormat) -> SearchCommand -> [String]+searchScriptArgs formats SearchCommand {..} =+ let extensionPattern = "/*{" <> (Text.unpack $ Text.intercalate "," $ toList $ zettelFormatToExtension <$> formats) <> "}"+ searchByArgs = case searchBy of- SearchByTitle -> ["(^# )|(^title: )", "2"]- SearchByContent -> ["", "2"]+ SearchByTitle -> ["(^# )|(^title: )", "2", extensionPattern]+ SearchByContent -> ["", "2", extensionPattern] editArg = bool "echo" "$EDITOR" searchEdit in searchByArgs <> [editArg] -interactiveSearch :: FilePath -> SearchCommand -> IO ()-interactiveSearch notesDir searchCmd =- execScript neuronSearchScript $ notesDir : searchScriptArgs searchCmd+interactiveSearch :: FilePath -> SearchCommand -> Config -> Action ()+interactiveSearch notesDir searchCmd config =+ do+ zettelFormats <- getZettelFormats config+ if searchBy searchCmd == SearchByTitle && ZettelFormat_Org `elem` toList zettelFormats+ then fail "search is not supported for .org files"+ else liftIO $ execScript neuronSearchScript $ notesDir : searchScriptArgs zettelFormats searchCmd where execScript scriptPath args = -- We must use the low-level execvp (via the unix package's `executeFile`)
src/app/Neuron/CLI/Types.hs view
@@ -12,6 +12,8 @@ NewCommand (..), SearchBy (..), SearchCommand (..),+ OpenCommand (..),+ QueryCommand (..), RibConfig (..), commandParser, )@@ -21,15 +23,21 @@ import Data.Some import Data.TagTree (mkTagPattern) import Data.Time+import Data.Time.DateMayTime+ ( DateMayTime,+ formatDateMayTime,+ mkDateMayTime,+ parseDateMayTime,+ ) import Neuron.Reader.Type (ZettelFormat)+import qualified Neuron.Web.Route as R import qualified Neuron.Zettelkasten.Connection as C-import Neuron.Zettelkasten.ID (ZettelID, parseZettelID')+import Neuron.Zettelkasten.ID (ZettelID, parseZettelID) import Neuron.Zettelkasten.ID.Scheme (IDScheme (..)) import qualified Neuron.Zettelkasten.Query.Error as Q import Neuron.Zettelkasten.Query.Graph as Q import qualified Neuron.Zettelkasten.Query.Parser as Q import Neuron.Zettelkasten.Zettel as Q-import Neuron.Zettelkasten.Zettel.Meta (parseZettelDate) import Options.Applicative import Relude import qualified Rib.Cli@@ -41,9 +49,8 @@ } data NewCommand = NewCommand- { title :: Maybe Text,- format :: Maybe ZettelFormat,- day :: Day,+ { format :: Maybe ZettelFormat,+ date :: DateMayTime, idScheme :: Some IDScheme, edit :: Bool }@@ -60,15 +67,27 @@ | SearchByContent deriving (Eq, Show) +data OpenCommand = OpenCommand+ { route :: Some R.Route+ }+ deriving (Eq, Show)++data QueryCommand = QueryCommand+ { -- Use cache instead of building the zettelkasten from scratch+ cached :: Bool,+ query :: Either (Some Q.ZettelQuery) (Some Q.GraphQuery)+ }+ deriving (Eq, Show)+ data Command = -- | Create a new zettel file New NewCommand | -- | Open the locally generated Zettelkasten- Open+ Open OpenCommand | -- | Search a zettel by title Search SearchCommand | -- | Run a query against the Zettelkasten- Query (Either (Some Q.ZettelQuery) (Some Q.GraphQuery))+ Query QueryCommand | -- | Delegate to Rib's command parser Rib RibConfig @@ -82,13 +101,13 @@ deriving (Eq, Show) -- | optparse-applicative parser for neuron CLI-commandParser :: FilePath -> Day -> Parser App-commandParser defaultNotesDir today = do+commandParser :: FilePath -> LocalTime -> Parser App+commandParser defaultNotesDir now = do notesDir <- option Rib.Cli.directoryReader- ( long "zettelkasten-dir" <> short 'd' <> metavar "NOTESDIR" <> value defaultNotesDir <> showDefault- <> help "Your zettelkasten directory containing the zettel files"+ ( short 'd' <> metavar "PATH" <> value defaultNotesDir+ <> help "Run as if neuron was started in PATH instead of the current working directory" ) cmd <- cmdParser pure $ App {..}@@ -103,68 +122,77 @@ command "rib" $ info ribCommand $ progDesc "Generate static site via rib" ] newCommand = do- title <- optional $ strArgument (metavar "TITLE" <> help "Title of the new Zettel")+ idScheme <-+ fmap (maybe (Some IDSchemeHash) (Some . IDSchemeCustom)) $+ optional $+ strArgument (metavar "TITLEID" <> help "Custom (title) ID to use; otherwise random ID will be generated") format <-- optional- $ option auto- $ metavar "FORMAT"- <> short 'f'- <> long "format"- <> help "The document format of the new zettel"+ optional $+ option auto $+ metavar "FORMAT"+ <> short 'f'+ <> long "format"+ <> help "The document format of the new zettel" edit <- switch (long "edit" <> short 'e' <> help "Open the newly-created zettel in $EDITOR")- day <-- option dayReader $- long "day"- <> metavar "DAY"- <> value today- <> showDefault- <> help "Zettel creation date in UTC"- -- NOTE: optparse-applicative picks the first option as the default.- idSchemeF <-+ dateParam <-+ option dateReader $+ long "date"+ <> metavar "DATE/TIME"+ <> value (mkDateMayTime $ Right now)+ <> showDefaultWith (toString . formatDateMayTime)+ <> help "Zettel date/time"+ pure $ New $ NewCommand format dateParam idScheme edit+ openCommand = do+ fmap Open $ fmap- (const $ const $ Some IDSchemeHash)- (switch (long "id-hash" <> help "Use random hash ID (default)"))+ (const $ OpenCommand $ Some $ R.Route_ZIndex)+ (switch (long "zindex" <> help "Open z-index")) <|> fmap- (const $ Some . IDSchemeDate)- (switch (long "id-date" <> help "Use date encoded ID"))+ (const $ OpenCommand $ Some $ R.Route_Search Nothing)+ (switch (long "search" <> help "Open the search page")) <|> fmap- (const . Some . IDSchemeCustom)- (option str (long "id" <> help "Use a custom ID" <> metavar "IDNAME"))- pure $ New $ NewCommand title format day (idSchemeF day) edit- openCommand =- pure Open- queryCommand =- fmap Query $- ( fmap- Left- ( fmap (Some . flip Q.ZettelQuery_ZettelByID Nothing) (option zettelIDReader (long "id"))- <|> fmap (\x -> Some $ Q.ZettelQuery_ZettelsByTag x Nothing def) (many (mkTagPattern <$> option str (long "tag" <> short 't')))- <|> option queryReader (long "uri" <> short 'u')+ (OpenCommand . Some . R.Route_Zettel)+ (option zettelIDReader (long "id" <> help "Open the zettel HTML page" <> metavar "ID"))+ queryCommand = do+ cached <- switch (long "cached" <> help "Use cached zettelkasten graph (faster)")+ query <-+ fmap+ Left+ ( fmap+ (Some . flip Q.ZettelQuery_ZettelByID connDummy)+ (option zettelIDReader (long "id"))+ <|> fmap+ (\x -> Some $ Q.ZettelQuery_ZettelsByTag x connDummy def)+ (many (mkTagPattern <$> option str (long "tag" <> short 't')))+ <|> option queryReader (long "uri" <> short 'u')+ )+ <|> fmap+ Right+ ( fmap+ (const $ Some $ Q.GraphQuery_Id)+ ( switch $+ long "graph" <> help "Get the entire zettelkasten graph as JSON"+ )+ <|> fmap+ (Some . Q.GraphQuery_BacklinksOf Nothing)+ ( option+ zettelIDReader+ ( long "backlinks-of"+ <> help "Get backlinks to the given zettel ID"+ <> metavar "ID"+ )+ )+ <|> fmap+ (Some . Q.GraphQuery_BacklinksOf (Just C.Folgezettel))+ ( option+ zettelIDReader+ ( long "uplinks-of"+ <> help "Get uplinks to the given zettel ID"+ <> metavar "ID"+ )+ ) )- <|> fmap- Right- (fmap (const $ Some $ Q.GraphQuery_Id) $ switch (long "graph" <> help "Get the entire zettelkasten graph as JSON"))- <|> fmap- Right- ( fmap (Some . Q.GraphQuery_BacklinksOf Nothing) $- option- zettelIDReader- ( long "backlinks-of"- <> help "Get backlinks to the given zettel ID"- <> metavar "ID"- )- )- <|> fmap- Right- ( fmap (Some . Q.GraphQuery_BacklinksOf (Just C.Folgezettel)) $- option- zettelIDReader- ( long "uplinks-of"- <> help "Get uplinks to the given zettel ID"- <> metavar "ID"- )- )- )+ pure $ Query $ QueryCommand {..} searchCommand = do searchBy <- bool SearchByTitle SearchByContent@@ -186,14 +214,20 @@ pure RibConfig {..} zettelIDReader :: ReadM ZettelID zettelIDReader =- eitherReader $ first show . parseZettelID' . toText+ eitherReader $ first show . parseZettelID . toText queryReader :: ReadM (Some Q.ZettelQuery) queryReader = eitherReader $ \(toText -> s) -> case URI.mkURI s of Right uri ->- either (Left . toString . Q.showQueryParseError) (maybe (Left "Unsupported query") Right) $ Q.queryFromURI uri+ either+ (Left . toString . Q.showQueryParseError)+ (maybe (Left "Unsupported query") Right)+ $ Q.queryFromURI connDummy uri Left e -> Left $ displayException e- dayReader :: ReadM Day- dayReader =- maybeReader (parseZettelDate . toText)+ dateReader :: ReadM DateMayTime+ dateReader =+ maybeReader (parseDateMayTime . toText)+ -- We don't care about connections in the CLI, but the query requires one -+ -- so pass a dummy value.+ connDummy = C.OrdinaryConnection
src/app/Neuron/Config.hs view
@@ -18,28 +18,35 @@ where import Data.Either.Validation (validationToEither)+import qualified Data.Text as T import Development.Shake (Action, readFile')-import qualified Dhall import Dhall (FromDhall)-import qualified Dhall.Core-import qualified Dhall.Parser-import qualified Dhall.TypeCheck+import qualified Dhall (Decoder (extract), auto)+import qualified Dhall.Core (normalize)+import qualified Dhall.Parser (exprFromText)+import qualified Dhall.TypeCheck (typeOf) import Neuron.Config.Orphans () import Neuron.Config.Type (Config, configFile, defaultConfig, mergeWithDefault) import Relude-import qualified Rib-import System.Directory-import System.FilePath+import Rib.Shake (ribInputDir)+import System.Directory (doesFileExist)+import System.FilePath ((</>)) -- | Read the optional @neuron.dhall@ config file from the zettelkasten getConfig :: Action Config getConfig = do- configPath <- Rib.ribInputDir <&> (</> configFile)- configVal :: Text <- liftIO (doesFileExist configPath) >>= \case- True -> do- mergeWithDefault . toText <$> readFile' configPath- False ->- pure defaultConfig+ notesDir <- ribInputDir+ let configPath = notesDir </> configFile+ configVal :: Text <-+ liftIO (doesFileExist configPath) >>= \case+ True -> do+ s <- readFile' configPath+ -- Accept empty neuron.dhall (used to signify a directory to be used with neuron)+ if T.null (T.strip $ toText s)+ then pure defaultConfig+ else mergeWithDefault . toText <$> readFile' configPath+ False ->+ fail $ "not a neuron notes directory (no neuron.dhall found under " <> notesDir <> ")" either fail pure $ parsePure configFile $ mergeWithDefault configVal -- | Pure version of `Dhall.input Dhall.auto`@@ -50,7 +57,7 @@ expr0 <- first show $ Dhall.Parser.exprFromText fn s expr <- maybeToRight "Cannot have imports" $ traverse (const Nothing) expr0 void $ first show $ Dhall.TypeCheck.typeOf expr- first show- $ validationToEither- $ Dhall.extract @a Dhall.auto- $ Dhall.Core.normalize expr+ first show $+ validationToEither $+ Dhall.extract @a Dhall.auto $+ Dhall.Core.normalize expr
src/app/Neuron/Config/Alias.hs view
@@ -5,6 +5,7 @@ module Neuron.Config.Alias where import Control.Monad.Except (liftEither, runExcept, throwError)+import Data.List (delete) import Neuron.Config.Type import qualified Neuron.Zettelkasten.Graph as G import Neuron.Zettelkasten.Graph.Type (ZettelGraph)@@ -32,20 +33,24 @@ pure v where hasIndexZettel =- isJust . G.getZettel (parseZettelID "index")+ isJust . G.getZettel indexZid mkAliases :: [Text] -> ZettelGraph -> Either Text [Alias] mkAliases aliasSpecs graph =- sequence $ flip fmap aliasSpecs $ \aliasSpec -> runExcept $ do- alias@Alias {..} <- liftEither $ parse aliasParser configFile aliasSpec- when (isJust $ G.getZettel aliasZettel graph) $ do- throwError $- "Cannot create redirect from '" <> zettelIDText aliasZettel <> "', because a zettel with that ID already exists"- when (zettelIDText targetZettel /= "z-index" && isNothing (G.getZettel targetZettel graph)) $ do- throwError $- "Target zettel '" <> zettelIDText targetZettel <> "' does not exist"- pure alias+ sequence $+ flip fmap aliasSpecs $ \aliasSpec -> runExcept $ do+ alias@Alias {..} <- liftEither $ parse aliasParser configFile aliasSpec+ when (isJust $ G.getZettel aliasZettel graph) $ do+ throwError $+ "Cannot create redirect from '" <> zettelIDRaw aliasZettel <> "', because a zettel with that ID already exists"+ when (zettelIDSlug targetZettel /= "z-index" && isNothing (G.getZettel targetZettel graph)) $ do+ throwError $+ "Target zettel '" <> zettelIDRaw targetZettel <> "' does not exist"+ pure alias aliasParser :: Parser Alias aliasParser =- Alias <$> (idParser <* M.char ':') <*> idParser+ -- Disallow ':' in IDs, because we use colon as a separator in alias spec.+ -- TODO: Do proper parsing so colon is allowed in both IDs.+ let idParserSansColon = idParser' $ delete ':' allowedSpecialChars+ in Alias <$> (idParserSansColon <* M.char ':') <*> idParser
src/app/Neuron/Reader/Org.hs view
@@ -15,13 +15,14 @@ import qualified Data.Map as Map import Data.TagTree (Tag (Tag)) import Data.Tagged-import Data.Time.Calendar (Day)+import Data.Text (toLower)+import Data.Time.DateMayTime (DateMayTime, parseDateMayTime) import Neuron.Reader.Type (ZettelParseError, ZettelReader)-import Neuron.Zettelkasten.Zettel.Meta (Meta (..), parseZettelDate)+import Neuron.Zettelkasten.Zettel.Meta (Meta (..)) import Relude import Relude.Extra.Map (lookup) import Text.Pandoc (def, runPure)-import Text.Pandoc.Definition hiding (Meta (..))+import Text.Pandoc.Definition (Pandoc) import Text.Pandoc.Readers.Org (readOrg) import Text.Pandoc.Util (getH1) @@ -39,8 +40,11 @@ -- title is now deprecated let title = Nothing tags = fmap Tag . words <$> lookup "tags" properties+ unlisted = parseUnlisted <$> lookup "unlisted" properties pure $ Just Meta {..} | otherwise = pure Nothing where- parseDate :: Text -> Either ZettelParseError Day- parseDate date = maybeToRight (Tagged $ "Invalid date format: " <> date) $ parseZettelDate @Maybe date+ parseDate :: Text -> Either ZettelParseError DateMayTime+ parseDate date = maybeToRight (Tagged $ "Invalid date format: " <> date) $ parseDateMayTime @Maybe date+ parseUnlisted :: Text -> Bool+ parseUnlisted a = toLower a == "true"
+ src/app/Neuron/Web/Cache.hs view
@@ -0,0 +1,53 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE NoImplicitPrelude #-}++-- | Responsible for caching zettelkasten graph on disk+module Neuron.Web.Cache where++import Data.Aeson (eitherDecodeFileStrict, encodeFile)+import Development.Shake (Action)+import Neuron.Config.Type (Config)+import Neuron.Zettelkasten.Graph.Type (ZettelGraph)+import Neuron.Zettelkasten.ID (ZettelID)+import Neuron.Zettelkasten.Zettel (ZettelError)+import Relude+import Rib.Shake+import System.Directory (createDirectoryIfMissing)+import System.FilePath++data ReadMode+ = ReadMode_Direct Config+ | ReadMode_Cached+ deriving (Eq, Show)++type CacheData = (ZettelGraph, Map ZettelID ZettelError)++cacheFile :: Action FilePath+cacheFile = do+ neuronDir <- (</> ".neuron") <$> ribInputDir+ liftIO $ createDirectoryIfMissing True neuronDir+ pure $ neuronDir </> "cache.json"++updateCache :: CacheData -> Action ()+updateCache v = do+ f <- cacheFile+ liftIO $ encodeFile f v++getCache :: Action CacheData+getCache = do+ (liftIO . eitherDecodeFileStrict =<< cacheFile) >>= \case+ Left err -> fail err+ Right v -> pure v++evalUnlessCacheRequested ::+ ReadMode -> (Config -> Action CacheData) -> Action CacheData+evalUnlessCacheRequested mode f = do+ case mode of+ ReadMode_Direct config ->+ f config+ ReadMode_Cached -> do+ (liftIO . eitherDecodeFileStrict =<< cacheFile) >>= \case+ Left err -> fail err+ Right v -> pure v
src/app/Neuron/Web/Generate.hs view
@@ -14,10 +14,11 @@ module Neuron.Web.Generate ( generateSite, loadZettelkasten,+ loadZettelkastenGraph, ) where -import Data.FileEmbed (embedStringFile)+import Data.FileEmbed (embedOneStringFileOf) import qualified Data.Map.Strict as Map import Data.Tagged (untag) import qualified Data.Text as T@@ -28,6 +29,7 @@ import Neuron.Reader (readerForZettelFormat) import Neuron.Reader.Type (ZettelFormat, zettelFormatToExtension) import Neuron.Version (neuronVersion, olderThan)+import qualified Neuron.Web.Cache as Cache import Neuron.Web.Generate.Route () import qualified Neuron.Web.Route as Z import qualified Neuron.Zettelkasten.Graph.Build as G@@ -37,12 +39,16 @@ import Neuron.Zettelkasten.Zettel import Options.Applicative import Relude-import qualified Rib import Rib.Route+import Rib.Shake (forEvery, ribInputDir) import System.FilePath +-- | The contents of search.js+--+-- We specify an alternate path, that is relative to project root, so that+-- ghcide will be able to compile this module. searchScript :: Text-searchScript = $(embedStringFile "./src-js/search.js")+searchScript = $(embedOneStringFileOf ["./src-js/search.js", "./neuron/src-js/search.js"]) -- | Generate the Zettelkasten site generateSite ::@@ -51,11 +57,12 @@ Action ZettelGraph generateSite config writeHtmlRoute' = do when (olderThan $ minVersion config) $ do- fail $ toString $- "Require neuron mininum version "- <> minVersion config- <> ", but your neuron version is "- <> neuronVersion+ fail $+ toString $+ "Require neuron mininum version "+ <> minVersion config+ <> ", but your neuron version is "+ <> neuronVersion (zettelGraph, zettelContents, errors) <- loadZettelkasten config let writeHtmlRoute :: forall a. a -> Z.Route a -> Action () writeHtmlRoute v r = writeHtmlRoute' r (zettelGraph, v)@@ -65,7 +72,7 @@ -- Generate the z-index writeHtmlRoute errors Z.Route_ZIndex -- Generate search page- writeHtmlRoute searchScript Z.Route_Search+ writeHtmlRoute searchScript $ Z.Route_Search Nothing -- Write alias redirects, unless a zettel with that name exists. aliases <- getAliases config zettelGraph forM_ aliases $ \Alias {..} ->@@ -99,6 +106,16 @@ go (x : xs) = x : fmap (toText . (take n (repeat ' ') <>) . toString) xs +-- | Like `loadZettelkasten` but without the content+--+-- Also allows retrieving the cached data for faster execution.+loadZettelkastenGraph ::+ Config ->+ Action (ZettelGraph, Map ZettelID ZettelError)+loadZettelkastenGraph config = do+ (g, _, errs) <- loadZettelkasten config+ pure (g, errs)+ loadZettelkasten :: Config -> Action@@ -110,9 +127,11 @@ formats <- getZettelFormats config zettelFiles <- forM formats $ \fmt -> do let pat = toString $ "*" <> zettelFormatToExtension fmt- files <- Rib.forEvery [pat] pure+ files <- forEvery [pat] pure pure (fmt, files)- loadZettelkastenFrom zettelFiles+ res@(g, _, errs) <- loadZettelkastenFrom zettelFiles+ Cache.updateCache (g, errs)+ pure res -- | Load the Zettelkasten from disk, using the given list of zettel files loadZettelkastenFrom ::@@ -123,38 +142,39 @@ Map ZettelID ZettelError ) loadZettelkastenFrom fs = do- notesDir <- Rib.ribInputDir+ notesDir <- ribInputDir -- Use State monad to "gather" duplicate zettel files using same IDs, in the -- `Right` of the Either state value; with the `Left` collecting the actual -- zettel files to load into the graph. zidMap :: Map ZettelID (Either (ZettelFormat, (FilePath, Text)) (NonEmpty FilePath)) <-- fmap snd $ flip runStateT Map.empty $ do- forM_ fs $ \(format, files) -> do- forM_ files $ \relPath -> do- case getZettelID relPath of- Nothing ->- pure ()- Just zid -> do- fmap (Map.lookup zid) get >>= \case- Just (Left (_f, (oldPath, _s))) -> do- -- The zettel ID is already used by `oldPath`. Mark it as a dup.- modify $ Map.insert zid (Right $ relPath :| [oldPath])- Just (Right (toList -> ambiguities)) -> do- -- Third or later duplicate file with the same Zettel ID- modify $ Map.insert zid (Right $ relPath :| ambiguities)- Nothing -> do- let absPath = notesDir </> relPath- lift $ need [absPath]- s <- decodeUtf8With lenientDecode <$> readFileBS absPath- modify $ Map.insert zid (Left (format, (relPath, s)))+ fmap snd $+ flip runStateT Map.empty $ do+ forM_ fs $ \(format, files) -> do+ forM_ files $ \relPath -> do+ case getZettelID format relPath of+ Nothing ->+ pure ()+ Just zid -> do+ fmap (Map.lookup zid) get >>= \case+ Just (Left (_f, (oldPath, _s))) -> do+ -- The zettel ID is already used by `oldPath`. Mark it as a dup.+ modify $ Map.insert zid (Right $ relPath :| [oldPath])+ Just (Right (toList -> ambiguities)) -> do+ -- Third or later duplicate file with the same Zettel ID+ modify $ Map.insert zid (Right $ relPath :| ambiguities)+ Nothing -> do+ let absPath = notesDir </> relPath+ lift $ need [absPath]+ s <- decodeUtf8With lenientDecode <$> readFileBS absPath+ modify $ Map.insert zid (Left (format, (relPath, s))) let dups = fmap ZettelError_AmbiguousFiles $ Map.mapMaybe rightToMaybe zidMap files =- fmap (first (id &&& readerForZettelFormat))- $ Map.toList- $ Map.fromListWith (<>)- $ flip fmap (Map.toList $ Map.mapMaybe leftToMaybe zidMap)- $ \(zid, (fmt, (path, s))) ->- (fmt, [(zid, path, s)])+ fmap (first (id &&& readerForZettelFormat)) $+ Map.toList $+ Map.fromListWith (<>) $+ flip fmap (Map.toList $ Map.mapMaybe leftToMaybe zidMap) $+ \(zid, (fmt, (path, s))) ->+ (fmt, [(zid, path, s)]) (g, zs, gerrs) = G.buildZettelkasten files errs = Map.unions [dups, gerrs] pure (g, zs, errs)
src/app/Neuron/Web/Generate/Route.hs view
@@ -15,11 +15,14 @@ import Control.Monad.Except import Data.Some+import Data.TagTree (unTag)+import qualified Network.URI.Encode as E import Neuron.Web.Route (Route (..), RouteConfig (..)) import Neuron.Zettelkasten.ID import Reflex.Dom.Core import Relude-import Rib (IsRoute (..), routeUrl, routeUrlRel)+import Rib.Route (IsRoute (..), routeUrlRel)+import Text.URI (URI, mkURI) import qualified Text.URI as URI instance IsRoute Route where@@ -28,9 +31,9 @@ routeFile $ Route_Zettel zid Route_ZIndex -> pure "z-index.html"- Route_Search ->+ Route_Search _mtag -> pure "search.html"- Route_Zettel (zettelIDText -> s) ->+ Route_Zettel (zettelIDSlug -> s) -> pure $ toString s <> ".html" staticRouteConfig :: RouteConfig t m@@ -46,7 +49,10 @@ withSome someR $ \r -> do routeFor r -- Using relative URLs enables the site work in file:/// URLs- routeFor = routeUrlRel+ routeFor = \case+ -- HACK: Hack around Rib.Route's limitation in dealing with query arguments+ r@(Route_Search (Just t)) -> routeUrlRel r <> "?tag=" <> unTag t+ r -> routeUrlRel r data BaseUrlError = BaseUrlNotAbsolute@@ -55,10 +61,16 @@ instance Exception BaseUrlError -- | Make an absolute URI for a route, given a base URL.-routeUri :: (HasCallStack, IsRoute r) => Text -> r a -> URI.URI-routeUri siteBaseUrl r = either (error . toText . displayException) id $ runExcept $ do- baseUrl <- liftEither $ URI.mkURI siteBaseUrl- uri <- liftEither $ URI.mkURI $ routeUrl r- case URI.relativeTo uri baseUrl of- Nothing -> liftEither $ Left $ toException BaseUrlNotAbsolute- Just x -> pure x+routeUri :: (HasCallStack, IsRoute r) => URI -> r a -> URI+routeUri baseUrl r = either (error . toText . displayException) id $+ runExcept $ do+ let -- We use routeUrlRel, rather than routeUrl, to avoid the leading '/' which+ -- will get encoded by `E.encode`, creating incorrect URL encoding.+ relUrlUnicode = routeUrlRel r+ -- Use `E.encode` to deal with unicode code points, as mkURI will fail on them.+ -- This is necessary to support non-ascii characters in filenames+ relUrl = toText . E.encode . toString $ relUrlUnicode+ uri <- liftEither $ mkURI relUrl+ case URI.relativeTo uri baseUrl of+ Nothing -> liftEither $ Left $ toException BaseUrlNotAbsolute+ Just x -> pure x
+ src/app/Neuron/Web/HeadHtml.hs view
@@ -0,0 +1,38 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE NoImplicitPrelude #-}++module Neuron.Web.HeadHtml+ ( HeadHtml,+ getHeadHtml,+ renderHeadHtml,+ )+where++import Development.Shake+import Reflex.Dom.Core+import Reflex.Dom.Pandoc (PandocBuilder)+import Reflex.Dom.Pandoc.PandocRaw (PandocRaw (..))+import Relude+import Rib.Shake (ribInputDir)+import System.FilePath ((</>))+import Text.Pandoc.Definition (Format (..))++newtype HeadHtml = HeadHtml (Maybe Text)++getHeadHtml :: Action HeadHtml+getHeadHtml = do+ headHtmlPath <- ribInputDir <&> (</> "head.html")+ doesFileExist headHtmlPath >>= \case+ True ->+ HeadHtml . Just . toText <$> readFile' headHtmlPath+ False ->+ pure $ HeadHtml Nothing++renderHeadHtml :: PandocBuilder t m => HeadHtml -> m ()+renderHeadHtml (HeadHtml headHtml) = case headHtml of+ Nothing ->+ -- Include the MathJax script if no custom head.html is provided.+ elAttr "script" ("id" =: "MathJax-script" <> "src" =: "https://cdn.jsdelivr.net/npm/mathjax@3/es5/tex-mml-chtml.js" <> "async" =: "") blank+ Just html ->+ elPandocRaw (Format "html") html
src/app/Neuron/Web/StructuredData.hs view
@@ -1,5 +1,6 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE LambdaCase #-}+{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-}@@ -12,9 +13,10 @@ import Data.Structured.Breadcrumb (Breadcrumb) import qualified Data.Structured.Breadcrumb as Breadcrumb+import Data.Structured.OpenGraph+import Data.Structured.OpenGraph.Render (renderOpenGraph) import qualified Data.Text as T-import Data.Time.ISO8601 (formatISO8601)-import Neuron.Config.Type+import Neuron.Config.Type (Config (..), getSiteBaseUrl) import Neuron.Web.Generate.Route (routeUri) import Neuron.Web.Route import Neuron.Zettelkasten.Connection@@ -23,11 +25,10 @@ import Neuron.Zettelkasten.Zettel import Reflex.Dom.Core hiding ((&)) import Relude-import Rib.Extra.OpenGraph-import qualified Rib.Parser.Pandoc as Pandoc import Text.Pandoc (runPure, writePlain)-import Text.Pandoc.Definition (Block (Plain), Inline, Pandoc (..))+import Text.Pandoc.Definition (Block (Plain), Inline (Image), Pandoc (..)) import Text.Pandoc.Util (getFirstParagraphText)+import Text.Pandoc.Walk (query) import qualified Text.URI as URI renderStructuredData :: DomBuilder t m => Config -> Route a -> (ZettelGraph, a) -> m ()@@ -36,9 +37,9 @@ Breadcrumb.renderBreadcrumbs $ routeStructuredData config val route routeStructuredData :: Config -> (ZettelGraph, a) -> Route a -> [Breadcrumb]-routeStructuredData Config {..} (graph, v) = \case+routeStructuredData cfg (graph, v) = \case Route_Zettel _ ->- case siteBaseUrl of+ case (either fail id $ getSiteBaseUrl cfg) of Nothing -> [] Just baseUrl -> let mkCrumb :: Zettel -> Breadcrumb.Item@@ -49,14 +50,14 @@ [] routeOpenGraph :: Config -> a -> Route a -> OpenGraph-routeOpenGraph Config {..} v r =+routeOpenGraph cfg@Config {siteTitle, author} v r = OpenGraph { _openGraph_title = routeTitle' v r, _openGraph_siteName = siteTitle, _openGraph_description = case r of Route_Redirect _ -> Nothing Route_ZIndex -> Just "Zettelkasten Index"- Route_Search -> Just "Search Zettelkasten"+ (Route_Search _mtag) -> Just "Search Zettelkasten" Route_Zettel _ -> do doc <- getPandocDoc v para <- getFirstParagraphText doc@@ -69,47 +70,24 @@ _openGraph_image = case r of Route_Zettel _ -> do doc <- getPandocDoc v- image <- URI.mkURI =<< Pandoc.getFirstImg doc- baseUrl <- URI.mkURI =<< siteBaseUrl+ image <- URI.mkURI =<< getFirstImg doc+ baseUrl <- either fail id $ getSiteBaseUrl cfg URI.relativeTo image baseUrl _ -> Nothing, _openGraph_url = do- baseUrl <- siteBaseUrl+ baseUrl <- either fail id $ getSiteBaseUrl cfg pure $ routeUri baseUrl r } where getPandocDoc = either (const Nothing) (Just . zettelContent)--renderOpenGraph :: forall t m. DomBuilder t m => OpenGraph -> m ()-renderOpenGraph OpenGraph {..} = do- meta' "author" `mapM_` _openGraph_author- meta' "description" `mapM_` _openGraph_description- requireAbsolute "OGP URL" (\ourl -> elAttr "link" ("rel" =: "canonical" <> "href" =: ourl) blank) `mapM_` _openGraph_url- metaOg "title" _openGraph_title- metaOg "site_name" _openGraph_siteName- whenJust _openGraph_type $ \case- OGType_Article (Article {..}) -> do- metaOg "type" "article"- metaOg "article:section" `mapM_` _article_section- metaOgTime "article:modified_time" `mapM_` _article_modifiedTime- metaOgTime "article:published_time" `mapM_` _article_publishedTime- metaOgTime "article:expiration_time" `mapM_` _article_expirationTime- metaOg "article:tag" `mapM_` _article_tag- OGType_Website -> do- metaOg "type" "website"- requireAbsolute "OGP image URL" (metaOg "image") `mapM_` _openGraph_image- where- meta' k v =- elAttr "meta" ("name" =: k <> "content" =: v) blank- metaOg k v =- elAttr "meta" ("property" =: ("og:" <> k) <> "content" =: v) blank- metaOgTime k t =- metaOg k $ toText $ formatISO8601 t- requireAbsolute :: Text -> (Text -> m ()) -> URI.URI -> m ()- requireAbsolute description f uri' =- if isJust (URI.uriScheme uri')- then f $ URI.render uri'- else error $ description <> " must be absolute. this URI is not: " <> URI.render uri'+ getFirstImg ::+ Pandoc ->+ -- | Relative URL path to the image+ Maybe Text+ getFirstImg (Pandoc _ bs) = listToMaybe $+ flip query bs $ \case+ Image _ _ (url, _) -> [toText url]+ _ -> [] renderPandocAsText :: [Inline] -> Maybe Text renderPandocAsText =
src/app/Neuron/Web/View.hs view
@@ -18,16 +18,17 @@ ) where -import Clay ((?), Css, em, gray, important, pct, px)+import Clay (Css, em, gray, important, pct, px, (?)) import qualified Clay as C import Control.Monad.Except-import Data.Aeson ((.=), object, toJSON)+import Data.Aeson (object, toJSON, (.=)) import qualified Data.Aeson.Text as Aeson import qualified Data.Set as Set import Data.Some import Data.TagTree (Tag (..)) import Neuron.Config.Type (Config (..)) import Neuron.Web.Common (neuronCommonStyle, neuronFonts)+import Neuron.Web.HeadHtml (HeadHtml, renderHeadHtml) import Neuron.Web.Manifest (Manifest, renderManifest) import qualified Neuron.Web.Query.View as QueryView import Neuron.Web.Route@@ -38,9 +39,9 @@ import qualified Neuron.Web.ZIndex as ZIndex import qualified Neuron.Web.Zettel.CSS as ZettelCSS import qualified Neuron.Web.Zettel.View as ZettelView-import qualified Neuron.Zettelkasten.Graph as G import Neuron.Zettelkasten.Graph (ZettelGraph)-import Neuron.Zettelkasten.ID (ZettelID (..))+import qualified Neuron.Zettelkasten.Graph as G+import Neuron.Zettelkasten.ID (indexZid) import Neuron.Zettelkasten.Zettel import Reflex.Dom.Core hiding ((&)) import Reflex.Dom.Pandoc (PandocBuilder)@@ -49,16 +50,18 @@ import qualified Skylighting.Styles as Skylighting -- | Render the given route-renderRoutePage :: PandocBuilder t m => Text -> Config -> Manifest -> Route a -> (ZettelGraph, a) -> NeuronWebT t m ()-renderRoutePage neuronVersion config manifest r val =+renderRoutePage :: PandocBuilder t m => Text -> Config -> HeadHtml -> Manifest -> Route a -> (ZettelGraph, a) -> NeuronWebT t m ()+renderRoutePage neuronVersion config headHtml manifest r val = do+ -- DOCTYPE declaration is helpful for code that might appear in the user's `head.html` file (e.g. KaTeX).+ el "!DOCTYPE html" $ blank elAttr "html" ("lang" =: "en") $ do el "head" $ do- renderRouteHead config manifest r val+ renderRouteHead config headHtml manifest r val el "body" $ do renderRouteBody neuronVersion config r val -renderRouteHead :: DomBuilder t m => Config -> Manifest -> Route a -> (ZettelGraph, a) -> m ()-renderRouteHead config manifest route val = do+renderRouteHead :: PandocBuilder t m => Config -> HeadHtml -> Manifest -> Route a -> (ZettelGraph, a) -> NeuronWebT t m ()+renderRouteHead config headHtml manifest route val = do elAttr "meta" ("http-equiv" =: "Content-Type" <> "content" =: "text/html; charset=utf-8") blank elAttr "meta" ("name" =: "viewport" <> "content" =: "width=device-width, initial-scale=1") blank el "title" $ text $ routeTitle config (snd val) route@@ -70,7 +73,7 @@ renderCommon forM_ [ "https://cdn.jsdelivr.net/npm/jquery@3.5.0/dist/jquery.min.js",- "https://cdn.jsdelivr.net/npm/semantic-ui@2.4.2/dist/semantic.min.js",+ "https://cdn.jsdelivr.net/npm/fomantic-ui@2.8.7/dist/semantic.min.js", "https://cdn.jsdelivr.net/npm/js-search@2.0.0/dist/umd/js-search.min.js" ] $ \scrpt -> do@@ -82,11 +85,10 @@ where renderCommon = do let neuronCss = toText $ C.renderWith C.compact [] style- elAttr "link" ("rel" =: "stylesheet" <> "href" =: "https://cdn.jsdelivr.net/npm/fomantic-ui@2.8.5/dist/semantic.min.css") blank+ elAttr "link" ("rel" =: "stylesheet" <> "href" =: "https://cdn.jsdelivr.net/npm/fomantic-ui@2.8.7/dist/semantic.min.css") blank elAttr "style" ("type" =: "text/css") $ text neuronCss elLinkGoogleFonts neuronFonts- when (mathJaxSupport config) $- elAttr "script" ("id" =: "MathJax-script" <> "src" =: "https://cdn.jsdelivr.net/npm/mathjax@3/es5/tex-mml-chtml.js" <> "async" =: "") blank+ renderHeadHtml headHtml routeTitle :: Config -> a -> Route a -> Text routeTitle Config {..} v = withSuffix siteTitle . routeTitle' v@@ -100,7 +102,7 @@ renderRouteBody neuronVersion Config {..} r (g, x) = do let neuronTheme = Theme.mkTheme theme themeSelector = toText $ Theme.themeIdentifier neuronTheme- indexZettel = G.getZettel (ZettelCustomID "index") g+ indexZettel = G.getZettel indexZid g elAttr "div" ("class" =: "ui fluid container" <> "id" =: themeSelector) $ do case r of Route_ZIndex -> do@@ -153,7 +155,7 @@ [ "id" .= toJSON zettelID, "title" .= zettelTitle, "tags" .= zettelTags,- "day" .= zettelDay+ "day" .= zettelDate ] renderBrandFooter :: DomBuilder t m => Maybe Text -> m ()@@ -180,7 +182,7 @@ forM_ mIndexZettel $ \Zettel {..} -> neuronRouteLink (Some $ Route_Zettel zettelID) ("class" =: "left item" <> "title" =: "Home") $ semanticIcon "home"- neuronRouteLink (Some Route_Search) ("class" =: "left item" <> "title" =: "Search Zettels") $ do+ neuronRouteLink (Some $ Route_Search Nothing) ("class" =: "left item" <> "title" =: "Search Zettels") $ do semanticIcon "search" forM_ mEditUrl $ \editUrl -> do let attrs = ("href" =: editUrl <> "title" =: "Edit this Zettel")
src/app/Neuron/Zettelkasten/ID/Scheme.hs view
@@ -5,14 +5,20 @@ {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE NoImplicitPrelude #-} -module Neuron.Zettelkasten.ID.Scheme where+-- TODO: Simplify or eliminate this module, now that date IDs are gone.+module Neuron.Zettelkasten.ID.Scheme+ ( nextAvailableZettelID,+ genVal,+ IDScheme (..),+ IDConflict (..),+ )+where import Control.Monad.Except import Data.GADT.Compare.TH import Data.GADT.Show.TH import qualified Data.Set as Set import qualified Data.Text as T-import Data.Time import Data.UUID (UUID) import qualified Data.UUID as UUID import Data.UUID.V4 (nextRandom)@@ -21,14 +27,15 @@ import Text.Megaparsec.Simple import Text.Show +-- | The scheme to use when generating new IDs data IDScheme a where- IDSchemeDate :: Day -> IDScheme ()+ -- | Random IDs (default) IDSchemeHash :: IDScheme UUID+ -- | Custom ID (specified by the user) IDSchemeCustom :: Text -> IDScheme () data IDConflict = IDConflict_AlreadyExists- | IDConflict_DateIDExhausted | IDConflict_HashConflict Text | IDConflict_BadCustomID Text Text deriving (Eq)@@ -37,53 +44,45 @@ show = \case IDConflict_AlreadyExists -> "A zettel with that ID already exists"- IDConflict_DateIDExhausted ->- "Ran out of date ID indices for this day" IDConflict_HashConflict s -> "Hash conflict on " <> toString s <> "; try again" IDConflict_BadCustomID s e -> "The custom ID " <> toString s <> " is malformed: " <> toString e --- | Produce a value that is required to run an ID scheme.+-- | Produce a value that is required ahead to run an ID scheme. genVal :: forall a. IDScheme a -> IO a genVal = \case IDSchemeHash -> nextRandom- IDSchemeDate _ ->- pure () IDSchemeCustom _ -> pure () --- | Create a new zettel ID based on the given scheme without conflicting with--- the IDs of existing zettels.+-- | Create a new zettel ID based on the given scheme+--+-- This is a pure function, with all impure actions done in @genVal@+--+-- Ensures that new ID doesn't conflict with existing zettels. nextAvailableZettelID :: forall a. -- Existing zettels Set ZettelID ->+ -- Seed value for the scheme a ->+ -- Scheme to use when generating an ID IDScheme a -> Either IDConflict ZettelID nextAvailableZettelID zs val = \case- IDSchemeDate day -> do- let dayIndices = nonEmpty $ sort $ flip mapMaybe (Set.toList zs) $ \case- ZettelDateID d x- | d == day -> Just x- _ -> Nothing- case last <$> dayIndices of- Nothing -> pure $ ZettelDateID day 1- Just 99 -> throwError IDConflict_DateIDExhausted- Just idx -> pure $ ZettelDateID day (idx + 1) IDSchemeHash -> do let s = T.take 8 $ UUID.toText val- if s `Set.member` (zettelIDText `Set.map` zs)+ if s `Set.member` (zettelIDSlug `Set.map` zs) then throwError $ IDConflict_HashConflict s else- either (error . toText) (pure . ZettelCustomID) $- parse customIDParser "<random-hash>" s+ either (error . toText) pure $+ parse idParser "<random-hash>" s IDSchemeCustom s -> runExcept $ do zid <-- either (throwError . IDConflict_BadCustomID s) (pure . ZettelCustomID) $- parse customIDParser "<next-id>" s+ either (throwError . IDConflict_BadCustomID s) pure $+ parse idParser "<next-id>" s if zid `Set.member` zs then throwError IDConflict_AlreadyExists else pure zid
+ src/exe/Main.hs view
@@ -0,0 +1,46 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE NoImplicitPrelude #-}++module Main where++import Control.Monad.Reader+import Development.Shake+import Main.Utf8+import Neuron.CLI (run)+import Neuron.Config.Type (Config)+import Neuron.Version (neuronVersion)+import Neuron.Web.Generate (generateSite)+import Neuron.Web.Generate.Route (staticRouteConfig)+import Neuron.Web.HeadHtml (getHeadHtml)+import qualified Neuron.Web.Manifest as Manifest+import Neuron.Web.Route (Route (..), runNeuronWeb)+import Neuron.Web.View (renderRoutePage)+import Neuron.Zettelkasten.Graph.Type (ZettelGraph)+import Reflex.Dom.Core+import Relude+import Rib.Route (writeRoute)+import Rib.Shake (buildStaticFiles, ribInputDir)++main :: IO ()+main = withUtf8 $ run generateMainSite++generateMainSite :: Config -> Action ()+generateMainSite config = do+ notesDir <- ribInputDir+ buildStaticFiles ["static/**", ".nojekyll"]+ manifest <- fmap Manifest.mkManifest $ getDirectoryFiles notesDir Manifest.manifestPatterns+ headHtml <- getHeadHtml+ let writeHtmlRoute :: Route a -> (ZettelGraph, a) -> Action ()+ writeHtmlRoute r x = do+ html <- liftIO $+ fmap snd $+ renderStatic $ do+ runNeuronWeb staticRouteConfig $+ renderRoutePage neuronVersion config headHtml manifest r x+ -- FIXME: Make rib take bytestrings+ writeRoute r $ decodeUtf8 @Text html+ void $ generateSite config writeHtmlRoute
src/lib/Data/Graph/Labelled.hs view
@@ -21,12 +21,14 @@ preSetWithEdgeLabelMany, topSort, clusters,+ dfsForest, dfsForestFrom, dfsForestBackwards, bfsForestFrom, bfsForestBackwards, obviateRootUnlessForest, induceOnEdge,+ induce, ) where
src/lib/Data/Graph/Labelled/Algorithm.hs view
@@ -75,19 +75,26 @@ topSort :: (Vertex v, Ord (VertexID v)) => LabelledGraph v e -> Either (NonEmpty v) [v] topSort g =- bimap (fmap (getVertex g)) (fmap (getVertex g))- $ Algo.topSort- $ LAM.skeleton- $ graph g+ bimap (fmap (getVertex g)) (fmap (getVertex g)) $+ Algo.topSort $+ LAM.skeleton $+ graph g -- | Returns the clusters in an ayclic graph. -- -- If the graph is one cluster and that is acyclic, this will return an empty list.+--+-- If any of the cluster is cyclic, that cluster will not be included. clusters :: (Vertex v, Ord (VertexID v)) => LabelledGraph v e -> [NonEmpty v] clusters g = fmap (fmap $ getVertex g) $ mothers $ LAM.skeleton $ graph g -- | Compute the dfsForest from the given vertices.+dfsForest :: (Vertex v, Ord (VertexID v)) => LabelledGraph v e -> Forest v+dfsForest g =+ fmap (fmap $ getVertex g) $ Algo.dfsForest $ LAM.skeleton $ graph g++-- | Compute the dfsForest from the given vertices. dfsForestFrom :: (Vertex v, Ord (VertexID v)) => [v] -> LabelledGraph v e -> Forest v dfsForestFrom (fmap vertexID -> vs) g = fmap (fmap $ getVertex g) $ Algo.dfsForestFrom vs $ LAM.skeleton $ graph g@@ -110,6 +117,12 @@ -------------------------- --- More general utilities --------------------------++induce :: Ord (VertexID v) => (VertexID v -> Bool) -> LabelledGraph v e -> LabelledGraph v e+induce f (LabelledGraph g v) =+ LabelledGraph g' v+ where+ g' = LAM.induce f g -- | Like `induce` but operates on edges instead of vertices induceOnEdge :: Ord (VertexID v) => (e -> Bool) -> LabelledGraph v e -> LabelledGraph v e
src/lib/Data/TagTree.hs view
@@ -30,7 +30,9 @@ import qualified Text.Megaparsec.Char as M import Text.Megaparsec.Simple --- | Tag metadata field in Zettel notes+-- | A hierarchical tag+--+-- Tag nodes are separated by @/@ newtype Tag = Tag {unTag :: Text} deriving (Eq, Ord, Show, ToJSON, FromJSON, FromYAML, ToYAML) @@ -38,9 +40,16 @@ -- Tag Pattern --------------- --- | Glob-based pattern matching of tags+-- | A glob-based pattern to match hierarchical tags ----- Eg.: "foo/**" matches both "foo/bar/baz" and "foo/baz"+-- For example, the pattern+--+-- > foo/**+--+-- matches both the following+--+-- > foo/bar/baz+-- > foo/baz newtype TagPattern = TagPattern {unTagPattern :: FilePattern} deriving (Eq, Show, ToJSON, FromJSON) @@ -62,7 +71,13 @@ -- Tag Tree ----------- --- | A tag like "foo/bar/baz" is split into three nodes "foo", "bar" and "baz."+-- | An individual component of a hierarchical tag+--+-- The following hierarchical tag,+--+-- > foo/bar/baz+--+-- has three tag nodes: @foo@, @bar@ and @baz@ newtype TagNode = TagNode {unTagNode :: Text} deriving (Eq, Show, Ord, ToJSON) @@ -81,13 +96,13 @@ constructTag (fmap unTagNode . toList -> nodes) = Tag $ T.intercalate "/" nodes --- | Construct a tree from a list of tags+-- | Construct the tree from a list of hierarchical tags tagTree :: ann ~ Natural => Map Tag ann -> Forest (TagNode, ann) tagTree tags =- fmap (annotatePathsWith $ countFor tags)- $ mkTreeFromPaths- $ fmap (toList . deconstructTag)- $ Map.keys tags+ fmap (annotatePathsWith $ countFor tags) $+ mkTreeFromPaths $+ fmap (toList . deconstructTag) $+ Map.keys tags where countFor tags' path = fromMaybe 0 $ Map.lookup (constructTag path) tags'
+ src/lib/Data/Time/DateMayTime.hs view
@@ -0,0 +1,80 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++module Data.Time.DateMayTime+ ( -- Date type+ DateMayTime,+ mkDateMayTime,+ getDay,+ -- Date formatting+ dateTimeFormat,+ formatDay,+ formatLocalTime,+ formatDateMayTime,+ -- Date parsing+ parseDateMayTime,+ )+where++import Data.Aeson (FromJSON, ToJSON)+import Data.Time+import Data.YAML+import Relude++-- | Like `Day` but with optional time.+newtype DateMayTime = DateMayTime {unDateMayTime :: (Day, Maybe TimeOfDay)}+ deriving (Eq, Show, Generic, Ord, ToJSON, FromJSON)++instance FromYAML DateMayTime where+ parseYAML =+ parseDateMayTime <=< parseYAML @Text++instance ToYAML DateMayTime where+ toYAML =+ toYAML . formatDateMayTime++mkDateMayTime :: Either Day LocalTime -> DateMayTime+mkDateMayTime =+ DateMayTime . \case+ Left day ->+ (day, Nothing)+ Right datetime ->+ localDay &&& Just . localTimeOfDay $ datetime++getDay :: DateMayTime -> Day+getDay = fst . unDateMayTime++formatDateMayTime :: DateMayTime -> Text+formatDateMayTime (DateMayTime (day, mtime)) =+ maybe (formatDay day) (formatLocalTime . LocalTime day) mtime++formatDay :: Day -> Text+formatDay = formatTime' dateFormat++formatLocalTime :: LocalTime -> Text+formatLocalTime = formatTime' dateTimeFormat++parseDateMayTime :: (MonadFail m, Alternative m) => Text -> m DateMayTime+parseDateMayTime (toString -> s) = do+ fmap mkDateMayTime $+ fmap Left (parseTimeM False defaultTimeLocale dateFormat s)+ <|> fmap Right (parseTimeM False defaultTimeLocale dateTimeFormat s)++dateFormat :: String+dateFormat = "%Y-%m-%d"++dateTimeFormat :: String+dateTimeFormat = "%Y-%m-%dT%H:%M"++-- | Like `formatTime` but with default time locale and returning Text+formatTime' :: FormatTime t => String -> t -> Text+formatTime' s = toText . formatTime defaultTimeLocale s
src/lib/Neuron/Config/Type.hs view
@@ -13,6 +13,7 @@ defaultConfig, mergeWithDefault, getZettelFormats,+ getSiteBaseUrl, ) where @@ -20,20 +21,20 @@ import Neuron.Reader.Type (ZettelFormat) import Relude hiding (readEither) import Text.Read (readEither)+import Text.URI (URI, mkURI) configFile :: FilePath configFile = "neuron.dhall" -- | Config type for @neuron.dhall@ ----- See <https://neuron.zettel.page/2011701.html guide> for description of the fields.+-- See <https://neuron.zettel.page/configuration.html guide> for description of the fields. -- -- TODO: Implement custom `FromDhall` instance, while using original field types data Config = Config { aliases :: [Text], author :: Maybe Text, editUrl :: Maybe Text,- mathJaxSupport :: Bool, -- TODO: This should use `NonEmpty`. formats :: [Text], minVersion :: Text,@@ -48,6 +49,16 @@ formats' <- maybe (fail "Empty formats") pure $ nonEmpty formats traverse (either (fail . toString) pure . readEither . toString) formats' +getSiteBaseUrl :: MonadFail m => Config -> m (Maybe URI)+getSiteBaseUrl Config {..} =+ runMaybeT $ do+ s <- MaybeT $ pure siteBaseUrl+ case mkURI s of+ Left e ->+ fail $ displayException e+ Right uri ->+ pure uri+ defaultConfig :: Text defaultConfig = "{ siteTitle =\@@ -64,8 +75,6 @@ \ [] : List Text\ \, formats =\ \ [ \"markdown\" ]\- \, mathJaxSupport =\- \ True\ \, minVersion =\ \ \"0.5\" \ \}"
src/lib/Neuron/Reader/Markdown.hs view
@@ -1,10 +1,9 @@ {-# LANGUAGE GADTs #-}-{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-}-{-# LANGUAGE ViewPatterns #-} {-# LANGUAGE NoImplicitPrelude #-} module Neuron.Reader.Markdown@@ -17,11 +16,9 @@ import qualified Commonmark.Extensions as CE import qualified Commonmark.Inlines as CM import qualified Commonmark.Pandoc as CP-import qualified Commonmark.Tag import Commonmark.TokParsers (noneOfToks, symbol) import Commonmark.Tokens (TokType (..)) import Control.Monad.Combinators (manyTill)-import Control.Monad.Except import Data.Tagged (Tagged (..)) import qualified Data.YAML as YAML import Neuron.Orphans ()@@ -30,11 +27,19 @@ import Relude hiding (show, traceShowId) import qualified Text.Megaparsec as M import qualified Text.Megaparsec.Char as M-import Text.Megaparsec.Simple+import Text.Megaparsec.Simple (Parser, parse) import qualified Text.Pandoc.Builder as B import Text.Pandoc.Definition (Pandoc (..)) import qualified Text.Parsec as P-import Text.Show+import Text.Show (Show (show))+import Text.URI+ ( QueryParam (QueryFlag),+ URI (URI, uriQuery),+ mkPathPiece,+ mkURI,+ render,+ )+import Text.URI.QQ (queryKey, scheme) -- | Parse Markdown document, along with the YAML metadata block in it. --@@ -99,14 +104,18 @@ CE.HasFootnote il bl, CE.HasMath il, CE.HasDefinitionList il bl,- CE.HasDiv bl+ CE.HasDiv bl,+ CE.HasQuoted il,+ CE.HasSpan il ) => CM.SyntaxSpec m il bl neuronSpec = mconcat- [ wrappedLinkSpec angleBracketLinkP,- wrappedLinkSpec wikiLinkP,+ [ autoLinkSpec,+ wikiLinkSpec,+ inlineTagSpec, gfmExtensionsSansEmoji,+ CE.fancyListSpec, CE.footnoteSpec, CE.mathSpec, CE.smartPunctuationSpec,@@ -114,6 +123,7 @@ CE.attributesSpec, CE.rawAttributeSpec, CE.fencedDivSpec,+ CE.bracketedSpanSpec, CM.defaultSyntaxSpec {CM.syntaxBlockSpecs = defaultBlockSpecsSansRawHtml} ] where@@ -124,40 +134,97 @@ <> CE.autoIdentifiersSpec <> CE.taskListSpec +inlineTagSpec ::+ (Monad m, CM.IsBlock il bl, CM.IsInline il) =>+ CM.SyntaxSpec m il bl+inlineTagSpec =+ mempty+ { CM.syntaxInlineParsers = [pInlineTag]+ }+ where+ pInlineTag ::+ (Monad m, CM.IsInline il) =>+ CM.InlineParser m il+ pInlineTag = P.try $ do+ _ <- symbol '#'+ tag <- CM.untokenize <$> inlineTagP+ let tagQuery = "z:tag/" <> tag+ pure $! cmAutoLink tagQuery+ -- | Convert the given wrapped link to a `B.Link`.-wrappedLinkSpec ::+autoLinkSpec :: (Monad m, CM.IsBlock il bl, CM.IsInline il) =>- (P.ParsecT [CM.Tok] (CM.IPState m) (StateT Commonmark.Tag.Enders m) [CM.Tok]) -> CM.SyntaxSpec m il bl-wrappedLinkSpec linkP =+autoLinkSpec = mempty- { CM.syntaxInlineParsers = [pLink linkP]+ { CM.syntaxInlineParsers = [pLink] } where pLink :: (Monad m, CM.IsInline il) =>- (P.ParsecT [CM.Tok] (CM.IPState m) (StateT Commonmark.Tag.Enders m) [CM.Tok]) -> CM.InlineParser m il- pLink p = P.try $ do- x <- p+ pLink = P.try $ do+ x <- angleBracketLinkP let url = CM.untokenize x- title = ""- pure $! CM.link url title $ CM.str url+ pure $! cmAutoLink url -angleBracketLinkP :: Monad m => P.ParsecT [CM.Tok] s m [CM.Tok]-angleBracketLinkP = do- void $ symbol '<'- x <- some (noneOfToks [Symbol '>', Spaces, UnicodeSpace, LineEnd])- void $ symbol '>'- pure x+-- | Create a commonmark link element+cmAutoLink :: CM.IsInline a => Text -> a+cmAutoLink url =+ CM.link url title $ CM.str url+ where+ title = "" -wikiLinkP :: Monad m => P.ParsecT [CM.Tok] s m [CM.Tok]-wikiLinkP = do- void $ symbol '[' >> symbol '['- x <- some (noneOfToks [Symbol ']', Spaces, UnicodeSpace, LineEnd])- void $ symbol ']' >> symbol ']'- pure x+wikiLinkSpec ::+ (Monad m, CM.IsBlock il bl, CM.IsInline il) =>+ CM.SyntaxSpec m il bl+wikiLinkSpec =+ mempty+ { CM.syntaxInlineParsers = [pLink]+ }+ where+ pLink ::+ (Monad m, CM.IsInline il) =>+ CM.InlineParser m il+ pLink = P.try $ do+ fmap cmAutoLink $+ P.choice+ [ -- Folgezettel link: [[[...]]]+ P.try (wikiLinkP 3),+ -- Cf link: [[...]]+ P.try (wikiLinkP 2)+ ]+ wikiLinkP :: Monad m => Int -> P.ParsecT [CM.Tok] s m Text+ wikiLinkP n = do+ void $ M.count n $ symbol '['+ s <- fmap CM.untokenize $ some $ noneOfToks [Symbol ']', LineEnd]+ -- Parse as URI, add cf flag, and then render back. If parse fails, we+ -- just ignore this inline.+ case parseNeuronUri s of+ Just uri -> do+ void $ M.count n $ symbol ']'+ pure $+ render $ case n of+ 2 ->+ -- [[..]] adds "cf" flag in URI+ uri {uriQuery = uriQuery uri <> [QueryFlag [queryKey|cf|]]}+ _ -> uri+ Nothing ->+ fail "Not a neuron URI; ignoring"+ parseNeuronUri :: Text -> Maybe URI+ parseNeuronUri s =+ case toString s of+ ('z' : ':' : _) ->+ mkURI s+ _ -> do+ -- Treat it as plain ID+ path <- mkPathPiece s+ pure $ URI (Just [scheme|z|]) (Left True) (Just (False, path :| [])) [] Nothing +inlineTagP :: Monad m => P.ParsecT [CM.Tok] s m [CM.Tok]+inlineTagP =+ some (noneOfToks [Symbol ']', Spaces, UnicodeSpace, LineEnd])+ -- rawHtmlSpec eats angle bracket links as html tags defaultBlockSpecsSansRawHtml :: (Monad m, CM.IsBlock il bl) => [CM.BlockSpec m il bl] defaultBlockSpecsSansRawHtml =@@ -179,4 +246,16 @@ myRawHtmlSpec = -- TODO: Ideally we should use a more restrictive parsers; one that allows known safe HTML tags -- Although, this prevents the user from naming their zettels say "div.md"- CM.rawHtmlSpec {CM.blockStart = P.notFollowedBy angleBracketLinkP >> CM.blockStart CM.rawHtmlSpec}+ CM.rawHtmlSpec+ { CM.blockStart = P.notFollowedBy angleBracketLinkP >> CM.blockStart CM.rawHtmlSpec+ }++angleBracketLinkP :: Monad m => P.ParsecT [CM.Tok] s m [CM.Tok]+angleBracketLinkP = do+ void $ symbol '<'+ -- NOTE: Intentionally be lenient to support `<z:zettels?t...>` style+ -- queries. FIXME: Should fail on `</foo>` though (HTML end tags). TODO:+ -- Add unit tests before modifying this matching any further.+ x <- some (noneOfToks [Symbol '>', Spaces, UnicodeSpace, LineEnd])+ void $ symbol '>'+ pure x
src/lib/Neuron/Reader/Type.hs view
@@ -22,6 +22,7 @@ import Text.Read import Prelude (show) +-- | A function that parses the zettel into a Pandoc AST type ZettelReader = FilePath -> Text -> Either ZettelParseError (Maybe Meta, Pandoc) type ZettelParseError = Tagged "ZettelParserError" Text
src/lib/Neuron/Web/Common.hs view
@@ -4,7 +4,7 @@ module Neuron.Web.Common where -import Clay ((?), Css)+import Clay (Css, (?)) import qualified Clay as C import Relude @@ -12,6 +12,9 @@ neuronCommonStyle = do C.important $ C.backgroundColor "#eee" C.important $ C.fontFamily [bodyFont] [C.serif]+ ".ui.container" ? do+ -- Override Semantic UI's font+ C.important $ C.fontFamily [bodyFont] [C.serif] "h1, h2, h3, h4, h5, h6, .ui.header, .headerFont" ? do C.important $ C.fontFamily [headerFont] [C.sansSerif] "code, pre, tt, .monoFont" ? do@@ -21,10 +24,10 @@ neuronFonts = [headerFont, bodyFont, monoFont] headerFont :: Text-headerFont = "DM Serif Text"+headerFont = "Kanit" bodyFont :: Text-bodyFont = "DM Sans"+bodyFont = "Ubuntu" monoFont :: Text-monoFont = "DM Mono"+monoFont = "Roboto Mono"
src/lib/Neuron/Web/Query/View.hs view
@@ -2,11 +2,9 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeApplications #-} {-# LANGUAGE ViewPatterns #-} {-# LANGUAGE NoImplicitPrelude #-} @@ -14,63 +12,86 @@ ( renderQueryResult, renderZettelLink, renderZettelLinkIDOnly,- zettelUrl,- tagUrl, style, ) where +import Clay (Css, em, (?)) import qualified Clay as C-import Clay ((?), Css, em)-import Control.Monad.Except-import Data.Default-import Data.Dependent.Sum+import Data.Dependent.Sum (DSum (..)) import qualified Data.Map.Strict as Map-import Data.Some-import Data.TagTree (Tag (..), TagNode (..), TagPattern (..), constructTag, foldTagTree, tagMatchAny, tagTree)+import Data.Some (Some (..))+import Data.TagTree+ ( Tag (..),+ TagNode (..),+ TagPattern (..),+ constructTag,+ foldTagTree,+ tagMatchAny,+ tagTree,+ ) import qualified Data.Text as T-import Data.Tree+import Data.Tree (Forest, Tree (Node)) import Neuron.Web.Route-import Neuron.Web.Widget-import Neuron.Zettelkasten.Connection-import Neuron.Zettelkasten.ID+ ( NeuronWebT,+ Route (..),+ neuronRouteLink,+ )+import Neuron.Web.Widget (elTime, semanticIcon)+import Neuron.Zettelkasten.Connection (Connection (Folgezettel))+import Neuron.Zettelkasten.ID (ZettelID (zettelIDRaw)) import Neuron.Zettelkasten.Query.Theme (LinkView (..), ZettelsView (..)) import Neuron.Zettelkasten.Zettel+ ( Zettel,+ ZettelQuery (..),+ ZettelT (..),+ sortZettelsReverseChronological,+ ) import Reflex.Dom.Core hiding (count, tag)+import Reflex.Dom.Pandoc (PandocBuilder, elPandocInlines) import Relude+import Text.Pandoc.Definition (Inline) -- | Render the query results. renderQueryResult ::- DomBuilder t m => DSum ZettelQuery Identity -> NeuronWebT t m ()-renderQueryResult = \case- ZettelQuery_ZettelByID _zid (fromMaybe def -> conn) :=> Identity target -> do- renderZettelLink (Just conn) Nothing target- q@(ZettelQuery_ZettelsByTag pats (fromMaybe def -> conn) view) :=> Identity res -> do+ PandocBuilder t m => Maybe [Inline] -> DSum ZettelQuery Identity -> NeuronWebT t m ()+renderQueryResult minner = \case+ ZettelQuery_ZettelByID _zid conn :=> Identity target -> do+ renderZettelLink (elPandocInlines <$> minner) (Just conn) Nothing target+ q@(ZettelQuery_ZettelsByTag pats conn view) :=> Identity res -> do el "section" $ do renderQuery $ Some q case zettelsViewGroupByTag view of False ->- el "ul" $ forM_ res $ \z -> do- el "li" $- renderZettelLink (Just conn) (Just $ zettelsViewLinkView view) z+ el "ul" $+ forM_ res $ \z -> do+ el "li" $+ renderZettelLink Nothing (Just conn) (Just $ zettelsViewLinkView view) z True -> forM_ (Map.toList $ groupZettelsByTagsMatching pats res) $ \(tag, zettelGrp) -> do el "section" $ do elClass "span" "ui basic pointing below grey label" $ do semanticIcon "tag" text $ unTag tag- el "ul" $ forM_ zettelGrp $ \z ->- el "li" $- renderZettelLink (Just conn) (Just $ zettelsViewLinkView view) z+ el "ul" $+ forM_ zettelGrp $ \z ->+ el "li" $+ renderZettelLink Nothing (Just conn) (Just $ zettelsViewLinkView view) z q@(ZettelQuery_Tags _) :=> Identity res -> do el "section" $ do renderQuery $ Some q renderTagTree $ foldTagTree $ tagTree res+ ZettelQuery_TagZettel tag :=> Identity () ->+ renderInlineTag tag mempty $ do+ text "#"+ text $ unTag tag where -- TODO: Instead of doing this here, group the results in runQuery itself. groupZettelsByTagsMatching pats matches =- fmap sortZettelsReverseChronological $ Map.fromListWith (<>) $ flip concatMap matches $ \z ->- flip concatMap (zettelTags z) $ \t -> [(t, [z]) | tagMatchAny pats t]+ fmap sortZettelsReverseChronological $+ Map.fromListWith (<>) $+ flip concatMap matches $ \z ->+ flip concatMap (zettelTags z) $ \t -> [(t, [z]) | tagMatchAny pats t] renderQuery :: DomBuilder t m => Some ZettelQuery -> m () renderQuery someQ =@@ -91,10 +112,21 @@ Some (ZettelQuery_Tags (fmap unTagPattern -> pats)) -> do let qs = toText $ intercalate ", " pats text $ "Tags matching '" <> qs <> "'"+ Some (ZettelQuery_TagZettel _tag) -> do+ blank -- | Render a link to an individual zettel.-renderZettelLink :: DomBuilder t m => Maybe Connection -> Maybe LinkView -> Zettel -> NeuronWebT t m ()-renderZettelLink conn (fromMaybe def -> linkView) Zettel {..} = do+renderZettelLink ::+ DomBuilder t m =>+ -- | Link inner text+ Maybe (m ()) ->+ -- | Connection type to display+ Maybe Connection ->+ -- | Link theme+ Maybe LinkView ->+ Zettel ->+ NeuronWebT t m ()+renderZettelLink mInner conn (fromMaybe def -> linkView) Zettel {..} = do let connClass = show <$> conn rawClass = either (const $ Just "raw") (const Nothing) zettelError mextra =@@ -102,28 +134,38 @@ LinkView_Default -> Nothing LinkView_ShowDate ->- elTime <$> zettelDay+ elTime <$> zettelDate LinkView_ShowID ->- Just $ el "tt" $ text $ zettelIDText zettelID+ Just $ el "tt" $ text $ zettelIDRaw zettelID classes :: [Text] = catMaybes $ [Just "zettel-link-container"] <> [connClass, rawClass] elClass "span" (T.intercalate " " classes) $ do forM_ mextra $ \extra ->- elAttr "span" ("class" =: "extra monoFont" <> noSnippet) $ do+ elNoSnippetSpan ("class" =: "extra monoFont") $ do extra -- The extra space is so that double clicking on this extra text -- doesn't select the title next. text " "- let linkTooltip =+ elAttr "span" ("class" =: "zettel-link" <> withTooltip linkTooltip) $ do+ let linkInnerHtml = fromMaybe (text zettelTitle) mInner+ neuronRouteLink (Some $ Route_Zettel zettelID) mempty linkInnerHtml+ case conn of+ Just Folgezettel -> elNoSnippetSpan mempty $ do+ elAttr "sup" ("title" =: "Branching link (folgezettel)") $ text "ᛦ"+ _ -> pure mempty+ where+ linkTooltip =+ -- If there is custom inner text, put zettel title in tooltip.+ -- Otherwise put tags if any.+ if isJust mInner+ then Just $ "Zettel: " <> zettelTitle+ else if null zettelTags then Nothing else Just $ "Tags: " <> T.intercalate "; " (unTag <$> zettelTags)- elAttr "span" ("class" =: "zettel-link" <> withTooltip linkTooltip) $ do- neuronRouteLink (Some $ Route_Zettel zettelID) mempty $ text zettelTitle- where -- Prevent this element from appearing in Google search results -- https://developers.google.com/search/reference/robots_meta_tag#data-nosnippet-attr- noSnippet :: Map Text Text- noSnippet = "data-nosnippet" =: ""+ elNoSnippetSpan :: DomBuilder t m => Map Text Text -> NeuronWebT t m a -> NeuronWebT t m a+ elNoSnippetSpan attrs = elAttr "span" ("data-nosnippet" =: "" <> attrs) withTooltip :: Maybe Text -> Map Text Text withTooltip = \case Nothing -> mempty@@ -138,29 +180,29 @@ renderZettelLinkIDOnly zid = elClass "span" "zettel-link-container" $ do elClass "span" "zettel-link" $ do- neuronRouteLink (Some $ Route_Zettel zid) mempty $ text $ zettelIDText zid+ neuronRouteLink (Some $ Route_Zettel zid) mempty $ text $ zettelIDRaw zid -renderTagTree :: forall t m. DomBuilder t m => Forest (NonEmpty TagNode, Natural) -> m ()+renderTagTree :: forall t m. DomBuilder t m => Forest (NonEmpty TagNode, Natural) -> NeuronWebT t m () renderTagTree t = divClass "tag-tree" $ renderForest mempty t where- renderForest :: [TagNode] -> Forest (NonEmpty TagNode, Natural) -> m ()+ renderForest :: [TagNode] -> Forest (NonEmpty TagNode, Natural) -> NeuronWebT t m () renderForest ancestors forest = el "ul" $ do forM_ forest $ \tree -> el "li" $ renderTree ancestors tree- renderTree :: [TagNode] -> Tree (NonEmpty TagNode, Natural) -> m ()+ renderTree :: [TagNode] -> Tree (NonEmpty TagNode, Natural) -> NeuronWebT t m () renderTree ancestors (Node (tagNode, count) children) = do renderTag ancestors (tagNode, count) renderForest (ancestors <> toList tagNode) $ toList children- renderTag :: [TagNode] -> (NonEmpty TagNode, Natural) -> m ()+ renderTag :: [TagNode] -> (NonEmpty TagNode, Natural) -> NeuronWebT t m () renderTag ancestors (tagNode, count) = do let tag = constructTag $ maybe tagNode (<> tagNode) $ nonEmpty ancestors tit = show count <> " zettels tagged" cls = bool "" "inactive" $ count == 0 divClass "node" $ do- elAttr "a" ("class" =: cls <> "title" =: tit <> "href" =: tagUrl tag) $ do+ renderInlineTag tag ("class" =: cls <> "title" =: tit) $ text $ renderTagNode tagNode renderTagNode :: NonEmpty TagNode -> Text renderTagNode = \case@@ -171,14 +213,9 @@ Just rest -> unTagNode n <> "/" <> renderTagNode rest --- TODO: not using Rib for ghcjs, but factorize this-zettelUrl :: ZettelID -> Text-zettelUrl zid =- zettelIDText zid <> ".html"--tagUrl :: Tag -> Text-tagUrl (Tag s) =- "search.html?tag=" <> s+renderInlineTag :: DomBuilder t m => Tag -> Map Text Text -> m () -> NeuronWebT t m ()+renderInlineTag tag attr body =+ neuronRouteLink (Some $ Route_Search $ Just tag) attr body style :: Css style = do@@ -196,9 +233,6 @@ C.textDecoration C.none "span.zettel-link-container span.extra" ? do C.color C.auto- "span.zettel-link-container.folgezettel::after" ? do- C.paddingLeft $ em 0.3- C.content $ C.stringContent "ᛦ" "span.zettel-link-container.raw" ? do C.border C.solid (C.px 1) C.red "[data-tooltip]:after" ? do
src/lib/Neuron/Web/Route.hs view
@@ -2,6 +2,7 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE NoImplicitPrelude #-} @@ -9,7 +10,10 @@ module Neuron.Web.Route where import Control.Monad.Reader+import Data.GADT.Compare.TH+import Data.GADT.Show.TH import Data.Some+import Data.TagTree (Tag) import Neuron.Zettelkasten.ID import Neuron.Zettelkasten.Zettel import Reflex.Dom.Core@@ -21,7 +25,9 @@ -- `Left` is skipped zettels; and Right is valid zettels with invalid query links. Route_ZIndex :: Route (Map ZettelID ZettelError) -- | Takes search JS code as render data- Route_Search :: Route Text+ -- The tag argument is only used in rendering the URL, and not when writing the file.+ -- TODO: Fix this bad use of types.+ Route_Search :: Maybe Tag -> Route Text Route_Zettel :: ZettelID -> Route ZettelC data RouteConfig t m = RouteConfig@@ -57,6 +63,10 @@ routeTitle' v = \case Route_Redirect _ -> "Redirecting..." Route_ZIndex -> "Zettel Index"- Route_Search -> "Search"+ Route_Search _mtag -> "Search" Route_Zettel _ -> either zettelTitle zettelTitle v++deriveGEq ''Route++deriveGShow ''Route
src/lib/Neuron/Web/Theme.hs view
@@ -13,7 +13,7 @@ ) where -import Clay ((?), Css, rgb, rgba)+import Clay (Css, rgb, rgba, (?)) import qualified Clay as C import Data.Text (toLower) import Relude@@ -41,14 +41,14 @@ -- | Make Theme from Semantic UI color name mkTheme :: Text -> Theme mkTheme s =- fromMaybe (error $ "Unsupported theme: " <> s)- $ listToMaybe- $ catMaybes- $ flip fmap [minBound .. maxBound]- $ \theme ->- if s == semanticColor theme- then Just theme- else Nothing+ fromMaybe (error $ "Unsupported theme: " <> s) $+ listToMaybe $+ catMaybes $+ flip fmap [minBound .. maxBound] $+ \theme ->+ if s == semanticColor theme+ then Just theme+ else Nothing -- | Convert Theme to Semantic UI color name semanticColor :: Theme -> Text
src/lib/Neuron/Web/Widget.hs view
@@ -1,21 +1,21 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE ViewPatterns #-} {-# LANGUAGE NoImplicitPrelude #-} module Neuron.Web.Widget where import qualified Data.Text as T-import Data.Time-import Neuron.Zettelkasten.Zettel.Meta (formatZettelDate)+import Data.Time.DateMayTime (DateMayTime, formatDateMayTime, formatDay, getDay) import Reflex.Dom.Core import Relude -- | <time> element-elTime :: DomBuilder t m => Day -> m ()+elTime :: DomBuilder t m => DateMayTime -> m () elTime t = do- let s = formatZettelDate t -- cf. https://developer.mozilla.org/en-US/docs/Web/HTML/Element/time#Attributes- elAttr "time" ("datetime" =: s) $ text s+ elAttr "time" ("datetime" =: formatDateMayTime t) $ do+ text $ formatDay $ getDay t semanticIcon :: DomBuilder t m => Text -> m () semanticIcon name = elClass "i" (name <> " icon") blank
src/lib/Neuron/Web/Widget/InvertedTree.hs view
@@ -91,22 +91,24 @@ C.listStyleType none C.position relative C.padding (em 1) (em 0.5) (em 0) (em 0.5)- forM_ [C.before, C.after] $ \sel -> sel & do- C.content $ stringContent ""- C.position absolute- C.top $ px 0- C.right $ pct 50- C.borderTop solid cellBorderWidth "#ccc"- C.width $ pct 50- C.height $ em 1.2+ forM_ [C.before, C.after] $ \sel ->+ sel & do+ C.content $ stringContent ""+ C.position absolute+ C.top $ px 0+ C.right $ pct 50+ C.borderTop solid cellBorderWidth "#ccc"+ C.width $ pct 50+ C.height $ em 1.2 C.after & do C.right auto C.left $ pct 50 C.borderLeft solid cellBorderWidth "#ccc" C.onlyChild & do C.paddingTop $ em 0- forM_ [C.after, C.before] $ \sel -> sel & do- C.display none+ forM_ [C.after, C.before] $ \sel ->+ sel & do+ C.display none C.firstChild & do C.before & do C.borderStyle none
src/lib/Neuron/Web/ZIndex.hs view
@@ -14,7 +14,7 @@ ) where -import Clay ((?), Css, em)+import Clay (Css, em, (?)) import qualified Clay as C import Data.Foldable (maximum) import qualified Data.Map.Strict as Map@@ -26,11 +26,11 @@ import Neuron.Zettelkasten.Connection import Neuron.Zettelkasten.Graph (ZettelGraph) import qualified Neuron.Zettelkasten.Graph as G-import Neuron.Zettelkasten.ID+import Neuron.Zettelkasten.ID (ZettelID (..)) import Neuron.Zettelkasten.Query (zettelsByTag) import Neuron.Zettelkasten.Query.Error (showQueryError) import Neuron.Zettelkasten.Zettel-import Reflex.Dom.Core hiding ((&))+import Reflex.Dom.Core hiding (mapMaybe, (&)) import Relude hiding ((&)) -- | The value needed to render the z-index@@ -40,6 +40,7 @@ data ZIndex = ZIndex { -- | Clusters on the folgezettel graph. zIndexClusters :: [Forest (Zettel, [Zettel])],+ zIndexOrphans :: [Zettel], -- | All zettel errors zIndexErrors :: Map ZettelID ZettelError, zIndexStats :: Stats,@@ -54,18 +55,23 @@ buildZIndex :: ZettelGraph -> Map ZettelID ZettelError -> ZIndex buildZIndex graph errors =- let clusters = G.categoryClusters graph- clusters' :: [Forest (Zettel, [Zettel])] =+ let (orphans, clusters) = partitionEithers $+ flip fmap (G.categoryClusters graph) $ \case+ [Node z []] -> Left z -- Orphans (cluster of exactly one)+ x -> Right x+ clustersWithBacklinks :: [Forest (Zettel, [Zettel])] =+ -- Compute backlinks for each node in the tree. flip fmap clusters $ \(zs :: [Tree Zettel]) -> G.backlinksMulti Folgezettel zs graph stats = Stats (length $ G.getZettels graph) (G.connectionCount graph) pinnedZettels = zettelsByTag (G.getZettels graph) [mkTagPattern "pinned"]- in ZIndex (fmap sortCluster clusters') errors stats pinnedZettels+ in ZIndex (fmap sortCluster clustersWithBacklinks) orphans errors stats pinnedZettels where -- TODO: Either optimize or get rid of this (or normalize the sorting somehow) sortCluster fs =- sortZettelForest $ flip fmap fs $ \Node {..} ->- Node rootLabel $ sortZettelForest subForest+ sortZettelForest $+ flip fmap fs $ \Node {..} ->+ Node rootLabel $ sortZettelForest subForest -- Sort zettel trees so that trees containing the most recent zettel (by ID) come first. sortZettelForest = reverse . sortOn maximum @@ -78,6 +84,26 @@ elClass "h1" "header" $ text "Zettel Index" renderErrors zIndexErrors divClass "z-index" $ do+ forM_ (nonEmpty zPinned) $ \zs ->+ divClass "ui pinned raised segment" $ do+ elClass "h3" "ui header" $ text "Pinned"+ el "ul" $+ forM_ zs $ \z ->+ el "li" $ QueryView.renderZettelLink Nothing Nothing def z+ whenNotNull zIndexOrphans $ \(toList -> zs) ->+ divClass ("ui piled segment") $ do+ elClass "h3" "ui header" $ text "Folgezettel Orphans"+ elClass "p" "info" $ do+ text "Notes without any "+ elAttr "a" ("href" =: "https://neuron.zettel.page/linking.html") $ text "folgezettel"+ text " relationships"+ el "ul" $+ forM_ zs $ \z ->+ el "li" $ do+ QueryView.renderZettelLink Nothing Nothing def z+ forM_ zIndexClusters $ \forest ->+ divClass ("ui " <> themeColor <> " segment") $ do+ el "ul" $ renderForest forest el "p" $ do text $ "The zettelkasten has "@@ -86,15 +112,8 @@ <> countNounBe "link" "links" (statsZettelConnectionCount zIndexStats) text $ ". It has " <> countNounBe "cluster" "clusters" (length zIndexClusters) <> " in its folgezettel graph. " text "Each cluster's "- elAttr "a" ("href" =: "https://neuron.zettel.page/2017401.html") $ text "folgezettel heterarchy"+ elAttr "a" ("href" =: "https://neuron.zettel.page/folgezettel-heterarchy.html") $ text "folgezettel heterarchy" text " is rendered as a forest."- forM_ (nonEmpty zPinned) $ \zs ->- divClass "ui message pinned raised segment" $ do- el "ul" $ forM_ zs $ \z ->- el "li" $ QueryView.renderZettelLink Nothing def z- forM_ zIndexClusters $ \forest ->- divClass ("ui " <> themeColor <> " segment") $ do- el "ul" $ renderForest forest where countNounBe noun nounPlural = \case 1 -> "1 " <> noun@@ -117,8 +136,8 @@ text " has malformed queries" ZettelError_AmbiguousFiles _ -> do text $- "More than one file define the same zettel ID ("- <> zettelIDText zid+ "More than one file define the same zettel ID slug ("+ <> zettelIDSlug zid <> "):" forM_ (Map.toList errors) $ \(zid, zError) -> divClass ("ui tiny message " <> severity zError) $ do@@ -143,7 +162,7 @@ renderForest trees = do forM_ trees $ \(Node (zettel, uplinks) subtrees) -> el "li" $ do- QueryView.renderZettelLink Nothing def zettel+ QueryView.renderZettelLink Nothing Nothing def zettel when (length uplinks >= 2) $ do elClass "span" "uplinks" $ do forM_ uplinks $ \z2 -> do@@ -155,6 +174,8 @@ style :: Css style = do "div.z-index" ? do+ "p.info" ? do+ C.color C.gray C.ul ? do C.listStyleType C.square C.paddingLeft $ em 1.5
src/lib/Neuron/Web/Zettel/CSS.hs view
@@ -40,11 +40,18 @@ zettelContentCss :: Css zettelContentCss = do+ ".pandoc" ? do+ -- GitHub task list+ ".ui.disabled.fitted.checkbox" ? do+ C.marginRight $ em 0.3+ C.verticalAlign C.middle ".zettel-content" ? do -- All of these apply to the zettel content card only.- "div.date" ? do- C.textAlign C.center- C.color C.gray+ ".metadata" ? do+ C.marginTop $ em 1+ "div.date" ? do+ C.textAlign C.center+ C.color C.gray C.h1 ? do C.paddingTop $ em 0.2 C.paddingBottom $ em 0.2
src/lib/Neuron/Web/Zettel/View.hs view
@@ -15,6 +15,7 @@ ) where +import Data.Some import Data.TagTree import qualified Neuron.Web.Query.View as Q import Neuron.Web.Route@@ -40,7 +41,7 @@ let upTree = G.backlinkForest Folgezettel z graph unless (null upTree) $ do IT.renderInvertedHeadlessTree "zettel-uptree" "deemphasized" upTree $ \z2 ->- Q.renderZettelLink (G.getConnection z z2 graph) def z2+ Q.renderZettelLink Nothing (G.getConnection z z2 graph) def z2 -- Main content elAttr "div" ("class" =: "ui text container" <> "id" =: "zettel-container" <> "style" =: "position: relative") $ do whenStaticallyGenerated $ do@@ -69,21 +70,21 @@ renderZettelBottomPane :: DomBuilder t m => ZettelGraph -> Zettel -> NeuronWebT t m () renderZettelBottomPane graph z@Zettel {..} = do- let cfBacklinks = nonEmpty $ fmap snd $ G.backlinks (== Just OrdinaryConnection) z graph+ let backlinks = nonEmpty $ G.backlinks isJust z graph tags = nonEmpty zettelTags- when (isJust cfBacklinks || isJust tags)- $ elClass "nav" "ui bottom attached segment deemphasized"- $ do- divClass "ui two column grid" $ do- divClass "column" $ do- whenJust cfBacklinks $ \links -> do- elAttr "div" ("class" =: "ui header" <> "title" =: "Zettels that link here, but without branching") $- text "More backlinks"- el "ul" $ do- forM_ links $ \zl ->- el "li" $ Q.renderZettelLink Nothing def zl- whenJust tags $- divClass "column" . renderTags+ when (isJust backlinks || isJust tags) $+ elClass "nav" "ui bottom attached segment deemphasized" $+ do+ divClass "ui grid" $ do+ divClass "fourteen wide column" $ do+ whenJust backlinks $ \links -> do+ elAttr "div" ("class" =: "ui header" <> "title" =: "Zettels that link here (branching or not)") $+ text "Backlinks"+ el "ul" $ do+ forM_ links $ \(conn, zl) ->+ el "li" $ Q.renderZettelLink Nothing (Just conn) def zl+ whenJust tags $+ divClass "two wide column" . renderTags evalAndRenderZettelQuery :: PandocBuilder t m =>@@ -91,7 +92,7 @@ NeuronWebT t m [QueryError] -> URILink -> NeuronWebT t m [QueryError]-evalAndRenderZettelQuery graph oldRender uriLink = do+evalAndRenderZettelQuery graph oldRender uriLink@(URILink inner _uri) = do case flip runReaderT (G.getZettels graph) (Q.runQueryURILink uriLink) of Left e -> do -- Error parsing or running the query.@@ -100,7 +101,7 @@ -- This is not a query link; pass through. oldRender Right (Just res) -> do- Q.renderQueryResult res+ Q.renderQueryResult inner res pure mempty where elInlineError e =@@ -118,10 +119,10 @@ unless zettelTitleInBody $ do el "h1" $ text zettelTitle void $ elPandoc (Config handleLink) zettelContent- whenJust zettelDay $ \day ->- elAttr "div" ("class" =: "date" <> "title" =: "Zettel creation date") $ do- text "Created on: "- elTime day+ whenJust zettelDate $ \date ->+ divClass "metadata" $ do+ elAttr "div" ("class" =: "date" <> "title" =: "Zettel date") $ do+ elTime date renderZettelRawContent :: (DomBuilder t m) => ZettelT Text -> m () renderZettelRawContent Zettel {..} = do@@ -131,19 +132,18 @@ elClass "article" "ui raised attached segment zettel-content raw" $ do el "pre" $ text $ zettelContent -renderTags :: DomBuilder t m => NonEmpty Tag -> m ()+renderTags :: DomBuilder t m => NonEmpty Tag -> NeuronWebT t m () renderTags tags = do forM_ tags $ \t -> do -- NOTE(ui): Ideally this should be at the top, not bottom. But putting it at -- the top pushes the zettel content down, introducing unnecessary white -- space below the title. So we put it at the bottom for now. elAttr "span" ("class" =: "ui right ribbon label zettel-tag" <> "title" =: "Tag") $ do- elAttr- "a"- ( "href" =: (Q.tagUrl t)- <> "class" =: "tag-inner"+ neuronRouteLink+ (Some $ Route_Search $ Just t)+ ( "class" =: "tag-inner" <> "title" =: ("See all zettels tagged '" <> unTag t <> "'") )- $ text- $ unTag t+ $ do+ text $ unTag t el "p" blank
src/lib/Neuron/Zettelkasten/Connection.hs view
@@ -6,7 +6,6 @@ module Neuron.Zettelkasten.Connection where import Data.Aeson (FromJSON, ToJSON)-import Data.Default import Relude hiding (show) import Text.Show @@ -24,9 +23,6 @@ Folgezettel <> _ = Folgezettel _ <> Folgezettel = Folgezettel OrdinaryConnection <> OrdinaryConnection = OrdinaryConnection--instance Default Connection where- def = Folgezettel instance Show Connection where show = \case
src/lib/Neuron/Zettelkasten/Graph.hs view
@@ -14,21 +14,19 @@ getZettels, getZettel, getConnection,- topSort, frontlinkForest, backlinkForest, backlinks, backlinksMulti,- clusters, categoryClusters, connectionCount, ) where import qualified Algebra.Graph.Labelled.AdjacencyMap as LAM-import Data.Default import Data.Foldable (maximum) import qualified Data.Graph.Labelled as G+import qualified Data.Set as Set import Data.Tree import Neuron.Zettelkasten.Connection import Neuron.Zettelkasten.Graph.Type@@ -72,37 +70,41 @@ (y, f y) categoryClusters :: ZettelGraph -> [Forest Zettel]-categoryClusters (categoryGraph -> g) =- let cs :: [[Zettel]] = sortMothers $ clusters g- in flip fmap cs $ \zs -> G.bfsForestFrom zs g+categoryClusters (G.induceOnEdge (== Just Folgezettel) -> g) =+ let cs :: [[Zettel]] = sortMothers $ G.clusters g+ cleanClusters = flip G.bfsForestFrom g <$> cs+ clusteredZettels :: [Zettel] =+ (flatten `concatMap`) `concatMap` cleanClusters+ unclustered =+ Set.map zettelID $+ Set.fromList (getZettels g)+ `Set.difference` Set.fromList clusteredZettels+ uncleanCluster =+ G.dfsForest $+ G.induce (flip Set.member unclustered) g+ in cleanClusters+ <> if null uncleanCluster+ then mempty+ else pure uncleanCluster where -- Sort clusters with newer mother zettels appearing first. sortMothers :: [NonEmpty Zettel] -> [[Zettel]] sortMothers = sortOn (Down . maximum) . fmap (sortOn Down . toList) -clusters :: ZettelGraph -> [NonEmpty Zettel]-clusters g =- case (G.clusters $ categoryGraph g) of- [] ->- maybe [] pure $ nonEmpty $ G.getVertices g- cs ->- cs--topSort :: ZettelGraph -> Either (NonEmpty Zettel) [Zettel]-topSort = G.topSort . categoryGraph--categoryGraph :: ZettelGraph -> ZettelGraph-categoryGraph = G.induceOnEdge (== Just Folgezettel)- getZettels :: ZettelGraph -> [Zettel] getZettels = G.getVertices getZettel :: ZettelID -> ZettelGraph -> Maybe Zettel getZettel = G.findVertex --- | If no connection exists, this returns Nothing.+-- | Return the connection if any between two zettels+--+-- If no connection exists, this returns Nothing. getConnection :: Zettel -> Zettel -> ZettelGraph -> Maybe Connection-getConnection z1 z2 g = fmap (fromMaybe def) $ G.edgeLabel g z1 z2+getConnection z1 z2 g =+ -- Use `join` so that empty edge monoid is treated as an abscence of edge+ -- (connection)+ join $ G.edgeLabel g z1 z2 connectionCount :: ZettelGraph -> Int connectionCount = LAM.edgeCount . G.getGraph
src/lib/Neuron/Zettelkasten/Graph/Build.hs view
@@ -29,12 +29,12 @@ ) buildZettelkasten fs = let zs = parseZettels fs- (g, queryErrors) = mkZettelGraph $ sansContent <$> zs+ (g, queryErrors) = mkZettelGraph $ filter (not . zettelUnlisted) $ sansContent <$> zs errors = Map.unions- [ fmap ZettelError_ParseError- $ Map.fromList- $ lefts zs <&> (zettelID &&& zettelError),+ [ fmap ZettelError_ParseError $+ Map.fromList $+ lefts zs <&> (zettelID &&& zettelError), fmap ZettelError_QueryErrors queryErrors ] in (g, zs, errors)@@ -49,23 +49,25 @@ Map ZettelID (NonEmpty QueryError) ) mkZettelGraph zettels =- let res :: [(Zettel, ([(Maybe Connection, Zettel)], [QueryError]))] =+ let res :: [(Zettel, ([(Connection, Zettel)], [QueryError]))] = flip fmap zettels $ \z -> (z, runQueryConnections zettels z)- g :: ZettelGraph = G.mkGraphFrom zettels $ flip concatMap res $ \(z1, fst -> conns) ->- edgeFromConnection z1 <$> conns- errors = Map.fromList $ flip mapMaybe res $ \(z, (nonEmpty . snd -> merrs)) ->- (zettelID z,) <$> merrs+ g :: ZettelGraph = G.mkGraphFrom zettels $+ flip concatMap res $ \(z1, fst -> conns) ->+ edgeFromConnection z1 <$> conns+ errors = Map.fromList $+ flip mapMaybe res $ \(z, (nonEmpty . snd -> merrs)) ->+ (zettelID z,) <$> merrs in (g, errors) -runQueryConnections :: [Zettel] -> Zettel -> ([(Maybe Connection, Zettel)], [QueryError])+runQueryConnections :: [Zettel] -> Zettel -> ([(Connection, Zettel)], [QueryError]) runQueryConnections zettels z = flip runReader zettels $ do runWriterT $ queryConnections z -edgeFromConnection :: Zettel -> (Maybe Connection, Zettel) -> (Maybe Connection, Zettel, Zettel)+edgeFromConnection :: Zettel -> (Connection, Zettel) -> (Maybe Connection, Zettel, Zettel) edgeFromConnection z (c, z2) =- (connectionMonoid $ fromMaybe Folgezettel c, z, z2)+ (connectionMonoid c, z, z2) where -- Our connection monoid will never be Nothing (mempty); see the note in -- type `ZettelGraph`.
src/lib/Neuron/Zettelkasten/ID.hs view
@@ -10,80 +10,75 @@ module Neuron.Zettelkasten.ID ( ZettelID (..), InvalidID (..),- zettelIDText,+ unsafeMkZettelID,+ indexZid, parseZettelID,- parseZettelID',+ allowedSpecialChars, idParser,+ idParser', getZettelID, zettelIDSourceFileName,- customIDParser, ) where import Data.Aeson import Data.Aeson.Types (toJSONKeyText) import qualified Data.Text as T-import Data.Time import Neuron.Reader.Type (ZettelFormat, zettelFormatToExtension) import Relude import System.FilePath import qualified Text.Megaparsec as M import qualified Text.Megaparsec.Char as M import Text.Megaparsec.Simple-import Text.Printf import qualified Text.Show -data ZettelID- = -- | Short Zettel ID encoding `Day` and a numeric index (on that day).- ZettelDateID Day Int- | -- | Arbitrary alphanumeric ID.- ZettelCustomID Text- deriving (Eq, Show, Ord, Generic)+data ZettelID = ZettelID+ { -- | Slug must be unique+ zettelIDSlug :: Text,+ -- | Actual ID used by the user, inside `[[..]]`+ zettelIDRaw :: Text+ }+ deriving (Show, Ord, Generic) +-- | Make ZettelID from raw text.+--+-- Assumes that input text is already validated for allowed characters.+unsafeMkZettelID :: Text -> ZettelID+unsafeMkZettelID s =+ let slug = T.intercalate "_" $ T.splitOn " " s+ in ZettelID slug s++indexZid :: ZettelID+indexZid = unsafeMkZettelID "index"++instance Eq ZettelID where+ (==) (ZettelID a _) (ZettelID b _) = a == b+ instance Show InvalidID where show (InvalidIDParseError s) = "Invalid Zettel ID: " <> toString s +instance ToJSON ZettelID where+ toJSON = toJSON . zettelIDRaw+ instance FromJSON ZettelID where- parseJSON x = do- s <- parseJSON x- case parseZettelID' s of- Left e -> fail $ show e- Right zid -> pure zid+ parseJSON = fmap unsafeMkZettelID . parseJSON instance ToJSONKey ZettelID where- toJSONKey = toJSONKeyText zettelIDText+ toJSONKey = toJSONKeyText zettelIDRaw instance FromJSONKey ZettelID where fromJSONKey = FromJSONKeyTextParser $ \s ->- case parseZettelID' s of+ case parseZettelID s of Right v -> pure v Left e -> fail $ show e -instance ToJSON ZettelID where- toJSON = toJSON . zettelIDText--zettelIDText :: ZettelID -> Text-zettelIDText = \case- ZettelDateID day idx ->- formatDay day <> toText @String (printf "%02d" idx)- ZettelCustomID s -> s--formatDay :: Day -> Text-formatDay day =- subDay $ toText $ formatTime defaultTimeLocale "%y%W%a" day- where- subDay =- T.replace "Mon" "1"- . T.replace "Tue" "2"- . T.replace "Wed" "3"- . T.replace "Thu" "4"- . T.replace "Fri" "5"- . T.replace "Sat" "6"- . T.replace "Sun" "7"- zettelIDSourceFileName :: ZettelID -> ZettelFormat -> FilePath-zettelIDSourceFileName zid fmt = toString $ zettelIDText zid <> zettelFormatToExtension fmt+zettelIDSourceFileName zid fmt =+ toString (fn <> ext)+ where+ fn = zettelIDRaw zid+ ext = zettelFormatToExtension fmt --------- -- Parser@@ -92,43 +87,39 @@ data InvalidID = InvalidIDParseError Text deriving (Eq, Generic, ToJSON, FromJSON) -parseZettelID :: HasCallStack => Text -> ZettelID+parseZettelID :: Text -> Either InvalidID ZettelID parseZettelID =- either (error . show) id . parseZettelID'--parseZettelID' :: Text -> Either InvalidID ZettelID-parseZettelID' = first InvalidIDParseError . parse idParser "parseZettelID" -idParser :: Parser ZettelID-idParser =- M.try (fmap (uncurry ZettelDateID) $ dayParser <* M.eof)- <|> fmap ZettelCustomID customIDParser+-- | Characters, aside from alpha numeric characters, to allow in IDs+allowedSpecialChars :: [Char]+allowedSpecialChars =+ [ '_',+ '-',+ '.',+ -- Whitespace is essential for title IDs+ ' ',+ -- Allow some puctuation letters that are common in note titles+ ',',+ ';',+ '(',+ ')',+ ':',+ '"',+ '\''+ ] -dayParser :: Parser (Day, Int)-dayParser = do- year <- parseNum 2- week <- parseNum 2- dayName <- dayFromIdx =<< parseNum 1- idx <- parseNum 2- day <-- parseTimeM False defaultTimeLocale "%y%W%a" $- printf "%02d" year <> printf "%02d" week <> dayName- pure (day, idx)- where- parseNum n = readNum =<< M.count n M.digitChar- readNum = maybe (fail "Not a number") pure . readMaybe- dayFromIdx :: MonadFail m => Int -> m String- dayFromIdx idx =- maybe (fail "Day should be a value from 1 to 7") pure $- ["Mon", "Tue", "Wed", "Thu", "Fri", "Sat", "Sun"] !!? (idx - 1)+idParser :: Parser ZettelID+idParser = idParser' allowedSpecialChars -customIDParser :: Parser Text-customIDParser = do- fmap toText $ M.some $ M.alphaNumChar <|> M.char '_' <|> M.char '-'+idParser' :: String -> Parser ZettelID+idParser' cs = do+ s <- M.some $ M.alphaNumChar <|> M.choice (M.char <$> cs)+ pure $ unsafeMkZettelID (toText s) -- | Parse the ZettelID if the given filepath is a zettel.-getZettelID :: FilePath -> Maybe ZettelID-getZettelID fp =- let (name, _) = splitExtension $ takeFileName fp- in rightToMaybe $ parseZettelID' $ toText name+getZettelID :: ZettelFormat -> FilePath -> Maybe ZettelID+getZettelID fmt fp = do+ let (name, ext) = splitExtension $ takeFileName fp+ guard $ zettelFormatToExtension fmt == toText ext+ rightToMaybe $ parseZettelID $ toText name
src/lib/Neuron/Zettelkasten/Query.hs view
@@ -45,6 +45,8 @@ Right allTags ZettelQuery_Tags pats -> Right $ Map.filterWithKey (const . tagMatchAny pats) allTags+ ZettelQuery_TagZettel _tag ->+ Right () where allTags :: Map.Map Tag Natural allTags =@@ -53,9 +55,11 @@ zettelsByTag :: [Zettel] -> [TagPattern] -> [Zettel] zettelsByTag zs pats =- sortZettelsReverseChronological $ flip filter zs $ \Zettel {..} ->- and $ flip fmap pats $ \pat ->- any (tagMatch pat) zettelTags+ sortZettelsReverseChronological $+ flip filter zs $ \Zettel {..} ->+ and $+ flip fmap pats $ \pat ->+ any (tagMatch pat) zettelTags runGraphQuery :: ZettelGraph -> GraphQuery r -> Either QueryResultError r runGraphQuery g = \case@@ -94,6 +98,8 @@ toJSON r ZettelQuery_Tags _ -> toJSON $ fmap treeToJson . tagTree $ r+ ZettelQuery_TagZettel _ ->+ toJSON r treeToJson (Node (tag, count) children) = object [ "name" .= tag,
src/lib/Neuron/Zettelkasten/Query/Error.hs view
@@ -8,7 +8,7 @@ import Data.Aeson import Neuron.Orphans ()-import Neuron.Zettelkasten.ID (InvalidID, ZettelID, zettelIDText)+import Neuron.Zettelkasten.ID (InvalidID, ZettelID (..)) import Relude import Text.URI (URI) import qualified Text.URI as URI@@ -20,8 +20,11 @@ | QueryParseError_UnsupportedHost URI deriving (Eq, Show, Generic, ToJSON, FromJSON) --- | This error is only thrown when *using* (eg: in HTML) the query results.-data QueryResultError = QueryResultError_NoSuchZettel ZettelID+-- | Error in evaluating a query+--+-- This error is only thrown when *using* (eg: in HTML) the query results.+data QueryResultError+ = QueryResultError_NoSuchZettel ZettelID deriving (Eq, Show, Generic, ToJSON, FromJSON) queryParseErrorUri :: QueryParseError -> URI@@ -47,4 +50,4 @@ showQueryResultError :: QueryResultError -> Text showQueryResultError (QueryResultError_NoSuchZettel zid) =- "links to non-existant zettel: " <> zettelIDText zid+ "links to non-existant zettel: " <> zettelIDRaw zid
src/lib/Neuron/Zettelkasten/Query/Eval.hs view
@@ -53,7 +53,7 @@ MonadReader [Zettel] m ) => Zettel ->- m [(Maybe Connection, Zettel)]+ m [(Connection, Zettel)] queryConnections Zettel {..} = do -- Report any query parse errors case zettelError of@@ -61,21 +61,24 @@ tell $ Left <$> queryParseErrors Left _ -> pure ()- fmap concat $ forM zettelQueries $ \someQ ->- runExceptT (runSomeZettelQuery someQ) >>= \case- Left e -> do- tell [Right e]- pure mempty- Right res ->- pure $ getConnections res+ fmap concat $+ forM zettelQueries $ \someQ ->+ runExceptT (runSomeZettelQuery someQ) >>= \case+ Left e -> do+ tell [Right e]+ pure mempty+ Right res ->+ pure $ getConnections res where- getConnections :: DSum ZettelQuery Identity -> [(Maybe Connection, Zettel)]+ getConnections :: DSum ZettelQuery Identity -> [(Connection, Zettel)] getConnections = \case- ZettelQuery_ZettelByID _ mconn :=> Identity res ->- [(mconn, res)]- ZettelQuery_ZettelsByTag _ mconn _mview :=> Identity res ->- (mconn,) <$> res+ ZettelQuery_ZettelByID _ conn :=> Identity res ->+ [(conn, res)]+ ZettelQuery_ZettelsByTag _ conn _mview :=> Identity res ->+ (conn,) <$> res ZettelQuery_Tags _ :=> _ ->+ mempty+ ZettelQuery_TagZettel _ :=> _ -> mempty runSomeZettelQuery ::
src/lib/Neuron/Zettelkasten/Query/Parser.hs view
@@ -6,16 +6,23 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ViewPatterns #-} {-# LANGUAGE NoImplicitPrelude #-} -module Neuron.Zettelkasten.Query.Parser where+module Neuron.Zettelkasten.Query.Parser+ ( queryFromURI,+ queryFromURILink,+ )+where import Control.Monad.Except import Data.Some-import Data.TagTree (mkTagPattern)+import Data.TagTree (TagNode (..), TagPattern, constructTag, mkTagPattern)+import Neuron.Reader.Type (ZettelFormat (..)) import Neuron.Zettelkasten.Connection import Neuron.Zettelkasten.ID import Neuron.Zettelkasten.Query.Error@@ -23,104 +30,117 @@ import Neuron.Zettelkasten.Zettel (ZettelQuery (..)) import Reflex.Dom.Pandoc (URILink (..)) import Relude+import Text.URI (URI) import qualified Text.URI as URI import Text.URI.QQ (queryKey) import Text.URI.Util (getQueryParam, hasQueryFlag) +-- | Parse a query if any from a Markdown link+queryFromURILink :: MonadError QueryParseError m => URILink -> m (Maybe (Some ZettelQuery))+queryFromURILink l@URILink {..} =+ queryFromURI (defaultConnection l) _uriLink_uri+ where+ -- The default connection to use if the user has not explicitly specified+ -- one in the query URI.+ defaultConnection :: URILink -> Connection+ defaultConnection URILink {..} =+ if isNothing _uriLink_inner+ then Folgezettel -- Autolinks+ -- NOTE: This will need to be changed when we implement `[[foo | some text]]`+ else OrdinaryConnection+ -- | Parse a query from the given URI.------ This function is used only in the CLI. For handling links in a Markdown file,--- your want `queryFromMarkdownLink` which allows specifying the link text as--- well.-queryFromURI :: MonadError QueryParseError m => URI.URI -> m (Maybe (Some ZettelQuery))-queryFromURI uri = do- -- We are setting markdownLinkText to the URI to support the new short links- queryFromURILink $ URILink (URI.render uri) uri+queryFromURI :: MonadError QueryParseError m => Connection -> URI -> m (Maybe (Some ZettelQuery))+queryFromURI defConn uri = do+ let conn = fromMaybe defConn (queryConn uri)+ liftEither . runMaybeT $ do+ -- Non-relevant parts of the URI should be empty+ guard $ isNothing $ URI.uriFragment uri+ case URI.uriScheme uri of+ -- Look for short links, eg: `<foo-bar>`+ Nothing -> do+ -- Detect <foo> but not </foo> or <foo/> or </foo/>+ let shortLinkPath = do+ guard $ URI.uriAuthority uri == Left False+ (False, path) <- URI.uriPath uri+ pure path+ (URI.unRText -> path) :| [] <- hoistMaybe shortLinkPath+ zid <-+ hoistMaybe $+ -- Allow raw filename (ending with ".md"). HACK: hardcoding+ -- format, but we shouldn't.+ getZettelID ZettelFormat_Markdown (toString path)+ -- Before checking for direct use of ID+ <|> rightToMaybe (parseZettelID path)+ pure $ Some $ ZettelQuery_ZettelByID zid conn+ Just (URI.unRText -> proto) -> do+ guard $ proto == "z"+ zPath <- hoistMaybe $ fmap snd (URI.uriPath uri)+ let -- Found "z:" without a trailing slash+ noSlash = URI.uriAuthority uri == Left False+ -- Found "z:/" instead of "z:"+ hasSlash = URI.uriAuthority uri == Left True+ case zPath of+ -- Parse z:/<id>+ (URI.unRText -> path) :| []+ | hasSlash -> do+ zid <- parseQueryZettelID uri path+ pure $ Some $ ZettelQuery_ZettelByID zid conn+ -- Parse z:zettel/<id>+ (URI.unRText -> "zettel") :| [URI.unRText -> path]+ | noSlash -> do+ zid <- parseQueryZettelID uri path+ pure $ Some $ ZettelQuery_ZettelByID zid conn+ -- Parse z:zettels?...+ (URI.unRText -> "zettels") :| []+ | noSlash -> do+ pure $ Some $ ZettelQuery_ZettelsByTag (tagPatterns uri "tag") conn (queryView uri)+ -- Parse z:tags?...+ (URI.unRText -> "tags") :| []+ | noSlash -> do+ pure $ Some $ ZettelQuery_Tags (tagPatterns uri "filter")+ -- Parse z:tag/foo+ (URI.unRText -> "tag") :| (nonEmpty . fmap (TagNode . URI.unRText) -> Just tagNodes)+ | noSlash -> do+ pure $ Some $ ZettelQuery_TagZettel (constructTag tagNodes)+ _ -> empty -queryFromURILink :: MonadError QueryParseError m => URILink -> m (Maybe (Some ZettelQuery))-queryFromURILink (URILink linkText uri) =- case fmap URI.unRText (URI.uriScheme uri) of- Just proto | not angleBracketLink && proto `elem` ["z", "zcf"] -> do- zid <- liftEither $ first (QueryParseError_InvalidID uri) $ parseZettelID' linkText- let mconn = if proto == "zcf" then Just OrdinaryConnection else Nothing- pure $ Just $ Some $ ZettelQuery_ZettelByID zid mconn- Just proto | proto `elem` ["zquery", "zcfquery"] ->- case uriHost uri of- Right "search" -> do- let mconn = if proto == "zcfquery" then Just OrdinaryConnection else Nothing- pure $ Just $ Some $- ZettelQuery_ZettelsByTag (tagPatterns "tag") mconn queryView- Right "tags" ->- pure $ Just $ Some $ ZettelQuery_Tags (tagPatterns "filter")- _ ->- throwError $ QueryParseError_UnsupportedHost uri- _ -> pure $ do- -- Modern links:- -- First, we expect that this is inside <..> (so same link text as link)- guard angleBracketLink- -- Then, non-relevant parts of the URI should be empty- guard $ URI.uriFragment uri == Nothing- let mconn =- if hasQueryFlag [queryKey|cf|] uri- then Just OrdinaryConnection- else Nothing- -- Found "z:" without a trailing slash- noSlash = URI.uriAuthority uri == Left False- -- Found "z:/" instead of "z:"- hasSlash = URI.uriAuthority uri == Left True- case fmap URI.unRText (URI.uriScheme uri) of- Just "z" -> do- fmap snd (URI.uriPath uri) >>= \case- (URI.unRText -> path) :| []- | hasSlash -> do- zid <- rightToMaybe $ parseZettelID' path- pure $ Some $ ZettelQuery_ZettelByID zid mconn- (URI.unRText -> "zettel") :| [URI.unRText -> path]- | noSlash -> do- zid <- rightToMaybe $ parseZettelID' path- pure $ Some $ ZettelQuery_ZettelByID zid mconn- (URI.unRText -> "zettels") :| []- | noSlash -> do- pure $ Some $ ZettelQuery_ZettelsByTag (tagPatterns "tag") mconn queryView- (URI.unRText -> "tags") :| []- | noSlash -> do- pure $ Some $ ZettelQuery_Tags (tagPatterns "filter")- _ -> Nothing- Just _ -> do- Nothing- Nothing -> do- -- Alias to short links- fmap snd (URI.uriPath uri) >>= \case- (URI.unRText -> path) :| [] -> do- zid <- rightToMaybe $ parseZettelID' path- pure $ Some $ ZettelQuery_ZettelByID zid mconn- _ ->- -- Multiple path elements, not supported- Nothing+parseQueryZettelID :: MonadError QueryParseError m => URI -> Text -> m ZettelID+parseQueryZettelID uri =+ liftEither . first (QueryParseError_InvalidID uri) . parseZettelID++tagPatterns :: URI -> Text -> [TagPattern]+tagPatterns uri k =+ mkTagPattern <$> getParamValues uri where- angleBracketLink = URI.render uri == linkText- tagPatterns k =- mkTagPattern <$> getParamValues k uri- queryView =- let isTimeline =- -- linkTheme=withDate is legacy format; timeline is current standard.- getQueryParam [queryKey|linkTheme|] uri == Just "withDate"- || hasQueryFlag [queryKey|timeline|] uri- isGrouped = hasQueryFlag [queryKey|grouped|] uri- linkView =- if isTimeline- then LinkView_ShowDate- else- if hasQueryFlag [queryKey|showid|] uri- then LinkView_ShowID- else LinkView_Default- in ZettelsView linkView isGrouped- getParamValues k u =+ getParamValues :: URI -> [Text]+ getParamValues u = flip mapMaybe (URI.uriQuery u) $ \case URI.QueryParam (URI.unRText -> key) (URI.unRText -> val) -> if key == k then Just val else Nothing _ -> Nothing- uriHost u =- fmap (URI.unRText . URI.authHost) (URI.uriAuthority u)++queryView :: URI -> ZettelsView+queryView uri =+ ZettelsView linkView isGrouped+ where+ isTimeline =+ -- linkTheme=withDate is legacy format; timeline is current standard.+ getQueryParam [queryKey|linkTheme|] uri == Just "withDate"+ || hasQueryFlag [queryKey|timeline|] uri+ isGrouped = hasQueryFlag [queryKey|grouped|] uri+ linkView =+ if isTimeline+ then LinkView_ShowDate+ else+ if hasQueryFlag [queryKey|showid|] uri+ then LinkView_ShowID+ else LinkView_Default++queryConn :: URI -> Maybe Connection+queryConn uri =+ if hasQueryFlag [queryKey|cf|] uri+ then Just OrdinaryConnection+ else Nothing
src/lib/Neuron/Zettelkasten/Zettel.hs view
@@ -25,9 +25,8 @@ import Data.GADT.Show.TH import Data.Graph.Labelled (Vertex (..)) import Data.Some-import Data.TagTree (Tag)-import Data.TagTree (TagPattern (..))-import Data.Time.Calendar+import Data.TagTree (Tag, TagPattern (..))+import Data.Time.DateMayTime (DateMayTime) import Neuron.Reader.Type import Neuron.Zettelkasten.Connection import Neuron.Zettelkasten.ID@@ -41,9 +40,10 @@ -- -- It does not care about the relationship *between* those zettels; for that use `GraphQuery`. data ZettelQuery r where- ZettelQuery_ZettelByID :: ZettelID -> Maybe Connection -> ZettelQuery Zettel- ZettelQuery_ZettelsByTag :: [TagPattern] -> Maybe Connection -> ZettelsView -> ZettelQuery [Zettel]+ ZettelQuery_ZettelByID :: ZettelID -> Connection -> ZettelQuery Zettel+ ZettelQuery_ZettelsByTag :: [TagPattern] -> Connection -> ZettelsView -> ZettelQuery [Zettel] ZettelQuery_Tags :: [TagPattern] -> ZettelQuery (Map Tag Natural)+ ZettelQuery_TagZettel :: Tag -> ZettelQuery () -- | A zettel note --@@ -51,12 +51,16 @@ data ZettelT content = Zettel { zettelID :: ZettelID, zettelFormat :: ZettelFormat,- -- Relative path to this zettel in the zettelkasten directory+ -- | Relative path to this zettel in the zettelkasten directory zettelPath :: FilePath, zettelTitle :: Text,+ -- | Whether the title was infered from the body zettelTitleInBody :: Bool, zettelTags :: [Tag],- zettelDay :: Maybe Day,+ -- | Date associated with the zettel if any+ zettelDate :: Maybe DateMayTime,+ zettelUnlisted :: Bool,+ -- | List of all queries in the zettel zettelQueries :: [Some ZettelQuery], zettelError :: ContentError content, zettelContent :: content@@ -118,7 +122,7 @@ sortZettelsReverseChronological :: [Zettel] -> [Zettel] sortZettelsReverseChronological =- sortOn (Down . zettelDay)+ sortOn (Down . zettelDate) deriveJSONGADT ''ZettelQuery
src/lib/Neuron/Zettelkasten/Zettel/Meta.hs view
@@ -1,19 +1,22 @@ {-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeApplications #-}+{-# LANGUAGE ViewPatterns #-} {-# LANGUAGE NoImplicitPrelude #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Neuron.Zettelkasten.Zettel.Meta ( Meta (..),- formatZettelDate,- parseZettelDate, ) where import Data.TagTree (Tag)-import Data.Time+import Data.Time.DateMayTime (DateMayTime) import Data.YAML import Relude @@ -22,7 +25,9 @@ { title :: Maybe Text, tags :: Maybe [Tag], -- | Creation day- date :: Maybe Day+ date :: Maybe DateMayTime,+ -- | List in the z-index+ unlisted :: Maybe Bool } deriving (Eq, Show, Generic) @@ -32,8 +37,9 @@ Meta <$> m .:? "title" -- "keywords" is an alias for "tags"- <*> (liftA2 (<|>) (m .:? "tags") (m .:? "keywords"))+ <*> liftA2 (<|>) (m .:? "tags") (m .:? "keywords") <*> m .:? "date"+ <*> m .:? "unlisted" -- NOTE: Not using this instance because it generates "tags: null" when tags is -- Nothing.@@ -44,23 +50,3 @@ -- "tags" .= tags, -- "date" .= date -- ]--instance FromYAML Day where- parseYAML =- parseZettelDate <=< parseYAML @Text--instance ToYAML Day where- toYAML =- toYAML . formatZettelDate---- | The format in which we decode and encode zettel dates.-zettelDateFormat :: String-zettelDateFormat = "%Y-%m-%d"--formatZettelDate :: Day -> Text-formatZettelDate =- toText . formatTime defaultTimeLocale zettelDateFormat--parseZettelDate :: MonadFail m => Text -> m Day-parseZettelDate =- parseTimeM False defaultTimeLocale zettelDateFormat . toString
src/lib/Neuron/Zettelkasten/Zettel/Parser.hs view
@@ -1,13 +1,17 @@ {-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE NoImplicitPrelude #-} module Neuron.Zettelkasten.Zettel.Parser where import Control.Monad.Writer+import Data.List (nub) import Data.Some-import qualified Data.Text as T+import Data.TagTree (Tag) import Neuron.Reader.Type import Neuron.Zettelkasten.ID import Neuron.Zettelkasten.Query.Error@@ -29,34 +33,39 @@ parseZettel format zreader fn zid s = do case zreader fn s of Left parseErr ->- Left $ Zettel zid format fn "Unknown" False [] Nothing [] parseErr s+ Left $ Zettel zid format fn "Unknown" False [] Nothing False [] parseErr s Right (meta, doc) ->- let (title, titleInBody) = case Meta.title =<< meta of+ let -- Determine zettel title+ (title, titleInBody) = case Meta.title =<< meta of Just tit -> (tit, False)- Nothing -> fromMaybe ("Untitled", False) $ do+ Nothing -> fromMaybe (zettelIDRaw zid, False) $ do ((,True) . plainify . snd <$> getH1 doc)- <|> ((,False) . takeInitial . plainify <$> getFirstParagraphText doc)- tags = fromMaybe [] $ Meta.tags =<< meta- day = case zid of- -- We ignore the "data" meta field on legacy Date IDs, which encode the- -- creation date in the ID.- ZettelDateID v _ -> Just v- ZettelCustomID _ -> Meta.date =<< meta+ -- Accumulate queries (queries, errors) = runWriter $ extractQueries doc- in Right $ Zettel zid format fn title titleInBody tags day queries errors doc+ -- Determine zettel tags+ metaTags = fromMaybe [] $ Meta.tags =<< meta+ queryTags = getInlineTag `mapMaybe` queries+ tags = nub $ metaTags <> queryTags+ -- Determine other metadata+ date = Meta.date =<< meta+ unlisted = fromMaybe False $ Meta.unlisted =<< meta+ in Right $ Zettel zid format fn title titleInBody tags date unlisted queries errors doc where -- Extract all (valid) queries from the Pandoc document extractQueries :: MonadWriter [QueryParseError] m => Pandoc -> m [Some ZettelQuery] extractQueries doc =- fmap catMaybes $ forM (queryURILinks doc) $ \ul ->- case queryFromURILink ul of- Left e -> do- tell [e]- pure Nothing- Right v ->- pure v- takeInitial =- (<> " ...") . T.take 18+ fmap catMaybes $+ forM (queryURILinks doc) $ \ul ->+ case queryFromURILink ul of+ Left e -> do+ tell [e]+ pure Nothing+ Right v ->+ pure v+ getInlineTag :: Some ZettelQuery -> Maybe Tag+ getInlineTag = \case+ Some (ZettelQuery_TagZettel tag) -> Just tag+ _ -> Nothing -- | Like `parseZettel` but operates on multiple files. parseZettels ::
src/lib/Text/URI/Util.hs view
@@ -13,18 +13,23 @@ getQueryParam :: URI.RText 'URI.QueryKey -> URI.URI -> Maybe Text getQueryParam k uri =- listToMaybe $ catMaybes $ flip fmap (URI.uriQuery uri) $ \case- URI.QueryFlag _ -> Nothing- URI.QueryParam key (URI.unRText -> val) ->- if key == k- then Just val- else Nothing+ listToMaybe $+ catMaybes $+ flip fmap (URI.uriQuery uri) $ \case+ URI.QueryFlag _ -> Nothing+ URI.QueryParam key (URI.unRText -> val) ->+ if key == k+ then Just val+ else Nothing hasQueryFlag :: URI.RText 'URI.QueryKey -> URI.URI -> Bool hasQueryFlag k uri =- fromMaybe False $ listToMaybe $ catMaybes $ flip fmap (URI.uriQuery uri) $ \case- URI.QueryFlag key ->- if key == k- then Just True- else Nothing- _ -> Nothing+ fromMaybe False $+ listToMaybe $+ catMaybes $+ flip fmap (URI.uriQuery uri) $ \case+ URI.QueryFlag key ->+ if key == k+ then Just True+ else Nothing+ _ -> Nothing
+ test/Data/Graph/Labelled/AlgorithmSpec.hs view
@@ -0,0 +1,42 @@+{-# LANGUAGE GeneralisedNewtypeDeriving #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE NoImplicitPrelude #-}++module Data.Graph.Labelled.AlgorithmSpec+ ( spec,+ )+where++import Data.Graph.Labelled+import Relude+import Test.Hspec++newtype SimpleVertex = SimpleVertex String+ deriving (Show, Eq, Ord, IsString)++instance Vertex SimpleVertex where+ type VertexID SimpleVertex = String+ vertexID (SimpleVertex v) = v++spec :: Spec+spec = do+ let mkG = mkGraphFrom @(Maybe ()) @SimpleVertex+ e = Just ()+ describe "cluster" $ do+ it "detects 1-graph cluster" $ do+ clusters (mkG ["a"] []) `shouldBe` ["a" :| []]+ it "detects 2-graph clusters" $ do+ sort (clusters (mkG ["a", "b"] []))+ `shouldBe` ["a" :| [], "b" :| []]+ sort (clusters (mkG ["a", "b"] [(e, "a", "b")]))+ `shouldBe` ["a" :| []]+ it "detects 2-cyclic-graph clusters" $ do+ sort (clusters (mkG ["a", "b"] [(e, "a", "b"), (e, "b", "a")]))+ -- Returns empty list on cyclic graphs+ `shouldBe` []+ it "detects 3-cyclic-graph clusters" $ do+ sort (clusters (mkG ["a", "b", "c"] [(e, "a", "b"), (e, "b", "a")]))+ -- a,b are not included, because they have no mothers.+ `shouldBe` ["c" :| []]
test/Neuron/Config/AliasSpec.hs view
@@ -26,4 +26,4 @@ fmap renderAlias (parse aliasParser "<hspec>" s) `shouldBe` Right s where renderAlias Alias {..} =- zettelIDText aliasZettel <> ":" <> zettelIDText targetZettel+ zettelIDSlug aliasZettel <> ":" <> zettelIDSlug targetZettel
test/Neuron/VersionSpec.hs view
@@ -23,15 +23,15 @@ isLesserOrEqual = shouldNotSatisfy it "simple versions" $ do -- If the user requires 0.4, and we are "older than" than that, fail (aka. isGreater)- "0.7" `isGreater` olderThan- "0.6" `isLesserOrEqual` olderThan -- This is current version+ "1.3" `isGreater` olderThan+ "1.0" `isLesserOrEqual` olderThan -- This is current version "0.4" `isLesserOrEqual` olderThan it "full versions" $ do- "0.7.1.2" `isGreater` olderThan- "0.6.12" `isGreater` olderThan- "0.6.11.8" `isGreater` olderThan- "0.6.0.0" `isLesserOrEqual` olderThan -- This is current version- "0.3.1.0" `isLesserOrEqual` olderThan+ "1.2.1.2" `isGreater` olderThan+ "1.0.15" `isGreater` olderThan+ "1.0.12.8" `isGreater` olderThan+ "1.0.0.0" `isLesserOrEqual` olderThan -- This is current version+ "0.6.1.0" `isLesserOrEqual` olderThan it "within same major version" $ do- "0.6.11.8" `isGreater` olderThan- "0.6.0.0" `isLesserOrEqual` olderThan -- This is current version+ "1.9.12.8" `isGreater` olderThan+ "1.0.0.0" `isLesserOrEqual` olderThan -- This is current version
test/Neuron/Zettelkasten/ID/SchemeSpec.hs view
@@ -7,7 +7,6 @@ where import qualified Data.Set as Set-import Data.Time import Neuron.Zettelkasten.ID import Neuron.Zettelkasten.ID.Scheme import Relude@@ -19,11 +18,10 @@ let zettels = Set.fromList $ fmap- parseZettelID+ (either (error . show) id . parseZettelID) [ "ribeye-steak", "2015403" ]- day = fromGregorian 2020 4 16 nextAvail scheme = do v <- genVal scheme pure $ nextAvailableZettelID zettels v scheme@@ -33,15 +31,7 @@ `shouldReturn` Left IDConflict_AlreadyExists it "succeeds" $ do nextAvail (IDSchemeCustom "sunny-side-eggs")- `shouldReturn` Right (ZettelCustomID "sunny-side-eggs")- context "date ID" $ do- it "should return index 0" $ do- let otherDay = fromGregorian 2020 5 16- nextAvail (IDSchemeDate otherDay)- `shouldReturn` Right (ZettelDateID otherDay 1)- it "should return correct index" $- nextAvail (IDSchemeDate day)- `shouldReturn` Right (ZettelDateID day 4)+ `shouldReturn` Right (unsafeMkZettelID "sunny-side-eggs") context "hash ID" $ do it "should succeed" $ nextAvail IDSchemeHash
test/Neuron/Zettelkasten/IDSpec.hs view
@@ -7,7 +7,6 @@ where import qualified Data.Aeson as Aeson-import Data.Time.Calendar import qualified Neuron.Reader.Type as Z import qualified Neuron.Zettelkasten.ID as Z import Relude@@ -16,31 +15,30 @@ spec :: Spec spec = do describe "ID parsing" $ do- let day = fromGregorian 2020 3 19- context "date id parsing" $ do- let zid = Z.ZettelDateID day 1- it "parses a zettel ID" $ do- Z.parseZettelID "2011401" `shouldBe` zid- it "parses a zettel ID from zettel filename" $ do- Z.getZettelID "2011401.md" `shouldBe` Just zid- Z.zettelIDSourceFileName zid Z.ZettelFormat_Markdown `shouldBe` "2011401.md" context "custom id parsing" $ do- let zid = Z.ZettelCustomID "20abcde"+ let zid = Z.unsafeMkZettelID "20abcde" it "parses a custom zettel ID" $ do- Z.parseZettelID' "20abcde" `shouldBe` Right zid+ Z.parseZettelID "20abcde" `shouldBe` Right zid it "parses a custom zettel ID from zettel filename" $ do- Z.getZettelID "20abcde.md" `shouldBe` Just zid+ Z.getZettelID Z.ZettelFormat_Markdown "20abcde.md" `shouldBe` Just zid Z.zettelIDSourceFileName zid Z.ZettelFormat_Markdown `shouldBe` "20abcde.md"- let deceptiveZid = Z.ZettelCustomID "2136537e"+ let deceptiveZid = Z.unsafeMkZettelID "2136537e" it "parses a custom zettel ID that looks like date ID" $ do- Z.parseZettelID' "2136537e" `shouldBe` Right deceptiveZid+ Z.parseZettelID "2136537e" `shouldBe` Right deceptiveZid+ it "parses a custom zettel ID with dot" $ do+ Z.parseZettelID "foo.bar" `shouldBe` Right (Z.ZettelID "foo.bar" "foo.bar")+ -- Even if there is a ".md" (not a file extension)+ Z.parseZettelID "foo.md" `shouldBe` Right (Z.ZettelID "foo.md" "foo.bar")+ it "parses full-phrase IDs" $ do+ Z.parseZettelID "foo bar" `shouldBe` Right (Z.ZettelID "foo_bar" "foo bar")+ context "i18n" $ do+ it "deals with unicode chars" $ do+ Z.parseZettelID "计算机" `shouldBe` Right (Z.ZettelID "计算机" "计算机")+ context "failures" $ do+ it "fails to parse ID with disallowed characters" $ do+ Z.parseZettelID "/foo" `shouldSatisfy` isLeft+ Z.parseZettelID "foo$" `shouldSatisfy` isLeft describe "ID converstion" $ do context "JSON encoding" $ do- let day = fromGregorian 2020 3 19- zid = Z.ZettelDateID day 1 it "Converts ID to text when encoding to JSON" $ do- Aeson.toJSON (Z.ZettelCustomID "20abcde") `shouldBe` Aeson.String "20abcde"- Aeson.toJSON zid `shouldBe` Aeson.String "2011401"- it "Date ID to Text" $ do- let day = fromGregorian 2020 4 21- Z.zettelIDText (Z.ZettelDateID day 1) `shouldBe` "2016201"+ Aeson.toJSON (Z.unsafeMkZettelID "20abcde") `shouldBe` Aeson.String "20abcde"
test/Neuron/Zettelkasten/Query/ParserSpec.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE NoImplicitPrelude #-} @@ -7,105 +8,93 @@ ) where +import Control.Monad.Catch (MonadThrow) import Data.Default (def)-import Data.Some-import Data.TagTree-import Neuron.Zettelkasten.Connection-import Neuron.Zettelkasten.ID-import Neuron.Zettelkasten.Query.Parser-import Neuron.Zettelkasten.Query.Theme-import Neuron.Zettelkasten.Zettel-import Reflex.Dom.Pandoc.URILink+import Data.Some (Some (Some))+import Data.TagTree (Tag (Tag), mkTagPattern)+import qualified Network.URI.Encode as E+import Neuron.Zettelkasten.Connection (Connection (..))+import Neuron.Zettelkasten.ID (unsafeMkZettelID)+import Neuron.Zettelkasten.Query.Parser (queryFromURILink)+import Neuron.Zettelkasten.Zettel (ZettelQuery (..))+import Reflex.Dom.Pandoc.URILink (URILink (URILink)) import Relude import Test.Hspec-import Text.URI+import Text.Pandoc.Definition (Inline (Str))+import Text.URI (URI, mkURI) spec :: Spec spec = do- legacyLinks- shortLinks--legacyLinks :: Spec-legacyLinks = do- describe "Parse zettels by tag URIs" $ do- for_ [("zquery", Nothing), ("zcfquery", Just OrdinaryConnection)] $ \(scheme, mconn) -> do- context scheme $ do- let zettelsByTag pat mview =- Right $ Just $ Some $ ZettelQuery_ZettelsByTag (fmap mkTagPattern pat) mconn mview- withScheme s = toText scheme <> s- legacyLink l = mkURILink "." l- it "Parse all zettels URI" $ do- queryFromURILink (legacyLink $ withScheme "://search")- `shouldBe` zettelsByTag [] def- it "Parse single tag" $- queryFromURILink (legacyLink $ withScheme "://search?tag=foo")- `shouldBe` zettelsByTag ["foo"] def- it "Parse hierarchical tag" $ do- queryFromURILink (legacyLink $ withScheme "://search?tag=foo/bar")- `shouldBe` zettelsByTag ["foo/bar"] def- it "Parse tag pattern" $ do- queryFromURILink (legacyLink $ withScheme "://search?tag=foo/**/bar/*/baz")- `shouldBe` zettelsByTag ["foo/**/bar/*/baz"] def- it "Parse multiple tags" $- queryFromURILink (legacyLink $ withScheme "://search?tag=foo&tag=bar")- `shouldBe` zettelsByTag ["foo", "bar"] def- it "Handles ?grouped" $ do- queryFromURILink (legacyLink $ withScheme "://search?grouped")- `shouldBe` zettelsByTag [] (ZettelsView def True)- it "Handles ?linkTheme=withDate" $ do- queryFromURILink (legacyLink $ withScheme "://search?linkTheme=withDate")- `shouldBe` zettelsByTag [] (ZettelsView (LinkView_ShowDate) False)- describe "Parse zettels by ID URI" $ do- let zid = parseZettelID "1234567"- it "parses z:/" $- queryFromURILink (mkURILink "1234567" "z:/")- `shouldBe` Right (Just $ Some $ ZettelQuery_ZettelByID zid Nothing)- it "parses z:/ ignoring annotation" $- queryFromURILink (mkURILink "1234567" "z://foo-bar")- `shouldBe` Right (Just $ Some $ ZettelQuery_ZettelByID zid Nothing)- it "parses zcf:/" $- queryFromURILink (mkURILink "1234567" "zcf:/")- `shouldBe` Right (Just $ Some $ ZettelQuery_ZettelByID zid (Just OrdinaryConnection))- describe "Parse tags URI" $ do- it "parses zquery://tags" $- queryFromURILink (mkURILink "." "zquery://tags?filter=foo/**")- `shouldBe` Right (Just $ Some $ ZettelQuery_Tags [mkTagPattern "foo/**"])--shortLinks :: Spec-shortLinks = do describe "short links" $ do let shortLink s = mkURILink s s- it "parses date ID" $ do- queryFromURILink (shortLink "1234567")- `shouldBe` Right (Just $ Some $ ZettelQuery_ZettelByID (parseZettelID "1234567") Nothing) it "parses custom/hash ID" $ do queryFromURILink (shortLink "foo-bar")- `shouldBe` Right (Just $ Some $ ZettelQuery_ZettelByID (parseZettelID "foo-bar") Nothing)+ `shouldBe` Right (Just $ Some $ ZettelQuery_ZettelByID (unsafeMkZettelID "foo-bar") Folgezettel) it "even with ?cf" $ do queryFromURILink (shortLink "foo-bar?cf")- `shouldBe` Right (Just $ Some $ ZettelQuery_ZettelByID (parseZettelID "foo-bar") (Just OrdinaryConnection))+ `shouldBe` Right (Just $ Some $ ZettelQuery_ZettelByID (unsafeMkZettelID "foo-bar") OrdinaryConnection) it "parses prefixed short link" $ do queryFromURILink (shortLink "z:/foo-bar")- `shouldBe` Right (Just $ Some $ ZettelQuery_ZettelByID (parseZettelID "foo-bar") Nothing)+ `shouldBe` Right (Just $ Some $ ZettelQuery_ZettelByID (unsafeMkZettelID "foo-bar") Folgezettel) it "resolves ambiguity using absolute URI" $ do queryFromURILink (shortLink "z:/tags")- `shouldBe` Right (Just $ Some $ ZettelQuery_ZettelByID (parseZettelID "tags") Nothing)+ `shouldBe` Right (Just $ Some $ ZettelQuery_ZettelByID (unsafeMkZettelID "tags") Folgezettel) it "z:zettels" $ do queryFromURILink (shortLink "z:zettels")- `shouldBe` Right (Just $ Some $ ZettelQuery_ZettelsByTag [] Nothing def)+ `shouldBe` Right (Just $ Some $ ZettelQuery_ZettelsByTag [] Folgezettel def) it "z:zettels?tag=foo" $ do queryFromURILink (shortLink "z:zettels?tag=foo")- `shouldBe` Right (Just $ Some $ ZettelQuery_ZettelsByTag [mkTagPattern "foo"] Nothing def)+ `shouldBe` Right (Just $ Some $ ZettelQuery_ZettelsByTag [mkTagPattern "foo"] Folgezettel def) it "z:zettels?cf" $ do queryFromURILink (shortLink "z:zettels?cf")- `shouldBe` Right (Just $ Some $ ZettelQuery_ZettelsByTag [] (Just OrdinaryConnection) def)+ `shouldBe` Right (Just $ Some $ ZettelQuery_ZettelsByTag [] OrdinaryConnection def) it "z:tags" $ do queryFromURILink (shortLink "z:tags") `shouldBe` Right (Just $ Some $ ZettelQuery_Tags []) it "z:tags?filter=foo" $ do queryFromURILink (shortLink "z:tags?filter=foo") `shouldBe` Right (Just $ Some $ ZettelQuery_Tags [mkTagPattern "foo"])+ it "z:tag/foo" $ do+ queryFromURILink (shortLink "z:tag/foo")+ `shouldBe` Right (Just $ Some $ ZettelQuery_TagZettel (Tag "foo"))+ it "z:tag/foo/bar/baz" $ do+ queryFromURILink (shortLink "z:tag/foo/bar/baz")+ `shouldBe` Right (Just $ Some $ ZettelQuery_TagZettel (Tag "foo/bar/baz"))+ it "i18n" $ do+ let encodeUriPath = toText . E.encode . toString+ shortLinkUnicode s = mkURILink' (mkURI . encodeUriPath) s s+ queryFromURILink (shortLinkUnicode "计算机")+ `shouldBe` Right (Just $ Some $ ZettelQuery_ZettelByID (unsafeMkZettelID "计算机") Folgezettel)+ let normalLink = mkURILink "some link text"+ describe "flexible links (regular markdown)" $ do+ it "Default connection type should be cf" $ do+ queryFromURILink (normalLink "foo-bar")+ `shouldBe` Right (Just $ Some $ ZettelQuery_ZettelByID (unsafeMkZettelID "foo-bar") OrdinaryConnection)+ it "Supports full filename instead of zettel ID" $ do+ queryFromURILink (normalLink "foo-bar.md")+ `shouldBe` Right (Just $ Some $ ZettelQuery_ZettelByID (unsafeMkZettelID "foo-bar") OrdinaryConnection)+ describe "non-connection links" $ do+ it "pass through normal links" $ do+ queryFromURILink (normalLink "https://www.srid.ca")+ `shouldBe` Right Nothing+ queryFromURILink (normalLink "/static/resume.pdf")+ `shouldBe` Right Nothing+ queryFromURILink (normalLink "/static/")+ `shouldBe` Right Nothing+ queryFromURILink (normalLink "/static")+ `shouldBe` Right Nothing mkURILink :: Text -> Text -> URILink-mkURILink s l =- URILink s $ either (error . toText . displayException) id $ mkURI l+mkURILink =+ mkURILink' mkURI++mkURILink' ::+ (forall m. MonadThrow m => Text -> m URI) ->+ Text ->+ Text ->+ URILink+mkURILink' mk linkText s =+ -- TODO: Do this in reflex-dom-pandoc+ let uri = either (error . toText . displayException) id $ mk s+ inner = if linkText == s then Nothing else Just [Str linkText]+ in URILink inner uri
+ test/Neuron/Zettelkasten/Zettel/ParserSpec.hs view
@@ -0,0 +1,37 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE NoImplicitPrelude #-}++module Neuron.Zettelkasten.Zettel.ParserSpec+ ( spec,+ )+where++import Data.TagTree (Tag (Tag))+import Neuron.Reader.Markdown (parseMarkdown)+import Neuron.Reader.Type (ZettelFormat (ZettelFormat_Markdown))+import Neuron.Zettelkasten.ID (unsafeMkZettelID)+import Neuron.Zettelkasten.Zettel+ ( Zettel,+ ZettelT (zettelTags),+ sansContent,+ )+import Neuron.Zettelkasten.Zettel.Parser (parseZettel)+import Relude+import Test.Hspec++spec :: Spec+spec = do+ describe "inline tags" $ do+ let parseSomeZettel =+ sansContent . parseZettel ZettelFormat_Markdown parseMarkdown "<test>" (unsafeMkZettelID "note.md")+ it "simple" $ do+ let z :: Zettel = parseSomeZettel "An #inline tag"+ zettelTags z `shouldBe` [Tag "inline"]+ it "hierarchical" $ do+ let z :: Zettel = parseSomeZettel "An #foo/bar/baz tag"+ zettelTags z `shouldBe` [Tag "foo/bar/baz"]+ it "allows URLs with a hash" $ do+ pendingWith "#397"+ let z :: Zettel = parseSomeZettel "Some http://www.google.com/#foo url"+ zettelTags z `shouldBe` []
test/Neuron/Zettelkasten/ZettelSpec.hs view
@@ -9,11 +9,13 @@ import Data.TagTree import Data.Time.Calendar+import Data.Time.DateMayTime+import Data.Time.LocalTime import Neuron.Reader.Markdown import Neuron.Reader.Type import Neuron.Zettelkasten.ID import Neuron.Zettelkasten.Zettel-import Neuron.Zettelkasten.Zettel.Meta (Meta)+import Neuron.Zettelkasten.Zettel.Meta import Relude import Test.Hspec @@ -24,20 +26,48 @@ noContent = MetadataOnly () describe "sortZettelsReverseChronological" $ do let mkDay = fromGregorian 2020 3+ mkZettelDay n =+ Just $ mkDateMayTime $ Left (mkDay n)+ mkZettelLocalTime day hh mm =+ Just $ mkDateMayTime $ Right $ LocalTime (mkDay day) (TimeOfDay hh mm 0)+ (_ :: Maybe Meta, _dummyContent) = either (error . show) id $ parseMarkdown "<spec>" "Dummy"- mkZettel day idx =++ mkZettel zid datetime = Zettel- (ZettelDateID (mkDay day) idx)+ (unsafeMkZettelID zid) ZettelFormat_Markdown "<spec>.md" "Some title" False [Tag "science", Tag "journal/class"]- (Just $ mkDay day)+ datetime+ False noQueries noError noContent- it "sorts correctly" $ do- let zs = [mkZettel 3 2, mkZettel 5 1]++ it "sorts correctly with day" $ do+ let zs =+ [ mkZettel "a" (mkZettelDay 3),+ mkZettel "b" (mkZettelDay 5)+ ] sortZettelsReverseChronological zs- `shouldBe` [mkZettel 5 1, mkZettel 3 2]+ `shouldBe` reverse zs++ it "sorts correctly with localtime" $ do+ let zs =+ [ mkZettel "a" (mkZettelLocalTime 3 9 59),+ mkZettel "b" (mkZettelLocalTime 3 10 0)+ ]+ sortZettelsReverseChronological zs+ `shouldBe` reverse zs++ it "sorts correctly with mixed dates" $ do+ let zs =+ [ mkZettel "c" (mkZettelLocalTime 7 0 0),+ mkZettel "a" (mkZettelDay 5),+ mkZettel "b" (mkZettelLocalTime 3 0 0)+ ]+ sortZettelsReverseChronological zs+ `shouldBe` zs