0958f2f · typeable/pandoc

git.iko.soy/typeable/pandoc

on master help sign in

Merge pull request #2927 from tarleb/org-attr-html

0958f2fJohn MacFarlane10 years ago

src/Text/Pandoc/Readers/Org.hs+106−80

compare with master

unifiedsplit

@@ -37,8 +37,9 @@ import Text.Pandoc.Error

37import Text.Pandoc.Options

38import qualified Text.Pandoc.Parsing as P

39import Text.Pandoc.Parsing hiding ( F, unF, askF, asksF, runF

40+ , anyLine, blanklines, newline

40− , newline, orderedListMarker

41+ , orderedListMarker

41− , parseFromString, blanklines

42+ , parseFromString

42 )

43 )

43import Text.Pandoc.Readers.LaTeX (inlineCommand, rawLaTeXInline)

44import Text.Pandoc.Readers.LaTeX (inlineCommand, rawLaTeXInline)

44import Text.Pandoc.Readers.Org.ParserState

45import Text.Pandoc.Readers.Org.ParserState

@@ -49,10 +50,10 @@ import qualified Text.TeXMath.Readers.MathML.EntityMap as MathMLEntityMap

49import Control.Arrow (first)

50import Control.Arrow (first)

50import Control.Monad (foldM, guard, mplus, mzero, when)

51import Control.Monad (foldM, guard, mplus, mzero, when)

51import Control.Monad.Reader ( Reader, runReader )

52import Control.Monad.Reader ( Reader, runReader )

52−import Data.Char (isAlphaNum, isSpace, toLower)

53+import Data.Char (isAlphaNum, isSpace, toLower, toUpper)

53−import Data.List (intersperse, isPrefixOf, isSuffixOf)

