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

Org reader: support archived trees, headline levels export setting

pandoc.cabal

@@ -399,6 +399,7 @@ Library
                    Text.Pandoc.Readers.Odt.Arrows.Utils,
                    Text.Pandoc.Readers.Org.BlockStarts,
                    Text.Pandoc.Readers.Org.Blocks,
+                   Text.Pandoc.Readers.Org.ExportSettings,
                    Text.Pandoc.Readers.Org.Inlines,
                    Text.Pandoc.Readers.Org.ParserState,
                    Text.Pandoc.Readers.Org.Parsing,

src/Text/Pandoc/Readers/Org.hs

@@ -52,41 +52,4 @@ parseOrg :: OrgParser Pandoc
 parseOrg = do
   blocks' <- blockList
   meta'   <- meta
-  return . Pandoc meta' $ removeUnwantedBlocks blocks'
- where
-   removeUnwantedBlocks :: [Block] -> [Block]
-   removeUnwantedBlocks = dropCommentTrees . filter (/= Null)
-
--- | Drop COMMENT headers and the document tree below those headers.
-dropCommentTrees :: [Block] -> [Block]
-dropCommentTrees [] = []
-dropCommentTrees (b:bs) =
-  maybe (b:dropCommentTrees bs)
-        (dropCommentTrees . flip dropUntilHeaderAboveLevel bs)
-        (commentHeaderLevel b)
-
--- | Return the level of a header starting a comment or :noexport: tree and
---  Nothing otherwise.
-commentHeaderLevel :: Block -> Maybe Int
-commentHeaderLevel blk =
-   case blk of
-     (Header level _ ((Str "COMMENT"):_))          -> Just level
-     (Header level _ title) | hasNoExportTag title -> Just level
-     _                                             -> Nothing
- where
-   hasNoExportTag :: [Inline] -> Bool
-   hasNoExportTag = any isNoExportTag
-
-   isNoExportTag :: Inline -> Bool
-   isNoExportTag (Span ("", ["tag"], [("data-tag-name", "noexport")]) []) = True
-   isNoExportTag _ = False
-
--- | Drop blocks until a header on or above the given level is seen
-dropUntilHeaderAboveLevel :: Int -> [Block] -> [Block]
-dropUntilHeaderAboveLevel n = dropWhile (not . isHeaderLevelLowerEq n)
-
-isHeaderLevelLowerEq :: Int -> Block -> Bool
-isHeaderLevelLowerEq n blk =
-  case blk of
-    (Header level _ _) -> n >= level
-    _                  -> False
+  return $ Pandoc meta' blocks'

src/Text/Pandoc/Readers/Org/Blocks.hs

