[#46] generalize extensions and renderer

Author: emekoi

Text/MMark/Extension.hs

@@ -82,14 +82,18 @@ module Text.MMark.Extension
     Block (..),
     CellAlign (..),
     blockTrans,
+    blockTransM,
     blockRender,
+    blockRenderM,
     Ois,
     getOis,
 
     -- ** Inline-level manipulation
     Inline (..),
     inlineTrans,
+    inlineTransM,
     inlineRender,
+    inlineRenderM,
 
     -- * Scanner construction
     scanner,
@@ -114,40 +118,62 @@ import Text.MMark.Util
 -- upwards. This has the benefit that the result of any transformation is
 -- final in the sense that sub-elements of resulting block won't be
 -- traversed again.
+blockTransM :: Monad m => (Bni -> m Bni) -> ExtensionT m
+blockTransM f = mempty {extBlockTrans = EndoM f}
+
+-- | 'blockTransM' specialized to `Identity`.
 blockTrans :: (Bni -> Bni) -> Extension
-blockTrans f = mempty {extBlockTrans = Endo f}
+blockTrans f = blockTransM (pure . f)
 
 -- | Create an extension that replaces or augments rendering of 'Block's of
--- markdown document. The argument of 'blockRender' will be given the
--- rendering function constructed so far @'Block' ('Ois', 'Html' ()) ->
--- 'Html' ()@ as well as an actual block to render—@'Block' ('Ois', 'Html'
--- ())@. The user can then decide whether to replace\/reuse that function to
--- get the final rendering of the type @'Html' ()@.
+-- markdown document. The argument of 'blockRenderM' will be given the
+-- rendering function constructed so far @'Block' ('Ois', 'HtmlT' m ()) ->
+-- 'HtmlT' m ()@ as well as an actual block to render—@'Block' ('Ois', 'HtmlT'
+-- m ())@. The user can then decide whether to replace\/reuse that function to
+-- get the final rendering of the type @'HtmlT' m ()@.
 --
--- The argument of 'blockRender' can also be thought of as a function that
+-- The argument of 'blockRenderM' can also be thought of as a function that
 -- transforms the rendering function constructed so far:
 --
--- > (Block (Ois, Html ()) -> Html ()) -> (Block (Ois, Html ()) -> Html ())
+-- > (Block (Ois, HtmlT m ()) -> HtmlT m ()) -> (Block (Ois, HtmlT m ()) -> HtmlT m ())
 --
 -- See also: 'Ois' and 'getOis'.
+blockRenderM ::
+  Monad m =>
+  ((Block (Ois, HtmlT m ()) -> HtmlT m ()) -> Block (Ois, HtmlT m ()) -> HtmlT m ()) ->
+  ExtensionT m
+blockRenderM f = mempty {extBlockRender = Endo f}
+
+-- | 'blockRenderM' specialized to `Identity`.
 blockRender ::
   ((Block (Ois, Html ()) -> Html ()) -> Block (Ois, Html ()) -> Html ()) ->
   Extension
-blockRender f = mempty {extBlockRender = Render f}
+blockRender = blockRenderM
 
 -- | Create an extension that performs a transformation on 'Inline'
--- components in entire markdown document. Similarly to 'blockTrans' the
+-- components in entire markdown document. Similarly to 'blockTransM' the
 -- transformation is applied from the most deeply nested elements moving
 -- upwards.
+inlineTransM :: Monad m => (Inline -> m Inline) -> ExtensionT m
+inlineTransM f = mempty {extInlineTrans = EndoM f}
+
+-- | 'blockTransM' specialized to `Identity`.
 inlineTrans :: (Inline -> Inline) -> Extension
-inlineTrans f = mempty {extInlineTrans = Endo f}
+inlineTrans f = inlineTransM (pure . f)
 
 -- | Create an extension that replaces or augments rendering of 'Inline's of
--- markdown document. This works like 'blockRender'.
+-- markdown document. This works like 'blockRenderM'.
+inlineRenderM ::
+  Monad m =>
+  ((Inline -> HtmlT m ()) -> Inline -> HtmlT m ()) ->
+  ExtensionT m
+inlineRenderM f = mempty {extInlineRender = Endo f}
+
+-- | 'inlineRender' specialized to `Identity`.
 inlineRender ::
   ((Inline -> Html ()) -> Inline -> Html ()) ->
   Extension
-inlineRender f = mempty {extInlineRender = Render f}
+inlineRender = inlineRenderM
 
 -- | Create a 'L.Fold' from an initial state and a folding function.
 scanner ::

Text/MMark/Internal/Type.hs

@@ -18,9 +18,14 @@
 --
 -- @since 0.0.8.0
 module Text.MMark.Internal.Type
-  ( MMark (..),
-    Extension (..),
-    Render (..),
+  ( MMark,
+    MMarkT (..),
+    Endo (..),
+    EndoM (..),
+    Extension,
+    ExtensionT (..),
+    Render,
+    RenderT,
     Bni,
     Block (..),
     CellAlign (..),
@@ -32,6 +37,7 @@ module Text.MMark.Internal.Type
 where
 
 import Control.DeepSeq
+import Control.Foldl (EndoM (..))
 import Data.Aeson
 import Data.Data (Data)
 import Data.Function (on)
@@ -42,26 +48,30 @@ import Data.Typeable (Typeable)
 import GHC.Generics
 import Lucid
 import Text.URI (URI (..))
+import Data.Functor.Identity
 
 -- | Representation of complete markdown document. You can't look inside of
--- 'MMark' on purpose. The only way to influence an 'MMark' document you
+-- 'MMarkT' on purpose. The only way to influence an 'MMarkT' document you
 -- obtain as a result of parsing is via the extension mechanism.
-data MMark = MMark
+data MMarkT m = MMark
   { -- | Parsed YAML document at the beginning (optional)
     mmarkYaml :: Maybe Value,
     -- | Actual contents of the document
     mmarkBlocks :: [Bni],
     -- | Extension specifying how to process and render the blocks
-    mmarkExtension :: Extension
+    mmarkExtension :: ExtensionT m
   }
 
-instance NFData MMark where
+-- | 'MMarkT' specialized to `Identity`.
+type MMark = MMarkT Identity
+
+instance NFData (MMarkT m) where
   rnf MMark {..} = rnf mmarkYaml `seq` rnf mmarkBlocks
 
 -- | Dummy instance.
 --
 -- @since 0.0.5.0
-instance Show MMark where
+instance Show (MMarkT m) where
   show = const "MMark {..}"
 
 -- | An extension. You can apply extensions with 'Text.MMark.useExtension'
@@ -85,18 +95,21 @@ instance Show MMark where
 -- Here, @e0@ will be applied first, then @e1@, then @e2@. The same applies
 -- to expressions involving 'mconcat'—extensions closer to beginning of the
 -- list passed to 'mconcat' will be applied later.
-data Extension = Extension
+data ExtensionT m = Extension
   { -- | Block transformation
-    extBlockTrans :: Endo Bni,
+    extBlockTrans :: EndoM m Bni,
     -- | Block render
-    extBlockRender :: Render (Block (Ois, Html ())),
+    extBlockRender :: RenderT m (Block (Ois, HtmlT m ())),
     -- | Inline transformation
-    extInlineTrans :: Endo Inline,
+    extInlineTrans :: EndoM m Inline,
     -- | Inline render
-    extInlineRender :: Render Inline
+    extInlineRender :: RenderT m Inline
   }
 
-instance Semigroup Extension where
+-- | 'ExtensionT' specialized to `Identity`.
+type Extension = ExtensionT Identity
+
+instance Monad m => Semigroup (ExtensionT m) where
   x <> y =
     Extension
       { extBlockTrans = on (<>) extBlockTrans x y,
@@ -105,7 +118,7 @@ instance Semigroup Extension where
         extInlineRender = on (<>) extInlineRender x y
       }
 
-instance Monoid Extension where
+instance Monad m => Monoid (ExtensionT m) where
   mempty =
     Extension
       { extBlockTrans = mempty,
@@ -117,18 +130,13 @@ instance Monoid Extension where
 
 -- | An internal type that captures the extensible rendering process we use.
 -- 'Render' has a function inside which transforms a rendering function of
--- the type @a -> Html ()@.
+-- the type @a -> HtmlT m ()@.
 --
 -- @since 0.0.8.0
-newtype Render a = Render
-  {runRender :: (a -> Html ()) -> a -> Html ()}
+type RenderT m a = Endo (a -> HtmlT m ())
 
-instance Semigroup (Render a) where
-  Render f <> Render g = Render (f . g)
-
-instance Monoid (Render a) where
-  mempty = Render id
-  mappend = (<>)
+-- | 'RenderT' specialized to `Identity`.
+type Render a = RenderT Identity a
 
 -- | A shortcut for the frequently used type @'Block' ('NonEmpty'
 -- 'Inline')@.
@@ -178,7 +186,7 @@ data Block a
     --
     -- @since 0.0.4.0
     Table (NonEmpty CellAlign) (NonEmpty (NonEmpty a))
-  deriving (Show, Eq, Ord, Data, Typeable, Generic, Functor, Foldable)
+  deriving (Show, Eq, Ord, Data, Typeable, Generic, Functor, Foldable, Traversable)
 
 instance (NFData a) => NFData (Block a)
 

Text/MMark/Parser.hs

@@ -21,6 +21,7 @@
 module Text.MMark.Parser
   ( MMarkErr (..),
     parse,
+    parseM
   )
 where
 
@@ -94,14 +95,15 @@ data InlineState
 
 -- | Parse a markdown document in the form of a strict 'Text' value and
 -- either report parse errors or return an 'MMark' document.
-parse ::
+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) MMark
-parse file input =
+  Either (ParseErrorBundle Text MMarkErr) (MMarkT m)
+parseM file input =
   case runBParser pMMark file input of
     Left bundle -> Left bundle
     Right ((myaml, rawBlocks), defs) ->
@@ -133,6 +135,13 @@ parse file input =
                         }
                   }
 
+-- | 'parseM' specialized to `Identity`.
+parse ::
+  FilePath ->
+  Text ->
+  Either (ParseErrorBundle Text MMarkErr) MMark
+parse = parseM
+
 ----------------------------------------------------------------------------
 -- Block parser
 

Text/MMark/Render.hs

@@ -26,6 +26,7 @@ where
 
 import Control.Arrow
 import Control.Monad
+import Control.Monad.Trans
 import Data.Char (isSpace)
 import Data.Function (fix)
 import Data.List.NonEmpty (NonEmpty (..))
@@ -43,36 +44,46 @@ import Text.URI qualified 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 {..} =
+renderM :: forall m. Monad m => MMarkT m -> HtmlT m ()
+renderM MMark {..} =
   mapM_ rBlock mmarkBlocks
   where
     Extension {..} = mmarkExtension
-    rBlock =
-      applyBlockRender extBlockRender
-        . fmap rInlines
-        . applyBlockTrans extBlockTrans
-    rInlines =
-      (mkOisInternal &&& mapM_ (applyInlineRender extInlineRender))
-        . fmap (applyInlineTrans extInlineTrans)
+
+    rBlock :: Monad m => Bni -> HtmlT m ()
+    rBlock x0 = do
+      x1 <- lift $ applyBlockTrans extBlockTrans x0
+      x2 <- lift $ traverse rInlines x1
+      applyBlockRender extBlockRender x2
+
+    rInlines :: Monad m => NonEmpty Inline -> m (Ois, HtmlT m ())
+    rInlines x0 = do
+      x1 <- traverse (applyInlineTrans extInlineTrans) x0
+      pure $ (mkOisInternal &&& mapM_ (applyInlineRender extInlineRender)) x1
+
+-- | 'renderM' specialized to `Identity`.
+render :: MMark -> Html ()
+render = renderM
 
 -- | Apply a 'Render' to a given @'Block' 'Html' ()@.
 --
 -- @since 0.0.8.0
 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 (appEndo r . defaultBlockRender)
 
 -- | The default 'Block' render.
 --
 -- @since 0.0.8.0
 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
@@ -144,17 +155,18 @@ defaultBlockRender blockRender = \case
 -- | Apply a render to a given 'Inline'.
 --
 -- @since 0.0.8.0
-applyInlineRender :: Render Inline -> Inline -> Html ()
-applyInlineRender r = fix (runRender r . defaultInlineRender)
+applyInlineRender :: Monad m => RenderT m Inline -> Inline -> HtmlT m ()
+applyInlineRender r = fix (appEndo r . defaultInlineRender)
 
 -- | The default render for 'Inline' elements.
 --
 -- @since 0.0.8.0
 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
@@ -182,5 +194,5 @@ defaultInlineRender inlineRender = \case
 -- | HTML containing a newline.
 --
 -- @since 0.0.8.0
-newline :: Html ()
+newline :: Monad m => HtmlT m ()
 newline = "\n"