feat: add monadic support

Text/MMark.hs

@@ -116,11 +116,14 @@
 module Text.MMark
   ( -- * Parsing
     MMark,
+    MMarkM,
     MMarkErr (..),
     parse,
+    parseM,
 
     -- * Extensions
     Extension,
+    ExtensionM,
     useExtension,
     useExtensions,
 
@@ -136,7 +139,7 @@ where
 
 import qualified Control.Foldl as L
 import Data.Aeson
-import Text.MMark.Parser (MMarkErr (..), parse)
+import Text.MMark.Parser (MMarkErr (..), parse, parseM)
 import Text.MMark.Render (render)
 import Text.MMark.Type
 
@@ -151,7 +154,7 @@ import Data.Semigroup ((<>))
 -- apply 'Extension's /does matter/. Extensions you apply first take effect
 -- first. The extension system is designed in such a way that in many cases
 -- the order doesn't matter, but sometimes the difference is important.
-useExtension :: Extension -> MMark -> MMark
+useExtension :: Monad m => ExtensionM m -> MMarkM m -> MMarkM m
 useExtension ext mmark =
   mmark {mmarkExtension = ext <> mmarkExtension mmark}
 
@@ -164,7 +167,7 @@ useExtension ext mmark =
 -- As mentioned in the docs for 'useExtension', the order in which you apply
 -- extensions matters. Extensions closer to beginning of the list are
 -- applied later, i.e. the last extension in the list is applied first.
-useExtensions :: [Extension] -> MMark -> MMark
+useExtensions :: Monad m => [ExtensionM m] -> MMarkM m -> MMarkM m
 useExtensions exts = useExtension (mconcat exts)
 
 ----------------------------------------------------------------------------
@@ -182,7 +185,7 @@ runScanner ::
   L.Fold Bni a ->
   -- | Result of scanning
   a
-runScanner MMark {..} f = L.fold f mmarkBlocks
+runScanner MMarkM {..} f = L.fold f mmarkBlocks
 
 -- | Like 'runScanner', but allows to run scanners with monadic context.
 --
@@ -198,8 +201,8 @@ runScannerM ::
   L.FoldM m Bni a ->
   -- | Result of scanning
   m a
-runScannerM MMark {..} f = L.foldM f mmarkBlocks
+runScannerM MMarkM {..} f = L.foldM f mmarkBlocks
 
 -- | Extract contents of an optional YAML block that may have been parsed.
-projectYaml :: MMark -> Maybe Value
+projectYaml :: MMarkM m -> Maybe Value
 projectYaml = mmarkYaml

Text/MMark/Extension.hs

@@ -82,13 +82,15 @@ module Text.MMark.Extension
     Block (..),
     CellAlign (..),
     blockTrans,
+    blockTransM,
     blockRender,
     Ois,
     getOis,
 
     -- ** Inline-level manipulation
     Inline (..),
     inlineTrans,
+    inlineTransM,
     inlineRender,
 
     -- * Scanner construction
@@ -102,8 +104,9 @@ module Text.MMark.Extension
   )
 where
 
+import Control.Arrow
 import qualified Control.Foldl as L
-import Data.Monoid hiding ((<>))
+import Data.Functor.Identity
 import Lucid
 import Text.MMark.Type
 import Text.MMark.Util
@@ -115,7 +118,10 @@ import Text.MMark.Util
 -- final in the sense that sub-elements of resulting block won't be
 -- traversed again.
 blockTrans :: (Bni -> Bni) -> Extension
-blockTrans f = mempty {extBlockTrans = Endo f}
+blockTrans f = mempty {extBlockTrans = Kleisli (Identity . f)}
+
+blockTransM :: Monad m => (Bni -> m Bni) -> ExtensionM m
+blockTransM f = mempty {extBlockTrans = Kleisli f}
 
 -- | Create an extension that replaces or augments rendering of 'Block's of
 -- markdown document. The argument of 'blockRender' will be given the
@@ -131,23 +137,28 @@ blockTrans f = mempty {extBlockTrans = Endo f}
 --
 -- See also: 'Ois' and 'getOis'.
 blockRender ::
-  ((Block (Ois, Html ()) -> Html ()) -> Block (Ois, Html ()) -> Html ()) ->
-  Extension
-blockRender f = mempty {extBlockRender = Render f}
+  Monad m =>
+  ((Block (Ois, HtmlT m ()) -> HtmlT m ()) -> Block (Ois, HtmlT m ()) -> HtmlT m ()) ->
+  ExtensionM m
+blockRender f = mempty {extBlockRender = RenderT f}
 
 -- | Create an extension that performs a transformation on 'Inline'
 -- components in entire markdown document. Similarly to 'blockTrans' the
 -- transformation is applied from the most deeply nested elements moving
 -- upwards.
 inlineTrans :: (Inline -> Inline) -> Extension
