@@ -43,13 +43,13 @@ import Text.Pandoc.Shared (compactify')
4343
4444import Control.Applicative ( Applicative, pure
4545 , (<$>), (<$), (<*>), (<*), (*>), (<**>) )
46−import Control.Arrow ((***))
4746import Control.Monad (foldM, guard, liftM, liftM2, when)
4847import Control.Monad.Reader (Reader, runReader, ask, asks)
4948import Data.Char (toLower)
5049import Data.Default
5150import Data.List (intersperse, isPrefixOf, isSuffixOf)
52−import Data.Maybe (listToMaybe, fromMaybe)
51+import qualified Data.Map as M
52+import Data.Maybe (listToMaybe, fromMaybe, isJust)
5353import Data.Monoid (Monoid, mconcat, mempty, mappend)
5454
5555-- | Parse org-mode string and return a Pandoc document.
@@ -74,9 +74,12 @@ parseOrg = do
7474type OrgNoteRecord = (String, F Blocks)
7575type OrgNoteTable = [OrgNoteRecord]
7676
77+type OrgBlockAttributes = M.Map String String
78+
7779-- | Org-mode parser state
7880data OrgParserState = OrgParserState
7981 { orgStateOptions :: ReaderOptions
82+ , orgStateBlockAttributes :: OrgBlockAttributes
8083 , orgStateEmphasisCharStack :: [Char]
8184 , orgStateEmphasisNewlines :: Maybe Int
8285 , orgStateLastForbiddenCharPos :: Maybe SourcePos
@@ -102,6 +105,7 @@ instance Default OrgParserState where
102105defaultOrgParserState :: OrgParserState
103106defaultOrgParserState = OrgParserState
104107 { orgStateOptions = def
108+ , orgStateBlockAttributes = M.empty
105109 , orgStateEmphasisCharStack = []
106110 , orgStateEmphasisNewlines = Nothing
107111 , orgStateLastForbiddenCharPos = Nothing
@@ -112,6 +116,19 @@ defaultOrgParserState = OrgParserState
112116 , orgStateNotes' = []
113117 }
114118
119+addBlockAttribute :: String -> String -> OrgParser ()
120+addBlockAttribute key val = updateState $ \s ->
121+ let attrs = orgStateBlockAttributes s
122+ in s{ orgStateBlockAttributes = M.insert key val attrs }
123+
124+lookupBlockAttribute :: String -> OrgParser (Maybe String)
125+lookupBlockAttribute key =
126+ M.lookup key . orgStateBlockAttributes <$> getState
127+
128+resetBlockAttributes :: OrgParser ()
129+resetBlockAttributes = updateState $ \s ->
130+ s{ orgStateBlockAttributes = orgStateBlockAttributes def }
131+
115132updateLastStrPos :: OrgParser ()
116133updateLastStrPos = getPosition >>= \p ->
117134 updateState $ \s -> s{ orgStateLastStrPos = Just p }
@@ -125,19 +142,19 @@ updateLastPreCharPos = getPosition >>= \p ->
125142 updateState $ \s -> s{ orgStateLastPreCharPos = Just p}
126143
127144pushToInlineCharStack :: Char -> OrgParser ()
128−pushToInlineCharStack c = updateState $ \st ->
129− st { orgStateEmphasisCharStack = c:orgStateEmphasisCharStack st }
145+pushToInlineCharStack c = updateState $ \s ->
146+ s{ orgStateEmphasisCharStack = c:orgStateEmphasisCharStack s }
130147
131148popInlineCharStack :: OrgParser ()
132−popInlineCharStack = updateState $ \st ->
133− st { orgStateEmphasisCharStack = drop 1 . orgStateEmphasisCharStack $ st }
149+popInlineCharStack = updateState $ \s ->
150+ s{ orgStateEmphasisCharStack = drop 1 . orgStateEmphasisCharStack $ s }
134151
135152surroundingEmphasisChar :: OrgParser [Char]
136153surroundingEmphasisChar = take 1 . drop 1 . orgStateEmphasisCharStack <$> getState
137154
138155startEmphasisNewlinesCounting :: Int -> OrgParser ()
139156startEmphasisNewlinesCounting maxNewlines = updateState $ \s ->
140− s { orgStateEmphasisNewlines = Just maxNewlines }
157+ s{ orgStateEmphasisNewlines = Just maxNewlines }
141158
142159decEmphasisNewlinesCount :: OrgParser ()
143160decEmphasisNewlinesCount = updateState $ \s ->
@@ -209,20 +226,50 @@ parseBlocks = mconcat <$> manyTill block eof
209226
210227block :: OrgParser (F Blocks)
211228block = choice [ mempty <$ blanklines
212− , orgBlock
229+ , optionalAttributes $ choice
230+ [ orgBlock
231+ , figure
232+ , table
233+ ]
213234 , example
214235 , drawer
215− , figure
216236 , specialLine
217237 , header
218238 , return <$> hline
219239 , list
220− , table
221240 , latexFragment
222241 , noteBlock
223242 , paraOrPlain
224243 ] <?> "block"
225244
245+optionalAttributes :: OrgParser (F Blocks) -> OrgParser (F Blocks)
246+optionalAttributes parser = try $
247+ resetBlockAttributes *> parseBlockAttributes *> parser
248+
249+parseBlockAttributes :: OrgParser ()
250+parseBlockAttributes = do
251+ attrs <- many attribute
252+ () <$ mapM (uncurry parseAndAddAttribute) attrs
253+ where
254+ attribute :: OrgParser (String, String)
255+ attribute = try $ do
256+ key <- metaLineStart *> many1Till (noneOf "\n\r") (char ':')
257+ val <- skipSpaces *> anyLine
258+ return (map toLower key, val)
259+
260+parseAndAddAttribute :: String -> String -> OrgParser ()
261+parseAndAddAttribute key value = do
262+ let key' = map toLower key
263+ () <$ addBlockAttribute key' value
264+
265+lookupInlinesAttr :: String -> OrgParser (Maybe (F Inlines))
266+lookupInlinesAttr attr = try $ do
267+ val <- lookupBlockAttribute attr
268+ maybe (return Nothing)
269+ (fmap Just . parseFromString parseInlines)
270+ val
271+
272+
226273--
227274-- Org Blocks (#+BEGIN_... / #+END_...)
228275--
@@ -235,13 +282,13 @@ orgBlock = try $ do
235282 let classArgs = [ translateLang . fromMaybe [] $ listToMaybe args ]
236283 case blockType of
237284 "comment" -> return mempty
238− "src" -> returnF $ B.codeBlockWith ("", classArgs, []) content
239285 "html" -> returnF $ B.rawBlock "html" content
240286 "latex" -> returnF $ B.rawBlock "latex" content
241287 "ascii" -> returnF $ B.rawBlock "ascii" content
242288 "example" -> returnF $ exampleCode content
243289 "quote" -> return $ B.blockQuote <$> contentBlocks
244290 "verse" -> parseVerse content
291+ "src" -> codeBlockWithAttr classArgs content
245292 _ -> return $ B.divWith ("", [blockType], []) <$> contentBlocks
246293 where
247294 returnF :: a -> OrgParser (F a)
@@ -260,6 +307,18 @@ blockHeader = (,,) <$> blockIndent
260307 blockType = map toLower <$> (stringAnyCase "#+begin_" *> many letter)
261308 blockArgs = manyTill (many nonspaceChar <* skipSpaces) newline
262309
310+codeBlockWithAttr :: [String] -> String -> OrgParser (F Blocks)
311+codeBlockWithAttr classArgs content = do
312+ identifier <- fromMaybe "" <$> lookupBlockAttribute "name"
313+ caption <- lookupInlinesAttr "caption"
314+ let codeBlck = B.codeBlockWith (identifier, classArgs, []) content
315+ return $ maybe (pure codeBlck) (labelDiv codeBlck) caption
316+ where
317+ labelDiv blk value =
318+ B.divWith nullAttr <$> (mappend <$> labelledBlock value
319+ <*> pure blk)
320+ labelledBlock = fmap (B.plain . B.spanWith ("", ["label"], []))
321+
263322rawBlockContent :: Int -> String -> OrgParser String
264323rawBlockContent indent blockType =
265324 unlines . map commaEscaped <$> manyTill indentedLine blockEnder
@@ -333,38 +392,26 @@ drawerEnd = try $
333392-- Figures (Image on a line by itself, preceded by name and/or caption)
334393figure :: OrgParser (F Blocks)
335394figure = try $ do
336− (tit, cap) <- (maybe mempty withFigPrefix *** fromMaybe mempty)
337− <$> nameAndOrCaption
395+ (cap, nam) <- nameAndCaption
338396 src <- skipSpaces *> selfTarget <* skipSpaces <* newline
339397 guard (isImageFilename src)
340398 return $ do
341399 cap' <- cap
342− return $ B.para $ B.image src tit cap'
343− where withFigPrefix cs = if "fig:" `isPrefixOf` cs
344− then cs
345− else "fig:" ++ cs
346−
347−nameAndOrCaption :: OrgParser (Maybe String, Maybe (F Inlines))
348−nameAndOrCaption = try $ nameFirst <|> captionFirst
400+ return $ B.para $ B.image src nam cap'
349401 where
350− nameFirst = try $ do
351− n <- name
352− c <- optionMaybe caption
353− return (Just n, c)
354− captionFirst = try $ do
355− c <- caption
356− n <- optionMaybe name
357− return (n, Just c)
358−
359−caption :: OrgParser (F Inlines)
360−caption = try $ annotation "CAPTION" *> inlinesTillNewline
361−
362−name :: OrgParser String
363−name = try $ annotation "NAME" *> skipSpaces *> manyTill anyChar newline
364−
365−annotation :: String -> OrgParser String
366−annotation ann = try $ metaLineStart *> stringAnyCase ann <* char ':'
402+ nameAndCaption =
403+ do
404+ maybeCap <- lookupInlinesAttr "caption"
405+ maybeNam <- lookupBlockAttribute "name"
406+ guard $ isJust maybeCap || isJust maybeNam
407+ return ( fromMaybe mempty maybeCap
408+ , maybe mempty withFigPrefix maybeNam )
409+ withFigPrefix cs =
410+ if "fig:" `isPrefixOf` cs
411+ then cs
412+ else "fig:" ++ cs
367413
414+--
368415-- Comments, Options and Metadata
369416specialLine :: OrgParser (F Blocks)
370417specialLine = fmap return . try $ metaLine <|> commentLine
@@ -400,6 +447,10 @@ metaKey = map toLower <$> many1 (noneOf ": \n\r")
400447 <* char ':'
401448 <* skipSpaces
402449
450+--
451+-- Headers
452+--
453+
403454-- | Headers
404455header :: OrgParser (F Blocks)
405456header = try $ do
@@ -411,6 +462,7 @@ headerStart :: OrgParser Int
411462headerStart = try $
412463 (length <$> many1 (char '*')) <* many1 (char ' ')
413464
465+
414466-- Don't use (or need) the reader wrapper here, we want hline to be
415467-- @show@able. Otherwise we can't use it with @notFollowedBy'@.
416468
@@ -444,12 +496,14 @@ table = try $ do
444496 lookAhead tableStart
445497 do
446498 rows <- tableRows
447− return $ return . orgToPandocTable . normalizeTable =<< rowsToTable rows
499+ cptn <- fromMaybe (pure "") <$> lookupInlinesAttr "caption"
500+ return $ (<$> cptn) . orgToPandocTable . normalizeTable =<< rowsToTable rows
448501
449502orgToPandocTable :: OrgTable
503+ -> Inlines
450504 -> Blocks
451−orgToPandocTable (OrgTable _ aligns heads lns) =
452− B.table "" (zip aligns $ repeat 0) heads lns
505+orgToPandocTable (OrgTable _ aligns heads lns) caption =
506+ B.table caption (zip aligns $ repeat 0) heads lns
453507
454508tableStart :: OrgParser Char
455509tableStart = try $ skipSpaces *> char '|'