Org reader: add support for #+SELECT_TAGS.

4 files changed, 78 insertions, 23 deletions

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