e548b8d · typeable/pandoc

git.iko.soy/typeable/pandoc

on master help sign in

Merge pull request #3010 from tarleb/org-header-tree

e548b8dJohn MacFarlane10 years ago

pandoc.cabal+1

compare with master

unifiedsplit

@@ -399,6 +399,7 @@ Library

399 Text.Pandoc.Readers.Odt.Arrows.Utils,

400 Text.Pandoc.Readers.Org.BlockStarts,

401 Text.Pandoc.Readers.Org.Blocks,

402+ Text.Pandoc.Readers.Org.ExportSettings,

402 Text.Pandoc.Readers.Org.Inlines,

403 Text.Pandoc.Readers.Org.Inlines,

403 Text.Pandoc.Readers.Org.ParserState,

404 Text.Pandoc.Readers.Org.ParserState,

404 Text.Pandoc.Readers.Org.Parsing,

405 Text.Pandoc.Readers.Org.Parsing,

src/Text/Pandoc/Readers/Org.hs+1−38

@@ -52,41 +52,4 @@ parseOrg :: OrgParser Pandoc

52parseOrg = do

53 blocks' <- blockList

54 meta' <- meta

55− return . Pandoc meta' $ removeUnwantedBlocks blocks'

55+ return $ Pandoc meta' blocks'

56− where

57− removeUnwantedBlocks :: [Block] -> [Block]

58− removeUnwantedBlocks = dropCommentTrees . filter (/= Null)

59−

60−-- | Drop COMMENT headers and the document tree below those headers.

61−dropCommentTrees :: [Block] -> [Block]

62−dropCommentTrees [] = []

63−dropCommentTrees (b:bs) =

64− maybe (b:dropCommentTrees bs)

65− (dropCommentTrees . flip dropUntilHeaderAboveLevel bs)

66− (commentHeaderLevel b)

67−

68−-- | Return the level of a header starting a comment or :noexport: tree and

69−-- Nothing otherwise.

70−commentHeaderLevel :: Block -> Maybe Int

71−commentHeaderLevel blk =

72− case blk of

73− (Header level _ ((Str "COMMENT"):_)) -> Just level

74− (Header level _ title) | hasNoExportTag title -> Just level

75− _ -> Nothing

76− where

77− hasNoExportTag :: [Inline] -> Bool

78− hasNoExportTag = any isNoExportTag

79−

80− isNoExportTag :: Inline -> Bool

81− isNoExportTag (Span ("", ["tag"], [("data-tag-name", "noexport")]) []) = True

82− isNoExportTag _ = False

83−

84−-- | Drop blocks until a header on or above the given level is seen

85−dropUntilHeaderAboveLevel :: Int -> [Block] -> [Block]

86−dropUntilHeaderAboveLevel n = dropWhile (not . isHeaderLevelLowerEq n)

87−

88−isHeaderLevelLowerEq :: Int -> Block -> Bool

89−isHeaderLevelLowerEq n blk =

90− case blk of

91− (Header level _ _) -> n >= level

92− _ -> False

src/Text/Pandoc/Readers/Org/Blocks.hs+181−147

@@ -1,4 +1,6 @@

