From e5c8b650041a270b58e2f72e18eb28a32f153954 Mon Sep 17 00:00:00 2001
From: Albert Krewinkel <albert@zeitkraut.de>
Date: Mon, 25 Dec 2017 23:31:05 +0100
Subject: Org reader: support minlevel option for includes

The level of headers in included files can be shifted to a higher level
by specifying a minimum header level via the `:minlevel` parameter. E.g.
`#+include: "tour.org" :minlevel 1` will shift the headers in tour.org
such that the topmost headers become level 1 headers.

Fixes: #4154
---
 src/Text/Pandoc/Readers/Org/Blocks.hs | 51 +++++++++++++++++++++++++----------
 1 file changed, 37 insertions(+), 14 deletions(-)

(limited to 'src')

diff --git a/src/Text/Pandoc/Readers/Org/Blocks.hs b/src/Text/Pandoc/Readers/Org/Blocks.hs
index cc6abbfa5..a930652af 100644
--- a/src/Text/Pandoc/Readers/Org/Blocks.hs
+++ b/src/Text/Pandoc/Readers/Org/Blocks.hs
@@ -41,7 +41,6 @@ import Text.Pandoc.Readers.Org.Shared (cleanLinkString, isImageFilename,
                                        originalLang, translateLang)
 
 import Text.Pandoc.Builder (Blocks, Inlines)
-import qualified Text.Pandoc.Builder as B
 import Text.Pandoc.Class (PandocMonad)
 import Text.Pandoc.Definition
 import Text.Pandoc.Options
@@ -54,6 +53,9 @@ import Data.List (foldl', isPrefixOf)
 import Data.Maybe (fromMaybe, isJust, isNothing)
 import Data.Monoid ((<>))
 
+import qualified Text.Pandoc.Builder as B
+import qualified Text.Pandoc.Walk as Walk
+
 --
 -- parsing blocks
 --
@@ -509,19 +511,18 @@ include :: PandocMonad m => OrgParser m (F Blocks)
 include = try $ do
   metaLineStart <* stringAnyCase "include:" <* skipSpaces
   filename <- includeTarget
-  blockType <- optionMaybe $ skipSpaces *> many1 alphaNum
-  blocksParser <- case blockType of
-                    Just "example" ->
-                      return $ pure . B.codeBlock <$> parseRaw
-                    Just "export" -> do
-                      format <- skipSpaces *> many (noneOf "\n\r\t ")
-                      return $ pure . B.rawBlock format <$> parseRaw
-                    Just "src" -> do
-                      language <- skipSpaces *> many (noneOf "\n\r\t ")
-                      let attr = (mempty, [language], mempty)
-                      return $ pure . B.codeBlockWith attr <$> parseRaw
-                    _ -> return $ pure . B.fromList <$> blockList
-  anyLine
+  includeArgs <- many (try $ skipSpaces *> many1 alphaNum)
+  params <- keyValues
+  blocksParser <- case includeArgs of
+      ("example" : _) -> return $ pure . B.codeBlock <$> parseRaw
+      ["export"] -> return . returnF $ B.fromList []
+      ("export" : format : []) -> return $ pure . B.rawBlock format <$> parseRaw
+      ("src" : rest) -> do
+        let attr = case rest of
+                     [lang] -> (mempty, [lang], mempty)
+                     _ -> nullAttr
+        return $ pure . B.codeBlockWith attr <$> parseRaw
+      _ -> return $ return . B.fromList . blockFilter params <$> blockList
   insertIncludedFileF blocksParser ["."] filename
  where
   includeTarget :: PandocMonad m => OrgParser m FilePath
@@ -532,6 +533,28 @@ include = try $ do
   parseRaw :: PandocMonad m => OrgParser m String
   parseRaw = many anyChar
 
+  blockFilter :: [(String, String)] -> [Block] -> [Block]
+  blockFilter params blks =
+    let minlvl = lookup "minlevel" params
+    in case (minlvl >>= safeRead :: Maybe Int) of
+         Nothing -> blks
+         Just lvl -> let levels = Walk.query headerLevel blks
+                         -- CAVE: partial function in else
+                         curMin = if null levels then 0 else minimum levels
+                     in Walk.walk (shiftHeader (curMin - lvl)) blks
+
+  headerLevel :: Block -> [Int]
+  headerLevel (Header lvl _attr _content) = [lvl]
+  headerLevel _ = []
+
+  shiftHeader :: Int -> Block -> Block
+  shiftHeader shift blk =
+    if shift <= 0
+    then blk
+    else case blk of
+      (Header lvl attr content) -> Header (lvl - shift) attr content
+      _ -> blk
+
 rawExportLine :: PandocMonad m => OrgParser m Blocks
 rawExportLine = try $ do
   metaLineStart
-- 
cgit v1.2.3