From ac83b9c37c39a49878e7d864fb276c0e4caed338 Mon Sep 17 00:00:00 2001 From: leungbk Date: Sun, 27 Jan 2019 22:22:44 +0100 Subject: Org reader: add support for #+SELECT_TAGS. --- src/Text/Pandoc/Readers/Org/Blocks.hs | 9 +++-- src/Text/Pandoc/Readers/Org/DocumentTree.hs | 56 +++++++++++++++++++++++++---- src/Text/Pandoc/Readers/Org/Meta.hs | 24 ++++++++----- src/Text/Pandoc/Readers/Org/ParserState.hs | 12 ++++--- 4 files changed, 78 insertions(+), 23 deletions(-) (limited to 'src/Text/Pandoc/Readers/Org') diff --git a/src/Text/Pandoc/Readers/Org/Blocks.hs b/src/Text/Pandoc/Readers/Org/Blocks.hs index d6930398c..e991d8132 100644 --- a/src/Text/Pandoc/Readers/Org/Blocks.hs +++ b/src/Text/Pandoc/Readers/Org/Blocks.hs @@ -34,7 +34,8 @@ module Text.Pandoc.Readers.Org.Blocks import Prelude import Text.Pandoc.Readers.Org.BlockStarts -import Text.Pandoc.Readers.Org.DocumentTree (documentTree, headlineToBlocks, filterHeadlineTree) +import Text.Pandoc.Readers.Org.DocumentTree (documentTree, + unprunedHeadlineToBlocks) import Text.Pandoc.Readers.Org.Inlines import Text.Pandoc.Readers.Org.Meta (metaExport, metaKey, metaLine) import Text.Pandoc.Readers.Org.ParserState @@ -64,12 +65,10 @@ import qualified Text.Pandoc.Walk as Walk -- | Get a list of blocks. blockList :: PandocMonad m => OrgParser m [Block] blockList = do - fHeadlineTree <- documentTree blocks inline + fHeadlineTree <- documentTree blocks inline st <- getState let headlineTree = runF fHeadlineTree st - headlineBlocks <- headlineToBlocks $ filterHeadlineTree headlineTree st - -- ignore first headline, it's the document's title - return . drop 1 . B.toList $ headlineBlocks + unprunedHeadlineToBlocks headlineTree st -- | Get the meta information saved in the state. meta :: Monad m => OrgParser m Meta diff --git a/src/Text/Pandoc/Readers/Org/DocumentTree.hs b/src/Text/Pandoc/Readers/Org/DocumentTree.hs index 131408289..4c2355d28 100644 --- a/src/Text/Pandoc/Readers/Org/DocumentTree.hs +++ b/src/Text/Pandoc/Readers/Org/DocumentTree.hs @@ -28,8 +28,7 @@ Parsers for org-mode headlines and document subtrees -} module Text.Pandoc.Readers.Org.DocumentTree ( documentTree - , headlineToBlocks - , filterHeadlineTree + , unprunedHeadlineToBlocks ) where import Prelude @@ -37,6 +36,7 @@ import Control.Arrow ((***)) import Control.Monad (guard, void) import Data.Char (toLower, toUpper) import Data.List (intersperse) +import Data.Maybe (mapMaybe) import Text.Pandoc.Builder (Blocks, Inlines) import Text.Pandoc.Class (PandocMonad) import Text.Pandoc.Definition @@ -155,6 +155,22 @@ headline blocks inline lvl = try $ do let tag = orgTagWord <* char ':' in map toTag <$> (skipSpaces *> char ':' *> many1 tag <* skipSpaces) +unprunedHeadlineToBlocks :: Monad m => Headline -> OrgParserState -> OrgParser m [Block] +unprunedHeadlineToBlocks hdln st = + let usingSelectedTags = docContainsSelectTags hdln st + rootNode = if not usingSelectedTags + then hdln + else includeRootAndSelected hdln st + rootNode' = removeExplicitlyExcludedNodes rootNode st + in if not usingSelectedTags || + any (`Set.member` orgStateSelectTags st) (headlineTags rootNode') + then do headlineBlocks <- headlineToBlocks rootNode' + -- ignore first headline, it's the document's title + return . drop 1 . B.toList $ headlineBlocks + else do headlineBlocks <- mconcat <$> mapM headlineToBlocks + (headlineChildren rootNode') + return . B.toList $ headlineBlocks + -- | Convert an Org mode headline (i.e. a document tree) into pandoc's Blocks headlineToBlocks :: Monad m => Headline -> OrgParser m Blocks headlineToBlocks hdln = do @@ -168,12 +184,40 @@ headlineToBlocks hdln = do _ | maxLevel <= level -> headlineToHeaderWithList hdln _ | otherwise -> headlineToHeaderWithContents hdln -filterHeadlineTree :: Headline -> OrgParserState -> Headline -filterHeadlineTree hdln st = +removeExplicitlyExcludedNodes :: Headline -> OrgParserState -> Headline +removeExplicitlyExcludedNodes hdln st = hdln { headlineChildren = - [filterHeadlineTree childHdln st | + [removeExplicitlyExcludedNodes childHdln st | childHdln <- headlineChildren hdln, - not $ any (`Set.member` orgStateExcludedTags st) (headlineTags childHdln)] } + not $ headlineContainsExcludeTags childHdln st] } + +includeRootAndSelected :: Headline -> OrgParserState -> Headline +includeRootAndSelected hdln st = + hdln { headlineChildren = mapMaybe (`includeAncestorsAndSelected` st) + (headlineChildren hdln)} + +docContainsSelectTags :: Headline -> OrgParserState -> Bool +docContainsSelectTags hdln st = + headlineContainsSelectTags hdln st || + any (`docContainsSelectTags` st) (headlineChildren hdln) + +includeAncestorsAndSelected :: Headline -> OrgParserState -> Maybe Headline +includeAncestorsAndSelected hdln st = + if headlineContainsSelectTags hdln st + then Just hdln + else let children = mapMaybe (`includeAncestorsAndSelected` st) + (headlineChildren hdln) + in case children of + [] -> Nothing + _ -> Just $ hdln { headlineChildren = children } + +headlineContainsSelectTags :: Headline -> OrgParserState -> Bool +headlineContainsSelectTags hdln st = + any (`Set.member` orgStateSelectTags st) (headlineTags hdln) + +headlineContainsExcludeTags :: Headline -> OrgParserState -> Bool +headlineContainsExcludeTags hdln st = + any (`Set.member` orgStateExcludeTags st) (headlineTags hdln) isArchiveTag :: Tag -> Bool isArchiveTag = (== toTag "ARCHIVE") diff --git a/src/Text/Pandoc/Readers/Org/Meta.hs b/src/Text/Pandoc/Readers/Org/Meta.hs index fc733a777..c0f95c4f6 100644 --- a/src/Text/Pandoc/Readers/Org/Meta.hs +++ b/src/Text/Pandoc/Readers/Org/Meta.hs @@ -159,7 +159,8 @@ optionLine = try $ do "seq_todo" -> todoSequence >>= updateState . registerTodoSequence "typ_todo" -> todoSequence >>= updateState . registerTodoSequence "macro" -> macroDefinition >>= updateState . registerMacro - "exclude_tags" -> excludedTagList >>= updateState . setExcludedTags + "exclude_tags" -> tagList >>= updateState . setExcludedTags + "select_tags" -> tagList >>= updateState . setSelectedTags "pandoc-emphasis-pre" -> emphChars >>= updateState . setEmphasisPreChar "pandoc-emphasis-post" -> emphChars >>= updateState . setEmphasisPostChar _ -> mzero @@ -192,17 +193,24 @@ parseFormat = try $ replacePlain <|> replaceUrl <|> justAppend rest = manyTill anyChar (eof <|> () <$ oneOf "\n\r") tillSpecifier c = manyTill (noneOf "\n\r") (try $ string ('%':c:"")) -excludedTagList :: Monad m => OrgParser m [Tag] -excludedTagList = do +tagList :: Monad m => OrgParser m [Tag] +tagList = do skipSpaces map Tag <$> many (orgTagWord <* skipSpaces) <* newline setExcludedTags :: [Tag] -> OrgParserState -> OrgParserState -setExcludedTags tagList st = - let finalSet = if orgStateExcludedTagsChanged st - then foldr Set.insert (orgStateExcludedTags st) tagList - else Set.fromList tagList - in st { orgStateExcludedTags = finalSet, orgStateExcludedTagsChanged = True } +setExcludedTags tags st = + let finalSet = if orgStateExcludeTagsChanged st + then foldr Set.insert (orgStateExcludeTags st) tags + else Set.fromList tags + in st { orgStateExcludeTags = finalSet, orgStateExcludeTagsChanged = True } + +setSelectedTags :: [Tag] -> OrgParserState -> OrgParserState +setSelectedTags tags st = + let finalSet = if orgStateSelectTagsChanged st + then foldr Set.insert (orgStateSelectTags st) tags + else Set.fromList tags + in st { orgStateSelectTags = finalSet, orgStateSelectTagsChanged = True } setEmphasisPreChar :: Maybe [Char] -> OrgParserState -> OrgParserState setEmphasisPreChar csMb st = diff --git a/src/Text/Pandoc/Readers/Org/ParserState.hs b/src/Text/Pandoc/Readers/Org/ParserState.hs index d57b848da..6143e8cc4 100644 --- a/src/Text/Pandoc/Readers/Org/ParserState.hs +++ b/src/Text/Pandoc/Readers/Org/ParserState.hs @@ -117,8 +117,8 @@ data OrgParserState = OrgParserState -- specified here. , orgStateEmphasisPostChars :: [Char] -- ^ Chars allowed at after emphasis , orgStateEmphasisNewlines :: Maybe Int - , orgStateExcludedTags :: Set.Set Tag - , orgStateExcludedTagsChanged :: Bool + , orgStateExcludeTags :: Set.Set Tag + , orgStateExcludeTagsChanged :: Bool , orgStateExportSettings :: ExportSettings , orgStateIdentifiers :: Set.Set String , orgStateIncludeFiles :: [String] @@ -132,6 +132,8 @@ data OrgParserState = OrgParserState , orgStateNotes' :: OrgNoteTable , orgStateOptions :: ReaderOptions , orgStateParserContext :: ParserContext + , orgStateSelectTags :: Set.Set Tag + , orgStateSelectTagsChanged :: Bool , orgStateTodoSequences :: [TodoSequence] , orgLogMessages :: [LogMessage] , orgMacros :: M.Map Text Macro @@ -184,8 +186,8 @@ defaultOrgParserState = OrgParserState , orgStateEmphasisCharStack = [] , orgStateEmphasisNewlines = Nothing , orgStateExportSettings = def - , orgStateExcludedTags = Set.singleton $ Tag "noexport" - , orgStateExcludedTagsChanged = False + , orgStateExcludeTags = Set.singleton $ Tag "noexport" + , orgStateExcludeTagsChanged = False , orgStateIdentifiers = Set.empty , orgStateIncludeFiles = [] , orgStateLastForbiddenCharPos = Nothing @@ -198,6 +200,8 @@ defaultOrgParserState = OrgParserState , orgStateNotes' = [] , orgStateOptions = def , orgStateParserContext = NullState + , orgStateSelectTags = Set.singleton $ Tag "export" + , orgStateSelectTagsChanged = False , orgStateTodoSequences = [] , orgLogMessages = [] , orgMacros = M.empty -- cgit v1.2.3