summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--src/Text/Pandoc/Readers/Org/Blocks.hs49
-rw-r--r--src/Text/Pandoc/Readers/Org/ParserState.hs21
-rw-r--r--tests/Tests/Readers/Org.hs24
3 files changed, 86 insertions, 8 deletions
diff --git a/src/Text/Pandoc/Readers/Org/Blocks.hs b/src/Text/Pandoc/Readers/Org/Blocks.hs
index c9e9d2ced..5d4a0cae2 100644
--- a/src/Text/Pandoc/Readers/Org/Blocks.hs
+++ b/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])
diff --git a/src/Text/Pandoc/Readers/Org/ParserState.hs b/src/Text/Pandoc/Readers/Org/ParserState.hs
index 0c58183f9..93be92ae8 100644
--- a/src/Text/Pandoc/Readers/Org/ParserState.hs
+++ b/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])
diff --git a/tests/Tests/Readers/Org.hs b/tests/Tests/Readers/Org.hs
index 7612d88f1..f57858a55 100644
--- a/tests/Tests/Readers/Org.hs
+++ b/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" $