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

pandoc.cabal

@@ -606,6 +606,7 @@ test-suite test-pandoc
                   pandoc-types >= 1.17.3 && < 1.18,
                   bytestring >= 0.9 && < 0.11,
                   text >= 0.11 && < 1.3,
+                  time >= 1.5 && < 1.9,
                   directory >= 1 && < 1.4,
                   filepath >= 1.1 && < 1.5,
                   hslua >= 0.9 && < 0.10,

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

test/Tests/Readers/Org/Directive.hs

@@ -1,13 +1,42 @@
 {-# LANGUAGE OverloadedStrings #-}
 module Tests.Readers.Org.Directive (tests) where
 
+import Control.Arrow (second)
+import Data.Time (UTCTime (UTCTime), secondsToDiffTime)
+import Data.Time.Calendar (Day (ModifiedJulianDay))
 import Test.Tasty (TestTree, testGroup)
-import Tests.Helpers ((=?>))
+import Tests.Helpers ((=?>), ToString, purely, test)
 import Tests.Readers.Org.Shared ((=:), tagSpan)
 import Text.Pandoc
 import Text.Pandoc.Builder
+import qualified Data.ByteString as BS
+import qualified Data.Map as Map
 import qualified Data.Text as T
 
+testWithFiles :: (ToString c)
+              => [(FilePath, BS.ByteString)]
+              -> String         -- ^ name of test case
+              -> (T.Text, c)    -- ^ (input, expected value)
+              -> TestTree
+testWithFiles fileDefs = test (orgWithFiles fileDefs)
+  where
+orgWithFiles :: [(FilePath, BS.ByteString)] -> T.Text -> Pandoc
+orgWithFiles fileDefs input =
+  let readOrg' = readOrg def{ readerExtensions = getDefaultExtensions "org" }
+  in flip purely input $ \inp -> do
+    modifyPureState (\st -> st { stFiles = files fileDefs })
+    readOrg' inp
+
+
+files :: [(FilePath, BS.ByteString)] -> FileTree
+files fileDefs =
+  let dummyTime = UTCTime (ModifiedJulianDay 125) (secondsToDiffTime 0)
+      fileInfo content = FileInfo
+                         { infoFileMTime = dummyTime
+                         , infoFileContents = content
+                         }
+  in FileTree (Map.fromList (map (second fileInfo) fileDefs))
+
 tests :: [TestTree]
 tests =
   [ testGroup "export options"
@@ -125,4 +154,51 @@ tests =
                   ] =?>
         headerWith ("headline", [], mempty) 1 "Headline"
     ]
+
+  , testGroup "Include"
+    [ testWithFiles [("./other.org", "content of other file\n")]
+      "file inclusion"
+      (T.unlines [ "#+include: \"other.org\"" ] =?>
+       plain "content of other file")
+
+    , testWithFiles [("./world.org", "World\n\n")]
+      "Included file belongs to item"
+      (T.unlines [ "- Hello,\n  #+include: \"world.org\"" ] =?>
+       bulletList [para "Hello," <> para "World"])
+
+    , testWithFiles [("./level3.org", "*** Level3\n\n")]
+      "Default include preserves level"
+      (T.unlines [ "#+include: \"level3.org\"" ] =?>
+       headerWith ("level3", [], []) 3 "Level3")
+
+    , testWithFiles [("./level3.org", "*** Level3\n\n")]
+      "Minlevel shifts level"
+      (T.unlines [ "#+include: \"level3.org\" :minlevel 1" ] =?>
+       headerWith ("level3", [], []) 1 "Level3")
+
+    , testWithFiles [("./src.hs", "putStrLn outString\n")]
+      "Include file as source code snippet"
+      (T.unlines [ "#+include: \"src.hs\" src haskell" ] =?>
+       codeBlockWith ("", ["haskell"], []) "putStrLn outString\n")
+
+    , testWithFiles [("./export-latex.org", "\\emph{Hello}\n")]
+      "Include file as export snippet"
+      (T.unlines [ "#+include: \"export-latex.org\" export latex" ] =?>
+       rawBlock "latex" "\\emph{Hello}\n")
+
+    , testWithFiles [("./subdir/foo-bar.latex", "foo\n"),
+                     ("./hello.lisp", "(print \"Hello!\")\n")
+                    ]
+      "include directive is limited to one line"
+      (T.unlines [ "#+INCLUDE: \"hello.lisp\" src lisp"
+                 , "#+include: \"subdir/foo-bar.latex\" export latex"
+                 , "bar"
+                 ] =?>
+       mconcat
+         [ codeBlockWith ("", ["lisp"], []) "(print \"Hello!\")\n"
+         , rawBlock "latex" "foo\n"
+         , para "bar"
+         ]
+      )
+    ]
   ]