WIP v2 org-mode support

neuron/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: 1.9.10.0
+version: 1.9.11.0
 license: AGPL-3.0-only
 copyright: 2020 Sridhar Ratnakumar
 maintainer: [email protected]
@@ -94,6 +94,8 @@ library
     Neuron.Zettelkasten.Graph.Type
     Neuron.Zettelkasten.Graph.Build
     Neuron.Zettelkasten.Resolver
+    Neuron.Zettelkasten.Format
+    Neuron.Zettelkasten.Format.Reader.Type
     Neuron.Cache.Type
     Neuron.Frontend.Route
     Neuron.Frontend.Route.Data
@@ -137,6 +139,7 @@ common app-common
     file-embed,
     optparse-applicative,
     pandoc-types,
+    pandoc,
     -- Use skylighting >= 0.9 as they are written in pure Haskell
     skylighting-core >= 0.9,
     relude,
@@ -202,6 +205,8 @@ library neuron-app-lib
     Neuron.Frontend.Static.HeadHtml
     Neuron.Frontend.Static.StructuredData
     Neuron.Zettelkasten.ID.Scheme
+    Neuron.Zettelkasten.Format.Reader
+    Neuron.Zettelkasten.Format.Reader.Org
   autogen-modules:
     Paths_neuron
   other-modules:

neuron/src/app/Neuron/Reactor/Build.hs

@@ -38,9 +38,12 @@ import qualified Neuron.Frontend.Route.Data as RD
 import qualified Neuron.Frontend.Static.HeadHtml as HeadHtml
 import qualified Neuron.Frontend.Static.Html as Html
 import qualified Neuron.Frontend.Widget as W
+import Neuron.Markdown (parseMarkdown)
 import Neuron.Plugin (PluginRegistry)
 import qualified Neuron.Plugin as Plugin
 import Neuron.Version (neuronVersion)
+import Neuron.Zettelkasten.Format
+import qualified Neuron.Zettelkasten.Format.Reader.Org as Org
 import qualified Neuron.Zettelkasten.Graph.Build as G
 import Neuron.Zettelkasten.Graph.Type (ZettelGraph)
 import Neuron.Zettelkasten.ID (ZettelID (..))
@@ -120,7 +123,7 @@ reportAllErrors issues = do
     reportError :: ZettelID -> ZettelError -> m ()
     reportError zid (zettelErrorText -> err) = do
       -- We don't know the full path to this zettel; so just print the ID.
-      log EE $ "Cannot accept Zettel ID: " <> unZettelID zid
+      log EE $ "Cannot accept Zettel with ID \"" <> unZettelID zid <> "\""
       log E $ indentAllButFirstLine 4 err
 
 genRouteHtml ::
@@ -216,8 +219,9 @@ loadZettelkastenFromFilesWithPlugins ::
       Map ZettelID ZettelIssue
     )
 loadZettelkastenFromFilesWithPlugins plugins fileTree = do
+  let markdownParser = parseMarkdown (Plugin.markdownSpec plugins)
   !zidRefs <-
-    case DC.pruneDirTree =<< DC.filterDirTree ((== ".md") . takeExtension) fileTree of
+    case DC.pruneDirTree =<< DC.filterDirTree ((`elem` [".org", ".md"]) . takeExtension) fileTree of
       Nothing ->
         pure mempty
       Just mdFileTree -> do
@@ -232,15 +236,18 @@ loadZettelkastenFromFilesWithPlugins plugins fileTree = do
               decodeUtf8With lenientDecode <$> readFileBS absPath
             Plugin.afterZettelRead plugins mdFileTree
   log D $ "Building graph (" <> show (length zidRefs) <> " notes) ..."
+  let getParser = \case
+        ZettelFormat_Markdown -> markdownParser
+        ZettelFormat_Org -> Org.parseOrg
   pure $
     runWriter $ do
       filesWithContent <-
         flip Map.traverseMaybeWithKey zidRefs $ \zid -> \case
           R.ZIDRef_Ambiguous fps -> do
             tell $ one (zid, ZettelIssue_Error $ ZettelError_AmbiguousID fps)
             pure Nothing
