Store "unnumbered" class in DocBook role attribute (#8481)

Markdown allows marking a heading as unnumbered, which is stored
as a class token internally. This change will recognize this
particular class token and append it to the role attribute, or
create a role attribute with it if needed. This does not imply
any processing in DocBook but is intended to let customized
stylesheets identify these sections and act accordingly.

Closes #1402

2 files changed, 29 insertions, 9 deletions

diff --git a/src/Text/Pandoc/Writers/DocBook.hs b/src/Text/Pandoc/Writers/DocBook.hs
index 6e3d5bd79..e9eceb60c 100644
--- a/src/Text/Pandoc/Writers/DocBook.hs
+++ b/src/Text/Pandoc/Writers/DocBook.hs
@@ -14,7 +14,7 @@ Conversion of 'Pandoc' documents to DocBook XML.
 module Text.Pandoc.Writers.DocBook ( writeDocBook4, writeDocBook5 ) where
 import Control.Monad.Reader
 import Data.Generics (everywhere, mkT)
-import Data.Maybe (isNothing)
+import Data.Maybe (isNothing, maybeToList)
 import Data.Monoid (Any (..))
 import Data.Text (Text)
 import qualified Data.Text as T
@@ -169,7 +169,7 @@ blockToDocBook :: PandocMonad m => WriterOptions -> Block -> DB m (Doc Text)
 blockToDocBook _ Null = return empty
 -- Add ids to paragraphs in divs with ids - this is needed for
 -- pandoc-citeproc to get link anchors in bibliographies:
-blockToDocBook opts (Div (id',"section":_,_) (Header lvl (_,_,attrs) ils : xs)) = do
+blockToDocBook opts (Div (id',"section":_,_) (Header lvl (_,classes,attrs) ils : xs)) = do
   version <- ask
   -- DocBook doesn't allow sections with no content, so insert some if needed
   let bs = if null xs
@@ -191,7 +191,8 @@ blockToDocBook opts (Div (id',"section":_,_) (Header lvl (_,_,attrs) ils : xs))
                  else []
 
       -- Populate miscAttr with Header.Attr.attributes, filtering out non-valid DocBook section attributes, id, and xml:id
-      miscAttr = filter (isSectionAttr version) attrs
+      -- Also enrich the role attribute with certain class tokens
+      miscAttr = enrichRole (filter (isSectionAttr version) attrs) classes      
       attribs = nsAttr <> idAttr <> miscAttr
   title' <- inlinesToDocBook opts ils
   contents <- blocksToDocBook opts bs
@@ -464,6 +465,14 @@ idAndRole (id',cls,_) = ident <> role
     ident = [("id", id') | not (T.null id')]
     role  = [("role", T.unwords cls) | not (null cls)]
 
+-- Used in blockToDocBook for Header (section) to create or extend
+-- the role attribute with candidate class tokens
+enrichRole :: [(Text, Text)] -> [Text] -> [(Text, Text)]
+enrichRole mattrs cls = [("role",rolevals) | rolevals /= ""]<>(filter (\x -> (fst x) /= "role") mattrs)
+  where
+    rolevals = T.unwords((filter (`elem` cand) cls)<>(maybeToList(lookup "role" mattrs)))
+    cand = ["unnumbered"]
+
 isSectionAttr :: DocBookVersion -> (Text, Text) -> Bool
 isSectionAttr _ ("label",_) = True
 isSectionAttr _ ("status",_) = True
diff --git a/test/Tests/Writers/DocBook.hs b/test/Tests/Writers/DocBook.hs
index 95111e364..604e3afe5 100644
--- a/test/Tests/Writers/DocBook.hs
+++ b/test/Tests/Writers/DocBook.hs
@@ -387,34 +387,45 @@ tests = [ testGroup "inline elements"
           ]
           , testGroup "section attributes" $
             let
-              headers =  headerWith ("myid1",[],[("role","internal"),("xml:id","anotherid"),("dir","rtl")]) 1 "header1"
-                      <> headerWith ("myid2",[],[("invalidname","value"),("arch","linux"),("dir","invaliddir")]) 1 "header2"
+              headers =  headerWith ("myid1",["unnumbered","ignored"],[("role","internal"),("xml:id","anotherid"),("dir","rtl")]) 1 "header1"
+                      <> headerWith ("myid2",["unnumbered"],[("invalidname","value"),("arch","linux"),("dir","invaliddir")]) 1 "header2"
+                      <> headerWith ("myid3",["ignored"],[]) 1 "header3"
             in
             [ test docbook5 "sections with attributes (db5)" $
               headers =?>
-              unlines [ "<section xmlns=\"http://docbook.org/ns/docbook\" xmlns:xlink=\"http://www.w3.org/1999/xlink\" xml:id=\"myid1\" role=\"internal\" dir=\"rtl\">"
+              unlines [ "<section xmlns=\"http://docbook.org/ns/docbook\" xmlns:xlink=\"http://www.w3.org/1999/xlink\" xml:id=\"myid1\" role=\"unnumbered internal\" dir=\"rtl\">"
                       , "  <title>header1</title>"
                       , "  <para>"
                       , "  </para>"
                       , "</section>"
-                      , "<section xmlns=\"http://docbook.org/ns/docbook\" xmlns:xlink=\"http://www.w3.org/1999/xlink\" xml:id=\"myid2\">"
+                      , "<section xmlns=\"http://docbook.org/ns/docbook\" xmlns:xlink=\"http://www.w3.org/1999/xlink\" xml:id=\"myid2\" role=\"unnumbered\">"
                       , "  <title>header2</title>"
                       , "  <para>"
                       , "  </para>"
                       , "</section>"
+                      , "<section xmlns=\"http://docbook.org/ns/docbook\" xmlns:xlink=\"http://www.w3.org/1999/xlink\" xml:id=\"myid3\">"
+                      , "  <title>header3</title>"
+                      , "  <para>"
+                      , "  </para>"
+                      , "</section>"
                       ]
             , test docbook "sections with attributes (db4)" $
               headers =?>
-              unlines [ "<sect1 id=\"myid1\" role=\"internal\">"
+              unlines [ "<sect1 id=\"myid1\" role=\"unnumbered internal\">"
                       , "  <title>header1</title>"
                       , "  <para>"
                       , "  </para>"
                       , "</sect1>"
-                      , "<sect1 id=\"myid2\" arch=\"linux\">"
+                      , "<sect1 id=\"myid2\" role=\"unnumbered\" arch=\"linux\">"
                       , "  <title>header2</title>"
                       , "  <para>"
                       , "  </para>"
                       , "</sect1>"
+                      , "<sect1 id=\"myid3\">"
+                      , "  <title>header3</title>"
+                      , "  <para>"
+                      , "  </para>"
+                      , "</sect1>"
                       ]
             ]
         ]