-inlineTrans f = mempty {extInlineTrans = Endo f}
+inlineTrans f = mempty {extInlineTrans = Kleisli (Identity . f)}
+
+inlineTransM :: Monad m => (Inline -> m Inline) -> ExtensionM m
+inlineTransM f = mempty {extInlineTrans = Kleisli f}
 
 -- | Create an extension that replaces or augments rendering of 'Inline's of
 -- markdown document. This works like 'blockRender'.
 inlineRender ::
-  ((Inline -> Html ()) -> Inline -> Html ()) ->
-  Extension
-inlineRender f = mempty {extInlineRender = Render f}
+  Monad m =>
+  ((Inline -> HtmlT m ()) -> Inline -> HtmlT m ()) ->
+  ExtensionM m
+inlineRender f = mempty {extInlineRender = RenderT f}
 
 -- | Create a 'L.Fold' from an initial state and a folding function.
 scanner ::

Text/MMark/Parser.hs

@@ -21,6 +21,7 @@
 module Text.MMark.Parser
   ( MMarkErr (..),
     parse,
+    parseM,
   )
 where
 
@@ -105,7 +106,17 @@ parse ::
   Text ->
   -- | Parse errors or parsed document
   Either (ParseErrorBundle Text MMarkErr) MMark
-parse file input =
+parse = parseM
+
+parseM ::
+  Monad m =>
+  -- | File name (only to be used in error messages), may be empty
+  FilePath ->
+  -- | Input to parse
+  Text ->
+  -- | Parse errors or parsed document
+  Either (ParseErrorBundle Text MMarkErr) (MMarkM m)
+parseM file input =
   case runBParser pMMark file input of
     Left bundle -> Left bundle
     Right ((myaml, rawBlocks), defs) ->
@@ -118,7 +129,7 @@ parse file input =
        in case NE.nonEmpty . DList.toList $ foldMap (foldMap e2p) parsed of
             Nothing ->
               Right
-                MMark
+                MMarkM
                   { mmarkYaml = myaml,
                     mmarkBlocks = fmap fromRight <$> parsed,
                     mmarkExtension = mempty

Text/MMark/Render.hs

@@ -17,10 +17,10 @@ module Text.MMark.Render
   )
 where
 
-import Control.Arrow
 import Control.Monad
+import Control.Monad.Fix
+import Control.Monad.Trans
 import Data.Char (isSpace)
-import Data.Function (fix)
 import Data.List.NonEmpty (NonEmpty (..))
 import qualified Data.List.NonEmpty as NE
 import qualified Data.Text as T
@@ -36,32 +36,35 @@ import qualified Text.URI as URI
 --     * to lazy 'Data.Taxt.Lazy.Text' with 'renderText'
 --     * to lazy 'Data.ByteString.Lazy.ByteString' with 'renderBS'
 --     * directly to file with 'renderToFile'
-render :: MMark -> Html ()
-render MMark {..} =
+render :: Monad m => MMarkM m -> HtmlT m ()
+render MMarkM {..} =
   mapM_ rBlock mmarkBlocks
   where
-    Extension {..} = mmarkExtension
-    rBlock =
-      applyBlockRender extBlockRender
-        . fmap rInlines
-        . applyBlockTrans extBlockTrans
-    rInlines =
-      (mkOisInternal &&& mapM_ (applyInlineRender extInlineRender))
-        . fmap (applyInlineTrans extInlineTrans)
+    ExtensionM {..} = mmarkExtension
+    rBlock bni =
+      lift (applyBlockTrans extBlockTrans bni)
+        >>= lift . traverse rInlines
+        >>= applyBlockRender extBlockRender
+    rInlines tis = do
+      tris <- traverse (applyInlineTrans extInlineTrans) tis
+      let tr = mapM_ (applyInlineRender extInlineRender) tris
+      return (mkOisInternal tris, tr)
 
 -- | Apply a 'Render' to a given @'Block' 'Html' ()@.
 applyBlockRender ::
-  Render (Block (Ois, Html ())) ->
-  Block (Ois, Html ()) ->
-  Html ()
-applyBlockRender r = fix (runRender r . defaultBlockRender)
+  Monad m =>
+  RenderT m (Block (Ois, HtmlT m ())) ->
+  Block (Ois, HtmlT m ()) ->
+  HtmlT m ()
+applyBlockRender r = fix (runRenderT r . defaultBlockRender)
 
 -- | The default 'Block' render.
 defaultBlockRender ::