1{-# LANGUAGE FlexibleContexts #-}

2+{-# LANGUAGE RecordWildCards #-}

3+{-# OPTIONS_GHC -fno-warn-overlapping-patterns #-}

2{-

4{-

@@ -32,6 +34,7 @@ module Text.Pandoc.Readers.Org.Blocks

32 ) where

34 ) where

34import Text.Pandoc.Readers.Org.BlockStarts

36import Text.Pandoc.Readers.Org.BlockStarts

37+import Text.Pandoc.Readers.Org.ExportSettings ( exportSettings )

35import Text.Pandoc.Readers.Org.Inlines

38import Text.Pandoc.Readers.Org.Inlines

36import Text.Pandoc.Readers.Org.ParserState

39import Text.Pandoc.Readers.Org.ParserState

37import Text.Pandoc.Readers.Org.Parsing

40import Text.Pandoc.Readers.Org.Parsing

@@ -46,13 +49,173 @@ import Text.Pandoc.Compat.Monoid ((<>))

46import Text.Pandoc.Options

49import Text.Pandoc.Options

47import Text.Pandoc.Shared ( compactify', compactify'DL )

50import Text.Pandoc.Shared ( compactify', compactify'DL )

49−import Control.Monad ( foldM, guard, mzero )

52+import Control.Monad ( foldM, guard, mzero, void )

50import Data.Char ( isSpace, toLower, toUpper)

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

51import Data.List ( foldl', intersperse, isPrefixOf )

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

52import qualified Data.Map as M

55import qualified Data.Map as M

53import Data.Maybe ( fromMaybe, isNothing )

56import Data.Maybe ( fromMaybe, isNothing )

57+import qualified Data.Sequence as S

54import Network.HTTP ( urlEncode )

58import Network.HTTP ( urlEncode )

60+--

61+-- Org headers

62+--

63+newtype Tag = Tag { fromTag :: String }

64+ deriving (Show, Eq)

65+

66+-- | Create a tag containing the given string.

67+toTag :: String -> Tag

68+toTag = Tag

69+

70+-- | The key (also called name or type) of a property.

71+newtype PropertyKey = PropertyKey { fromKey :: String }

72+ deriving (Show, Eq, Ord)

73+

74+-- | Create a property key containing the given string. Org mode keys are

75+-- case insensitive and are hence converted to lower case.

76+toPropertyKey :: String -> PropertyKey

77+toPropertyKey = PropertyKey . map toLower

78+

79+-- | The value assigned to a property.

80+newtype PropertyValue = PropertyValue { fromValue :: String }

81+

82+-- | Create a property value containing the given string.

83+toPropertyValue :: String -> PropertyValue

84+toPropertyValue = PropertyValue

85+

86+-- | Key/value pairs from a PROPERTIES drawer

87+type Properties = [(PropertyKey, PropertyValue)]

88+

89+-- | Org mode headline (i.e. a document subtree).

90+data Headline = Headline

91+ { headlineLevel :: Int

92+ , headlineText :: Inlines

93+ , headlineTags :: [Tag]

94+ , headlineProperties :: Properties

95+ , headlineContents :: Blocks

96+ , headlineChildren :: [Headline]

97+ }

98+

99+--

100+-- Parsing headlines and subtrees

101+--

102+

103+-- | Read an Org mode headline and its contents (i.e. a document subtree).

104+-- @lvl@ gives the minimum acceptable level of the tree.

105+headline :: Int -> OrgParser (F Headline)

106+headline lvl = try $ do

107+ level <- headerStart

108+ guard (lvl <= level)

109+ title <- trimInlinesF . mconcat <$> manyTill inline endOfTitle

110+ tags <- option [] headerTags

111+ newline

112+ properties <- option mempty propertiesDrawer

113+ contents <- blocks

114+ children <- many (headline (level + 1))

115+ return $ do

116+ title' <- title

117+ contents' <- contents

118+ children' <- sequence children

119+ return $ Headline

120+ { headlineLevel = level

121+ , headlineText = title'

122+ , headlineTags = tags

123+ , headlineProperties = properties

124+ , headlineContents = contents'

125+ , headlineChildren = children'

126+ }

127+ where

128+ endOfTitle :: OrgParser ()

129+ endOfTitle = void . lookAhead $ optional headerTags *> newline

130+

131+ headerTags :: OrgParser [Tag]

132+ headerTags = try $

133+ let tag = many1 (alphaNum <|> oneOf "@%#_") <* char ':'

134+ in map toTag <$> (skipSpaces *> char ':' *> many1 tag <* skipSpaces)

135+

136+-- | Convert an Org mode headline (i.e. a document tree) into pandoc's Blocks

137+headlineToBlocks :: Headline -> OrgParser Blocks

138+headlineToBlocks hdln@(Headline {..}) = do

139+ maxHeadlineLevels <- getExportSetting exportHeadlineLevels

140+ case () of

141+ _ | any isNoExportTag headlineTags -> return mempty

142+ _ | any isArchiveTag headlineTags -> archivedHeadlineToBlocks hdln

143+ _ | isCommentTitle headlineText -> return mempty

144+ _ | headlineLevel >= maxHeadlineLevels -> headlineToHeaderWithList hdln

145+ _ -> headlineToHeaderWithContents hdln

146+

147+isNoExportTag :: Tag -> Bool

148+isNoExportTag = (== toTag "noexport")

149+

150+isArchiveTag :: Tag -> Bool

151+isArchiveTag = (== toTag "ARCHIVE")

152+

153+-- | Check if the title starts with COMMENT.

154+-- FIXME: This accesses builder internals not intended for use in situations

155+-- like these. Replace once keyword parsing is supported.

156+isCommentTitle :: Inlines -> Bool

157+isCommentTitle xs = (B.Many . S.take 1 . B.unMany) xs == B.str "COMMENT"

158+isCommentTitle _ = False

159+

160+archivedHeadlineToBlocks :: Headline -> OrgParser Blocks

161+archivedHeadlineToBlocks hdln = do

162+ archivedTreesOption <- getExportSetting exportArchivedTrees

163+ case archivedTreesOption of

164+ ArchivedTreesNoExport -> return mempty

165+ ArchivedTreesExport -> headlineToHeaderWithContents hdln

166+ ArchivedTreesHeadlineOnly -> headlineToHeader hdln

167+

168+headlineToHeaderWithList :: Headline -> OrgParser Blocks

169+headlineToHeaderWithList hdln@(Headline {..}) = do

170+ maxHeadlineLevels <- getExportSetting exportHeadlineLevels

171+ header <- headlineToHeader hdln

172+ listElements <- sequence (map headlineToBlocks headlineChildren)

173+ let listBlock = if null listElements

174+ then mempty

175+ else B.orderedList listElements

176+ let headerText = if maxHeadlineLevels == headlineLevel

177+ then header

178+ else flattenHeader header

179+ return $ headerText <> headlineContents <> listBlock

180+ where

181+ flattenHeader :: Blocks -> Blocks

182+ flattenHeader blks =

183+ case B.toList blks of

184+ (Header _ _ inlns:_) -> B.para (B.fromList inlns)

185+ _ -> mempty

186+

187+headlineToHeaderWithContents :: Headline -> OrgParser Blocks

188+headlineToHeaderWithContents hdln@(Headline {..}) = do

189+ header <- headlineToHeader hdln

190+ childrenBlocks <- mconcat <$> sequence (map headlineToBlocks headlineChildren)

191+ return $ header <> headlineContents <> childrenBlocks

192+

193+headlineToHeader :: Headline -> OrgParser Blocks

194+headlineToHeader (Headline {..}) = do

195+ let text = tagTitle headlineText headlineTags

196+ let propAttr = propertiesToAttr headlineProperties

197+ attr <- registerHeader propAttr headlineText

198+ return $ B.headerWith attr headlineLevel text

199+

200+propertiesToAttr :: Properties -> Attr

201+propertiesToAttr properties =

202+ let

203+ toStringPair prop = (fromKey (fst prop), fromValue (snd prop))

204+ customIdKey = toPropertyKey "custom_id"

205+ classKey = toPropertyKey "class"

206+ id' = fromMaybe mempty . fmap fromValue . lookup customIdKey $ properties

207+ cls = fromMaybe mempty . fmap fromValue . lookup classKey $ properties

208+ kvs' = map toStringPair . filter ((`notElem` [customIdKey, classKey]) . fst)

209+ $ properties

210+ in

211+ (id', words cls, kvs')

212+

213+tagTitle :: Inlines -> [Tag] -> Inlines

214+tagTitle title tags = title <> (mconcat $ map tagToInline tags)

215+

216+tagToInline :: Tag -> Inlines

217+tagToInline t = B.spanWith ("", ["tag"], [("data-tag-name", fromTag t)]) mempty

218+

219

57--

220--

58-- parsing blocks

221-- parsing blocks

@@ -61,9 +224,11 @@ import Network.HTTP ( urlEncode )

61-- | Get a list of blocks.

224-- | Get a list of blocks.

62blockList :: OrgParser [Block]

225blockList :: OrgParser [Block]

63blockList = do

226blockList = do

64− blocks' <- blocks

227+ initialBlocks <- blocks

228+ headlines <- sequence <$> manyTill (headline 1) eof

65− st <- getState

229+ st <- getState

230+ headlineBlocks <- fmap mconcat . sequence . map headlineToBlocks $ runF headlines st

66− return . B.toList $ runF blocks' st

231+ return . B.toList $ (runF initialBlocks st) <> headlineBlocks

232

68-- | Get the meta information safed in the state.

233-- | Get the meta information safed in the state.

69meta :: OrgParser Meta

234meta :: OrgParser Meta

@@ -72,7 +237,7 @@ meta = do

72 return $ runF (orgStateMeta st) st

237 return $ runF (orgStateMeta st) st

238

74blocks :: OrgParser (F Blocks)

239blocks :: OrgParser (F Blocks)

75−blocks = mconcat <$> manyTill block eof

240+blocks = mconcat <$> manyTill block (void (lookAhead headerStart) <|> eof)

241

77block :: OrgParser (F Blocks)

242block :: OrgParser (F Blocks)

78block = choice [ mempty <$ blanklines

243block = choice [ mempty <$ blanklines

@@ -82,7 +247,6 @@ block = choice [ mempty <$ blanklines

82 , example

247 , example

83 , genericDrawer

248 , genericDrawer

84 , specialLine

249 , specialLine

85− , header

86 , horizontalRule

250 , horizontalRule

87 , list

251 , list

88 , latexFragment

252 , latexFragment

@@ -381,30 +545,22 @@ drawerEnd = try $

381

545

382-- | Read a :PROPERTIES: drawer and return the key/value pairs contained

546-- | Read a :PROPERTIES: drawer and return the key/value pairs contained

383-- within.

547-- within.

384−propertiesDrawer :: OrgParser [(String, String)]

548+propertiesDrawer :: OrgParser Properties

385propertiesDrawer = try $ do

549propertiesDrawer = try $ do

386 drawerType <- drawerStart

550 drawerType <- drawerStart

387 guard $ map toUpper drawerType == "PROPERTIES"

551 guard $ map toUpper drawerType == "PROPERTIES"

388 manyTill property (try drawerEnd)

552 manyTill property (try drawerEnd)

389 where

553 where

390− property :: OrgParser (String, String)

554+ property :: OrgParser (PropertyKey, PropertyValue)

391 property = try $ (,) <$> key <*> value

555 property = try $ (,) <$> key <*> value

392

556

393− key :: OrgParser String

557+ key :: OrgParser PropertyKey

558+ key = fmap toPropertyKey . try $

394− key = try $ skipSpaces *> char ':' *> many1Till nonspaceChar (char ':')

559+ skipSpaces *> char ':' *> many1Till nonspaceChar (char ':')

395

560

396− value :: OrgParser String

561+ value :: OrgParser PropertyValue

562+ value = fmap toPropertyValue . try $

397− value = try $ skipSpaces *> manyTill anyChar (try $ skipSpaces *> newline)

563+ skipSpaces *> manyTill anyChar (try $ skipSpaces *> newline)

398−

399−keyValuesToAttr :: [(String, String)] -> Attr

400−keyValuesToAttr kvs =

401− let

402− lowerKvs = map (\(k, v) -> (map toLower k, v)) kvs

403− id' = fromMaybe mempty . lookup "custom_id" $ lowerKvs

404− cls = fromMaybe mempty . lookup "class" $ lowerKvs

405− kvs' = filter (flip notElem ["custom_id", "class"] . fst) lowerKvs

406− in

407− (id', words cls, kvs')

408

564

409

565

410--

566--

@@ -486,7 +642,7 @@ optionLine = try $ do

486 key <- metaKey

642 key <- metaKey

487 case key of

643 case key of

488 "link" -> parseLinkFormat >>= uncurry addLinkFormat

644 "link" -> parseLinkFormat >>= uncurry addLinkFormat

489− "options" -> () <$ sepBy spaces exportSetting

645+ "options" -> exportSettings

490 _ -> mzero

646 _ -> mzero

491

647

492addLinkFormat :: String

648addLinkFormat :: String

@@ -496,100 +652,6 @@ addLinkFormat key formatter = updateState $ \s ->

496 let fs = orgStateLinkFormatters s

652 let fs = orgStateLinkFormatters s

497 in s{ orgStateLinkFormatters = M.insert key formatter fs }

653 in s{ orgStateLinkFormatters = M.insert key formatter fs }

498

654

499−

500−--

501−-- Export Settings

502−--

503−

504−-- | Read and process org-mode specific export options.

505−exportSetting :: OrgParser ()

506−exportSetting = choice

507− [ booleanSetting "^" setExportSubSuperscripts

508− , booleanSetting "'" setExportSmartQuotes

509− , booleanSetting "*" setExportEmphasizedText

510− , booleanSetting "-" setExportSpecialStrings

511− , ignoredSetting ":"

512− , ignoredSetting "<"

513− , ignoredSetting "\\n"

514− , ignoredSetting "arch"

515− , ignoredSetting "author"

516− , ignoredSetting "c"

517− , ignoredSetting "creator"

518− , complementableListSetting "d" setExportDrawers

519− , ignoredSetting "date"

520− , ignoredSetting "e"

521− , ignoredSetting "email"

522− , ignoredSetting "f"

523− , ignoredSetting "H"

524− , ignoredSetting "inline"

525− , ignoredSetting "num"

526− , ignoredSetting "p"

527− , ignoredSetting "pri"

528− , ignoredSetting "prop"

529− , ignoredSetting "stat"

530− , ignoredSetting "tags"

531− , ignoredSetting "tasks"

532− , ignoredSetting "tex"

533− , ignoredSetting "timestamp"

534− , ignoredSetting "title"

535− , ignoredSetting "toc"

536− , ignoredSetting "todo"

537− , ignoredSetting "|"

538− ] <?> "export setting"

539−

540−booleanSetting :: String -> ExportSettingSetter Bool -> OrgParser ()

541−booleanSetting settingIdentifier setter = try $ do

542− string settingIdentifier

543− char ':'

544− value <- elispBoolean

545− updateState $ modifyExportSettings setter value

546−

547−-- | Read an elisp boolean. Only NIL is treated as false, non-NIL values are

548−-- interpreted as true.

549−elispBoolean :: OrgParser Bool

550−elispBoolean = try $ do

551− value <- many1 nonspaceChar

552− return $ case map toLower value of

553− "nil" -> False

554− "{}" -> False

555− "()" -> False

556− _ -> True

557−

558−-- | A list or a complement list (i.e. a list starting with `not`).

559−complementableListSetting :: String

560− -> ExportSettingSetter (Either [String] [String])

561− -> OrgParser ()

562−complementableListSetting settingIdentifier setter = try $ do

563− _ <- string settingIdentifier <* char ':'

564− value <- choice [ Left <$> complementStringList

565− , Right <$> stringList

566− , (\b -> if b then Left [] else Right []) <$> elispBoolean

567− ]

568− updateState $ modifyExportSettings setter value

569− where

570− -- Read a plain list of strings.

571− stringList :: OrgParser [String]

572− stringList = try $

573− char '('

574− *> sepBy elispString spaces

575− <* char ')'

576−

577− -- Read an emacs lisp list specifying a complement set.

578− complementStringList :: OrgParser [String]

579− complementStringList = try $

580− string "(not "

581− *> sepBy elispString spaces

582− <* char ')'

583−

584− elispString :: OrgParser String

585− elispString = try $

586− char '"'

587− *> manyTill alphaNum (char '"')

588−

589−ignoredSetting :: String -> OrgParser ()

590−ignoredSetting s = try (() <$ string s <* char ':' <* many1 nonspaceChar)

591−

592−

593parseLinkFormat :: OrgParser ((String, String -> String))

655parseLinkFormat :: OrgParser ((String, String -> String))

594parseLinkFormat = try $ do

656parseLinkFormat = try $ do

595 linkType <- (:) <$> letter <*> many (alphaNum <|> oneOf "-_") <* skipSpaces

657 linkType <- (:) <$> letter <*> many (alphaNum <|> oneOf "-_") <* skipSpaces

@@ -612,36 +674,6 @@ parseFormat = try $ do

612 rest = manyTill anyChar (eof <|> () <$ oneOf "\n\r")

674 rest = manyTill anyChar (eof <|> () <$ oneOf "\n\r")

613 tillSpecifier c = manyTill (noneOf "\n\r") (try $ string ('%':c:""))

675 tillSpecifier c = manyTill (noneOf "\n\r") (try $ string ('%':c:""))

614

676

615−--

616−-- Headers

617−--

618−

619−-- | Headers

620−header :: OrgParser (F Blocks)

621−header = try $ do

622− level <- headerStart

623− title <- manyTill inline (lookAhead $ optional headerTags <* newline)

624− tags <- option [] headerTags

625− newline

626− let text = tagTitle title tags

627− propAttr <- option nullAttr (keyValuesToAttr <$> propertiesDrawer)

628− attr <- registerHeader propAttr (runF text def)

629− return (B.headerWith attr level <$> text)

630− where

631− tagTitle :: [F Inlines] -> [String] -> F Inlines

632− tagTitle title tags = trimInlinesF . mconcat $ title <> map tagToInlineF tags

633−

634− tagToInlineF :: String -> F Inlines

635− tagToInlineF t = return $ B.spanWith ("", ["tag"], [("data-tag-name", t)]) mempty

636−

637− headerTags :: OrgParser [String]

638− headerTags = try $

639− let tag = many1 (alphaNum <|> oneOf "@%#_") <* char ':'

640− in skipSpaces

641− *> char ':'

642− *> many1 tag

643− <* skipSpaces

644−

645

677

646--

678--

647-- Tables

679-- Tables

@@ -806,6 +838,8 @@ noteBlock = try $ do

806-- Paragraphs or Plain text

838-- Paragraphs or Plain text

807paraOrPlain :: OrgParser (F Blocks)

839paraOrPlain :: OrgParser (F Blocks)

808paraOrPlain = try $ do

840paraOrPlain = try $ do

841+ -- Make sure we are not looking at a headline

842+ notFollowedBy' (char '*' *> (oneOf " *"))

809 ils <- inlines

843 ils <- inlines

810 nl <- option False (newline *> return True)

844 nl <- option False (newline *> return True)

811 -- Read block as paragraph, except if we are in a list context and the block

845 -- Read block as paragraph, except if we are in a list context and the block

src/Text/Pandoc/Readers/Org/ExportSettings.hsnew file+167

@@ -0,0 +1,167 @@

1+{-

4+This program is free software; you can redistribute it and/or modify

5+it under the terms of the GNU General Public License as published by

6+the Free Software Foundation; either version 2 of the License, or

7+(at your option) any later version.

9+This program is distributed in the hope that it will be useful,

10+but WITHOUT ANY WARRANTY; without even the implied warranty of

11+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the

12+GNU General Public License for more details.

13+

14+You should have received a copy of the GNU General Public License

15+along with this program; if not, write to the Free Software

16+Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA

17+-}

18+

19+{- |

20+ Module : Text.Pandoc.Readers.Org.Options

22+ License : GNU GPL, version 2 or above

23+

24+ Maintainer : Albert Krewinkel <tarleb+pandoc@moltkeplatz.de>

25+

26+Parsers for Org-mode export options.

27+-}

28+module Text.Pandoc.Readers.Org.ExportSettings

29+ ( exportSettings

30+ ) where

31+

32+import Text.Pandoc.Readers.Org.ParserState

33+import Text.Pandoc.Readers.Org.Parsing

34+

35+import Control.Monad ( mzero, void )

36+import Data.Char ( toLower )

37+import Data.Maybe ( listToMaybe )

38+

39+-- | Read and handle space separated org-mode export settings.

40+exportSettings :: OrgParser ()

41+exportSettings = void $ sepBy spaces exportSetting

42+

43+-- | Setter function for export settings.

44+type ExportSettingSetter a = a -> ExportSettings -> ExportSettings

45+

46+-- | Read and process a single org-mode export option.

47+exportSetting :: OrgParser ()

48+exportSetting = choice

49+ [ booleanSetting "^" (\val es -> es { exportSubSuperscripts = val })

50+ , booleanSetting "'" (\val es -> es { exportSmartQuotes = val })

51+ , booleanSetting "*" (\val es -> es { exportEmphasizedText = val })

52+ , booleanSetting "-" (\val es -> es { exportSpecialStrings = val })

53+ , ignoredSetting ":"

54+ , ignoredSetting "<"

55+ , ignoredSetting "\\n"

56+ , archivedTreeSetting "arch" (\val es -> es { exportArchivedTrees = val })

57+ , ignoredSetting "author"

58+ , ignoredSetting "c"

59+ , ignoredSetting "creator"

60+ , complementableListSetting "d" (\val es -> es { exportDrawers = val })

61+ , ignoredSetting "date"

62+ , ignoredSetting "e"

63+ , ignoredSetting "email"

64+ , ignoredSetting "f"

65+ , integerSetting "H" (\val es -> es { exportHeadlineLevels = val })

66+ , ignoredSetting "inline"

67+ , ignoredSetting "num"

68+ , ignoredSetting "p"

69+ , ignoredSetting "pri"

70+ , ignoredSetting "prop"

71+ , ignoredSetting "stat"

72+ , ignoredSetting "tags"

73+ , ignoredSetting "tasks"

74+ , ignoredSetting "tex"

75+ , ignoredSetting "timestamp"

76+ , ignoredSetting "title"

77+ , ignoredSetting "toc"

78+ , ignoredSetting "todo"

79+ , ignoredSetting "|"

80+ ] <?> "export setting"

81+

82+genericExportSetting :: OrgParser a

83+ -> String

84+ -> ExportSettingSetter a

85+ -> OrgParser ()

86+genericExportSetting optionParser settingIdentifier setter = try $ do

87+ _ <- string settingIdentifier *> char ':'

88+ value <- optionParser

89+ updateState $ modifyExportSettings value

90+ where

91+ modifyExportSettings val st =

92+ st { orgStateExportSettings = setter val . orgStateExportSettings $ st }

93+

94+-- | A boolean option, either nil (False) or non-nil (True).

95+booleanSetting :: String -> ExportSettingSetter Bool -> OrgParser ()

96+booleanSetting = genericExportSetting elispBoolean

97+

98+-- | An integer-valued option.

99+integerSetting :: String -> ExportSettingSetter Int -> OrgParser ()

100+integerSetting = genericExportSetting parseInt

101+ where

102+ parseInt = try $

103+ many1 digit >>= maybe mzero (return . fst) . listToMaybe . reads

104+

105+-- | Either the string "headline" or an elisp boolean and treated as an

106+-- @ArchivedTreesOption@.

107+archivedTreeSetting :: String

108+ -> ExportSettingSetter ArchivedTreesOption

109+ -> OrgParser ()

110+archivedTreeSetting =

111+ genericExportSetting $ archivedTreesHeadlineSetting <|> archivedTreesBoolean

112+ where

113+ archivedTreesHeadlineSetting = try $ do

114+ _ <- string "headline"

115+ lookAhead (newline <|> spaceChar)

116+ return ArchivedTreesHeadlineOnly

117+

118+ archivedTreesBoolean = try $ do

119+ exportBool <- elispBoolean

120+ return $

121+ if exportBool

122+ then ArchivedTreesExport

123+ else ArchivedTreesNoExport

124+

125+-- | A list or a complement list (i.e. a list starting with `not`).

126+complementableListSetting :: String

127+ -> ExportSettingSetter (Either [String] [String])

128+ -> OrgParser ()

129+complementableListSetting = genericExportSetting $ choice

130+ [ Left <$> complementStringList

131+ , Right <$> stringList

132+ , (\b -> if b then Left [] else Right []) <$> elispBoolean

133+ ]

134+ where

135+ -- Read a plain list of strings.

136+ stringList :: OrgParser [String]

137+ stringList = try $

138+ char '('

139+ *> sepBy elispString spaces

140+ <* char ')'

141+

142+ -- Read an emacs lisp list specifying a complement set.

143+ complementStringList :: OrgParser [String]

144+ complementStringList = try $

145+ string "(not "

146+ *> sepBy elispString spaces

147+ <* char ')'

148+

149+ elispString :: OrgParser String

150+ elispString = try $

151+ char '"'

152+ *> manyTill alphaNum (char '"')

153+

154+-- | Read but ignore the export setting.

155+ignoredSetting :: String -> OrgParser ()

156+ignoredSetting s = try (() <$ string s <* char ':' <* many1 nonspaceChar)

157+

158+-- | Read an elisp boolean. Only NIL is treated as false, non-NIL values are

159+-- interpreted as true.

160+elispBoolean :: OrgParser Bool

161+elispBoolean = try $ do

162+ value <- many1 nonspaceChar

163+ return $ case map toLower value of

164+ "nil" -> False

165+ "{}" -> False

166+ "()" -> False

167+ _ -> True

src/Text/Pandoc/Readers/Org/ParserState.hs+37−62

@@ -40,14 +40,8 @@ module Text.Pandoc.Readers.Org.ParserState

40 , trimInlinesF

41 , runF

42 , returnF

43− , ExportSettingSetter

44 , ExportSettings (..)

43 , ExportSettings (..)

45− , setExportDrawers

44+ , ArchivedTreesOption (..)

46− , setExportEmphasizedText

47− , setExportSmartQuotes

48− , setExportSpecialStrings

49− , setExportSubSuperscripts

50− , modifyExportSettings

51 , optionsToParserState

45 , optionsToParserState

52 ) where

46 ) where

@@ -78,19 +72,6 @@ type OrgNoteTable = [OrgNoteRecord]

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

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

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

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

81−-- | Export settings <http://orgmode.org/manual/Export-settings.html>

82−-- These settings can be changed via OPTIONS statements.

83−data ExportSettings = ExportSettings

84− { exportDrawers :: Either [String] [String]

85− -- ^ Specify drawer names which should be exported. @Left@ names are

86− -- explicitly excluded from the resulting output while @Right@ means that

87− -- only the listed drawer names should be included.

88− , exportEmphasizedText :: Bool -- ^ Parse emphasized text

89− , exportSmartQuotes :: Bool -- ^ Parse quotes smartly

90− , exportSpecialStrings :: Bool -- ^ Parse ellipses and dashes smartly

91− , exportSubSuperscripts :: Bool -- ^ TeX-like syntax for sub- and superscripts

92− }

93−

94-- | Org-mode parser state

75-- | Org-mode parser state

95data OrgParserState = OrgParserState

76data OrgParserState = OrgParserState

96 { orgStateAnchorIds :: [String]

77 { orgStateAnchorIds :: [String]

@@ -133,9 +114,6 @@ instance HasHeaderMap OrgParserState where

133 extractHeaderMap = orgStateHeaderMap

114 extractHeaderMap = orgStateHeaderMap

134 updateHeaderMap f s = s{ orgStateHeaderMap = f (orgStateHeaderMap s) }

115 updateHeaderMap f s = s{ orgStateHeaderMap = f (orgStateHeaderMap s) }

135

116

136−instance Default ExportSettings where

137− def = defaultExportSettings

138−

139instance Default OrgParserState where

117instance Default OrgParserState where

140 def = defaultOrgParserState

118 def = defaultOrgParserState

141

119

@@ -157,53 +135,50 @@ defaultOrgParserState = OrgParserState

157 , orgStateParserContext = NullState

135 , orgStateParserContext = NullState

158 }

136 }

159

137

138+optionsToParserState :: ReaderOptions -> OrgParserState

139+optionsToParserState opts =

140+ def { orgStateOptions = opts }

141+

142+--

143+-- Export Settings

144+--

145+

146+-- | Options for the way archived trees are handled.

147+data ArchivedTreesOption =

148+ ArchivedTreesExport -- ^ Export the complete tree

149+ | ArchivedTreesNoExport -- ^ Exclude archived trees from exporting

150+ | ArchivedTreesHeadlineOnly -- ^ Export only the headline, discard the contents

151+

152+-- | Export settings <http://orgmode.org/manual/Export-settings.html>

153+-- These settings can be changed via OPTIONS statements.

154+data ExportSettings = ExportSettings

155+ { exportArchivedTrees :: ArchivedTreesOption -- ^ How to treat archived trees

156+ , exportDrawers :: Either [String] [String]

157+ -- ^ Specify drawer names which should be exported. @Left@ names are

158+ -- explicitly excluded from the resulting output while @Right@ means that

159+ -- only the listed drawer names should be included.

160+ , exportEmphasizedText :: Bool -- ^ Parse emphasized text

161+ , exportHeadlineLevels :: Int

162+ -- ^ Maximum depth of headlines, deeper headlines are convert to list

163+ , exportSmartQuotes :: Bool -- ^ Parse quotes smartly

164+ , exportSpecialStrings :: Bool -- ^ Parse ellipses and dashes smartly

165+ , exportSubSuperscripts :: Bool -- ^ TeX-like syntax for sub- and superscripts

166+ }

167+

168+instance Default ExportSettings where

169+ def = defaultExportSettings

170+

160defaultExportSettings :: ExportSettings

171defaultExportSettings :: ExportSettings

161defaultExportSettings = ExportSettings

172defaultExportSettings = ExportSettings

173+ { exportArchivedTrees = ArchivedTreesHeadlineOnly

162− { exportDrawers = Left ["LOGBOOK"]

174+ , exportDrawers = Left ["LOGBOOK"]

163 , exportEmphasizedText = True

175 , exportEmphasizedText = True

176+ , exportHeadlineLevels = 3

164 , exportSmartQuotes = True

177 , exportSmartQuotes = True

165 , exportSpecialStrings = True

178 , exportSpecialStrings = True

166 , exportSubSuperscripts = True

179 , exportSubSuperscripts = True

167 }

180 }

168

181

169−optionsToParserState :: ReaderOptions -> OrgParserState

170−optionsToParserState opts =

171− def { orgStateOptions = opts }

172−

173−

174−--

175−-- Setter for exporting options

176−--

177−type ExportSettingSetter a = a -> ExportSettings -> ExportSettings

178−

179−-- | Set export options for drawers. See the @exportDrawers@ in ADT

180−-- @ExportSettings@ for details.

181−setExportDrawers :: ExportSettingSetter (Either [String] [String])

182−setExportDrawers val es = es { exportDrawers = val }

183−

184−-- | Set export options for emphasis parsing.

185−setExportEmphasizedText :: ExportSettingSetter Bool

186−setExportEmphasizedText val es = es { exportEmphasizedText = val }

187−

188−-- | Set export options for parsing of smart quotes.

189−setExportSmartQuotes :: ExportSettingSetter Bool

190−setExportSmartQuotes val es = es { exportSmartQuotes = val }

191−

192−-- | Set export options for parsing of special strings (like em/en dashes or

193−-- ellipses).

194−setExportSpecialStrings :: ExportSettingSetter Bool

195−setExportSpecialStrings val es = es { exportSpecialStrings = val }

196−

197−-- | Set export options for sub/superscript parsing. The short syntax will

198−-- not be parsed if this is set set to @False@.

199−setExportSubSuperscripts :: ExportSettingSetter Bool

200−setExportSubSuperscripts val es = es { exportSubSuperscripts = val }

201−

202−-- | Modify a parser state

203−modifyExportSettings :: ExportSettingSetter a -> a -> OrgParserState -> OrgParserState

204−modifyExportSettings setter val state =

205− state { orgStateExportSettings = setter val . orgStateExportSettings $ state }

206−

207

182

208--

183--

209-- Parser state reader

184-- Parser state reader

tests/Tests/Readers/Org.hs+36

@@ -587,6 +587,42 @@ tests =

587 , ":END:"

588 ] =?>

589 divWith (mempty, ["IMPORTANT", "drawer"], mempty) (para "5")

590+

591+ , "Export option: don't include archive trees" =:

592+ unlines [ "#+OPTIONS: arch:nil"

593+ , "* old :ARCHIVE:"

594+ ] =?>

595+ (mempty ::Blocks)

596+

597+ , "Export option: include complete archive trees" =:

598+ unlines [ "#+OPTIONS: arch:t"

599+ , "* old :ARCHIVE:"

600+ , " boring"

601+ ] =?>

602+ let tagSpan t = spanWith ("", ["tag"], [("data-tag-name", t)]) mempty

603+ in mconcat [ headerWith ("old", [], mempty) 1 ("old" <> tagSpan "ARCHIVE")

604+ , para "boring"

605+ ]

606+

607+ , "Export option: include archive tree header only" =:

608+ unlines [ "#+OPTIONS: arch:headline"

609+ , "* old :ARCHIVE:"

610+ , " boring"

611+ ] =?>

612+ let tagSpan t = spanWith ("", ["tag"], [("data-tag-name", t)]) mempty

613+ in headerWith ("old", [], mempty) 1 ("old" <> tagSpan "ARCHIVE")

614+

615+ , "Export option: limit headline depth" =:

616+ unlines [ "#+OPTIONS: H:2"

617+ , "* section"

618+ , "** subsection"

619+ , "*** list item 1"

620+ , "*** list item 2"

621+ ] =?>

622+ mconcat [ headerWith ("section", [], []) 1 "section"

623+ , headerWith ("subsection", [], []) 2 "subsection"

624+ , orderedList [ para "list item 1", para "list item 2" ]

625+ ]

590 ]

626 ]

591

627

592 , testGroup "Basic Blocks" $

628 , testGroup "Basic Blocks" $