Org reader: support archived trees export options

Handling of archived trees can be modified using the `arch` option.
Archived trees are either dropped, exported completely, or collapsed to
include just the header when the `arch` option is nil, non-nil, or
`headline`, respectively.

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

@@ -137,27 +137,43 @@ headlineToBlocks :: Headline -> OrgParser Blocks
 headlineToBlocks hdln@(Headline {..}) =
   case () of
     _ | any isNoExportTag headlineTags -> return mempty
+    _ | any isArchiveTag  headlineTags -> archivedHeadlineToBlocks hdln
     _ | isCommentTitle headlineText    -> return mempty
-    _                                  -> headlineToHeader 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
--- as these.  Replace once keyword parsing is supported.
+-- 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
+
+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
-  let header      = B.headerWith attr headlineLevel text
-  childrenBlocks <- mconcat <$> sequence (map headlineToBlocks headlineChildren)
-  return $ header <> headlineContents <> childrenBlocks
+  return $ B.headerWith attr headlineLevel text
 
 propertiesToAttr :: Properties -> Attr
 propertiesToAttr properties =
@@ -629,7 +645,7 @@ exportSetting = choice
   , ignoredSetting ":"
   , ignoredSetting "<"
   , ignoredSetting "\\n"
-  , ignoredSetting "arch"
+  , archivedTreeSetting "arch" setExportArchivedTrees
   , ignoredSetting "author"
   , ignoredSetting "c"
   , ignoredSetting "creator"
@@ -673,6 +689,27 @@ elispBoolean = try $ do
              "()"  -> False
              _     -> True
 
+archivedTreeSetting :: String
+                    -> ExportSettingSetter ArchivedTreesOption
+                    -> OrgParser ()
+archivedTreeSetting settingIdentifier setter = try $ do
+  string settingIdentifier
+  char ':'
+  value <- archivedTreesHeadlineSetting <|> archivedTreesBoolean
+  updateState $ modifyExportSettings setter value
+ 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])

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

@@ -42,6 +42,8 @@ module Text.Pandoc.Readers.Org.ParserState
   , returnF
   , ExportSettingSetter
   , ExportSettings (..)
+  , ArchivedTreesOption (..)
+  , setExportArchivedTrees
   , setExportDrawers
   , setExportEmphasizedText
   , setExportSmartQuotes
@@ -78,10 +80,17 @@ type OrgNoteTable = [OrgNoteRecord]
 -- link-type, the corresponding function transforms the given link string.
 type OrgLinkFormatters = M.Map String (String -> String)
 
+-- | 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
+
 -- | Export settings <http://orgmode.org/manual/Export-settings.html>
 -- These settings can be changed via OPTIONS statements.
 data ExportSettings = ExportSettings
-  { exportDrawers         :: Either [String] [String]
+  { 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.
@@ -159,7 +168,8 @@ defaultOrgParserState = OrgParserState
 
 defaultExportSettings :: ExportSettings
 defaultExportSettings = ExportSettings
-  { exportDrawers = Left ["LOGBOOK"]
+  { exportArchivedTrees = ArchivedTreesHeadlineOnly
+  , exportDrawers = Left ["LOGBOOK"]
   , exportEmphasizedText = True
   , exportSmartQuotes = True
   , exportSpecialStrings = True
@@ -174,8 +184,15 @@ optionsToParserState opts =
 --
 -- Setter for exporting options
 --
+
+-- This whole section could be scraped if we were using lenses.
+
 type ExportSettingSetter a = a -> ExportSettings -> ExportSettings
 
+-- | Set export options for archived trees.
+setExportArchivedTrees :: ExportSettingSetter ArchivedTreesOption
+setExportArchivedTrees val es = es { exportArchivedTrees = val }
+
 -- | Set export options for drawers.  See the @exportDrawers@ in ADT
 -- @ExportSettings@ for details.
 setExportDrawers :: ExportSettingSetter (Either [String] [String])

tests/Tests/Readers/Org.hs

@@ -587,6 +587,30 @@ 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")
       ]
 
   , testGroup "Basic Blocks" $