-          R.ZIDRef_Available fp s pluginData ->
-            pure $ Just (fp, (s, pluginData))
-      let !zs = Plugin.afterZettelParse plugins (Map.toList filesWithContent)
+          R.ZIDRef_Available fp fmt s pluginData ->
+            pure $ Just (fp, fmt, (s, pluginData))
+      let !zs = Plugin.afterZettelParse plugins getParser (Map.toList filesWithContent)
       !g <- G.buildZettelkasten plugins zs
       pure (g, zs)

neuron/src/app/Neuron/Zettelkasten/Format/Reader.hs

@@ -0,0 +1,16 @@
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE ViewPatterns #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+
+module Neuron.Zettelkasten.Format.Reader
+  (
+  )
+where
+
+-- getParser,
+
+-- import Relude
+
+-- getParser :: ZettelFormat -> ZettelParser
+-- getParser = undefined

neuron/src/app/Neuron/Zettelkasten/Format/Reader/Org.hs

@@ -0,0 +1,60 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE ViewPatterns #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+
+module Neuron.Zettelkasten.Format.Reader.Org
+  ( parseOrg,
+  )
+where
+
+import qualified Data.Map as Map
+import Data.Text (toLower)
+import qualified Data.YAML as Y
+import qualified Data.YAML.Event as YE
+import Neuron.Zettelkasten.Format.Reader.Type
+import Relude
+import Relude.Extra.Map (lookup)
+import Text.Pandoc (def, runPure)
+import Text.Pandoc.Definition (Pandoc)
+import Text.Pandoc.Readers.Org (readOrg)
+import Text.Pandoc.Util (getH1)
+
+parseOrg :: ZettelParser
+parseOrg _ s = do
+  doc <- first show $ runPure $ readOrg def s
+  meta <- extractMetadata doc
+  pure (meta, doc)
+
+-- | Extract metadata from the properties that are attached to the first headline
+extractMetadata :: Pandoc -> Either ZettelParseError (Maybe (Y.Node Y.Pos))
+extractMetadata doc
+  | Just ((_, _, Map.fromList -> properties), _) <- getH1 doc = do
+    let date = lookup "date" properties
+        tags = words <$> lookup "tags" properties
+        unlisted = parseUnlisted <$> lookup "unlisted" properties
+    pure $
+      Just $
+        Y.Mapping
+          noPos
+          yTagMap
+          $ Map.fromList $
+            catMaybes
+              [ unlisted <&> \x ->
+                  (Y.Scalar noPos $ Y.SStr "unlisted", Y.Scalar noPos $ Y.SBool x),
+                date <&> \x ->
+                  (Y.Scalar noPos $ Y.SStr "date", Y.Scalar noPos $ Y.SStr x),
+                tags <&> \xs ->
+                  ( Y.Scalar noPos $ Y.SStr "tags",
+                    Y.Sequence noPos yTagSeq $
+                      xs <&> \x -> Y.Scalar noPos $ Y.SStr x
+                  )
+              ]
+  | otherwise = pure Nothing
+  where
+    noPos = Y.Pos 0 0 0 0
+    yTagMap = YE.mkTag "tag:yaml.org,2002:map"
+    yTagSeq = YE.mkTag "tag:yaml.org,2002:seq"
+    parseUnlisted :: Text -> Bool
+    parseUnlisted a = toLower a == "true"

neuron/src/lib/Neuron/Markdown.hs

@@ -32,6 +32,7 @@ import qualified Commonmark.Pandoc as CP
 import Control.Monad.Combinators (manyTill)
 import Data.Tagged (Tagged (..))
 import qualified Data.YAML as Y
+import Neuron.Zettelkasten.Format.Reader.Type
 import Relude hiding (show, traceShowId)
 import qualified Text.Megaparsec as M
 import qualified Text.Megaparsec.Char as M
@@ -41,10 +42,6 @@ import Text.Pandoc.Definition (Pandoc (..))
 import qualified Text.Parsec as P
 import Text.Show (Show (show))
 
