Add Diary example using org-mode and fsnotify (#2)

* Dairy example, prototype. Without fsnotify.

* Add basic org renderer

* Rough version of fswatcher

* Refactor, and add example org notebook

.ghcid

@@ -1 +1 @@
---warnings -T "Ema.Example.Ex02_Clock.main"
+--warnings -T "Ema.Example.Ex03_Diary.mainWith [\"src/Ema/Example/Diary\"]"

ema.cabal

@@ -25,6 +25,10 @@ extra-source-files:
   LICENSE
   README.md
 
+data-files:
+  if flag(with-examples)
+    src/Ema/Example/Diary/*.org
+
 library
   -- Modules included in this executable, other than Main.
   -- other-modules:
@@ -39,7 +43,6 @@ library
     , blaze-markup
     , containers
     , data-default
-    , directory
     , filepath
     , http-types
     , neat-interpolation
@@ -54,7 +57,12 @@ library
     , websockets
   if flag(with-examples)
     build-depends:
-      time
+      , fsnotify
+      , filepattern
+      , directory
+      , time
+      , org-mode
+      , shower
 
   mixins:
     base hiding (Prelude),

flake.lock

@@ -33,17 +33,17 @@
     },
     "nixpkgs": {
       "locked": {
-        "lastModified": 1618447066,
-        "narHash": "sha256-2f9ydxgdW2igSIe1vmV8buTEpAVQPVhV+OxvlFRTA+Y=",
+        "lastModified": 1618909122,
+        "narHash": "sha256-rvbQKioaJli21xlPXAUO/pxO/3zL98TloG5QZmJmZKI=",
         "owner": "nixos",
         "repo": "nixpkgs",
-        "rev": "dcdf30a78a523296b5f9d44fb67afac485b64737",
+        "rev": "8389dcb67d934ee72c1d1e7228d92be9b3f71bad",
         "type": "github"
       },
       "original": {
         "owner": "nixos",
         "repo": "nixpkgs",
-        "rev": "dcdf30a78a523296b5f9d44fb67afac485b64737",
+        "rev": "8389dcb67d934ee72c1d1e7228d92be9b3f71bad",
         "type": "github"
       }
     },

flake.nix

@@ -1,7 +1,7 @@
 {
   description = "Ema project";
   inputs = {
-    nixpkgs.url = "github:nixos/nixpkgs/dcdf30a78a523296b5f9d44fb67afac485b64737";
+    nixpkgs.url = "github:nixos/nixpkgs/8389dcb67d934ee72c1d1e7228d92be9b3f71bad";
     flake-utils.url = "github:numtide/flake-utils";
     flake-compat = {
       url = "github:edolstra/flake-compat";
@@ -12,13 +12,19 @@
     flake-utils.lib.eachSystem [ "x86_64-linux" "x86_64-darwin" ] (system:
       let
         overlays = [ ];
-        pkgs = import nixpkgs { inherit system overlays; };
+        pkgs = import nixpkgs {
+          inherit system overlays;
+          config.allowBroken = true; # To allow `org-mode` package which is broken
+        };
         emaProject = returnShellEnv:
           pkgs.haskellPackages.developPackage {
             inherit returnShellEnv;
             name = "ema";
             root = ./.;
             withHoogle = false;
+            overrides = self: super: with pkgs.haskell.lib; {
+              org-mode = dontCheck super.org-mode; # `tasty` dependency is broken on nixpkgs
+            };
             modifier = drv:
               pkgs.haskell.lib.addBuildTools drv (with pkgs.haskellPackages;
               [

src/Ema/Changing.hs

@@ -4,6 +4,7 @@
 module Ema.Changing where
 
 import qualified Data.Map.Strict as Map
+import Prelude hiding (modify)
 
 -- A mutable variable with change notification
 -- TODO: Rename to something more accurate?
@@ -14,7 +15,7 @@ data Changing a = Changing
     changingSubscribers :: TMVar (Map Int (TMVar ()))
   }
 
-new :: MonadIO m => a -> m (Changing a)
+new :: forall a m. MonadIO m => a -> m (Changing a)
 new val = do
   Changing <$> newTMVarIO val <*> newTMVarIO mempty
 
@@ -28,9 +29,13 @@ get v =
 
 -- | Sets a new value; listeners from @subscribe@ are automatically notifed.
 set :: MonadIO m => Changing a -> a -> m ()
-set v val = do
+set v = modify v . const
+
+modify :: MonadIO m => Changing a -> (a -> a) -> m ()
+modify v f = do
   n <- atomically $ do
-    void $ swapTMVar (changingCurrent v) val
+    curr <- readTMVar (changingCurrent v)
+    void $ swapTMVar (changingCurrent v) (f curr)
     publish v
   when (n > 0) $
     putStrLn $ "pub: published; " <> show n <> " subscribers listening"

src/Ema/Example/Diary/2001-07-24.org

@@ -0,0 +1,4 @@
+#+mood: 4
+
+* A very *old* diary entry
+** Indeed, it is. :someTag:

src/Ema/Example/Diary/2021-04-20.org

@@ -0,0 +1,8 @@
+#+mood: 5
+
+* From today, I'll record my daily thoughts in org-mode
+** TODO Soon, this will also become my task manager!
+* Things to study
+** Richard Dawkins' The Selfish Gene :book:
+* Things to explore
+** [[https://radicle.xyz/][Radicle for git]] :decentralized:

src/Ema/Example/Ex03_Diary.hs

@@ -6,37 +6,180 @@
 -- daily notes written in org-mode format.
 module Ema.Example.Ex03_Diary where
 
-{-
-type Zk = Map FilePath ()
+import Control.Concurrent (threadDelay)
+import Control.Concurrent.Async (race_)
+import Control.Exception (finally)
+import qualified Data.Map.Strict as Map
+import Data.Org (OrgFile)
+import qualified Data.Org as Org
+import qualified Data.Set as Set
+import qualified Data.Text as T
+import Data.Time (Day, defaultTimeLocale, parseTimeM)
+import Ema.App (Ema (..), runEma)
+import qualified Ema.Changing as Changing
+import qualified Ema.Layout as Layout
+import Ema.Route
+import qualified Shower
+import System.Directory (canonicalizePath)
+import System.Environment (getArgs)
+import System.FSNotify
+  ( Event (..),
+    watchDir,
+    withManager,
+  )
+import System.FilePath (takeFileName, (</>))
+import System.FilePattern.Directory (getDirectoryFiles)
+import Text.Blaze.Html5 ((!))
+import qualified Text.Blaze.Html5 as H
+import qualified Text.Blaze.Html5.Attributes as A
 
-runNeuron :: FilePath -> IO ()
-runNeuron fp = do
-  s <- neuronModel fp
-  runEma $
-    Ema s $ \_zk () -> do
-      "TODO"
+data Route
+  = Index
+  | OnDay Day
+  deriving (Show)
 
-neuronModel :: FilePath -> IO (Changing Zk)
-neuronModel notebookDir = do
-  ch <- watchDir notebookDir
-  buildWorldIncrementally mempty ch $ \zk diff ->
-    foldl' go zk (Map.toList diff)
+instance IsRoute Route where
+  toSlug = \case
+    Index -> mempty
+    OnDay day -> one $ show day
+  fromSlug = \case
+    [] -> Just Index
+    [s] -> OnDay <$> parseDay (toString $ unSlug s)
+    _ -> Nothing
+
+parseDay :: String -> Maybe Day
+parseDay =
+  parseTimeM False defaultTimeLocale "%Y-%m-%d"
+
+parseDailyNote :: FilePath -> IO (Maybe (Day, OrgFile))
+parseDailyNote f =
+  case parseDailyNoteFilepath f of
+    Nothing -> pure Nothing
+    Just day -> do
+      s <- readFileText f
+      pure $ (day,) <$> Org.org s
+
+parseDailyNoteFilepath :: FilePath -> Maybe Day
+parseDailyNoteFilepath f =
+  parseDay . toString =<< T.stripSuffix ".org" (toText $ takeFileName f)
+
+type Diary = Map Day OrgFile
+
+diaryFrom :: FilePath -> IO Diary
+diaryFrom folder = do
+  putStrLn $ "Loading .org files from " <> folder
+  fs <- getDirectoryFiles folder (one "*.org")
+  Map.fromList . catMaybes <$> forM fs (parseDailyNote . (folder </>))
+
+watchAndUpdateDiary :: FilePath -> Changing.Changing Diary -> IO ()
+watchAndUpdateDiary folder model = do
+  putStrLn $ "Watching .org files in " <> folder
+  withManager $ \mgr -> do
+    stop <- watchDir mgr folder (const True) $ \event -> do
+      print event
+      let updateFile fp = do
+            parseDailyNote fp >>= \case
+              Nothing -> pure ()
+              Just (day, org) -> do
+                putStrLn $ "Update: " <> show day
+                Changing.modify model $ Map.insert day org
+          deleteFile fp = do
+            whenJust (parseDailyNoteFilepath fp) $ \day -> do
+              putStrLn $ "Delete: " <> show day
+              Changing.modify model $ Map.delete day
+      case event of
+        Added fp _ isDir -> unless isDir $ updateFile fp
+        Modified fp _ isDir -> unless isDir $ updateFile fp
+        Removed fp _ isDir -> unless isDir $ deleteFile fp
+        Unknown fp _ _ -> updateFile fp
+    threadDelay maxBound
+      `finally` stop
+
+main :: IO ()
+main = mainWith . drop 1 =<< getArgs
+
+mainWith :: [String] -> IO ()
+mainWith args = do
+  folder <- case args of
+    [path] -> canonicalizePath path
+    _ -> pure "/home/srid/KB"
+  model <- Changing.new =<< diaryFrom folder
+  race_
+    (runEma $ Ema model render)
+    (watchAndUpdateDiary folder model)
   where
-    watchDir :: FilePath -> IO (TBQueue (Map FilePath (Maybe ByteString)))
-    watchDir = undefined
+    render (diary :: Diary) (r :: Route) =
+      Layout.tailwindSite (H.title "My Diary") $
+        H.div ! A.class_ "container mx-auto" $ do
+          let heading =
+                H.header
+                  ! A.class_ "text-4xl my-2 py-2 font-bold text-center bg-purple-50 shadow"
+          case r of
+            Index -> do
+              heading "My Diary"
+              H.div ! A.class_ "" $
+                forM_ (sortOn Down $ Map.keys diary) $ \day ->
+                  H.li $ routeElem (OnDay day) $ H.toMarkup @Text (show day)
+            OnDay day -> do
+              heading $ show day
+              routeElem Index "Back to Index"
+              maybe "not found" renderOrg (Map.lookup day diary)
+    routeElem r w =
+      H.a ! A.class_ "text-xl text-purple-500 hover:underline" ! routeHref r $ w
+    routeHref r =
+      A.href (fromString . toString $ routeUrl r)
 
-    buildWorldIncrementally ::
-      state ->
-      TBQueue worldChange ->
-      (state -> worldChange -> state) ->
-      IO (Changing state)
-    buildWorldIncrementally _state0 _change _f =
-      undefined
-    go zk (k, mv) = case mv of
-      Nothing ->
-        -- Deleted!
-        Map.delete k zk
-      Just newVal ->
-        Map.insert k (parseMarkdown newVal) zk
-    parseMarkdown = const ()
--}
+renderOrg :: OrgFile -> H.Html
+renderOrg _org@(Org.OrgFile meta doc) = do
+  let heading = H.header ! A.class_ "text-2xl my-2 font-bold"
+  unless (null meta) $ do
+    heading "Meta"
+    renderMeta meta
+  heading "Doc"
+  -- Debug dump
+  -- H.pre $ H.toMarkup (Shower.shower org)
+  renderOrgDoc doc
+
+renderMeta :: Map Text Text -> H.Html
+renderMeta meta = do
+  H.table ! A.class_ "Metatable-auto" $ do
+    let td cls = H.td ! A.class_ ("border px-4 py-2 " <> cls)
+    forM_ (Map.toList meta) $ \(k, v) ->
+      H.tr $ do
+        td "font-bold" $ H.toMarkup k
+        td "font-mono" $ H.toMarkup v
+
+renderOrgDoc :: Org.OrgDoc -> H.Html
+renderOrgDoc (Org.OrgDoc blocks sections) = do
+  H.ul ! A.class_ "list-disc ml-8" $ do
+    whenNotNull blocks $ \_ -> do
+      H.header ! A.class_ "text-2xl font-bold" $ "Blocks"
+      H.pre $ H.toMarkup (Shower.shower blocks)
+    whenNotNull sections $ \_ -> do
+      forM_ sections renderSection
+
+renderSection :: Org.Section -> H.Html
+renderSection (Org.Section heading tags doc) = do
+  H.li $ do
+    forM_ heading $ \s ->
+      renderWords s >> " "
+    forM_ tags renderTag
+    renderOrgDoc doc
+
+renderTag :: Text -> H.Html
+renderTag tag =
+  H.span
+    ! A.class_ "border-1 p-0.5 bg-purple-200 font-bold rounded"
+    ! A.title "Tag"
+    $ H.toMarkup tag
+
+renderWords :: Org.Words -> H.Markup
+renderWords ws = do
+  let s = Org.prettyWords ws
+  if s `Set.member` Set.fromList ["TODO", "DONE"]
+    then
+      H.span
+        ! A.class_ "border-1 p-0.5 bg-gray-600 text-white"
+        ! A.title "Keyword"
+        $ H.toMarkup s
+    else H.toMarkup s