git.iko.soy/typeable/pandoc
on master help sign in
Merge pull request #3010 from tarleb/org-header-tree

Org reader: support archived trees, headline levels export setting

commite548b8df072c4eecfeb43f94c6517c35d5eba30c authorJohn MacFarlane <jgm@berkeley.edu> dateSun 3 Jul 2016, 22:57 (10 years ago) parent4099b2d5ffa4ab
6 files changed+423−247
compare with master
unifiedsplit
pandoc.cabal+1 src/Text/Pandoc/Readers/Org.hs+1−38 src/Text/Pandoc/Readers/Org/Blocks.hs+181−147 src/Text/Pandoc/Readers/Org/ExportSettings.hs+167 src/Text/Pandoc/Readers/Org/ParserState.hs+37−62 tests/Tests/Readers/Org.hs+36
pandoc.cabal+1
@@ -399,6 +399,7 @@ Library
399399 Text.Pandoc.Readers.Odt.Arrows.Utils,
400400 Text.Pandoc.Readers.Org.BlockStarts,
401401 Text.Pandoc.Readers.Org.Blocks,
402+ Text.Pandoc.Readers.Org.ExportSettings,
402403 Text.Pandoc.Readers.Org.Inlines,
403404 Text.Pandoc.Readers.Org.ParserState,
404405 Text.Pandoc.Readers.Org.Parsing,
src/Text/Pandoc/Readers/Org.hs+1−38
@@ -52,41 +52,4 @@ parseOrg :: OrgParser Pandoc
5252parseOrg = do
5353 blocks' <- blockList
5454 meta' <- meta
55− return . Pandoc meta' $ removeUnwantedBlocks 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
55+ return $ Pandoc meta' blocks'
src/Text/Pandoc/Readers/Org/Blocks.hs+181−147
@@ -1,4 +1,6 @@
11{-# LANGUAGE FlexibleContexts #-}
2+{-# LANGUAGE RecordWildCards #-}
3+{-# OPTIONS_GHC -fno-warn-overlapping-patterns #-}
24{-
35Copyright (C) 2014-2016 Albert Krewinkel <tarleb+pandoc@moltkeplatz.de>
46
@@ -32,6 +34,7 @@ module Text.Pandoc.Readers.Org.Blocks
3234 ) where
3335
3436import Text.Pandoc.Readers.Org.BlockStarts
37+import Text.Pandoc.Readers.Org.ExportSettings ( exportSettings )
3538import Text.Pandoc.Readers.Org.Inlines
3639import Text.Pandoc.Readers.Org.ParserState
3740import Text.Pandoc.Readers.Org.Parsing
@@ -46,13 +49,173 @@ import Text.Pandoc.Compat.Monoid ((<>))
4649import Text.Pandoc.Options
4750import Text.Pandoc.Shared ( compactify', compactify'DL )
4851
49−import Control.Monad ( foldM, guard, mzero )
52+import Control.Monad ( foldM, guard, mzero, void )
5053import Data.Char ( isSpace, toLower, toUpper)
5154import Data.List ( foldl', intersperse, isPrefixOf )
5255import qualified Data.Map as M
5356import Data.Maybe ( fromMaybe, isNothing )
57+import qualified Data.Sequence as S
5458import Network.HTTP ( urlEncode )
5559
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+
56219
57220--
58221-- parsing blocks
@@ -61,9 +224,11 @@ import Network.HTTP ( urlEncode )
61224-- | Get a list of blocks.
62225blockList :: OrgParser [Block]
63226blockList = do
64− blocks' <- blocks
65− st <- getState
66− return . B.toList $ runF blocks' st
227+ initialBlocks <- blocks
228+ headlines <- sequence <$> manyTill (headline 1) eof
229+ st <- getState
230+ headlineBlocks <- fmap mconcat . sequence . map headlineToBlocks $ runF headlines st
231+ return . B.toList $ (runF initialBlocks st) <> headlineBlocks
67232
68233-- | Get the meta information safed in the state.
69234meta :: OrgParser Meta
@@ -72,7 +237,7 @@ meta = do
72237 return $ runF (orgStateMeta st) st
73238
74239blocks :: OrgParser (F Blocks)
75−blocks = mconcat <$> manyTill block eof
240+blocks = mconcat <$> manyTill block (void (lookAhead headerStart) <|> eof)
76241
77242block :: OrgParser (F Blocks)
78243block = choice [ mempty <$ blanklines
@@ -82,7 +247,6 @@ block = choice [ mempty <$ blanklines
82247 , example
83248 , genericDrawer
84249 , specialLine
85− , header
86250 , horizontalRule
87251 , list
88252 , latexFragment
@@ -381,30 +545,22 @@ drawerEnd = try $
381545
382546-- | Read a :PROPERTIES: drawer and return the key/value pairs contained
383547-- within.
384−propertiesDrawer :: OrgParser [(String, String)]
548+propertiesDrawer :: OrgParser Properties
385549propertiesDrawer = try $ do
386550 drawerType <- drawerStart
387551 guard $ map toUpper drawerType == "PROPERTIES"
388552 manyTill property (try drawerEnd)
389553 where
390− property :: OrgParser (String, String)
554+ property :: OrgParser (PropertyKey, PropertyValue)
391555 property = try $ (,) <$> key <*> value
392556
393− key :: OrgParser String
394− key = try $ skipSpaces *> char ':' *> many1Till nonspaceChar (char ':')
557+ key :: OrgParser PropertyKey
558+ key = fmap toPropertyKey . try $
559+ skipSpaces *> char ':' *> many1Till nonspaceChar (char ':')
395560
396− value :: OrgParser String
397− value = try $ 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')
561+ value :: OrgParser PropertyValue
562+ value = fmap toPropertyValue . try $
563+ skipSpaces *> manyTill anyChar (try $ skipSpaces *> newline)
408564
409565
410566--
@@ -486,7 +642,7 @@ optionLine = try $ do
486642 key <- metaKey
487643 case key of
488644 "link" -> parseLinkFormat >>= uncurry addLinkFormat
489− "options" -> () <$ sepBy spaces exportSetting
645+ "options" -> exportSettings
490646 _ -> mzero
491647
492648addLinkFormat :: String
@@ -496,100 +652,6 @@ addLinkFormat key formatter = updateState $ \s ->
496652 let fs = orgStateLinkFormatters s
497653 in s{ orgStateLinkFormatters = M.insert key formatter fs }
498654
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−
593655parseLinkFormat :: OrgParser ((String, String -> String))
594656parseLinkFormat = try $ do
595657 linkType <- (:) <$> letter <*> many (alphaNum <|> oneOf "-_") <* skipSpaces
@@ -612,36 +674,6 @@ parseFormat = try $ do
612674 rest = manyTill anyChar (eof <|> () <$ oneOf "\n\r")
613675 tillSpecifier c = manyTill (noneOf "\n\r") (try $ string ('%':c:""))
614676
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−
645677
646678--
647679-- Tables
@@ -806,6 +838,8 @@ noteBlock = try $ do
806838-- Paragraphs or Plain text
807839paraOrPlain :: OrgParser (F Blocks)
808840paraOrPlain = try $ do
841+ -- Make sure we are not looking at a headline
842+ notFollowedBy' (char '*' *> (oneOf " *"))
809843 ils <- inlines
810844 nl <- option False (newline *> return True)
811845 -- 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+{-
2+Copyright (C) 2014-2016 Albert Krewinkel <tarleb+pandoc@moltkeplatz.de>
3+
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.
8+
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
21+ Copyright : Copyright (C) 2016 Albert Krewinkel
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
4040 , trimInlinesF
4141 , runF
4242 , returnF
43− , ExportSettingSetter
4443 , ExportSettings (..)
45− , setExportDrawers
46− , setExportEmphasizedText
47− , setExportSmartQuotes
48− , setExportSpecialStrings
49− , setExportSubSuperscripts
50− , modifyExportSettings
44+ , ArchivedTreesOption (..)
5145 , optionsToParserState
5246 ) where
5347
@@ -78,19 +72,6 @@ type OrgNoteTable = [OrgNoteRecord]
7872-- link-type, the corresponding function transforms the given link string.
7973type OrgLinkFormatters = M.Map String (String -> String)
8074
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−
9475-- | Org-mode parser state
9576data OrgParserState = OrgParserState
9677 { orgStateAnchorIds :: [String]
@@ -133,9 +114,6 @@ instance HasHeaderMap OrgParserState where
133114 extractHeaderMap = orgStateHeaderMap
134115 updateHeaderMap f s = s{ orgStateHeaderMap = f (orgStateHeaderMap s) }
135116
136−instance Default ExportSettings where
137− def = defaultExportSettings
138−
139117instance Default OrgParserState where
140118 def = defaultOrgParserState
141119
@@ -157,53 +135,50 @@ defaultOrgParserState = OrgParserState
157135 , orgStateParserContext = NullState
158136 }
159137
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+
160171defaultExportSettings :: ExportSettings
161172defaultExportSettings = ExportSettings
162− { exportDrawers = Left ["LOGBOOK"]
173+ { exportArchivedTrees = ArchivedTreesHeadlineOnly
174+ , exportDrawers = Left ["LOGBOOK"]
163175 , exportEmphasizedText = True
176+ , exportHeadlineLevels = 3
164177 , exportSmartQuotes = True
165178 , exportSpecialStrings = True
166179 , exportSubSuperscripts = True
167180 }
168181
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−
207182
208183--
209184-- Parser state reader
tests/Tests/Readers/Org.hs+36
@@ -587,6 +587,42 @@ tests =
587587 , ":END:"
588588 ] =?>
589589 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+ ]
590626 ]
591627
592628 , testGroup "Basic Blocks" $