Merge pull request #6922 from jtojnar/db-writer-admonitions

Docbook writer: handle admonitions

2 files changed, 111 insertions, 19 deletions

diff --git a/src/Text/Pandoc/Writers/Docbook.hs b/src/Text/Pandoc/Writers/Docbook.hs
index 3f4c67f10..affa0de04 100644
--- a/src/Text/Pandoc/Writers/Docbook.hs
+++ b/src/Text/Pandoc/Writers/Docbook.hs
@@ -53,6 +53,13 @@ getStartLvl opts =
        TopLevelSection -> 1
        TopLevelDefault -> 1
 
+-- | Get correct name for the id attribute based on DocBook version.
+-- DocBook 4 used custom id attribute but DocBook 5 adopted the xml:id specification.
+-- https://www.w3.org/TR/xml-id/
+idName :: DocBookVersion -> Text
+idName DocBook5 = "xml:id"
+idName DocBook4 = "id"
+
 -- | Convert list of authors to a docbook <author> section
 authorToDocbook :: PandocMonad m => WriterOptions -> [Inline] -> DB m B.Inlines
 authorToDocbook opts name' = do
@@ -174,10 +181,7 @@ blockToDocbook opts (Div (id',"section":_,_) (Header lvl _ ils : xs)) = do
                                               then "section"
                                               else "sect" <> tshow n
                  _                    -> "simplesect"
-      idName = if version == DocBook5
-                 then "xml:id"
-                 else "id"
-      idAttr = [(idName, writerIdentifierPrefix opts <> id') | not (T.null id')]
+      idAttr = [(idName version, writerIdentifierPrefix opts <> id') | not (T.null id')]
       -- We want to add namespaces to the root (top-level) element.
       nsAttr = if version == DocBook5 && lvl == getStartLvl opts && isNothing (writerTemplate opts)
       -- Though, DocBook 4 does not support namespaces and
@@ -188,18 +192,39 @@ blockToDocbook opts (Div (id',"section":_,_) (Header lvl _ ils : xs)) = do
   title' <- inlinesToDocbook opts ils
   contents <- blocksToDocbook opts bs
   return $ inTags True tag attribs $ inTagsSimple "title" title' $$ contents
-blockToDocbook opts (Div (ident,_,_) [Para lst]) =
-  let attribs = [("id", ident) | not (T.null ident)] in
-  if hasLineBreaks lst
-     then flush . nowrap . inTags False "literallayout" attribs
-                         <$> inlinesToDocbook opts lst
-     else inTags True "para" attribs <$> inlinesToDocbook opts lst
-blockToDocbook opts (Div (ident,_,_) bs) = do
-  contents <- blocksToDocbook opts (map plainToPara bs)
-  return $
-    (if T.null ident
-        then mempty
-        else selfClosingTag "anchor" [("id", ident)]) $$ contents
+blockToDocbook opts (Div (ident,classes,_) bs) = do
+  version <- ask
+  let identAttribs = [(idName version, ident) | not (T.null ident)]
+      admonitions = ["attention","caution","danger","error","hint",
+                     "important","note","tip","warning"]
+  case classes of
+    (l:_) | l `elem` admonitions -> do
+        let (mTitleBs, bodyBs) =
+                case bs of
+                  -- Matches AST produced by the DocBook reader → Markdown writer → Markdown reader chain.
+                  (Div (_,["title"],_) [Para ts] : rest) -> (Just (inlinesToDocbook opts ts), rest)
+                  -- Matches AST produced by the Docbook reader.
+                  (Div (_,["title"],_) ts : rest) -> (Just (blocksToDocbook opts ts), rest)
+                  _ -> (Nothing, bs)
+        admonitionTitle <- case mTitleBs of
+                              Nothing -> return mempty
+                              -- id will be attached to the admonition so let’s pass empty identAttrs.
+                              Just titleBs -> inTags False "title" [] <$> titleBs
+        admonitionBody <- handleDivBody [] bodyBs
+        return (inTags True l identAttribs (admonitionTitle $$ admonitionBody))
+    _ -> handleDivBody identAttribs bs
+  where
+    handleDivBody identAttribs [Para lst] =
+      if hasLineBreaks lst
+         then flush . nowrap . inTags False "literallayout" identAttribs
+                             <$> inlinesToDocbook opts lst
+         else inTags True "para" identAttribs <$> inlinesToDocbook opts lst
+    handleDivBody identAttribs bodyBs = do
+      contents <- blocksToDocbook opts (map plainToPara bodyBs)
+      return $
+        (if null identAttribs
+            then mempty
+            else selfClosingTag "anchor" identAttribs) $$ contents
 blockToDocbook _ h@Header{} = do
   -- should be handled by Div section above, except inside lists/blockquotes
   report $ BlockNotRendered h
@@ -353,11 +378,12 @@ inlineToDocbook opts (Quoted _ lst) =
   inTagsSimple "quote" <$> inlinesToDocbook opts lst
 inlineToDocbook opts (Cite _ lst) =
   inlinesToDocbook opts lst
-inlineToDocbook opts (Span (ident,_,_) ils) =
+inlineToDocbook opts (Span (ident,_,_) ils) = do
+  version <- ask
   ((if T.null ident
        then mempty
-       else selfClosingTag "anchor" [("id", ident)]) <>) <$>
-  inlinesToDocbook opts ils
+       else selfClosingTag "anchor" [(idName version, ident)]) <>) <$>
+    inlinesToDocbook opts ils
 inlineToDocbook _ (Code _ str) =
   return $ inTagsSimple "literal" $ literal (escapeStringForXML str)
 inlineToDocbook opts (Math t str)
diff --git a/test/Tests/Writers/Docbook.hs b/test/Tests/Writers/Docbook.hs
index f6a047b0b..621c1280b 100644
--- a/test/Tests/Writers/Docbook.hs
+++ b/test/Tests/Writers/Docbook.hs
@@ -70,6 +70,72 @@ tests = [ testGroup "line blocks"
                                       , "</para>" ]
                                     )
           ]
