diff options
| -rw-r--r-- | src/Text/Pandoc/Readers/Org/Blocks.hs | 49 | ||||
| -rw-r--r-- | src/Text/Pandoc/Readers/Org/ParserState.hs | 21 | ||||
| -rw-r--r-- | tests/Tests/Readers/Org.hs | 24 |
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" $ |