From d5ed49084eec066121260b4ca8072bb3a31e7229 Mon Sep 17 00:00:00 2001 From: Emeka Nkurumeh Date: Tue, 9 Jul 2024 14:11:47 -0500 Subject: [PATCH] [#46] generalize extensions and renderer --- Text/MMark/Extension.hs | 52 ++++++++++++++++++++++++--------- Text/MMark/Internal/Type.hs | 58 +++++++++++++++++++++---------------- Text/MMark/Parser.hs | 15 ++++++++-- Text/MMark/Render.hs | 54 ++++++++++++++++++++-------------- Text/MMark/Trans.hs | 33 ++++++++++----------- 5 files changed, 133 insertions(+), 79 deletions(-) diff --git a/Text/MMark/Extension.hs b/Text/MMark/Extension.hs index 4ccfc53..d0d9f5c 100644 --- a/Text/MMark/Extension.hs +++ b/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 :: diff --git a/Text/MMark/Internal/Type.hs b/Text/MMark/Internal/Type.hs index f562e30..3fe570c 100644 --- a/Text/MMark/Internal/Type.hs +++ b/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) diff --git a/Text/MMark/Parser.hs b/Text/MMark/Parser.hs index c23ea78..4433808 100644 --- a/Text/MMark/Parser.hs +++ b/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 diff --git a/Text/MMark/Render.hs b/Text/MMark/Render.hs index fbe00ea..3555ff7 100644 --- a/Text/MMark/Render.hs +++ b/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" diff --git a/Text/MMark/Trans.hs b/Text/MMark/Trans.hs index 944505a..e52c39c 100644 --- a/Text/MMark/Trans.hs +++ b/Text/MMark/Trans.hs @@ -18,34 +18,33 @@ module Text.MMark.Trans ) where -import Data.Monoid hiding ((<>)) import Text.MMark.Internal.Type -- | Apply block transformation in the @'Endo' 'Bni'@ form to a block 'Bni'. -- -- @since 0.0.8.0 -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)) +applyBlockTrans :: Monad m => EndoM m Bni -> Bni -> m Bni +applyBlockTrans t@(EndoM f) = \case + Blockquote xs -> s xs >>= f . Blockquote + OrderedList w xs -> traverse s xs >>= f . OrderedList w + UnorderedList xs -> traverse s xs >>= f . UnorderedList other -> f other where - s = fmap (applyBlockTrans trans) + s = traverse (applyBlockTrans t) -- | Apply inline transformation in the @'Endo' 'Inline'@ form to an -- 'Inline'. -- -- @since 0.0.8.0 -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) +applyInlineTrans :: Monad m => EndoM m Inline -> Inline -> m Inline +applyInlineTrans t@(EndoM f) = \case + Emphasis xs -> s xs >>= f . Emphasis + Strong xs -> s xs >>= f . Strong + Strikeout xs -> s xs >>= f . Strikeout + Subscript xs -> s xs >>= f . Subscript + Superscript xs -> s xs >>= f . Superscript + Link xs uri mt -> s xs >>= f . (\ys -> Link ys uri mt) + Image xs uri mt -> s xs >>= f . (\ys -> Image ys uri mt) other -> f other where - s = fmap (applyInlineTrans trans) + s = traverse (applyInlineTrans t)