From a66e4ac022f0966924d34c2e4b2a4a180b578062 Mon Sep 17 00:00:00 2001
From: flupe <flupe@sbi.re>
Date: Wed, 5 Oct 2022 10:20:33 +0200
Subject: [PATCH] switch to monad transformers (?)

---
 src/Config.hs   |  0
 src/Main.hs     |  2 --
 src/Markdown.hs | 48 ++++++++++++++++++++++++++++--------------------
 src/Template.hs |  0
 4 files changed, 28 insertions(+), 22 deletions(-)
 mode change 100755 => 100644 src/Config.hs
 mode change 100755 => 100644 src/Main.hs
 mode change 100755 => 100644 src/Template.hs

diff --git a/src/Config.hs b/src/Config.hs
old mode 100755
new mode 100644
diff --git a/src/Main.hs b/src/Main.hs
old mode 100755
new mode 100644
index 1acb9d5..d76748a
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -122,7 +122,6 @@ main = achille do
     else do
       spath <- toAbsolute src
       odir  <- getOutputDir <&> (</> dropExtensions src)
-      debug odir
       tmp   <- liftIO System.getTemporaryDirectory <&> (</> "escot")
 
       liftIO $ System.createDirectoryIfMissing False tmp
@@ -142,7 +141,6 @@ main = achille do
       callCommand $ "cp " <> tmp <> "/* " <> odir
 
       (meta@Note{..}, doc) <- readAbsPandocMetadataWith def {readerExtensions = pandocExtensions} (tmp </> "index.md")
-      debug doc
       path <- renderPandoc doc >>= write (dropExtensions src </> "index.html")
         . render index (KeyMap.insert "title" (String title) $ KeyMap.insert "nav" (String nav) $ KeyMap.empty)
       return (takeDirectory path, meta)
diff --git a/src/Markdown.hs b/src/Markdown.hs
index 4d6d2e0..9757b9a 100644
--- a/src/Markdown.hs
+++ b/src/Markdown.hs
@@ -1,3 +1,4 @@
+{-# LANGUAGE FlexibleContexts #-}
 module Markdown where
 
 import Lucid
@@ -5,29 +6,34 @@ import Lucid.Base (makeElement)
 import Data.Text (pack)
 import Text.Pandoc.Builder
 import Control.Monad (foldM)
+import Control.Monad.Trans
 import Data.Functor ((<&>))
 import Data.Bifoldable (Bifoldable, bifoldMap, bifoldrM)
 import Control.Monad.State.Strict
-import Control.Monad.Identity
+import Control.Monad.State.Class
+import Control.Monad.Reader
+import Control.Monad.Reader.Class
 
 data MDState = MDState 
   { stNoteCount :: Int       -- count of notes that HAVE been printed
   , stNotes     :: [Html ()] -- notes that haven't be printed yet
-  , stLevel     :: Int       -- block depth
   }
 
 defaultMDState :: MDState
 defaultMDState = MDState
   { stNoteCount = 0
   , stNotes     = []
-  , stLevel     = 0
   }
 
+type BlockLevel = Int
+
 render :: Pandoc -> Html ()
 render (Pandoc meta blocks) =
-  fst $ runIdentity $ runStateT (blocksToHtml blocks) defaultMDState
+  fst $ runReader (runStateT (blocksToHtml blocks) defaultMDState) 0
 
-inlineToHtml :: Monad m => Inline -> StateT MDState m (Html ())
+inlineToHtml
+  :: (MonadState MDState m, MonadReader BlockLevel m) 
+  => Inline -> m (Html ())
 inlineToHtml (Str str) = pure $ toHtml str
 inlineToHtml (Emph ins) = em_ <$> inlinesToHtml ins
 inlineToHtml (Underline ins) = makeElement "u" <$> inlinesToHtml ins
@@ -59,10 +65,14 @@ inlineToHtml (Note blocks) = do
   pure $ a_ [href_ $ "#note" <> pack (show currentIdx)] $ "[" <> toHtml (show currentIdx) <> "]"
 inlineToHtml (Span attrs ins) = span_ <$> inlinesToHtml ins
 
-inlinesToHtml :: Monad m => [Inline] -> StateT MDState m (Html ())
+inlinesToHtml
+  :: (MonadState MDState m, MonadReader BlockLevel m)
+  => [Inline] -> m (Html ())
 inlinesToHtml = foldMapM inlineToHtml
 
-blockToHtml :: Monad m => Block -> StateT MDState m (Html ())
+blockToHtml
+  :: (MonadState MDState m, MonadReader BlockLevel m)
+  => Block -> m (Html ())
 blockToHtml (Plain ins) = pre_ <$> inlinesToHtml ins
 blockToHtml (Para ins) = p_ <$> inlinesToHtml ins
 blockToHtml (LineBlock ins) = undefined
@@ -87,21 +97,19 @@ blockToHtml (Table attrs caption _ head rows foot) = pure mempty
 blockToHtml (Div attrs blocks) = pure mempty
 blockToHtml Null = pure mempty
 
-blocksToHtml :: Monad m => [Block] -> StateT MDState m (Html ())
-blocksToHtml = fmap mconcat . mapM renderBlock
-  where renderBlock :: Monad m => Block -> StateT MDState m (Html ())
-        renderBlock block = do
-          modify \s -> s { stLevel = stLevel s + 1 }
-          html <- blockToHtml block
-          MDState {..} <- get
-          let printingNotes = not (null stNotes) && stLevel == 1
+blocksToHtml
+  :: (MonadState MDState m, MonadReader BlockLevel m) 
+  => [Block] -> m (Html ())
+blocksToHtml = foldMapM \block -> do
+  html <- local (+1) $ blockToHtml block
+  lvl  <- ask
 
-          let notes = when printingNotes (ol_ [class_ "footnotes", start_ $ pack (show $ stNoteCount + 1)] $ foldMap li_ (reverse stNotes))
-          when printingNotes $ modify \s -> s {stNoteCount = stNoteCount + length stNotes, stNotes = [] }
+  MDState {..} <- get
+  let shouldPrintNotes = not (null stNotes) && lvl == 0
+  let notes = when shouldPrintNotes (ol_ [class_ "footnotes", start_ $ pack (show $ stNoteCount + 1)] $ foldMap li_ (reverse stNotes))
+  when shouldPrintNotes $ modify \s -> s {stNoteCount = stNoteCount + length stNotes, stNotes = [] }
 
-          modify \s -> s { stLevel = stLevel - 1 }
-
-          pure $ html <> notes
+  pure $ html <> notes
 
 foldMapM :: (Monad m, Monoid w, Foldable t) => (a -> m w) -> t a -> m w
 foldMapM f = foldM (\acc a -> do
diff --git a/src/Template.hs b/src/Template.hs
old mode 100755
new mode 100644