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: [PATCH] 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 | 1 +
src/Text/Pandoc/Readers/Org/Blocks.hs | 51 +++++++++++++-----
test/Tests/Readers/Org/Directive.hs | 78 ++++++++++++++++++++++++++-
3 files changed, 115 insertions(+), 15 deletions(-)
diff --git a/pandoc.cabal b/pandoc.cabal
index aa2e52e48..efe734093 100644
--- a/pandoc.cabal
+++ b/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,
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
diff --git a/test/Tests/Readers/Org/Directive.hs b/test/Tests/Readers/Org/Directive.hs
index 29ffaa20c..1970a0471 100644
--- a/test/Tests/Readers/Org/Directive.hs
+++ b/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"
+ ]
+ )
+ ]
]