+        , testGroup "divs"
+          [ "admonition" =: divWith ("foo", ["warning"], []) (para "This is a test")
+                              =?> unlines
+                                    [ "<warning id=\"foo\">"
+                                    , "  <para>"
+                                    , "    This is a test"
+                                    , "  </para>"
+                                    , "</warning>"
+                                    ]
+          , "admonition-with-title" =:
+                            divWith ("foo", ["attention"], []) (
+                              divWith ("foo", ["title"], [])
+                                (plain (text "This is title")) <>
+                              para "This is a test"
+                            )
+                              =?> unlines
+                                    [ "<attention id=\"foo\">"
+                                    , "  <title>This is title</title>"
+                                    , "  <para>"
+                                    , "    This is a test"
+                                    , "  </para>"
+                                    , "</attention>"
+                                    ]
+          , "admonition-with-title-in-para" =:
+                            divWith ("foo", ["attention"], []) (
+                              divWith ("foo", ["title"], [])
+                                (para "This is title") <>
+                              para "This is a test"
+                            )
+                              =?> unlines
+                                    [ "<attention id=\"foo\">"
+                                    , "  <title>This is title</title>"
+                                    , "  <para>"
+                                    , "    This is a test"
+                                    , "  </para>"
+                                    , "</attention>"
+                                    ]
+          , "single-child" =:
+                            divWith ("foo", [], []) (para "This is a test")
+                              =?> unlines
+                                    [ "<para id=\"foo\">"
+                                    , "  This is a test"
+                                    , "</para>"
+                                    ]
+          , "single-literal-child" =:
+                            divWith ("foo", [], []) lineblock
+                              =?> unlines
+                                    [ "<literallayout id=\"foo\">some text"
+                                    , "and more lines"
+                                    , "and again</literallayout>"
+                                    ]
+          , "multiple-children" =:
+                            divWith ("foo", [], []) (
+                              para "This is a test" <>
+                              para "This is an another test"
+                            )
+                              =?> unlines
+                                    [ "<anchor id=\"foo\" />"
+                                    , "<para>"
+                                    , "  This is a test"
+                                    , "</para>"
+                                    , "<para>"
+                                    , "  This is an another test"
+                                    , "</para>"
+                                    ]
+          ]
         , testGroup "compact lists"
           [ testGroup "bullet"
             [ "compact"    =: bulletList [plain "a", plain "b", plain "c"]