Org reader: refactor block attribute handling

A parser state attribute was used to keep track of block attributes
defined in meta-lines.  Global state is undesirable, so block attributes
are no longer saved as part of the parser state.  Old functions and the
respective part of the parser state are removed.

src/Text/Pandoc/Readers/Org.hs

@@ -49,10 +49,10 @@ import qualified Text.TeXMath.Readers.MathML.EntityMap as MathMLEntityMap
 import           Control.Arrow (first)
 import           Control.Monad (foldM, guard, mplus, mzero, when)
 import           Control.Monad.Reader ( Reader, runReader )
-import           Data.Char (isAlphaNum, isSpace, toLower)
-import           Data.List (intersperse, isPrefixOf, isSuffixOf)
+import           Data.Char (isAlphaNum, isSpace, toLower, toUpper)
+import           Data.List ( foldl', intersperse, isPrefixOf, isSuffixOf )
 import qualified Data.Map as M
-import           Data.Maybe (fromMaybe, isJust)
+import           Data.Maybe ( fromMaybe, isNothing )
 import           Network.HTTP (urlEncode)
 
 
@@ -273,11 +273,9 @@ parseBlocks = mconcat <$> manyTill block eof
 
 block :: OrgParser (F Blocks)
 block = choice [ mempty <$ blanklines
-               , optionalAttributes $ choice
-                 [ orgBlock
-                 , figure
                , table
-                 ]
+               , orgBlock
+               , figure
                , example
                , drawer
                , specialLine
@@ -289,50 +287,53 @@ block = choice [ mempty <$ blanklines
                , paraOrPlain
                ] <?> "block"
 
+
 --
 -- Block Attributes
 --
 
--- | Parse optional block attributes (like #+TITLE or #+NAME)
-optionalAttributes :: OrgParser (F Blocks) -> OrgParser (F Blocks)
-optionalAttributes parser = try $
-  resetBlockAttributes *> parseBlockAttributes *> parser
- where
-   resetBlockAttributes :: OrgParser ()
-   resetBlockAttributes = updateState $ \s ->
-     s{ orgStateBlockAttributes = orgStateBlockAttributes def }
+-- | Attributes that may be added to figures (like a name or caption).
+data BlockAttributes = BlockAttributes
+  { blockAttrName    :: Maybe String
+  , blockAttrCaption :: Maybe (F Inlines)
+  }
 
-parseBlockAttributes :: OrgParser ()
-parseBlockAttributes = do
-  attrs <- many attribute
-  mapM_ (uncurry parseAndAddAttribute) attrs
- where
-   attribute :: OrgParser (String, String)
-   attribute = try $ do
-         key <- metaLineStart *> many1Till nonspaceChar (char ':')
-         val <- skipSpaces *> anyLine
-         return (map toLower key, val)
+stringyMetaAttribute :: (String -> Bool) -> OrgParser (String, String)
+stringyMetaAttribute attrCheck = try $ do
+  metaLineStart
+  attrName <- map toUpper <$> many1Till nonspaceChar (char ':')
+  guard $ attrCheck attrName
+  skipSpaces
+  attrValue <- manyTill anyChar newline
+  return (attrName, attrValue)
 
-parseAndAddAttribute :: String -> String -> OrgParser ()
-parseAndAddAttribute key value = do
-  let key' = map toLower key
-  () <$ addBlockAttribute key' value
-
-lookupInlinesAttr :: String -> OrgParser (Maybe (F Inlines))
-lookupInlinesAttr attr = try $ do
-  val <- lookupBlockAttribute attr
-  maybe (return Nothing)
+blockAttributes :: OrgParser BlockAttributes
+blockAttributes = try $ do
+  kv <- many (stringyMetaAttribute attrCheck)
+  let caption = foldl' (appendValues "CAPTION") Nothing kv
+  let name    = lookup "NAME" kv
+  caption' <- maybe (return Nothing)
                     (fmap Just . parseFromString parseInlines)
-        val
+                    caption
+  return $ BlockAttributes
+           { blockAttrName = name
+           , blockAttrCaption = caption'
+           }
+ where
+   attrCheck :: String -> Bool
+   attrCheck attr =
+     case attr of
+       "NAME"    -> True
+       "CAPTION" -> True
+       _         -> False
 
-addBlockAttribute :: String -> String -> OrgParser ()
-addBlockAttribute key val = updateState $ \s ->
-  let attrs = orgStateBlockAttributes s
-  in s{ orgStateBlockAttributes = M.insert key val attrs }
-
-lookupBlockAttribute :: String -> OrgParser (Maybe String)
-lookupBlockAttribute key =
-  M.lookup key . orgStateBlockAttributes <$> getState
+   appendValues :: String -> Maybe String -> (String, String) -> Maybe String
+   appendValues attrName accValue (key, value) =
+     if key /= attrName
+     then accValue
+     else case accValue of
+            Just acc -> Just $ acc ++ ' ':value
+            Nothing  -> Just value
 
 
 --
@@ -346,6 +347,7 @@ updateIndent (_, blkType) indent = (indent, blkType)
 
 orgBlock :: OrgParser (F Blocks)
 orgBlock = try $ do
+  blockAttrs <- blockAttributes
   blockProp@(_, blkType) <- blockHeaderStart
   ($ blockProp) $
     case blkType of
@@ -356,7 +358,7 @@ orgBlock = try $ do
       "example" -> withRaw'   (return . exampleCode)
       "quote"   -> withParsed (fmap B.blockQuote)
       "verse"   -> verseBlock
-      "src"     -> codeBlock
+      "src"     -> codeBlock blockAttrs
       _         -> withParsed (fmap $ divWithClass blkType)
 
 blockHeaderStart :: OrgParser (Int, String)
@@ -410,20 +412,20 @@ followingResultsBlock =
                                      *> blankline
                                      *> block)
 
-codeBlock :: BlockProperties -> OrgParser (F Blocks)
-codeBlock blkProp = do
+codeBlock :: BlockAttributes -> BlockProperties -> OrgParser (F Blocks)
+codeBlock blockAttrs blkProp = do
   skipSpaces
   (classes, kv)     <- codeHeaderArgs <|> (mempty <$ ignHeaders)
-  id'               <- fromMaybe "" <$> lookupBlockAttribute "name"
   leadingIndent     <- lookAhead indentation
   content           <- rawBlockContent (updateIndent blkProp leadingIndent)
   resultsContent    <- followingResultsBlock
+  let id'            = fromMaybe mempty $ blockAttrName blockAttrs
   let includeCode    = exportsCode kv
   let includeResults = exportsResults kv
   let codeBlck       = B.codeBlockWith ( id', classes, kv ) content
-  labelledBlck      <- maybe (pure codeBlck)
+  let labelledBlck   = maybe (pure codeBlck)
                              (labelDiv codeBlck)
-                             <$> lookupInlinesAttr "caption"
+                             (blockAttrCaption blockAttrs)
   let resultBlck     = fromMaybe mempty resultsContent
   return $ (if includeCode then labelledBlck else mempty)
            <> (if includeResults then resultBlck else mempty)
@@ -579,23 +581,18 @@ drawerEnd = try $
 -- Figures
 --
 
--- Figures (Image on a line by itself, preceded by name and/or caption)
+
+-- | Figures (Image on a line by itself, preceded by name and/or caption)
 figure :: OrgParser (F Blocks)
 figure = try $ do
-  (cap, nam) <- nameAndCaption
+  figAttrs <- blockAttributes
   src <- skipSpaces *> selfTarget <* skipSpaces <* P.newline
+  guard . not . isNothing . blockAttrCaption $ figAttrs
   guard (isImageFilename src)
-  return $ do
-    cap' <- cap
-    return $ B.para $ B.image src nam cap'
+  let figName    = fromMaybe mempty $ blockAttrName figAttrs
+  let figCaption = fromMaybe mempty $ blockAttrCaption figAttrs
+  return $ (B.para . B.image src (withFigPrefix figName) <$> figCaption)
  where
-   nameAndCaption =
-       do
-         maybeCap <- lookupInlinesAttr "caption"
-         maybeNam <- lookupBlockAttribute "name"
-         guard $ isJust maybeCap || isJust maybeNam
-         return ( fromMaybe mempty maybeCap
-                , withFigPrefix $ fromMaybe mempty maybeNam )
    withFigPrefix cs =
      if "fig:" `isPrefixOf` cs
      then cs
@@ -603,23 +600,23 @@ figure = try $ do
 
 --
 -- Comments, Options and Metadata
+--
 specialLine :: OrgParser (F Blocks)
 specialLine = fmap return . try $ metaLine <|> commentLine
 
 metaLine :: OrgParser Blocks
-metaLine = try $ mempty
-              <$ (metaLineStart *> (optionLine <|> declarationLine))
-
-commentLine :: OrgParser Blocks
-commentLine = try $ commentLineStart *> anyLine *> pure mempty
+metaLine = mempty <$ metaLineStart <* (optionLine <|> declarationLine)
 
 -- The order, in which blocks are tried, makes sure that we're not looking at
 -- the beginning of a block, so we don't need to check for it
-metaLineStart :: OrgParser String
-metaLineStart = try $ mappend <$> many spaceChar <*> string "#+"
+metaLineStart :: OrgParser ()
+metaLineStart = try $ skipSpaces <* string "#+"
 
-commentLineStart :: OrgParser String
-commentLineStart = try $ mappend <$> many spaceChar <*> string "# "
+commentLine :: OrgParser Blocks
+commentLine = commentLineStart *> anyLine *> pure mempty
+
+commentLineStart :: OrgParser ()
+commentLineStart = try $ skipSpaces <* string "# "
 
 declarationLine :: OrgParser ()
 declarationLine = try $ do
@@ -738,11 +735,12 @@ data OrgTable = OrgTable
 
 table :: OrgParser (F Blocks)
 table = try $ do
+  blockAttrs <- blockAttributes
   lookAhead tableStart
   do
     rows <- tableRows
-    cptn <- fromMaybe (pure "") <$> lookupInlinesAttr "caption"
-    return $ (<$> cptn) . orgToPandocTable . normalizeTable =<< rowsToTable rows
+    let caption = fromMaybe (return mempty) $ blockAttrCaption blockAttrs
+    return $ (<$> caption) . orgToPandocTable . normalizeTable =<< rowsToTable rows
 
 orgToPandocTable :: OrgTable
                  -> Inlines

src/Text/Pandoc/Readers/Org/ParserState.hs

@@ -68,8 +68,6 @@ import           Text.Pandoc.Parsing ( HasHeaderMap(..)
 type OrgNoteRecord = (String, F Blocks)
 -- | Table of footnotes
 type OrgNoteTable = [OrgNoteRecord]
--- | Map of org block attributes (e.g. LABEL, CAPTION, NAME, etc)
-type OrgBlockAttributes = M.Map String String
 -- | Map of functions for link transformations.  The map key is refers to the
 -- link-type, the corresponding function transforms the given link string.
 type OrgLinkFormatters = M.Map String (String -> String)
@@ -84,7 +82,6 @@ data ExportSettings = ExportSettings
 data OrgParserState = OrgParserState
   { orgStateOptions              :: ReaderOptions
   , orgStateAnchorIds            :: [String]
-  , orgStateBlockAttributes      :: OrgBlockAttributes
   , orgStateEmphasisCharStack    :: [Char]
   , orgStateEmphasisNewlines     :: Maybe Int
   , orgStateExportSettings       :: ExportSettings
@@ -140,7 +137,6 @@ defaultOrgParserState :: OrgParserState
 defaultOrgParserState = OrgParserState
   { orgStateOptions = def
   , orgStateAnchorIds = []
-  , orgStateBlockAttributes = M.empty
   , orgStateEmphasisCharStack = []
   , orgStateEmphasisNewlines = Nothing
   , orgStateExportSettings = def