Org reader: support `ATTR_HTML` for special blocks

Special blocks (i.e. blocks with unrecognized names) can be prefixed
with an `ATTR_HTML` block attribute.  The attributes defined in that
meta-directive are added to the `Div` which is used to represent the
special block.

Closes: #3182

2 files changed, 31 insertions, 9 deletions

diff --git a/src/Text/Pandoc/Readers/Org/Blocks.hs b/src/Text/Pandoc/Readers/Org/Blocks.hs
index a5957dbc9..d42e93d78 100644
--- a/src/Text/Pandoc/Readers/Org/Blocks.hs
+++ b/src/Text/Pandoc/Readers/Org/Blocks.hs
@@ -294,6 +294,17 @@ data BlockAttributes = BlockAttributes
   , blockAttrKeyValues :: [(String, String)]
   }
 
+-- | Convert BlockAttributes into pandoc Attr
+attrFromBlockAttributes :: BlockAttributes -> Attr
+attrFromBlockAttributes (BlockAttributes{..}) =
+  let
+    ident   = fromMaybe mempty $ lookup "id" blockAttrKeyValues
+    classes = case lookup "class" blockAttrKeyValues of
+                Nothing     -> []
+                Just clsStr -> words clsStr
+    kv      = filter ((`notElem` ["id", "class"]) . fst) blockAttrKeyValues
+  in (ident, classes, kv)
+
 stringyMetaAttribute :: (String -> Bool) -> OrgParser (String, String)
 stringyMetaAttribute attrCheck = try $ do
   metaLineStart
@@ -364,23 +375,25 @@ orgBlock = try $ do
   blockAttrs <- blockAttributes
   blkType <- blockHeaderStart
   ($ blkType) $
-    case blkType of
+    case (map toLower blkType) of
       "export"  -> exportBlock
       "comment" -> rawBlockLines (const mempty)
-      "html"    -> rawBlockLines (return . (B.rawBlock blkType))
-      "latex"   -> rawBlockLines (return . (B.rawBlock blkType))
-      "ascii"   -> rawBlockLines (return . (B.rawBlock blkType))
+      "html"    -> rawBlockLines (return . B.rawBlock (lowercase blkType))
+      "latex"   -> rawBlockLines (return . B.rawBlock (lowercase blkType))
+      "ascii"   -> rawBlockLines (return . B.rawBlock (lowercase blkType))
       "example" -> rawBlockLines (return . exampleCode)
       "quote"   -> parseBlockLines (fmap B.blockQuote)
       "verse"   -> verseBlock
       "src"     -> codeBlock blockAttrs
-      _         -> parseBlockLines (fmap $ B.divWith (mempty, [blkType], mempty))
+      _         -> parseBlockLines $
+                   let (ident, classes, kv) = attrFromBlockAttributes blockAttrs
+                   in fmap $ B.divWith (ident, classes ++ [blkType], kv)
  where
    blockHeaderStart :: OrgParser String
-   blockHeaderStart = try $ do
-     skipSpaces
-     blockType <- stringAnyCase "#+begin_" *> orgArgWord
-     return (map toLower blockType)
+   blockHeaderStart = try $ skipSpaces *> stringAnyCase "#+begin_" *> orgArgWord
+
+   lowercase :: String -> String
+   lowercase = map toLower
 
 rawBlockLines :: (String   -> F Blocks) -> String -> OrgParser (F Blocks)
 rawBlockLines f blockType = (ignHeaders *> (f <$> rawBlockContent blockType))
diff --git a/tests/Tests/Readers/Org.hs b/tests/Tests/Readers/Org.hs
index 3aa38ff0c..1b536551c 100644
--- a/tests/Tests/Readers/Org.hs
+++ b/tests/Tests/Readers/Org.hs
@@ -1625,6 +1625,15 @@ tests =
                   ] =?>
           rawBlock "html" "\n<span>boring</span>\n\n"
 
+      , "Accept `ATTR_HTML` attributes for generic block" =:
+          unlines [ "#+ATTR_HTML: :title hello, world :id test :class fun code"
+                  , "#+BEGIN_TEST"
+                  , "nonsense"
+                  , "#+END_TEST"
+                  ] =?>
+          let attr = ("test", ["fun", "code", "TEST"], [("title", "hello, world")])
+          in divWith attr (para "nonsense")
+
       , "Non-letter chars in source block parameters" =:
           unlines [ "#+BEGIN_SRC C :tangle xxxx.c :city Zürich"
                   , "code body"