6ded3d4 · typeable/pandoc

git.iko.soy/typeable/pandoc

on master help sign in

Org reader: Apply captions to code blocks and tables

6ded3d4Albert Krewinkel13 years ago

src/Text/Pandoc/Readers/Org.hs+94−40

compare with master

unifiedsplit

@@ -43,13 +43,13 @@ import Text.Pandoc.Shared (compactify')

44import Control.Applicative ( Applicative, pure

45 , (<$>), (<$), (<*>), (<*), (*>), (<**>) )

46−import Control.Arrow ((***))

47import Control.Monad (foldM, guard, liftM, liftM2, when)

46import Control.Monad (foldM, guard, liftM, liftM2, when)

48import Control.Monad.Reader (Reader, runReader, ask, asks)

47import Control.Monad.Reader (Reader, runReader, ask, asks)

49import Data.Char (toLower)

48import Data.Char (toLower)

50import Data.Default

49import Data.Default

51import Data.List (intersperse, isPrefixOf, isSuffixOf)

50import Data.List (intersperse, isPrefixOf, isSuffixOf)

51+import qualified Data.Map as M

52−import Data.Maybe (listToMaybe, fromMaybe)

52+import Data.Maybe (listToMaybe, fromMaybe, isJust)

53import Data.Monoid (Monoid, mconcat, mempty, mappend)

55-- | Parse org-mode string and return a Pandoc document.

@@ -74,9 +74,12 @@ parseOrg = do

74type OrgNoteRecord = (String, F Blocks)

75type OrgNoteTable = [OrgNoteRecord]

77+type OrgBlockAttributes = M.Map String String

78+

77-- | Org-mode parser state

79-- | Org-mode parser state

78data OrgParserState = OrgParserState

80data OrgParserState = OrgParserState

79 { orgStateOptions :: ReaderOptions

81 { orgStateOptions :: ReaderOptions

82+ , orgStateBlockAttributes :: OrgBlockAttributes

80 , orgStateEmphasisCharStack :: [Char]

83 , orgStateEmphasisCharStack :: [Char]

81 , orgStateEmphasisNewlines :: Maybe Int

84 , orgStateEmphasisNewlines :: Maybe Int

82 , orgStateLastForbiddenCharPos :: Maybe SourcePos

85 , orgStateLastForbiddenCharPos :: Maybe SourcePos

@@ -102,6 +105,7 @@ instance Default OrgParserState where

102defaultOrgParserState :: OrgParserState

105defaultOrgParserState :: OrgParserState

103defaultOrgParserState = OrgParserState

106defaultOrgParserState = OrgParserState

104 { orgStateOptions = def

107 { orgStateOptions = def

108+ , orgStateBlockAttributes = M.empty

105 , orgStateEmphasisCharStack = []

109 , orgStateEmphasisCharStack = []

106 , orgStateEmphasisNewlines = Nothing

110 , orgStateEmphasisNewlines = Nothing

107 , orgStateLastForbiddenCharPos = Nothing

111 , orgStateLastForbiddenCharPos = Nothing

@@ -112,6 +116,19 @@ defaultOrgParserState = OrgParserState

112 , orgStateNotes' = []

116 , orgStateNotes' = []

113 }

117 }

114

118

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+

115updateLastStrPos :: OrgParser ()

132updateLastStrPos :: OrgParser ()

116updateLastStrPos = getPosition >>= \p ->

133updateLastStrPos = getPosition >>= \p ->

117 updateState $ \s -> s{ orgStateLastStrPos = Just p }

134 updateState $ \s -> s{ orgStateLastStrPos = Just p }

@@ -125,19 +142,19 @@ updateLastPreCharPos = getPosition >>= \p ->

125 updateState $ \s -> s{ orgStateLastPreCharPos = Just p}

142 updateState $ \s -> s{ orgStateLastPreCharPos = Just p}

126

143

127pushToInlineCharStack :: Char -> OrgParser ()

144pushToInlineCharStack :: Char -> OrgParser ()

128−pushToInlineCharStack c = updateState $ \st ->

145+pushToInlineCharStack c = updateState $ \s ->

129− st { orgStateEmphasisCharStack = c:orgStateEmphasisCharStack st }

146+ s{ orgStateEmphasisCharStack = c:orgStateEmphasisCharStack s }

130

147

131popInlineCharStack :: OrgParser ()

148popInlineCharStack :: OrgParser ()

132−popInlineCharStack = updateState $ \st ->

149+popInlineCharStack = updateState $ \s ->

133− st { orgStateEmphasisCharStack = drop 1 . orgStateEmphasisCharStack $ st }

150+ s{ orgStateEmphasisCharStack = drop 1 . orgStateEmphasisCharStack $ s }

134

151

135surroundingEmphasisChar :: OrgParser [Char]

152surroundingEmphasisChar :: OrgParser [Char]

136surroundingEmphasisChar = take 1 . drop 1 . orgStateEmphasisCharStack <$> getState

153surroundingEmphasisChar = take 1 . drop 1 . orgStateEmphasisCharStack <$> getState

137

154

138startEmphasisNewlinesCounting :: Int -> OrgParser ()

155startEmphasisNewlinesCounting :: Int -> OrgParser ()

139startEmphasisNewlinesCounting maxNewlines = updateState $ \s ->

156startEmphasisNewlinesCounting maxNewlines = updateState $ \s ->

140− s { orgStateEmphasisNewlines = Just maxNewlines }

157+ s{ orgStateEmphasisNewlines = Just maxNewlines }

141

158

142decEmphasisNewlinesCount :: OrgParser ()

159decEmphasisNewlinesCount :: OrgParser ()

143decEmphasisNewlinesCount = updateState $ \s ->

160decEmphasisNewlinesCount = updateState $ \s ->

@@ -209,20 +226,50 @@ parseBlocks = mconcat <$> manyTill block eof

209

226

210block :: OrgParser (F Blocks)

227block :: OrgParser (F Blocks)

211block = choice [ mempty <$ blanklines

228block = choice [ mempty <$ blanklines

229+ , optionalAttributes $ choice

212− , orgBlock

230+ [ orgBlock

231+ , figure

232+ , table

233+ ]

213 , example

234 , example

214 , drawer

235 , drawer

215− , figure

216 , specialLine

236 , specialLine

217 , header

237 , header

218 , return <$> hline

238 , return <$> hline

219 , list

239 , list

220− , table

221 , latexFragment

240 , latexFragment

222 , noteBlock

241 , noteBlock

223 , paraOrPlain

242 , paraOrPlain

224 ] <?> "block"

243 ] <?> "block"

225

244

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+

226--

273--

227-- Org Blocks (#+BEGIN_... / #+END_...)

274-- Org Blocks (#+BEGIN_... / #+END_...)

228--

275--

@@ -235,13 +282,13 @@ orgBlock = try $ do

235 let classArgs = [ translateLang . fromMaybe [] $ listToMaybe args ]

282 let classArgs = [ translateLang . fromMaybe [] $ listToMaybe args ]

236 case blockType of

283 case blockType of

237 "comment" -> return mempty

284 "comment" -> return mempty

238− "src" -> returnF $ B.codeBlockWith ("", classArgs, []) content

239 "html" -> returnF $ B.rawBlock "html" content

285 "html" -> returnF $ B.rawBlock "html" content

240 "latex" -> returnF $ B.rawBlock "latex" content

286 "latex" -> returnF $ B.rawBlock "latex" content

241 "ascii" -> returnF $ B.rawBlock "ascii" content

287 "ascii" -> returnF $ B.rawBlock "ascii" content

242 "example" -> returnF $ exampleCode content

288 "example" -> returnF $ exampleCode content

243 "quote" -> return $ B.blockQuote <$> contentBlocks

289 "quote" -> return $ B.blockQuote <$> contentBlocks

244 "verse" -> parseVerse content

290 "verse" -> parseVerse content

291+ "src" -> codeBlockWithAttr classArgs content

245 _ -> return $ B.divWith ("", [blockType], []) <$> contentBlocks

292 _ -> return $ B.divWith ("", [blockType], []) <$> contentBlocks

246 where

293 where

247 returnF :: a -> OrgParser (F a)

294 returnF :: a -> OrgParser (F a)

@@ -260,6 +307,18 @@ blockHeader = (,,) <$> blockIndent

260 blockType = map toLower <$> (stringAnyCase "#+begin_" *> many letter)

307 blockType = map toLower <$> (stringAnyCase "#+begin_" *> many letter)

261 blockArgs = manyTill (many nonspaceChar <* skipSpaces) newline

308 blockArgs = manyTill (many nonspaceChar <* skipSpaces) newline

262

309

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+

263rawBlockContent :: Int -> String -> OrgParser String

322rawBlockContent :: Int -> String -> OrgParser String

264rawBlockContent indent blockType =

323rawBlockContent indent blockType =

265 unlines . map commaEscaped <$> manyTill indentedLine blockEnder

324 unlines . map commaEscaped <$> manyTill indentedLine blockEnder

@@ -333,38 +392,26 @@ drawerEnd = try $

333-- Figures (Image on a line by itself, preceded by name and/or caption)

392-- Figures (Image on a line by itself, preceded by name and/or caption)

334figure :: OrgParser (F Blocks)

393figure :: OrgParser (F Blocks)

335figure = try $ do

394figure = try $ do

336− (tit, cap) <- (maybe mempty withFigPrefix *** fromMaybe mempty)

395+ (cap, nam) <- nameAndCaption

337− <$> nameAndOrCaption

338 src <- skipSpaces *> selfTarget <* skipSpaces <* newline

396 src <- skipSpaces *> selfTarget <* skipSpaces <* newline

339 guard (isImageFilename src)

397 guard (isImageFilename src)

340 return $ do

398 return $ do

341 cap' <- cap

399 cap' <- cap

342− return $ B.para $ B.image src tit cap'

400+ return $ B.para $ B.image src nam 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

349 where

401 where

350− nameFirst = try $ do

402+ nameAndCaption =

351− n <- name

403+ do

352− c <- optionMaybe caption

404+ maybeCap <- lookupInlinesAttr "caption"

353− return (Just n, c)

405+ maybeNam <- lookupBlockAttribute "name"

354− captionFirst = try $ do

406+ guard $ isJust maybeCap || isJust maybeNam

355− c <- caption

407+ return ( fromMaybe mempty maybeCap

356− n <- optionMaybe name

408+ , maybe mempty withFigPrefix maybeNam )

357− return (n, Just c)

409+ withFigPrefix cs =

358−

410+ if "fig:" `isPrefixOf` cs

359−caption :: OrgParser (F Inlines)

411+ then cs

360−caption = try $ annotation "CAPTION" *> inlinesTillNewline

412+ else "fig:" ++ cs

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 ':'

367

413

414+--

368-- Comments, Options and Metadata

415-- Comments, Options and Metadata

369specialLine :: OrgParser (F Blocks)

416specialLine :: OrgParser (F Blocks)

370specialLine = fmap return . try $ metaLine <|> commentLine

417specialLine = fmap return . try $ metaLine <|> commentLine

@@ -400,6 +447,10 @@ metaKey = map toLower <$> many1 (noneOf ": \n\r")

400 <* char ':'

447 <* char ':'

401 <* skipSpaces

448 <* skipSpaces

402

449

450+--

451+-- Headers

452+--

453+

403-- | Headers

454-- | Headers

404header :: OrgParser (F Blocks)

455header :: OrgParser (F Blocks)

405header = try $ do

456header = try $ do

@@ -411,6 +462,7 @@ headerStart :: OrgParser Int

411headerStart = try $

462headerStart = try $

412 (length <$> many1 (char '*')) <* many1 (char ' ')

463 (length <$> many1 (char '*')) <* many1 (char ' ')

413

464

465+

414-- Don't use (or need) the reader wrapper here, we want hline to be

466-- Don't use (or need) the reader wrapper here, we want hline to be

415-- @show@able. Otherwise we can't use it with @notFollowedBy'@.

467-- @show@able. Otherwise we can't use it with @notFollowedBy'@.

416

468

@@ -444,12 +496,14 @@ table = try $ do

444 lookAhead tableStart

496 lookAhead tableStart

445 do

497 do

446 rows <- tableRows

498 rows <- tableRows

499+ cptn <- fromMaybe (pure "") <$> lookupInlinesAttr "caption"

447− return $ return . orgToPandocTable . normalizeTable =<< rowsToTable rows

500+ return $ (<$> cptn) . orgToPandocTable . normalizeTable =<< rowsToTable rows

448

501

449orgToPandocTable :: OrgTable

502orgToPandocTable :: OrgTable

503+ -> Inlines

450 -> Blocks

504 -> Blocks

451−orgToPandocTable (OrgTable _ aligns heads lns) =

505+orgToPandocTable (OrgTable _ aligns heads lns) caption =

452− B.table "" (zip aligns $ repeat 0) heads lns

506+ B.table caption (zip aligns $ repeat 0) heads lns

453

507

454tableStart :: OrgParser Char

508tableStart :: OrgParser Char

455tableStart = try $ skipSpaces *> char '|'

509tableStart = try $ skipSpaces *> char '|'

tests/Tests/Readers/Org.hs+30−1

@@ -8,7 +8,7 @@ import Tests.Arbitrary()

8import Text.Pandoc.Builder

9import Text.Pandoc

10import Data.List (intersperse)

11−import Data.Monoid (mempty, mconcat)

11+import Data.Monoid (mempty, mappend, mconcat)

13org :: String -> Pandoc

14org = readOrg def

@@ -648,6 +648,18 @@ tests =

648 [ [ plain "1" , plain "One" , plain "foo" ]

649 , [ plain "2" , plain mempty , plain mempty ]

650 ]

651+

652+ , "Table with caption" =:

653+ unlines [ "#+CAPTION: Hitchhiker's Multiplication Table"

654+ , "| x | 6 |"

655+ , "| 9 | 42 |"

656+ ] =?>

657+ table "Hitchhiker's Multiplication Table"

658+ [(AlignDefault, 0), (AlignDefault, 0)]

659+ []

660+ [ [ plain "x", plain "6" ]

661+ , [ plain "9", plain "42" ]

662+ ]

651 ]

663 ]

652

664

653 , testGroup "Blocks and fragments"

665 , testGroup "Blocks and fragments"

@@ -740,5 +752,22 @@ tests =

740 , "\\end{equation}"

752 , "\\end{equation}"

741 ])

753 ])

742

754

755+ , "Code block with caption" =:

756+ unlines [ "#+CAPTION: Functor laws in Haskell"

757+ , "#+NAME: functor-laws"

758+ , "#+BEGIN_SRC haskell"

759+ , "fmap id = id"

760+ , "fmap (p . q) = (fmap p) . (fmap q)"

761+ , "#+END_SRC"

762+ ] =?>

763+ divWith

764+ nullAttr

765+ (mappend

766+ (plain $ spanWith ("", ["label"], [])

767+ (spcSep [ "Functor", "laws", "in", "Haskell" ]))

768+ (codeBlockWith ("functor-laws", ["haskell"], [])

769+ (unlines [ "fmap id = id"

770+ , "fmap (p . q) = (fmap p) . (fmap q)"

771+ ])))

743 ]

772 ]

744 ]

773 ]