Implement defaults file inheritance

Allow defaults files to inherit options from other defaults files by
specifying them with the following syntax:
'defaults: [list of defaults files]'.

MANUAL.txt

@@ -1509,6 +1509,13 @@ input-files:
 - content.md
 # or you may use input-file: with a single value
 
+# Include options from the specified defaults files.
+# The files will be searched for first in the working directory
+# and then in the defaults subdirectory of the user data directory.
+defaults:
+- defsA
+- defsB
+
 template: letter
 standalone: true
 self-contained: false

src/Text/Pandoc/App/CommandLineOptions.hs

@@ -25,6 +25,7 @@ module Text.Pandoc.App.CommandLineOptions (
 import Control.Monad
 import Control.Monad.Trans
 import Control.Monad.Except (throwError)
+import Control.Monad.State.Strict
 import Data.Aeson.Encode.Pretty (encodePretty', Config(..), keyOrder,
          defConfig, Indent(..), NumberFormat(..))
 import Data.Bifunctor (second)
@@ -46,10 +47,12 @@ import System.FilePath
 import System.IO (stdout)
 import Text.DocTemplates (Context (..), ToContext (toVal), Val (..))
 import Text.Pandoc
-import Text.Pandoc.App.Opt (Opt (..), LineEnding (..), IpynbOutput (..), addMeta)
+import Text.Pandoc.App.Opt (Opt (..), LineEnding (..), IpynbOutput (..),
+                            DefaultsState (..), addMeta, applyDefaults,
+                            fullDefaultsPath)
 import Text.Pandoc.Filter (Filter (..))
 import Text.Pandoc.Highlighting (highlightingStyles)
-import Text.Pandoc.Shared (ordNub, elemText, safeStrRead, defaultUserDataDirs, findM)
+import Text.Pandoc.Shared (ordNub, elemText, safeStrRead, defaultUserDataDirs)
 import Text.Printf
 
 #ifdef EMBED_DATA_FILES
@@ -64,7 +67,6 @@ import qualified Data.ByteString as BS
 import qualified Data.ByteString.Lazy as B
 import qualified Data.Map as M
 import qualified Data.Text as T
-import qualified Data.YAML as Y
 import qualified Text.Pandoc.UTF8 as UTF8
 
 parseOptions :: [OptDescr (Opt -> IO Opt)] -> Opt -> IO Opt
@@ -166,7 +168,11 @@ options =
 
     , Option "d" ["defaults"]
                  (ReqArg
-                  (\arg opt -> applyDefaults opt arg
+                  (\arg opt -> runIOorExplode $ do
+                     let defsState = DefaultsState { curDefaults = Nothing,
+                                                     inheritanceGraph = [] }
+                     fp <- fullDefaultsPath (optDataDir opt) arg
+                     evalStateT (applyDefaults opt fp) defsState
                   )
                   "FILE")
                 ""
@@ -1012,28 +1018,6 @@ writersNames = sort
 splitField :: String -> (String, String)
 splitField = second (tailDef "true") . break (`elemText` ":=")
 
--- | Apply defaults from --defaults file.
-applyDefaults :: Opt -> FilePath -> IO Opt
-applyDefaults opt file = runIOorExplode $ do
-  let fp = if null (takeExtension file)
-              then addExtension file "yaml"
-              else file
-  setVerbosity $ optVerbosity opt
-  dataDirs <- liftIO defaultUserDataDirs
-  let fps = fp : case optDataDir opt of
-              Nothing -> map (</> ("defaults" </> fp))
-                               dataDirs
-              Just dd -> [dd </> "defaults" </> fp]
-  fp' <- fromMaybe fp <$> findM fileExists fps
-  inp <- readFileLazy fp'
-  case Y.decode1 inp of
-      Right (f :: Opt -> Opt) -> return $ f opt
-      Left (errpos, errmsg)  -> throwError $
-         PandocParseError $ T.pack $
-         "Error parsing " ++ fp' ++ " line " ++
-          show (Y.posLine errpos) ++ " column " ++
-          show (Y.posColumn errpos) ++ ":\n" ++ errmsg
-
 lookupHighlightStyle :: PandocMonad m => String -> m Style
 lookupHighlightStyle s
   | takeExtension s == ".theme" = -- attempt to load KDE theme

src/Text/Pandoc/App/Opt.hs

@@ -20,10 +20,18 @@ module Text.Pandoc.App.Opt (
             Opt(..)
           , LineEnding (..)
           , IpynbOutput (..)
+          , DefaultsState (..)
           , defaultOpts
           , addMeta
+          , applyDefaults
+          , fullDefaultsPath
           ) where
+import Control.Monad.Except (MonadIO, liftIO, throwError, (>=>), foldM)
+import Control.Monad.State.Strict (StateT, modify, gets)
+import System.FilePath ( addExtension, (</>), takeExtension )
 import Data.Char (isLower, toLower)
+import Data.List (find)
+import Data.Maybe (fromMaybe)
 import GHC.Generics hiding (Meta)
 import Text.Pandoc.Builder (setMeta)
 import Text.Pandoc.Filter (Filter (..))
@@ -34,7 +42,9 @@ import Text.Pandoc.Options (TopLevelDivision (TopLevelDefault),
                             ReferenceLocation (EndOfDocument),
                             ObfuscationMethod (NoObfuscation),
                             CiteMethod (Citeproc))
-import Text.Pandoc.Shared (camelCaseStrToHyphenated)
+import Text.Pandoc.Class (readFileLazy, fileExists, setVerbosity, PandocMonad)
+import Text.Pandoc.Error (PandocError (PandocParseError, PandocSomeError))
+import Text.Pandoc.Shared (camelCaseStrToHyphenated, defaultUserDataDirs, findM, ordNub)
 import qualified Text.Pandoc.Parsing as P
 import Text.Pandoc.Readers.Metadata (yamlMap)
 import Text.Pandoc.Class.PandocPure
@@ -149,11 +159,61 @@ data Opt = Opt
     , optStripComments         :: Bool       -- ^ Skip HTML comments
     } deriving (Generic, Show)
 
-instance FromYAML (Opt -> Opt) where
-  parseYAML (Mapping _ _ m) =
-    foldr (.) id <$> mapM doOpt (M.toList m)
+data DefaultsState = DefaultsState
+    {
+      curDefaults      :: Maybe FilePath -- currently parsed file
+    , inheritanceGraph :: [[FilePath]]   -- defaults file inheritance graph
+    } deriving (Show)
+
+instance (PandocMonad m, MonadIO m)
+      => FromYAML (Opt -> StateT DefaultsState m Opt) where
+  parseYAML (Mapping _ _ m) = do
+    let opts = M.toList m
+    dataDir <- case find (byKey "data-dir") opts of
+      Nothing -> return Nothing
+      Just (_, v) -> Just . unpack <$> parseYAML v
+    case find (byKey "defaults") opts of
+      Just (_, v) -> do
+        f <- parseDefaults v dataDir
+        g <- parseOptions opts
+        return  $ f >=> g
+      Nothing -> parseOptions opts
   parseYAML n = failAtNode n "Expected a mapping"
 
+byKey :: Text -> (Node Pos, Node Pos) -> Bool
+byKey s (Scalar _ (SStr s'), _) = s == s'
+byKey _ _ = False
+
+parseDefaults :: (PandocMonad m, MonadIO m)
+              => Node Pos
+              -> Maybe FilePath
+              -> Parser (Opt -> StateT DefaultsState m Opt)
+parseDefaults ns dataDir = parseYAML ns >>= \x -> return $ \o -> do
+  -- get parent defaults:
+  curDefsPath <- gets $ fromMaybe "" . curDefaults
+  let defsParent = curDefsPath
+  -- get child defaults:
+  let defsPaths = map unpack x
+  defsChildren <- mapM (fullDefaultsPath dataDir) defsPaths
+  -- expand parent in defaults inheritance graph by children:
+  defsGraph <- gets inheritanceGraph
+  let defsGraphExp = expand defsGraph defsChildren defsParent
+  modify $ \defsState -> defsState{ inheritanceGraph = defsGraphExp }
+  -- check for cyclic inheritance:
+  if cyclic defsGraphExp
+    then throwError $
+      PandocSomeError $ T.pack $
+        "Error: Circular defaults file reference in " ++
+        "'" ++ defsParent ++ "'"
+    else foldM applyDefaults o defsChildren
+
+parseOptions :: Monad m
+             => [(Node Pos, Node Pos)]
+             -> Parser (Opt -> StateT DefaultsState m Opt)
+parseOptions m = do
+  f <- foldr (.) id <$> mapM doOpt m
+  return $ \o -> return $ f o
+
 doOpt :: (Node Pos, Node Pos) -> Parser (Opt -> Opt)
 doOpt (k',v) = do
   k <- case k' of
@@ -417,6 +477,8 @@ doOpt (k',v) = do
       parseYAML v >>= \x -> return (\o -> o{ optEol = x })
     "strip-comments" ->
       parseYAML v >>= \x -> return (\o -> o  { optStripComments = x })
+    -- skip, because this is handled separately beforehand
+    "defaults" -> return id
     _ -> failAtNode k' $ "Unknown option " ++ show k
 
 -- | Defaults for command-line options.
@@ -524,6 +586,52 @@ readMetaValue s
   | s == "FALSE" = MetaBool False
   | otherwise    = MetaString $ T.pack s
 
+-- | Apply defaults from --defaults file.
+applyDefaults :: (PandocMonad m, MonadIO m)
+              => Opt
+              -> FilePath
+              -> StateT DefaultsState m Opt
+applyDefaults opt file = do
+  setVerbosity $ optVerbosity opt
+  modify $ \defsState -> defsState{ curDefaults = Just file }
+  inp <- readFileLazy file
+  case decode1 inp of
+      Right f -> f opt
+      Left (errpos, errmsg)  -> throwError $
+         PandocParseError $ T.pack $
+         "Error parsing " ++ file ++ " line " ++
+          show (posLine errpos) ++ " column " ++
+          show (posColumn errpos) ++ ":\n" ++ errmsg
+
+fullDefaultsPath :: (PandocMonad m, MonadIO m)
+                 => Maybe FilePath
+                 -> FilePath
+                 -> m FilePath
+fullDefaultsPath dataDir file = do
+  let fp = if null (takeExtension file)
+              then addExtension file "yaml"
+              else file
+  dataDirs <- liftIO defaultUserDataDirs
+  let fps = fp : case dataDir of
+                   Nothing -> map (</> ("defaults" </> fp))
+                                    dataDirs
+                   Just dd -> [dd </> "defaults" </> fp]
+  fromMaybe fp <$> findM fileExists fps
+
+-- | In a list of lists, append another list in front of every list which
+-- starts with specific element.
+expand :: Ord a => [[a]] -> [a] -> a -> [[a]]
+expand [] ns n = fmap (\x -> x : [n]) ns
+expand ps ns n = concatMap (ext n ns) ps
+  where
+    ext x xs p = case p of
+      (l : _) | x == l -> fmap (: p) xs
+      _ -> [p]
+
+cyclic :: Ord a => [[a]] -> Bool
+cyclic = any hasDuplicate
+  where
+    hasDuplicate xs = length (ordNub xs) /= length xs
 
 -- see https://github.com/jgm/pandoc/pull/4083
 -- using generic deriving caused long compilation times

test/command/defaults-inheritance-1.md

@@ -0,0 +1,6 @@
+```
+% pandoc -d command/defaults3
+# Header
+^D
+# Header
+```

test/command/defaults-inheritance-2.md

@@ -0,0 +1,5 @@
+```
+% pandoc -d command/defaults6
+^D
+Error: Circular defaults file reference in 'command/defaults7.yaml'
+```

test/command/defaults3.yaml

@@ -0,0 +1,4 @@
+defaults:
+  - command/defaults4
+  - command/defaults5
+to: markdown

test/command/defaults4.yaml

@@ -0,0 +1,3 @@
+from: html
+defaults:
+  - command/defaults5

test/command/defaults5.yaml

@@ -0,0 +1,2 @@
+from: markdown
+to: html

test/command/defaults6.yaml

@@ -0,0 +1,2 @@
+defaults:
+  - command/defaults7

test/command/defaults7.yaml

@@ -0,0 +1,2 @@
+defaults:
+  - command/defaults6