+  Monad m =>
   -- | Rendering function to use to render sub-blocks
-  (Block (Ois, Html ()) -> Html ()) ->
-  Block (Ois, Html ()) ->
-  Html ()
+  (Block (Ois, HtmlT m ()) -> HtmlT m ()) ->
+  Block (Ois, HtmlT m ()) ->
+  HtmlT m ()
 defaultBlockRender blockRender = \case
   ThematicBreak ->
     hr_ [] >> newline
@@ -131,15 +134,16 @@ defaultBlockRender blockRender = \case
       CellAlignCenter -> [style_ "text-align:center"]
 
 -- | Apply a render to a given 'Inline'.
-applyInlineRender :: Render Inline -> Inline -> Html ()
-applyInlineRender r = fix (runRender r . defaultInlineRender)
+applyInlineRender :: Monad m => RenderT m Inline -> Inline -> HtmlT m ()
+applyInlineRender r = fix (runRenderT r . defaultInlineRender)
 
 -- | The default render for 'Inline' elements.
 defaultInlineRender ::
+  Monad m =>
   -- | Rendering function to use to render sub-inlines
-  (Inline -> Html ()) ->
+  (Inline -> HtmlT m ()) ->
   Inline ->
-  Html ()
+  HtmlT m ()
 defaultInlineRender inlineRender = \case
   Plain txt ->
     toHtml txt
@@ -165,5 +169,5 @@ defaultInlineRender inlineRender = \case
      in img_ (alt_ (asPlainText desc) : src_ (URI.render src) : title)
 
 -- | HTML containing a newline.
-newline :: Html ()
+newline :: Monad m => HtmlT m ()
 newline = "\n"

Text/MMark/Trans.hs

@@ -16,30 +16,29 @@ module Text.MMark.Trans
   )
 where
 
-import Data.Monoid hiding ((<>))
+import Control.Arrow
 import Text.MMark.Type
 
--- | Apply block transformation in the @'Endo' 'Bni'@ form to a block 'Bni'.
-applyBlockTrans :: Endo Bni -> Bni -> Bni
-applyBlockTrans trans@(Endo f) = \case
-  Blockquote xs -> f (Blockquote (s xs))
-  OrderedList w xs -> f (OrderedList w (s <$> xs))
-  UnorderedList xs -> f (UnorderedList (s <$> xs))
+-- | Apply block transformation.
+applyBlockTrans :: Monad m => Kleisli m Bni Bni -> Bni -> m Bni
+applyBlockTrans trans@(Kleisli f) = \case
+  Blockquote xs -> (Blockquote <$> s xs) >>= f
+  OrderedList w xs -> (OrderedList w <$> traverse s xs) >>= f
+  UnorderedList xs -> (UnorderedList <$> traverse s xs) >>= f
   other -> f other
   where
-    s = fmap (applyBlockTrans trans)
+    s = traverse (applyBlockTrans trans)
 
--- | Apply inline transformation in the @'Endo' 'Inline'@ form to an
--- 'Inline'.
-applyInlineTrans :: Endo Inline -> Inline -> Inline
-applyInlineTrans trans@(Endo f) = \case
-  Emphasis xs -> f (Emphasis (s xs))
-  Strong xs -> f (Strong (s xs))
-  Strikeout xs -> f (Strikeout (s xs))
-  Subscript xs -> f (Subscript (s xs))
-  Superscript xs -> f (Superscript (s xs))
-  Link xs uri mt -> f (Link (s xs) uri mt)
-  Image xs uri mt -> f (Image (s xs) uri mt)
+-- | Apply inline transformation.
+applyInlineTrans :: Monad m => Kleisli m Inline Inline -> Inline -> m Inline
+applyInlineTrans trans@(Kleisli f) = \case
+  Emphasis xs -> (Emphasis <$> s xs) >>= f
+  Strong xs -> (Strong <$> s xs) >>= f
+  Strikeout xs -> (Strikeout <$> s xs) >>= f
+  Subscript xs -> (Subscript <$> s xs) >>= f
+  Superscript xs -> (Superscript <$> s xs) >>= f
+  Link xs uri mt -> (Link <$> s xs <*> pure uri <*> pure mt) >>= f
+  Image xs uri mt -> (Image <$> s xs <*> pure uri <*> pure mt) >>= f
   other -> f other
   where
-    s = fmap (applyInlineTrans trans)
+    s = traverse (applyInlineTrans trans)