@@ -1,4 +1,6 @@
 {-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# OPTIONS_GHC -fno-warn-overlapping-patterns #-}
 {-
 Copyright (C) 2014-2016 Albert Krewinkel <tarleb+pandoc@moltkeplatz.de>
 
@@ -32,6 +34,7 @@ module Text.Pandoc.Readers.Org.Blocks
   ) where
 
 import           Text.Pandoc.Readers.Org.BlockStarts
+import           Text.Pandoc.Readers.Org.ExportSettings ( exportSettings )
 import           Text.Pandoc.Readers.Org.Inlines
 import           Text.Pandoc.Readers.Org.ParserState
 import           Text.Pandoc.Readers.Org.Parsing
@@ -46,13 +49,173 @@ import           Text.Pandoc.Compat.Monoid ((<>))
 import           Text.Pandoc.Options
 import           Text.Pandoc.Shared ( compactify', compactify'DL )
 
-import           Control.Monad ( foldM, guard, mzero )
+import           Control.Monad ( foldM, guard, mzero, void )
 import           Data.Char ( isSpace, toLower, toUpper)
 import           Data.List ( foldl', intersperse, isPrefixOf )
 import qualified Data.Map as M
 import           Data.Maybe ( fromMaybe, isNothing )
+import qualified Data.Sequence as S
 import           Network.HTTP ( urlEncode )
 
+--
+-- Org headers
+--
+newtype Tag = Tag { fromTag :: String }
+  deriving (Show, Eq)
+
+-- | Create a tag containing the given string.
+toTag :: String -> Tag
+toTag = Tag
+
+-- | The key (also called name or type) of a property.
+newtype PropertyKey = PropertyKey { fromKey :: String }
+  deriving (Show, Eq, Ord)
+
+-- | Create a property key containing the given string.  Org mode keys are
+-- case insensitive and are hence converted to lower case.
+toPropertyKey :: String -> PropertyKey
+toPropertyKey = PropertyKey . map toLower
+
+-- | The value assigned to a property.
+newtype PropertyValue = PropertyValue { fromValue :: String }
+
+-- | Create a property value containing the given string.
+toPropertyValue :: String -> PropertyValue
+toPropertyValue = PropertyValue
+
+-- | Key/value pairs from a PROPERTIES drawer
+type Properties = [(PropertyKey, PropertyValue)]
+
+-- | Org mode headline (i.e. a document subtree).
+data Headline = Headline
+  { headlineLevel      :: Int
+  , headlineText       :: Inlines
+  , headlineTags       :: [Tag]
+  , headlineProperties :: Properties
+  , headlineContents   :: Blocks
+  , headlineChildren   :: [Headline]
+  }
+
+--
+-- Parsing headlines and subtrees
+--
+
+-- | Read an Org mode headline and its contents (i.e. a document subtree).
+-- @lvl@ gives the minimum acceptable level of the tree.
+headline :: Int -> OrgParser (F Headline)
+headline lvl = try $ do
+  level <- headerStart
+  guard (lvl <= level)
+  title <- trimInlinesF . mconcat <$> manyTill inline endOfTitle
+  tags  <- option [] headerTags
+  newline
+  properties <- option mempty propertiesDrawer
+  contents   <- blocks
+  children   <- many (headline (level + 1))
+  return $ do
+    title'    <- title
+    contents' <- contents
+    children' <- sequence children
+    return $ Headline
+      { headlineLevel = level
+      , headlineText = title'
+      , headlineTags = tags
+      , headlineProperties = properties
+      , headlineContents = contents'
+      , headlineChildren = children'
+      }
+ where
+   endOfTitle :: OrgParser ()
+   endOfTitle = void . lookAhead $ optional headerTags *> newline
+
+   headerTags :: OrgParser [Tag]
+   headerTags = try $
+     let tag = many1 (alphaNum <|> oneOf "@%#_") <* char ':'
+     in map toTag <$> (skipSpaces *> char ':' *> many1 tag <* skipSpaces)
+
+-- | Convert an Org mode headline (i.e. a document tree) into pandoc's Blocks
+headlineToBlocks :: Headline -> OrgParser Blocks
+headlineToBlocks hdln@(Headline {..}) = do
+  maxHeadlineLevels <- getExportSetting exportHeadlineLevels
+  case () of
+    _ | any isNoExportTag headlineTags     -> return mempty
+    _ | any isArchiveTag  headlineTags     -> archivedHeadlineToBlocks hdln
+    _ | isCommentTitle headlineText        -> return mempty
+    _ | headlineLevel >= maxHeadlineLevels -> headlineToHeaderWithList hdln
+    _                                      -> headlineToHeaderWithContents hdln
+
+isNoExportTag :: Tag -> Bool
+isNoExportTag = (== toTag "noexport")
+
+isArchiveTag :: Tag -> Bool
+isArchiveTag = (== toTag "ARCHIVE")
+
+-- | Check if the title starts with COMMENT.
+-- FIXME: This accesses builder internals not intended for use in situations
+-- like these.  Replace once keyword parsing is supported.
+isCommentTitle :: Inlines -> Bool
+isCommentTitle xs = (B.Many . S.take 1 . B.unMany) xs == B.str "COMMENT"
+isCommentTitle _  = False
+
+archivedHeadlineToBlocks :: Headline -> OrgParser Blocks
+archivedHeadlineToBlocks hdln = do
+  archivedTreesOption <- getExportSetting exportArchivedTrees
+  case archivedTreesOption of
+    ArchivedTreesNoExport     -> return mempty
+    ArchivedTreesExport       -> headlineToHeaderWithContents hdln
+    ArchivedTreesHeadlineOnly -> headlineToHeader hdln
+
+headlineToHeaderWithList :: Headline -> OrgParser Blocks
+headlineToHeaderWithList hdln@(Headline {..}) = do
+  maxHeadlineLevels <- getExportSetting exportHeadlineLevels
+  header        <- headlineToHeader hdln
+  listElements  <- sequence (map headlineToBlocks headlineChildren)
+  let listBlock  = if null listElements
+                   then mempty
+                   else B.orderedList listElements
+  let headerText = if maxHeadlineLevels == headlineLevel
+                   then header
+                   else flattenHeader header
+  return $ headerText <> headlineContents <> listBlock
+ where
+   flattenHeader :: Blocks -> Blocks
+   flattenHeader blks =
+     case B.toList blks of
+       (Header _ _ inlns:_) -> B.para (B.fromList inlns)
+       _                    -> mempty
+
+headlineToHeaderWithContents :: Headline -> OrgParser Blocks
+headlineToHeaderWithContents hdln@(Headline {..}) = do
+  header         <- headlineToHeader hdln
+  childrenBlocks <- mconcat <$> sequence (map headlineToBlocks headlineChildren)
+  return $ header <> headlineContents <> childrenBlocks
+
+headlineToHeader :: Headline -> OrgParser Blocks
+headlineToHeader (Headline {..}) = do
+  let text        = tagTitle headlineText headlineTags
+  let propAttr    = propertiesToAttr headlineProperties
+  attr           <- registerHeader propAttr headlineText
+  return $ B.headerWith attr headlineLevel text
+
+propertiesToAttr :: Properties -> Attr
+propertiesToAttr properties =
+  let
+    toStringPair prop = (fromKey (fst prop), fromValue (snd prop))
+    customIdKey = toPropertyKey "custom_id"
+    classKey    = toPropertyKey "class"
+    id'  = fromMaybe mempty . fmap fromValue . lookup customIdKey $ properties
+    cls  = fromMaybe mempty . fmap fromValue . lookup classKey    $ properties
+    kvs' = map toStringPair . filter ((`notElem` [customIdKey, classKey]) . fst)
+           $ properties
+  in
+    (id', words cls, kvs')
+
+tagTitle :: Inlines -> [Tag] -> Inlines
+tagTitle title tags = title <> (mconcat $ map tagToInline tags)
+
+tagToInline :: Tag -> Inlines
+tagToInline t = B.spanWith ("", ["tag"], [("data-tag-name", fromTag t)]) mempty
+
 
 --
 -- parsing blocks
@@ -61,9 +224,11 @@ import           Network.HTTP ( urlEncode )
 -- | Get a list of blocks.
 blockList :: OrgParser [Block]
 blockList = do
-  blocks' <- blocks
-  st      <- getState
-  return . B.toList $ runF blocks' st
+  initialBlocks  <- blocks
+  headlines      <- sequence <$> manyTill (headline 1) eof
+  st             <- getState
+  headlineBlocks <- fmap mconcat . sequence . map headlineToBlocks $ runF headlines st
+  return . B.toList $ (runF initialBlocks st) <> headlineBlocks
 
 -- | Get the meta information safed in the state.
 meta :: OrgParser Meta
@@ -72,7 +237,7 @@ meta = do
   return $ runF (orgStateMeta st) st
 
 blocks :: OrgParser (F Blocks)
-blocks = mconcat <$> manyTill block eof
+blocks = mconcat <$> manyTill block (void (lookAhead headerStart) <|> eof)
 
 block :: OrgParser (F Blocks)
 block = choice [ mempty <$ blanklines
@@ -82,7 +247,6 @@ block = choice [ mempty <$ blanklines
                , example
                , genericDrawer
                , specialLine
-               , header
                , horizontalRule
                , list
                , latexFragment
@@ -381,30 +545,22 @@ drawerEnd = try $
 
 -- | Read a :PROPERTIES: drawer and return the key/value pairs contained
 -- within.
-propertiesDrawer :: OrgParser [(String, String)]
+propertiesDrawer :: OrgParser Properties
 propertiesDrawer = try $ do
   drawerType <- drawerStart
   guard $ map toUpper drawerType == "PROPERTIES"
   manyTill property (try drawerEnd)
  where
-   property :: OrgParser (String, String)
+   property :: OrgParser (PropertyKey, PropertyValue)
    property = try $ (,) <$> key <*> value
 
-   key :: OrgParser String
-   key = try $ skipSpaces *> char ':' *> many1Till nonspaceChar (char ':')
+   key :: OrgParser PropertyKey
+   key = fmap toPropertyKey . try $
+         skipSpaces *> char ':' *> many1Till nonspaceChar (char ':')
 
-   value :: OrgParser String
-   value = try $ skipSpaces *> manyTill anyChar (try $ skipSpaces *> newline)
-
-keyValuesToAttr :: [(String, String)] -> Attr
-keyValuesToAttr kvs =
-  let
-    lowerKvs = map (\(k, v) -> (map toLower k, v)) kvs
-    id'  = fromMaybe mempty . lookup "custom_id" $ lowerKvs
-    cls  = fromMaybe mempty . lookup "class"     $ lowerKvs
-    kvs' = filter (flip notElem ["custom_id", "class"] . fst) lowerKvs
-  in
-    (id', words cls, kvs')
+   value :: OrgParser PropertyValue
+   value = fmap toPropertyValue . try $
+           skipSpaces *> manyTill anyChar (try $ skipSpaces *> newline)
 
 
 --
@@ -486,7 +642,7 @@ optionLine = try $ do
   key <- metaKey
   case key of
     "link"    -> parseLinkFormat >>= uncurry addLinkFormat
-    "options" -> () <$ sepBy spaces exportSetting
+    "options" -> exportSettings
     _         -> mzero
 
 addLinkFormat :: String
@@ -496,100 +652,6 @@ addLinkFormat key formatter = updateState $ \s ->
   let fs = orgStateLinkFormatters s
   in s{ orgStateLinkFormatters = M.insert key formatter fs }
 
-
---
--- Export Settings
---
-
--- | Read and process org-mode specific export options.
-exportSetting :: OrgParser ()
-exportSetting = choice
-  [ booleanSetting "^" setExportSubSuperscripts
-  , booleanSetting "'" setExportSmartQuotes
-  , booleanSetting "*" setExportEmphasizedText
-  , booleanSetting "-" setExportSpecialStrings
-  , ignoredSetting ":"
-  , ignoredSetting "<"
-  , ignoredSetting "\\n"
-  , ignoredSetting "arch"
-  , ignoredSetting "author"
-  , ignoredSetting "c"
-  , ignoredSetting "creator"
-  , complementableListSetting "d" setExportDrawers
-  , ignoredSetting "date"
-  , ignoredSetting "e"
-  , ignoredSetting "email"
-  , ignoredSetting "f"
-  , ignoredSetting "H"
-  , ignoredSetting "inline"
-  , ignoredSetting "num"
-  , ignoredSetting "p"
-  , ignoredSetting "pri"
-  , ignoredSetting "prop"
-  , ignoredSetting "stat"
-  , ignoredSetting "tags"
-  , ignoredSetting "tasks"
-  , ignoredSetting "tex"
-  , ignoredSetting "timestamp"
-  , ignoredSetting "title"
-  , ignoredSetting "toc"
-  , ignoredSetting "todo"
-  , ignoredSetting "|"
-  ] <?> "export setting"
-
-booleanSetting :: String -> ExportSettingSetter Bool -> OrgParser ()
-booleanSetting settingIdentifier setter = try $ do
-  string settingIdentifier
-  char ':'
-  value <- elispBoolean
-  updateState $ modifyExportSettings setter value
-
--- | Read an elisp boolean.  Only NIL is treated as false, non-NIL values are
--- interpreted as true.
-elispBoolean :: OrgParser Bool
-elispBoolean = try $ do
-  value <- many1 nonspaceChar
-  return $ case map toLower value of
-             "nil" -> False
-             "{}"  -> False
-             "()"  -> False
-             _     -> True
-
--- | A list or a complement list (i.e. a list starting with `not`).
-complementableListSetting :: String
-                          -> ExportSettingSetter (Either [String] [String])
-                          -> OrgParser ()
-complementableListSetting settingIdentifier setter = try $ do
-  _     <- string settingIdentifier <* char ':'
-  value <- choice [ Left <$> complementStringList
-                  , Right <$> stringList
-                  , (\b -> if b then Left [] else Right []) <$> elispBoolean
-                  ]
-  updateState $ modifyExportSettings setter value
- where
-   -- Read a plain list of strings.
-   stringList :: OrgParser [String]
-   stringList = try $
-     char '('
-       *> sepBy elispString spaces
-       <* char ')'
-
-   -- Read an emacs lisp list specifying a complement set.
-   complementStringList :: OrgParser [String]
-   complementStringList = try $
-     string "(not "
-       *> sepBy elispString spaces
-       <* char ')'
-
-   elispString :: OrgParser String
-   elispString = try $
-     char '"'
-       *> manyTill alphaNum (char '"')
-
-ignoredSetting :: String -> OrgParser ()
-ignoredSetting s = try (() <$ string s <* char ':' <* many1 nonspaceChar)
-
-
 parseLinkFormat :: OrgParser ((String, String -> String))
 parseLinkFormat = try $ do
   linkType <- (:) <$> letter <*> many (alphaNum <|> oneOf "-_") <* skipSpaces
@@ -612,36 +674,6 @@ parseFormat = try $ do
    rest            = manyTill anyChar         (eof <|> () <$ oneOf "\n\r")
    tillSpecifier c = manyTill (noneOf "\n\r") (try $ string ('%':c:""))
 
---
--- Headers
---
-
--- | Headers
-header :: OrgParser (F Blocks)
-header = try $ do
-  level    <- headerStart
-  title    <- manyTill inline (lookAhead $ optional headerTags <* newline)
-  tags     <- option [] headerTags
-  newline
-  let text = tagTitle title tags
-  propAttr <- option nullAttr (keyValuesToAttr <$> propertiesDrawer)
-  attr     <- registerHeader propAttr (runF text def)
-  return (B.headerWith attr level <$> text)
- where
-   tagTitle :: [F Inlines] -> [String] -> F Inlines
-   tagTitle title tags = trimInlinesF . mconcat $ title <> map tagToInlineF tags
-
-   tagToInlineF :: String -> F Inlines
-   tagToInlineF t = return $ B.spanWith ("", ["tag"], [("data-tag-name", t)]) mempty
-
-   headerTags :: OrgParser [String]
-   headerTags = try $
-     let tag = many1 (alphaNum <|> oneOf "@%#_") <* char ':'
-     in skipSpaces
-          *> char ':'
-          *> many1 tag
-          <* skipSpaces
-
 
 --
 -- Tables
@@ -806,6 +838,8 @@ noteBlock = try $ do
 -- Paragraphs or Plain text
 paraOrPlain :: OrgParser (F Blocks)
 paraOrPlain = try $ do
+  -- Make sure we are not looking at a headline
+  notFollowedBy' (char '*' *> (oneOf " *"))
   ils <- inlines
   nl <- option False (newline *> return True)
   -- Read block as paragraph, except if we are in a list context and the block

src/Text/Pandoc/Readers/Org/ExportSettings.hs

@@ -0,0 +1,167 @@
+{-
+Copyright (C) 2014-2016 Albert Krewinkel <tarleb+pandoc@moltkeplatz.de>
+
+This program is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2 of the License, or
+(at your option) any later version.
+
+This program is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+GNU General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with this program; if not, write to the Free Software
+Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
+-}
+
+{- |
+   Module      : Text.Pandoc.Readers.Org.Options
+   Copyright   : Copyright (C) 2016 Albert Krewinkel
+   License     : GNU GPL, version 2 or above
+
+   Maintainer  : Albert Krewinkel <tarleb+pandoc@moltkeplatz.de>
+
+Parsers for Org-mode export options.
+-}
+module Text.Pandoc.Readers.Org.ExportSettings
+  ( exportSettings
+  ) where
+
+import           Text.Pandoc.Readers.Org.ParserState
+import           Text.Pandoc.Readers.Org.Parsing
+
+import           Control.Monad ( mzero, void )
+import           Data.Char ( toLower )
+import           Data.Maybe ( listToMaybe )
+
+-- | Read and handle space separated org-mode export settings.
+exportSettings :: OrgParser ()
+exportSettings = void $ sepBy spaces exportSetting
+
+-- | Setter function for export settings.
+type ExportSettingSetter a = a -> ExportSettings -> ExportSettings
+
+-- | Read and process a single org-mode export option.
+exportSetting :: OrgParser ()
+exportSetting = choice
+  [ booleanSetting "^" (\val es -> es { exportSubSuperscripts = val })
+  , booleanSetting "'" (\val es -> es { exportSmartQuotes = val })
+  , booleanSetting "*" (\val es -> es { exportEmphasizedText = val })
+  , booleanSetting "-" (\val es -> es { exportSpecialStrings = val })
+  , ignoredSetting ":"
+  , ignoredSetting "<"
+  , ignoredSetting "\\n"
+  , archivedTreeSetting "arch" (\val es -> es { exportArchivedTrees = val })
+  , ignoredSetting "author"
+  , ignoredSetting "c"
+  , ignoredSetting "creator"
+  , complementableListSetting "d" (\val es -> es { exportDrawers = val })
+  , ignoredSetting "date"
+  , ignoredSetting "e"
+  , ignoredSetting "email"
+  , ignoredSetting "f"
+  , integerSetting "H" (\val es -> es { exportHeadlineLevels = val })
+  , ignoredSetting "inline"
+  , ignoredSetting "num"
+  , ignoredSetting "p"
+  , ignoredSetting "pri"
+  , ignoredSetting "prop"
+  , ignoredSetting "stat"
+  , ignoredSetting "tags"
+  , ignoredSetting "tasks"
+  , ignoredSetting "tex"
+  , ignoredSetting "timestamp"
+  , ignoredSetting "title"
+  , ignoredSetting "toc"
+  , ignoredSetting "todo"
+  , ignoredSetting "|"
+  ] <?> "export setting"
+
+genericExportSetting :: OrgParser a
+                     -> String
+                     -> ExportSettingSetter a
+                     -> OrgParser ()
+genericExportSetting optionParser settingIdentifier setter = try $ do
+  _     <- string settingIdentifier *> char ':'
+  value <- optionParser
+  updateState $ modifyExportSettings value
+ where
+   modifyExportSettings val st =
+     st { orgStateExportSettings = setter val . orgStateExportSettings $ st }
+
+-- | A boolean option, either nil (False) or non-nil (True).
+booleanSetting :: String ->  ExportSettingSetter Bool -> OrgParser ()
+booleanSetting = genericExportSetting elispBoolean
+
+-- | An integer-valued option.
+integerSetting :: String -> ExportSettingSetter Int -> OrgParser ()
+integerSetting = genericExportSetting parseInt
+ where
+   parseInt = try $
+     many1 digit >>= maybe mzero (return . fst) . listToMaybe . reads
+
+-- | Either the string "headline" or an elisp boolean and treated as an
+-- @ArchivedTreesOption@.
+archivedTreeSetting :: String
+                    -> ExportSettingSetter ArchivedTreesOption
+                    -> OrgParser ()
+archivedTreeSetting =
+  genericExportSetting $ archivedTreesHeadlineSetting <|> archivedTreesBoolean
+ where
+   archivedTreesHeadlineSetting = try $ do
+     _ <- string "headline"
+     lookAhead (newline <|> spaceChar)
+     return ArchivedTreesHeadlineOnly
+
+   archivedTreesBoolean = try $ do
+     exportBool <- elispBoolean
+     return $
+       if exportBool
+       then ArchivedTreesExport
+       else ArchivedTreesNoExport
+
+-- | A list or a complement list (i.e. a list starting with `not`).
+complementableListSetting :: String
+                          -> ExportSettingSetter (Either [String] [String])
+                          -> OrgParser ()
+complementableListSetting = genericExportSetting $ choice
+  [ Left  <$> complementStringList
+  , Right <$> stringList
+  , (\b -> if b then Left [] else Right []) <$> elispBoolean
+  ]
+ where
+   -- Read a plain list of strings.
+   stringList :: OrgParser [String]
+   stringList = try $
+     char '('
+       *> sepBy elispString spaces
+       <* char ')'
+
+   -- Read an emacs lisp list specifying a complement set.
+   complementStringList :: OrgParser [String]
+   complementStringList = try $
+     string "(not "
+       *> sepBy elispString spaces
+       <* char ')'
+
+   elispString :: OrgParser String
+   elispString = try $
+     char '"'
+       *> manyTill alphaNum (char '"')
+
+-- | Read but ignore the export setting.
+ignoredSetting :: String -> OrgParser ()
+ignoredSetting s = try (() <$ string s <* char ':' <* many1 nonspaceChar)
+
+-- | Read an elisp boolean.  Only NIL is treated as false, non-NIL values are
+-- interpreted as true.
+elispBoolean :: OrgParser Bool
+elispBoolean = try $ do
+  value <- many1 nonspaceChar
+  return $ case map toLower value of
+             "nil" -> False
+             "{}"  -> False
+             "()"  -> False
+             _     -> True

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

@@ -40,14 +40,8 @@ module Text.Pandoc.Readers.Org.ParserState
   , trimInlinesF
   , runF
   , returnF
-  , ExportSettingSetter
   , ExportSettings (..)
-  , setExportDrawers
-  , setExportEmphasizedText
-  , setExportSmartQuotes
-  , setExportSpecialStrings
-  , setExportSubSuperscripts
-  , modifyExportSettings
+  , ArchivedTreesOption (..)
   , optionsToParserState
   ) where
 
@@ -78,19 +72,6 @@ type OrgNoteTable = [OrgNoteRecord]
 -- link-type, the corresponding function transforms the given link string.
 type OrgLinkFormatters = M.Map String (String -> String)
 
--- | Export settings <http://orgmode.org/manual/Export-settings.html>
--- These settings can be changed via OPTIONS statements.
-data ExportSettings = ExportSettings
-  { exportDrawers         :: Either [String] [String]
-  -- ^ Specify drawer names which should be exported.  @Left@ names are
-  -- explicitly excluded from the resulting output while @Right@ means that
-  -- only the listed drawer names should be included.
-  , exportEmphasizedText  :: Bool -- ^ Parse emphasized text
-  , exportSmartQuotes     :: Bool -- ^ Parse quotes smartly
-  , exportSpecialStrings  :: Bool -- ^ Parse ellipses and dashes smartly
-  , exportSubSuperscripts :: Bool -- ^ TeX-like syntax for sub- and superscripts
-  }
-
 -- | Org-mode parser state
 data OrgParserState = OrgParserState
   { orgStateAnchorIds            :: [String]
@@ -133,9 +114,6 @@ instance HasHeaderMap OrgParserState where
   extractHeaderMap = orgStateHeaderMap
   updateHeaderMap  f s = s{ orgStateHeaderMap = f (orgStateHeaderMap s) }
 
-instance Default ExportSettings where
-  def = defaultExportSettings
-
 instance Default OrgParserState where
   def = defaultOrgParserState
 
@@ -157,52 +135,49 @@ defaultOrgParserState = OrgParserState
   , orgStateParserContext = NullState
   }
 
-defaultExportSettings :: ExportSettings
-defaultExportSettings = ExportSettings
-  { exportDrawers = Left ["LOGBOOK"]
-  , exportEmphasizedText = True
-  , exportSmartQuotes = True
-  , exportSpecialStrings = True
-  , exportSubSuperscripts = True
-  }
-
 optionsToParserState :: ReaderOptions -> OrgParserState
 optionsToParserState opts =
   def { orgStateOptions = opts }
 
-
 --
--- Setter for exporting options
+-- Export Settings
 --
-type ExportSettingSetter a = a -> ExportSettings -> ExportSettings
 
--- | Set export options for drawers.  See the @exportDrawers@ in ADT
--- @ExportSettings@ for details.
-setExportDrawers :: ExportSettingSetter (Either [String] [String])
-setExportDrawers val es = es { exportDrawers = val }
+-- | Options for the way archived trees are handled.
+data ArchivedTreesOption =
+    ArchivedTreesExport       -- ^ Export the complete tree
+  | ArchivedTreesNoExport     -- ^ Exclude archived trees from exporting
+  | ArchivedTreesHeadlineOnly -- ^ Export only the headline, discard the contents
 
--- | Set export options for emphasis parsing.
-setExportEmphasizedText :: ExportSettingSetter Bool
-setExportEmphasizedText val es = es { exportEmphasizedText = val }
+-- | Export settings <http://orgmode.org/manual/Export-settings.html>
+-- These settings can be changed via OPTIONS statements.
+data ExportSettings = ExportSettings
+  { exportArchivedTrees   :: ArchivedTreesOption -- ^ How to treat archived trees
+  , exportDrawers         :: Either [String] [String]
+  -- ^ Specify drawer names which should be exported.  @Left@ names are
+  -- explicitly excluded from the resulting output while @Right@ means that
+  -- only the listed drawer names should be included.
+  , exportEmphasizedText  :: Bool -- ^ Parse emphasized text
+  , exportHeadlineLevels  :: Int
+  -- ^ Maximum depth of headlines, deeper headlines are convert to list
+  , exportSmartQuotes     :: Bool -- ^ Parse quotes smartly
+  , exportSpecialStrings  :: Bool -- ^ Parse ellipses and dashes smartly
+  , exportSubSuperscripts :: Bool -- ^ TeX-like syntax for sub- and superscripts
+  }
 
--- | Set export options for parsing of smart quotes.
-setExportSmartQuotes :: ExportSettingSetter Bool
-setExportSmartQuotes val es = es { exportSmartQuotes = val }
+instance Default ExportSettings where
+  def = defaultExportSettings
 
--- | Set export options for parsing of special strings (like em/en dashes or
--- ellipses).
-setExportSpecialStrings :: ExportSettingSetter Bool
-setExportSpecialStrings val es = es { exportSpecialStrings = val }
-
--- | Set export options for sub/superscript parsing.  The short syntax will
--- not be parsed if this is set set to @False@.
-setExportSubSuperscripts :: ExportSettingSetter Bool
-setExportSubSuperscripts val es = es { exportSubSuperscripts = val }
-
--- | Modify a parser state
-modifyExportSettings :: ExportSettingSetter a -> a -> OrgParserState -> OrgParserState
-modifyExportSettings setter val state =
-  state { orgStateExportSettings = setter val . orgStateExportSettings $ state }
+defaultExportSettings :: ExportSettings
+defaultExportSettings = ExportSettings
+  { exportArchivedTrees = ArchivedTreesHeadlineOnly
+  , exportDrawers = Left ["LOGBOOK"]
+  , exportEmphasizedText = True
+  , exportHeadlineLevels = 3
+  , exportSmartQuotes = True
+  , exportSpecialStrings = True
+  , exportSubSuperscripts = True
+  }
 
 
 --

tests/Tests/Readers/Org.hs

@@ -587,6 +587,42 @@ tests =
                   , ":END:"
                   ] =?>
           divWith (mempty, ["IMPORTANT", "drawer"], mempty) (para "5")
+
+      , "Export option: don't include archive trees" =:
+          unlines [ "#+OPTIONS: arch:nil"
+                  , "* old  :ARCHIVE:"
+                  ] =?>
+          (mempty ::Blocks)
+
+      , "Export option: include complete archive trees" =:
+          unlines [ "#+OPTIONS: arch:t"
+                  , "* old  :ARCHIVE:"
+                  , "  boring"
+                  ] =?>
+          let tagSpan t = spanWith ("", ["tag"], [("data-tag-name", t)]) mempty
+          in mconcat [ headerWith ("old", [], mempty) 1 ("old" <> tagSpan "ARCHIVE")
+                     , para "boring"
+                     ]
+
+      , "Export option: include archive tree header only" =:
+          unlines [ "#+OPTIONS: arch:headline"
+                  , "* old  :ARCHIVE:"
+                  , "  boring"
+                  ] =?>
+          let tagSpan t = spanWith ("", ["tag"], [("data-tag-name", t)]) mempty
+          in headerWith ("old", [], mempty) 1 ("old" <> tagSpan "ARCHIVE")
+
+      , "Export option: limit headline depth" =:
+          unlines [ "#+OPTIONS: H:2"
+                  , "* section"
+                  , "** subsection"
+                  , "*** list item 1"
+                  , "*** list item 2"
+                  ] =?>
+          mconcat [ headerWith ("section", [], [])    1 "section"
+                  , headerWith ("subsection", [], []) 2 "subsection"
+                  , orderedList [ para "list item 1", para "list item 2" ]
+                  ]
       ]
 
   , testGroup "Basic Blocks" $