54+import Data.List ( foldl', intersperse, isPrefixOf, isSuffixOf )

54import qualified Data.Map as M

55import qualified Data.Map as M

55−import Data.Maybe (fromMaybe, isJust)

56+import Data.Maybe ( fromMaybe, isNothing )

56import Network.HTTP (urlEncode)

57import Network.HTTP (urlEncode)

@@ -247,6 +248,12 @@ blanklines =

247 <* updateLastPreCharPos

248 <* updateLastPreCharPos

248 <* updateLastForbiddenCharPos

249 <* updateLastForbiddenCharPos

249

250

251+anyLine :: OrgParser String

252+anyLine =

253+ P.anyLine

254+ <* updateLastPreCharPos

255+ <* updateLastForbiddenCharPos

256+

250-- | Succeeds when we're in list context.

257-- | Succeeds when we're in list context.

251inList :: OrgParser ()

258inList :: OrgParser ()

252inList = do

259inList = do

@@ -273,11 +280,9 @@ parseBlocks = mconcat <$> manyTill block eof

273

280

274block :: OrgParser (F Blocks)

281block :: OrgParser (F Blocks)

275block = choice [ mempty <$ blanklines

282block = choice [ mempty <$ blanklines

276− , optionalAttributes $ choice

283+ , table

277− [ orgBlock

284+ , orgBlock

278− , figure

285+ , figure

279− , table

280− ]

281 , example

286 , example

282 , drawer

287 , drawer

283 , specialLine

288 , specialLine

@@ -289,50 +294,73 @@ block = choice [ mempty <$ blanklines

289 , paraOrPlain

294 , paraOrPlain

290 ] <?> "block"

295 ] <?> "block"

291

296

297+

292--

298--

293-- Block Attributes

299-- Block Attributes

294--

300--

295

301

296−-- | Parse optional block attributes (like #+TITLE or #+NAME)

302+-- | Attributes that may be added to figures (like a name or caption).

297−optionalAttributes :: OrgParser (F Blocks) -> OrgParser (F Blocks)

303+data BlockAttributes = BlockAttributes

298−optionalAttributes parser = try $

304+ { blockAttrName :: Maybe String

299− resetBlockAttributes *> parseBlockAttributes *> parser

305+ , blockAttrCaption :: Maybe (F Inlines)

306+ , blockAttrKeyValues :: [(String, String)]

307+ }

308+

309+stringyMetaAttribute :: (String -> Bool) -> OrgParser (String, String)

310+stringyMetaAttribute attrCheck = try $ do

311+ metaLineStart

312+ attrName <- map toUpper <$> many1Till nonspaceChar (char ':')

313+ guard $ attrCheck attrName

314+ skipSpaces

315+ attrValue <- anyLine

316+ return (attrName, attrValue)

317+

318+blockAttributes :: OrgParser BlockAttributes

319+blockAttributes = try $ do

320+ kv <- many (stringyMetaAttribute attrCheck)

321+ let caption = foldl' (appendValues "CAPTION") Nothing kv

322+ let kvAttrs = foldl' (appendValues "ATTR_HTML") Nothing kv

323+ let name = lookup "NAME" kv

324+ caption' <- maybe (return Nothing)

325+ (fmap Just . parseFromString parseInlines)

326+ caption

327+ kvAttrs' <- parseFromString keyValues . (++ "\n") $ fromMaybe mempty kvAttrs

328+ return $ BlockAttributes

329+ { blockAttrName = name

330+ , blockAttrCaption = caption'

331+ , blockAttrKeyValues = kvAttrs'

332+ }

300 where

333 where

301− resetBlockAttributes :: OrgParser ()

334+ attrCheck :: String -> Bool

302− resetBlockAttributes = updateState $ \s ->

335+ attrCheck attr =

303− s{ orgStateBlockAttributes = orgStateBlockAttributes def }

336+ case attr of

304−

337+ "NAME" -> True

305−parseBlockAttributes :: OrgParser ()

338+ "CAPTION" -> True

306−parseBlockAttributes = do

339+ "ATTR_HTML" -> True

307− attrs <- many attribute

340+ _ -> False

308− mapM_ (uncurry parseAndAddAttribute) attrs

341+

342+ appendValues :: String -> Maybe String -> (String, String) -> Maybe String

343+ appendValues attrName accValue (key, value) =

344+ if key /= attrName

345+ then accValue

346+ else case accValue of

347+ Just acc -> Just $ acc ++ ' ':value

348+ Nothing -> Just value

349+

350+keyValues :: OrgParser [(String, String)]

351+keyValues = try $

352+ manyTill ((,) <$> key <*> value) newline

309 where

353 where

310− attribute :: OrgParser (String, String)

354+ key :: OrgParser String

311− attribute = try $ do

355+ key = try $ skipSpaces *> char ':' *> many1 nonspaceChar

312− key <- metaLineStart *> many1Till nonspaceChar (char ':')

356+

313− val <- skipSpaces *> anyLine

357+ value :: OrgParser String

314− return (map toLower key, val)

358+ value = skipSpaces *> manyTill anyChar endOfValue

315−

359+

316−parseAndAddAttribute :: String -> String -> OrgParser ()

360+ endOfValue :: OrgParser ()

317−parseAndAddAttribute key value = do

361+ endOfValue =

318− let key' = map toLower key

362+ lookAhead $ (() <$ try (many1 spaceChar <* key))

319− () <$ addBlockAttribute key' value

363+ <|> () <$ P.newline

320−

321−lookupInlinesAttr :: String -> OrgParser (Maybe (F Inlines))

322−lookupInlinesAttr attr = try $ do

323− val <- lookupBlockAttribute attr

324− maybe (return Nothing)

325− (fmap Just . parseFromString parseInlines)

326− val

327−

328−addBlockAttribute :: String -> String -> OrgParser ()

329−addBlockAttribute key val = updateState $ \s ->

330− let attrs = orgStateBlockAttributes s

331− in s{ orgStateBlockAttributes = M.insert key val attrs }

332−

333−lookupBlockAttribute :: String -> OrgParser (Maybe String)

334−lookupBlockAttribute key =

335− M.lookup key . orgStateBlockAttributes <$> getState

336

364

337

365

338--

366--

@@ -346,6 +374,7 @@ updateIndent (_, blkType) indent = (indent, blkType)

346

374

347orgBlock :: OrgParser (F Blocks)

375orgBlock :: OrgParser (F Blocks)

348orgBlock = try $ do

376orgBlock = try $ do

377+ blockAttrs <- blockAttributes

349 blockProp@(_, blkType) <- blockHeaderStart

378 blockProp@(_, blkType) <- blockHeaderStart

350 ($ blockProp) $

379 ($ blockProp) $

351 case blkType of

380 case blkType of

@@ -356,7 +385,7 @@ orgBlock = try $ do

356 "example" -> withRaw' (return . exampleCode)

385 "example" -> withRaw' (return . exampleCode)

357 "quote" -> withParsed (fmap B.blockQuote)

386 "quote" -> withParsed (fmap B.blockQuote)

358 "verse" -> verseBlock

387 "verse" -> verseBlock

359− "src" -> codeBlock

388+ "src" -> codeBlock blockAttrs

360 _ -> withParsed (fmap $ divWithClass blkType)

389 _ -> withParsed (fmap $ divWithClass blkType)

361

390

362blockHeaderStart :: OrgParser (Int, String)

391blockHeaderStart :: OrgParser (Int, String)

@@ -410,20 +439,20 @@ followingResultsBlock =

410 *> blankline

439 *> blankline

411 *> block)

440 *> block)

412

441

413−codeBlock :: BlockProperties -> OrgParser (F Blocks)

442+codeBlock :: BlockAttributes -> BlockProperties -> OrgParser (F Blocks)

414−codeBlock blkProp = do

443+codeBlock blockAttrs blkProp = do

415 skipSpaces

444 skipSpaces

416 (classes, kv) <- codeHeaderArgs <|> (mempty <$ ignHeaders)

445 (classes, kv) <- codeHeaderArgs <|> (mempty <$ ignHeaders)

417− id' <- fromMaybe "" <$> lookupBlockAttribute "name"

418 leadingIndent <- lookAhead indentation

446 leadingIndent <- lookAhead indentation

419 content <- rawBlockContent (updateIndent blkProp leadingIndent)

447 content <- rawBlockContent (updateIndent blkProp leadingIndent)

420 resultsContent <- followingResultsBlock

448 resultsContent <- followingResultsBlock

449+ let id' = fromMaybe mempty $ blockAttrName blockAttrs

421 let includeCode = exportsCode kv

450 let includeCode = exportsCode kv

422 let includeResults = exportsResults kv

451 let includeResults = exportsResults kv

423 let codeBlck = B.codeBlockWith ( id', classes, kv ) content

452 let codeBlck = B.codeBlockWith ( id', classes, kv ) content

424− labelledBlck <- maybe (pure codeBlck)

453+ let labelledBlck = maybe (pure codeBlck)

425 (labelDiv codeBlck)

454 (labelDiv codeBlck)

426− <$> lookupInlinesAttr "caption"

455+ (blockAttrCaption blockAttrs)

427 let resultBlck = fromMaybe mempty resultsContent

456 let resultBlck = fromMaybe mempty resultsContent

428 return $ (if includeCode then labelledBlck else mempty)

457 return $ (if includeCode then labelledBlck else mempty)

429 <> (if includeResults then resultBlck else mempty)

458 <> (if includeResults then resultBlck else mempty)

@@ -579,47 +608,43 @@ drawerEnd = try $

579-- Figures

608-- Figures

580--

609--

581

610

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

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

583figure :: OrgParser (F Blocks)

612figure :: OrgParser (F Blocks)

584figure = try $ do

613figure = try $ do

585− (cap, nam) <- nameAndCaption

614+ figAttrs <- blockAttributes

586 src <- skipSpaces *> selfTarget <* skipSpaces <* P.newline

615 src <- skipSpaces *> selfTarget <* skipSpaces <* P.newline

616+ guard . not . isNothing . blockAttrCaption $ figAttrs

587 guard (isImageFilename src)

617 guard (isImageFilename src)

588− return $ do

618+ let figName = fromMaybe mempty $ blockAttrName figAttrs

589− cap' <- cap

619+ let figCaption = fromMaybe mempty $ blockAttrCaption figAttrs

590− return $ B.para $ B.image src nam cap'

620+ let figKeyVals = blockAttrKeyValues figAttrs

621+ let attr = (mempty, mempty, figKeyVals)

622+ return $ (B.para . B.imageWith attr src (withFigPrefix figName) <$> figCaption)

591 where

623 where

592− nameAndCaption =

593− do

594− maybeCap <- lookupInlinesAttr "caption"

595− maybeNam <- lookupBlockAttribute "name"

596− guard $ isJust maybeCap || isJust maybeNam

597− return ( fromMaybe mempty maybeCap

598− , withFigPrefix $ fromMaybe mempty maybeNam )

599 withFigPrefix cs =

624 withFigPrefix cs =

600− if "fig:" `isPrefixOf` cs

625+ if "fig:" `isPrefixOf` cs

601− then cs

626+ then cs

602− else "fig:" ++ cs

627+ else "fig:" ++ cs

603

628

604--

629--

605-- Comments, Options and Metadata

630-- Comments, Options and Metadata

631+--

606specialLine :: OrgParser (F Blocks)

632specialLine :: OrgParser (F Blocks)

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

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

608

634

609metaLine :: OrgParser Blocks

635metaLine :: OrgParser Blocks

610−metaLine = try $ mempty

611− <$ (metaLineStart *> (optionLine <|> declarationLine))

636+metaLine = mempty <$ metaLineStart <* (optionLine <|> declarationLine)

612−

613−commentLine :: OrgParser Blocks

614−commentLine = try $ commentLineStart *> anyLine *> pure mempty

615

637

616-- The order, in which blocks are tried, makes sure that we're not looking at

638-- The order, in which blocks are tried, makes sure that we're not looking at

617-- the beginning of a block, so we don't need to check for it

639-- the beginning of a block, so we don't need to check for it

618−metaLineStart :: OrgParser String

640+metaLineStart :: OrgParser ()

619−metaLineStart = try $ mappend <$> many spaceChar <*> string "#+"

641+metaLineStart = try $ skipSpaces <* string "#+"

642+

643+commentLine :: OrgParser Blocks

644+commentLine = commentLineStart *> anyLine *> pure mempty

620

645

621−commentLineStart :: OrgParser String

646+commentLineStart :: OrgParser ()

622−commentLineStart = try $ mappend <$> many spaceChar <*> string "# "

647+commentLineStart = try $ skipSpaces <* string "# "

623

648

624declarationLine :: OrgParser ()

649declarationLine :: OrgParser ()

625declarationLine = try $ do

650declarationLine = try $ do

@@ -738,11 +763,12 @@ data OrgTable = OrgTable

738

763

739table :: OrgParser (F Blocks)

764table :: OrgParser (F Blocks)

740table = try $ do

765table = try $ do

766+ blockAttrs <- blockAttributes

741 lookAhead tableStart

767 lookAhead tableStart

742 do

768 do

743 rows <- tableRows

769 rows <- tableRows

744− cptn <- fromMaybe (pure "") <$> lookupInlinesAttr "caption"

770+ let caption = fromMaybe (return mempty) $ blockAttrCaption blockAttrs

745− return $ (<$> cptn) . orgToPandocTable . normalizeTable =<< rowsToTable rows

771+ return $ (<$> caption) . orgToPandocTable . normalizeTable =<< rowsToTable rows

746

772

747orgToPandocTable :: OrgTable

773orgToPandocTable :: OrgTable

748 -> Inlines

774 -> Inlines

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

@@ -68,8 +68,6 @@ import Text.Pandoc.Parsing ( HasHeaderMap(..)

68type OrgNoteRecord = (String, F Blocks)

69-- | Table of footnotes

70type OrgNoteTable = [OrgNoteRecord]

71−-- | Map of org block attributes (e.g. LABEL, CAPTION, NAME, etc)

72−type OrgBlockAttributes = M.Map String String

73-- | Map of functions for link transformations. The map key is refers to the

71-- | Map of functions for link transformations. The map key is refers to the

74-- link-type, the corresponding function transforms the given link string.

72-- link-type, the corresponding function transforms the given link string.

75type OrgLinkFormatters = M.Map String (String -> String)

73type OrgLinkFormatters = M.Map String (String -> String)

@@ -84,7 +82,6 @@ data ExportSettings = ExportSettings

84data OrgParserState = OrgParserState

82data OrgParserState = OrgParserState

85 { orgStateOptions :: ReaderOptions

83 { orgStateOptions :: ReaderOptions

86 , orgStateAnchorIds :: [String]

84 , orgStateAnchorIds :: [String]

87− , orgStateBlockAttributes :: OrgBlockAttributes

88 , orgStateEmphasisCharStack :: [Char]

85 , orgStateEmphasisCharStack :: [Char]

89 , orgStateEmphasisNewlines :: Maybe Int

86 , orgStateEmphasisNewlines :: Maybe Int

90 , orgStateExportSettings :: ExportSettings

87 , orgStateExportSettings :: ExportSettings

@@ -140,7 +137,6 @@ defaultOrgParserState :: OrgParserState

140defaultOrgParserState = OrgParserState

137defaultOrgParserState = OrgParserState

141 { orgStateOptions = def

138 { orgStateOptions = def

142 , orgStateAnchorIds = []

139 , orgStateAnchorIds = []

143− , orgStateBlockAttributes = M.empty

144 , orgStateEmphasisCharStack = []

140 , orgStateEmphasisCharStack = []

145 , orgStateEmphasisNewlines = Nothing

141 , orgStateEmphasisNewlines = Nothing

146 , orgStateExportSettings = def

142 , orgStateExportSettings = def

tests/Tests/Readers/Org.hs+11

@@ -667,6 +667,17 @@ tests =

667 para (image "the-red-queen.jpg" "fig:redqueen"

668 "Used as a metapher in evolutionary biology.")

669

670+ , "Figure with HTML attributes" =:

671+ unlines [ "#+CAPTION: mah brain just explodid"

672+ , "#+NAME: lambdacat"

673+ , "#+ATTR_HTML: :style color: blue :role button"

674+ , "[[lambdacat.jpg]]"

675+ ] =?>

676+ let kv = [("style", "color: blue"), ("role", "button")]

677+ name = "fig:lambdacat"

678+ caption = "mah brain just explodid"

679+ in para (imageWith (mempty, mempty, kv) "lambdacat.jpg" name caption)

680+

670 , "Footnote" =:

681 , "Footnote" =:

671 unlines [ "A footnote[1]"

682 unlines [ "A footnote[1]"

672 , ""

683 , ""