Org reader: add support for ATTR_HTML attributes

Arbitrary key-value pairs can be added to some block types using a
`#+ATTR_HTML` line before the block.  Emacs Org-mode only includes these
when exporting to HTML, but since we cannot make this distinction here,
the attributes are always added.

The functionality is now supported for figures.

This closes #1906.

src/Text/Pandoc/Readers/Org.hs

@@ -301,8 +301,9 @@ block = choice [ mempty <$ blanklines
 
 -- | Attributes that may be added to figures (like a name or caption).
 data BlockAttributes = BlockAttributes
-  { blockAttrName    :: Maybe String
-  , blockAttrCaption :: Maybe (F Inlines)
+  { blockAttrName      :: Maybe String
+  , blockAttrCaption   :: Maybe (F Inlines)
+  , blockAttrKeyValues :: [(String, String)]
   }
 
 stringyMetaAttribute :: (String -> Bool) -> OrgParser (String, String)
@@ -318,21 +319,25 @@ blockAttributes :: OrgParser BlockAttributes
 blockAttributes = try $ do
   kv <- many (stringyMetaAttribute attrCheck)
   let caption = foldl' (appendValues "CAPTION") Nothing kv
+  let kvAttrs = foldl' (appendValues "ATTR_HTML") Nothing kv
   let name    = lookup "NAME" kv
   caption' <- maybe (return Nothing)
                     (fmap Just . parseFromString parseInlines)
                     caption
+  kvAttrs' <- parseFromString keyValues . (++ "\n") $ fromMaybe mempty kvAttrs
   return $ BlockAttributes
            { blockAttrName = name
            , blockAttrCaption = caption'
+           , blockAttrKeyValues = kvAttrs'
            }
  where
    attrCheck :: String -> Bool
    attrCheck attr =
      case attr of
-       "NAME"    -> True
-       "CAPTION" -> True
-       _         -> False
+       "NAME"      -> True
+       "CAPTION"   -> True
+       "ATTR_HTML" -> True
+       _           -> False
 
    appendValues :: String -> Maybe String -> (String, String) -> Maybe String
    appendValues attrName accValue (key, value) =
@@ -342,6 +347,21 @@ blockAttributes = try $ do
             Just acc -> Just $ acc ++ ' ':value
             Nothing  -> Just value
 
+keyValues :: OrgParser [(String, String)]
+keyValues = try $
+  manyTill ((,) <$> key <*> value) newline
+ where
+   key :: OrgParser String
+   key = try $ skipSpaces *> char ':' *> many1 nonspaceChar
+
+   value :: OrgParser String
+   value = skipSpaces *> manyTill anyChar endOfValue
+
+   endOfValue :: OrgParser ()
+   endOfValue =
+     lookAhead $ (() <$ try (many1 spaceChar <* key))
+              <|> () <$ P.newline
+
 
 --
 -- Org Blocks (#+BEGIN_... / #+END_...)
@@ -588,7 +608,6 @@ drawerEnd = try $
 -- Figures
 --
 
-
 -- | Figures (Image on a line by itself, preceded by name and/or caption)
 figure :: OrgParser (F Blocks)
 figure = try $ do
@@ -598,7 +617,9 @@ figure = try $ do
   guard (isImageFilename src)
   let figName    = fromMaybe mempty $ blockAttrName figAttrs
   let figCaption = fromMaybe mempty $ blockAttrCaption figAttrs
-  return $ (B.para . B.image src (withFigPrefix figName) <$> figCaption)
+  let figKeyVals = blockAttrKeyValues figAttrs
+  let attr       = (mempty, mempty, figKeyVals)
+  return $ (B.para . B.imageWith attr src (withFigPrefix figName) <$> figCaption)
  where
    withFigPrefix cs =
      if "fig:" `isPrefixOf` cs

tests/Tests/Readers/Org.hs

@@ -667,6 +667,17 @@ tests =
           para (image "the-red-queen.jpg" "fig:redqueen"
                       "Used as a metapher in evolutionary biology.")
 
+      , "Figure with HTML attributes" =:
+          unlines [ "#+CAPTION: mah brain just explodid"
+                  , "#+NAME: lambdacat"
+                  , "#+ATTR_HTML: :style color: blue :role button"
+                  , "[[lambdacat.jpg]]"
+                  ] =?>
+          let kv = [("style", "color: blue"), ("role", "button")]
+              name = "fig:lambdacat"
+              caption = "mah brain just explodid"
+          in para (imageWith (mempty, mempty, kv) "lambdacat.jpg" name caption)
+
       , "Footnote" =:
           unlines [ "A footnote[1]"
                   , ""