-type ZettelParser = FilePath -> Text -> Either ZettelParseError (Maybe (Y.Node Y.Pos), Pandoc)
-
-type ZettelParseError = Tagged "ZettelParserError" Text
-
 -- | Parse Markdown document, along with the YAML metadata block in it.
 --
 -- We are not using the Pandoc AST "metadata" field (as it is not clear whether

neuron/src/lib/Neuron/Plugin.hs

@@ -22,14 +22,16 @@ import Data.Some
 import qualified Data.Text as T
 import Neuron.Frontend.Route (NeuronWebT)
 import Neuron.Frontend.Route.Data.Types
-import Neuron.Markdown (NeuronSyntaxSpec, parseMarkdown)
+import Neuron.Markdown (NeuronSyntaxSpec)
 import qualified Neuron.Plugin.Plugins.DirTree as DirTree
 import qualified Neuron.Plugin.Plugins.Links as Links
 import qualified Neuron.Plugin.Plugins.NeuronIgnore as NeuronIgnore
 import qualified Neuron.Plugin.Plugins.Tags as Tags
 import qualified Neuron.Plugin.Plugins.UpTree as UpTree
 import Neuron.Plugin.Type (Plugin (..))
 import Neuron.Zettelkasten.Connection (ContextualConnection)
+import Neuron.Zettelkasten.Format
+import Neuron.Zettelkasten.Format.Reader.Type
 import Neuron.Zettelkasten.Graph.Type (ZettelGraph)
 import Neuron.Zettelkasten.ID (ZettelID)
 import Neuron.Zettelkasten.Resolver (ZIDRef)
@@ -83,12 +85,12 @@ filterSources plugins t = do
       combiner = \ima f -> (fmap join . traverse f) =<< ima
   foldl' combiner (pure $ Just t) applyF
 
-afterZettelParse :: PluginRegistry -> [(ZettelID, (FilePath, (Text, DMap PluginZettelData Identity)))] -> [ZettelC]
-afterZettelParse plugins fs = do
+afterZettelParse :: PluginRegistry -> (ZettelFormat -> ZettelParser) -> [(ZettelID, (FilePath, ZettelFormat, (Text, DMap PluginZettelData Identity)))] -> [ZettelC]
+afterZettelParse plugins getParser fs = do
   let h =
         Map.elems plugins <&> \sp ->
           withSome sp $ \p (m, x) -> (m,) $ _plugin_afterZettelParse p m x
-  parseZettels (parseMarkdown $ markdownSpec plugins) fs <&> \x ->
+  parseZettels getParser fs <&> \x ->
     snd $ foldl' (\x1 f -> f x1) x h
 
 afterZettelRead :: MonadState (Map ZettelID ZIDRef) m => PluginRegistry -> DC.DirTree FilePath -> m ()

neuron/src/lib/Neuron/Plugin/Plugins/DirTree.hs

@@ -37,6 +37,7 @@ import qualified Neuron.Plugin.Plugins.Links as Links
 import qualified Neuron.Plugin.Plugins.Tags as Tags
 import Neuron.Plugin.Type (Plugin (..))
 import Neuron.Zettelkasten.Connection (Connection (Folgezettel, OrdinaryConnection), ContextualConnection)
+import Neuron.Zettelkasten.Format
 import qualified Neuron.Zettelkasten.Graph as G
 import Neuron.Zettelkasten.Graph.Type (ZettelGraph)
 import Neuron.Zettelkasten.ID (ZettelID (ZettelID, unZettelID), indexZid)
@@ -165,7 +166,7 @@ injectDirectoryZettels = \case
           DMap.singleton DirTree $
             Identity $ DirZettel tags mparent (Just $ tagFromPath absPath) meta
     gets (Map.lookup dirZettelId) >>= \case
-      Just (ZIDRef_Available p s pluginDataPrev) -> do
+      Just (ZIDRef_Available p fmt s pluginDataPrev) -> do
         -- A zettel with this directory name was already registered. Deal with it.
         case runIdentity <$> DMap.lookup DirTree pluginDataPrev of
           Just _ -> do
@@ -182,15 +183,15 @@ injectDirectoryZettels = \case
                         [ guard (dirZettelId /= indexZid) >> parentDirTag absPath,
                           parentDirTag p
                         ]
-                newRef = ZIDRef_Available p s (DMap.union pluginData pluginDataPrev)
+                newRef = ZIDRef_Available p fmt s (DMap.union pluginData pluginDataPrev)
             modify $ Map.update (const $ Just newRef) dirZettelId
       Just ZIDRef_Ambiguous {} ->
         -- TODO: What to do here?
         pure ()
       Nothing -> do
         -- Inject a new zettel corresponding to this directory, that is uniquely named.
         let pluginData = mkPluginData $ maybe Set.empty Set.singleton $ parentDirTag absPath
-        R.addZettel absPath dirZettelId pluginData $ do
+        R.addZettel absPath ZettelFormat_Markdown dirZettelId pluginData $ do
           -- Set an appropriate title (same as directory name)
           let heading = toText (takeFileName absPath) <> "/"
           pure $ "# " <> heading

neuron/src/lib/Neuron/Plugin/Plugins/Links.hs

@@ -118,7 +118,7 @@ parseQueryLink attrs url = do
   let conn :: Connection =
         fromMaybe def $ readMaybe . toString =<< Map.lookup "title" (Map.fromList attrs)
   path <- asMarkdownPath url
-  zid <- getZettelID (toString path)
+  zid <- snd <$> getZettelID (toString path)
   pure (zid, conn)
   where
     -- Return .md file path, for the given link text.

neuron/src/lib/Neuron/Zettelkasten/Format.hs

@@ -0,0 +1,30 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE DeriveAnyClass #-}
+{-# LANGUAGE DeriveFunctor #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE TupleSections #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE UndecidableInstances #-}
+{-# LANGUAGE ViewPatterns #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+
+module Neuron.Zettelkasten.Format where
+
+import Data.Aeson hiding ((.:))
+import Relude
+
+-- TODO: rewrite json instance for brevity
+data ZettelFormat
+  = ZettelFormat_Markdown
+  | ZettelFormat_Org
+  deriving (Eq, Show, Ord, Generic, ToJSON, FromJSON)

neuron/src/lib/Neuron/Zettelkasten/Format/Reader/Type.hs

@@ -0,0 +1,26 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE DeriveAnyClass #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+
+module Neuron.Zettelkasten.Format.Reader.Type where
+
+import Data.Tagged (Tagged)
+import qualified Data.YAML as Y
+import Relude hiding (readEither, show)
+import Text.Pandoc.Definition (Pandoc)
+
+type ZettelParser =
+  -- | Source filepath (used only in error messages)
+  FilePath ->
+  -- | Text to parse
+  Text ->
+  -- | Parse result: a tuple of YAML metadata and Pandoc AST.
+  Either
+    ZettelParseError
+    (Maybe (Y.Node Y.Pos), Pandoc)
+
+type ZettelParseError = Tagged "ZettelParserError" Text

neuron/src/lib/Neuron/Zettelkasten/ID.hs

@@ -4,7 +4,9 @@
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TupleSections #-}
 {-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE ViewPatterns #-}
 {-# LANGUAGE NoImplicitPrelude #-}
 
 module Neuron.Zettelkasten.ID
@@ -29,6 +31,7 @@ import Data.Aeson
     ToJSONKey (toJSONKey),
   )
 import Data.Aeson.Types (toJSONKeyText)
+import Neuron.Zettelkasten.Format
 import Relude hiding (traceShowId)
 import System.FilePath (splitExtension, takeFileName)
 import qualified Text.Megaparsec as M
@@ -107,8 +110,11 @@ idParser' cs = do
   pure $ ZettelID $ toText s
 
 -- | Parse the ZettelID if the given filepath is a Markdown zettel.
-getZettelID :: FilePath -> Maybe ZettelID
+getZettelID :: FilePath -> Maybe (ZettelFormat, ZettelID)
 getZettelID fp = do
-  let (fileName, ext) = splitExtension $ takeFileName fp
-  guard $ ".md" == toText ext
-  rightToMaybe $ parseZettelID (toText fileName)
+  let (fileName, toText -> ext) = splitExtension $ takeFileName fp
+  fmt <- case ext of
+    ".md" -> pure ZettelFormat_Markdown
+    ".org" -> pure ZettelFormat_Org
+    _ -> Nothing
+  fmap (fmt,) $ rightToMaybe $ parseZettelID (toText fileName)