aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--pandoc.cabal1
-rw-r--r--src/Text/Pandoc/Readers/Org/Blocks.hs9
-rw-r--r--src/Text/Pandoc/Readers/Org/DocumentTree.hs56
-rw-r--r--src/Text/Pandoc/Readers/Org/Meta.hs24
-rw-r--r--src/Text/Pandoc/Readers/Org/ParserState.hs12
-rw-r--r--test/Tests/Old.hs4
-rw-r--r--test/org-select-tags.native7
-rw-r--r--test/org-select-tags.org17
8 files changed, 107 insertions, 23 deletions
diff --git a/pandoc.cabal b/pandoc.cabal
index f8852c0f5..56d4065ec 100644
--- a/pandoc.cabal
+++ b/pandoc.cabal
@@ -208,6 +208,7 @@ extra-source-files:
test/docbook-xref.docbook
test/html-reader.html
test/opml-reader.opml
+ test/org-select-tags.org
test/haddock-reader.haddock
test/insert
test/lalune.jpg
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
diff --git a/test/Tests/Old.hs b/test/Tests/Old.hs
index 842e0f656..4a1fbcbf7 100644
--- a/test/Tests/Old.hs
+++ b/test/Tests/Old.hs
@@ -175,6 +175,10 @@ tests = [ testGroup "markdown"
[ test "reader" ["-r", "man", "-w", "native", "-s"]
"man-reader.man" "man-reader.native"
]
+ , testGroup "org"
+ [ test "reader" ["-r", "org", "-w", "native", "-s"]
+ "org-select-tags.org" "org-select-tags.native"
+ ]
]
-- makes sure file is fully closed after reading
diff --git a/test/org-select-tags.native b/test/org-select-tags.native
new file mode 100644
index 000000000..5fbfd92d1
--- /dev/null
+++ b/test/org-select-tags.native
@@ -0,0 +1,7 @@
+Pandoc (Meta {unMeta = fromList []})
+[Header 1 ("will-appear-because-it-is-the-ancestor-of-something-tagged-yes",[],[]) [Str "Will",Space,Str "appear",Space,Str "because",Space,Str "it",Space,Str "is",Space,Str "the",Space,Str "ancestor",Space,Str "of",Space,Str "something",Space,Str "tagged",Space,Str "\"yes\""]
+,Header 2 ("will-appear",[],[]) [Str "Will",Space,Str "appear",Space,Span ("",["tag"],[("tag-name","yes")]) [SmallCaps [Str "yes"]]]
+,Header 3 ("will-appear-since-the-entire-subtree-of-something-selected-will-appear",[],[]) [Str "Will",Space,Str "appear",Space,Str "since",Space,Str "the",Space,Str "entire",Space,Str "subtree",Space,Str "of",Space,Str "something",Space,Str "selected",Space,Str "will",Space,Str "appear"]
+,OrderedList (1,DefaultStyle,DefaultDelim)
+ [[Para [Str "Will",Space,Str "appear"]]]
+,Header 2 ("will-appear-because-it-is-the-ancestor-of-something-listed-in-select-tags",[],[]) [Str "Will",Space,Str "appear",Space,Str "because",Space,Str "it",Space,Str "is",Space,Str "the",Space,Str "ancestor",Space,Str "of",Space,Str "something",Space,Str "listed",Space,Str "in",Space,Str "SELECT-TAGS"]]
diff --git a/test/org-select-tags.org b/test/org-select-tags.org
new file mode 100644
index 000000000..8f0ebfdbd
--- /dev/null
+++ b/test/org-select-tags.org
@@ -0,0 +1,17 @@
+#+SELECT_TAGS: yes no
+#+EXCLUDE_TAGS: no
+
+In a document containing one or more trees containing a tag
+listed in SELECT_TAGS, only those trees and their ancestor nodes will appear;
+this text and any other text preceding the first headline
+won't appear for such documents.
+
+* Will appear because it is the ancestor of something tagged "yes"
+** Will appear :yes:
+*** Will appear since the entire subtree of something selected will appear
+**** Will appear
+*** Will not appear since this has tagged with something in EXCLUDE-TAGS :no:
+** Will not appear since it's not an ancestor of listed in SELECT-TAGS
+** Will appear because it is the ancestor of something listed in SELECT-TAGS
+*** Will not appear because it has an EXCLUDE-TAG, but since "no" is also listed as a SELECT-TAG, it will force its parent to appear :no:
+* Will not appear
generated by cgit v1.2.3 (git 2.39.1) at 2024-06-20 15:03:40 +0000