Fix stuctural propagation of rendering extensions

CHANGELOG.md

@@ -1,3 +1,9 @@
+## MMark 0.0.5.2
+
+* Fix the bug that prevented application of rendering extensions to
+  sub-blocks (blocks contained inside other blocks) and sub-inlines (inlines
+  contained inside other inlines).
+
 ## MMark 0.0.5.1
 
 * The parser can now recover from block-level parse errors in tables and

Text/MMark/Render.hs

@@ -20,6 +20,7 @@ where
 import Control.Arrow
 import Control.Monad
 import Data.Char (isSpace)
+import Data.Function (fix)
 import Data.List.NonEmpty (NonEmpty (..))
 import Data.Monoid hiding ((<>))
 import Data.Semigroup
@@ -56,15 +57,18 @@ applyBlockRender
   :: Render (Block (Ois, Html ()))
   -> Block (Ois, Html ())
   -> Html ()
-applyBlockRender r = getRender r defaultBlockRender
+applyBlockRender r = fix (runRender r . defaultBlockRender)
 
 -- | The default 'Block' render. Note that it does not care about what we
 -- have rendered so far because it always starts rendering. Thus it's OK to
 -- just pass it something dummy as the second argument of the inner
 -- function.
 
-defaultBlockRender :: Block (Ois, Html ()) -> Html ()
-defaultBlockRender = \case
+defaultBlockRender
+  :: (Block (Ois, Html ()) -> Html ())
+     -- ^ Rendering function to use to render sub-blocks
+  -> Block (Ois, Html ()) -> Html ()
+defaultBlockRender blockRender = \case
   ThematicBreak ->
     hr_ [] >> newline
   Heading1 (h,html) ->
@@ -88,21 +92,21 @@ defaultBlockRender = \case
   Paragraph (_,html) ->
     p_ html >> newline
   Blockquote blocks -> do
-    blockquote_ (newline <* mapM_ defaultBlockRender blocks)
+    blockquote_ (newline <* mapM_ blockRender blocks)
     newline
   OrderedList i items -> do
     let startIndex = [start_ (T.pack $ show i) | i /= 1]
     ol_ startIndex $ do
       newline
       forM_ items $ \x -> do
-        li_ (newline <* mapM_ defaultBlockRender x)
+        li_ (newline <* mapM_ blockRender x)
         newline
     newline
   UnorderedList items -> do
     ul_ $ do
       newline
       forM_ items $ \x -> do
-        li_ (newline <* mapM_ defaultBlockRender x)
+        li_ (newline <* mapM_ blockRender x)
         newline
     newline
   Table calign (hs :| rows) -> do
@@ -135,32 +139,35 @@ defaultBlockRender = \case
 -- | Apply a render to a given 'Inline'.
 
 applyInlineRender :: Render Inline -> Inline -> Html ()
-applyInlineRender r = getRender r defaultInlineRender
+applyInlineRender r = fix (runRender r . defaultInlineRender)
 
 -- | The default render for 'Inline' elements. Comments about
 -- 'defaultBlockRender' apply here just as well.
 
-defaultInlineRender :: Inline -> Html ()
-defaultInlineRender = \case
+defaultInlineRender
+  :: (Inline -> Html ())
+     -- ^ Rendering function to use to render sub-inlines
+  -> Inline -> Html ()
+defaultInlineRender inlineRender = \case
   Plain txt ->
     toHtml txt
   LineBreak ->
     br_ [] >> newline
   Emphasis inner ->
-    em_ (mapM_ defaultInlineRender inner)
+    em_ (mapM_ inlineRender inner)
   Strong inner ->
-    strong_ (mapM_ defaultInlineRender inner)
+    strong_ (mapM_ inlineRender inner)
   Strikeout inner ->
-    del_ (mapM_ defaultInlineRender inner)
+    del_ (mapM_ inlineRender inner)
   Subscript inner ->
-    sub_ (mapM_ defaultInlineRender inner)
+    sub_ (mapM_ inlineRender inner)
   Superscript inner ->
-    sup_ (mapM_ defaultInlineRender inner)
+    sup_ (mapM_ inlineRender inner)
   CodeSpan txt ->
     code_ (toHtmlRaw txt)
   Link inner dest mtitle ->
     let title = maybe [] (pure . title_) mtitle
-    in a_ (href_ (URI.render dest) : title) (mapM_ defaultInlineRender inner)
+    in a_ (href_ (URI.render dest) : title) (mapM_ inlineRender inner)
   Image desc src mtitle ->
     let title = maybe [] (pure . title_) mtitle
     in img_ (alt_ (asPlainText desc) : src_ (URI.render src) : title)

Text/MMark/Type.hs

@@ -118,7 +118,7 @@ instance Monoid Extension where
 -- the type @a -> Html ()@.
 
 newtype Render a = Render
-  { getRender :: (a -> Html ()) -> a -> Html () }
+  { runRender :: (a -> Html ()) -> a -> Html () }
 
 instance Semigroup (Render a) where
   Render f <> Render g = Render $ \h -> f (g h)

tests/Text/MMark/ExtensionSpec.hs

@@ -24,21 +24,29 @@ spec = parallel $ do
       doc <- mkDoc "# My heading"
       toText (MMark.useExtension h1_to_h2 doc)
         `shouldBe` "<h2 id=\"my-heading\">My heading</h2>\n"
-  describe "blockRender" $
+  describe "blockRender" $ do
     it "works" $ do
       doc <- mkDoc "# My heading"
       toText (MMark.useExtension add_h1_content doc)
         `shouldBe` "<h1 data-content=\"My heading\" id=\"my-heading\">My heading</h1>\n"
+    it "extensions can affect nested block structures" $ do
+      doc <- mkDoc "* # Something"
+      toText (MMark.useExtension add_h1_content doc)
+       `shouldBe` "<ul>\n<li>\n<h1 data-content=\"Something\" id=\"something\">Something</h1>\n</li>\n</ul>\n"
   describe "inlineTrans" $
     it "works" $ do
       doc <- mkDoc "# My *heading*"
       toText (MMark.useExtension em_to_strong doc)
         `shouldBe` "<h1 id=\"my-heading\">My <strong>heading</strong></h1>\n"
-  describe "inlineRender" $
+  describe "inlineRender" $ do
     it "works" $ do
       doc <- mkDoc "# My *heading*"
       toText (MMark.useExtension (add_em_class "foo") doc)
         `shouldBe` "<h1 id=\"my-heading\">My <em class=\"foo\">heading</em></h1>\n"
+    it "extensions can affect nested inline structures" $ do
+      doc <- mkDoc "[*heading*](/url)"
+      toText (MMark.useExtension (add_em_class "foo") doc)
+        `shouldBe` "<p><a href=\"/url\"><em class=\"foo\">heading</em></a></p>\n"
   describe "asPlainText" $ do
     let f x = Ext.asPlainText (x:|[])
     context "with Plain" $