From ac83b9c37c39a49878e7d864fb276c0e4caed338 Mon Sep 17 00:00:00 2001
From: leungbk <bkleung89@gmail.com>
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