Org reader: add support for #+SELECT_TAGS.

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