diff --git a/neuron.cabal b/neuron.cabal
--- a/neuron.cabal
+++ b/neuron.cabal
@@ -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
diff --git a/src-bash/neuron-search b/src-bash/neuron-search
--- a/src-bash/neuron-search
+++ b/src-bash/neuron-search
@@ -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}" \
diff --git a/src/app/Data/Structured/OpenGraph.hs b/src/app/Data/Structured/OpenGraph.hs
new file mode 100644
--- /dev/null
+++ b/src/app/Data/Structured/OpenGraph.hs
@@ -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)
diff --git a/src/app/Data/Structured/OpenGraph/Render.hs b/src/app/Data/Structured/OpenGraph/Render.hs
new file mode 100644
--- /dev/null
+++ b/src/app/Data/Structured/OpenGraph/Render.hs
@@ -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'
diff --git a/src/app/Main.hs b/src/app/Main.hs
deleted file mode 100644
--- a/src/app/Main.hs
+++ /dev/null
@@ -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
diff --git a/src/app/Neuron/CLI.hs b/src/app/Neuron/CLI.hs
--- a/src/app/Neuron/CLI.hs
+++ b/src/app/Neuron/CLI.hs
@@ -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 ")
+ (fullDesc <> progDesc "Neuron, future-proof Zettelkasten app ")
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
diff --git a/src/app/Neuron/CLI/New.hs b/src/app/Neuron/CLI/New.hs
--- a/src/app/Neuron/CLI/New.hs
+++ b/src/app/Neuron/CLI/New.hs
@@ -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
diff --git a/src/app/Neuron/CLI/Open.hs b/src/app/Neuron/CLI/Open.hs
new file mode 100644
--- /dev/null
+++ b/src/app/Neuron/CLI/Open.hs
@@ -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
diff --git a/src/app/Neuron/CLI/Rib.hs b/src/app/Neuron/CLI/Rib.hs
--- a/src/app/Neuron/CLI/Rib.hs
+++ b/src/app/Neuron/CLI/Rib.hs
@@ -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
diff --git a/src/app/Neuron/CLI/Search.hs b/src/app/Neuron/CLI/Search.hs
--- a/src/app/Neuron/CLI/Search.hs
+++ b/src/app/Neuron/CLI/Search.hs
@@ -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`)
diff --git a/src/app/Neuron/CLI/Types.hs b/src/app/Neuron/CLI/Types.hs
--- a/src/app/Neuron/CLI/Types.hs
+++ b/src/app/Neuron/CLI/Types.hs
@@ -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
diff --git a/src/app/Neuron/Config.hs b/src/app/Neuron/Config.hs
--- a/src/app/Neuron/Config.hs
+++ b/src/app/Neuron/Config.hs
@@ -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
diff --git a/src/app/Neuron/Config/Alias.hs b/src/app/Neuron/Config/Alias.hs
--- a/src/app/Neuron/Config/Alias.hs
+++ b/src/app/Neuron/Config/Alias.hs
@@ -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
diff --git a/src/app/Neuron/Reader/Org.hs b/src/app/Neuron/Reader/Org.hs
--- a/src/app/Neuron/Reader/Org.hs
+++ b/src/app/Neuron/Reader/Org.hs
@@ -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"
diff --git a/src/app/Neuron/Web/Cache.hs b/src/app/Neuron/Web/Cache.hs
new file mode 100644
--- /dev/null
+++ b/src/app/Neuron/Web/Cache.hs
@@ -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
diff --git a/src/app/Neuron/Web/Generate.hs b/src/app/Neuron/Web/Generate.hs
--- a/src/app/Neuron/Web/Generate.hs
+++ b/src/app/Neuron/Web/Generate.hs
@@ -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)
diff --git a/src/app/Neuron/Web/Generate/Route.hs b/src/app/Neuron/Web/Generate/Route.hs
--- a/src/app/Neuron/Web/Generate/Route.hs
+++ b/src/app/Neuron/Web/Generate/Route.hs
@@ -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
diff --git a/src/app/Neuron/Web/HeadHtml.hs b/src/app/Neuron/Web/HeadHtml.hs
new file mode 100644
--- /dev/null
+++ b/src/app/Neuron/Web/HeadHtml.hs
@@ -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
diff --git a/src/app/Neuron/Web/StructuredData.hs b/src/app/Neuron/Web/StructuredData.hs
--- a/src/app/Neuron/Web/StructuredData.hs
+++ b/src/app/Neuron/Web/StructuredData.hs
@@ -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 =
diff --git a/src/app/Neuron/Web/View.hs b/src/app/Neuron/Web/View.hs
--- a/src/app/Neuron/Web/View.hs
+++ b/src/app/Neuron/Web/View.hs
@@ -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")
diff --git a/src/app/Neuron/Zettelkasten/ID/Scheme.hs b/src/app/Neuron/Zettelkasten/ID/Scheme.hs
--- a/src/app/Neuron/Zettelkasten/ID/Scheme.hs
+++ b/src/app/Neuron/Zettelkasten/ID/Scheme.hs
@@ -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 "" s
+ either (error . toText) pure $
+ parse idParser "" s
IDSchemeCustom s -> runExcept $ do
zid <-
- either (throwError . IDConflict_BadCustomID s) (pure . ZettelCustomID) $
- parse customIDParser "" s
+ either (throwError . IDConflict_BadCustomID s) pure $
+ parse idParser "" s
if zid `Set.member` zs
then throwError IDConflict_AlreadyExists
else pure zid
diff --git a/src/exe/Main.hs b/src/exe/Main.hs
new file mode 100644
--- /dev/null
+++ b/src/exe/Main.hs
@@ -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
diff --git a/src/lib/Data/Graph/Labelled.hs b/src/lib/Data/Graph/Labelled.hs
--- a/src/lib/Data/Graph/Labelled.hs
+++ b/src/lib/Data/Graph/Labelled.hs
@@ -21,12 +21,14 @@
preSetWithEdgeLabelMany,
topSort,
clusters,
+ dfsForest,
dfsForestFrom,
dfsForestBackwards,
bfsForestFrom,
bfsForestBackwards,
obviateRootUnlessForest,
induceOnEdge,
+ induce,
)
where
diff --git a/src/lib/Data/Graph/Labelled/Algorithm.hs b/src/lib/Data/Graph/Labelled/Algorithm.hs
--- a/src/lib/Data/Graph/Labelled/Algorithm.hs
+++ b/src/lib/Data/Graph/Labelled/Algorithm.hs
@@ -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
diff --git a/src/lib/Data/TagTree.hs b/src/lib/Data/TagTree.hs
--- a/src/lib/Data/TagTree.hs
+++ b/src/lib/Data/TagTree.hs
@@ -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'
diff --git a/src/lib/Data/Time/DateMayTime.hs b/src/lib/Data/Time/DateMayTime.hs
new file mode 100644
--- /dev/null
+++ b/src/lib/Data/Time/DateMayTime.hs
@@ -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
diff --git a/src/lib/Neuron/Config/Type.hs b/src/lib/Neuron/Config/Type.hs
--- a/src/lib/Neuron/Config/Type.hs
+++ b/src/lib/Neuron/Config/Type.hs
@@ -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 for description of the fields.
+-- See 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\" \
\}"
diff --git a/src/lib/Neuron/Reader/Markdown.hs b/src/lib/Neuron/Reader/Markdown.hs
--- a/src/lib/Neuron/Reader/Markdown.hs
+++ b/src/lib/Neuron/Reader/Markdown.hs
@@ -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 `` style
+ -- queries. FIXME: Should fail on `` 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
diff --git a/src/lib/Neuron/Reader/Type.hs b/src/lib/Neuron/Reader/Type.hs
--- a/src/lib/Neuron/Reader/Type.hs
+++ b/src/lib/Neuron/Reader/Type.hs
@@ -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
diff --git a/src/lib/Neuron/Web/Common.hs b/src/lib/Neuron/Web/Common.hs
--- a/src/lib/Neuron/Web/Common.hs
+++ b/src/lib/Neuron/Web/Common.hs
@@ -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"
diff --git a/src/lib/Neuron/Web/Query/View.hs b/src/lib/Neuron/Web/Query/View.hs
--- a/src/lib/Neuron/Web/Query/View.hs
+++ b/src/lib/Neuron/Web/Query/View.hs
@@ -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
diff --git a/src/lib/Neuron/Web/Route.hs b/src/lib/Neuron/Web/Route.hs
--- a/src/lib/Neuron/Web/Route.hs
+++ b/src/lib/Neuron/Web/Route.hs
@@ -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
diff --git a/src/lib/Neuron/Web/Theme.hs b/src/lib/Neuron/Web/Theme.hs
--- a/src/lib/Neuron/Web/Theme.hs
+++ b/src/lib/Neuron/Web/Theme.hs
@@ -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
diff --git a/src/lib/Neuron/Web/Widget.hs b/src/lib/Neuron/Web/Widget.hs
--- a/src/lib/Neuron/Web/Widget.hs
+++ b/src/lib/Neuron/Web/Widget.hs
@@ -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
-- |