Implement defaults file inheritance (#6924)

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

2 files changed, 139 insertions, 33 deletions

diff --git a/src/Text/Pandoc/App/CommandLineOptions.hs b/src/Text/Pandoc/App/CommandLineOptions.hs
index 906fcc4c0..21ee47b7b 100644
--- a/src/Text/Pandoc/App/CommandLineOptions.hs
+++ b/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
diff --git a/src/Text/Pandoc/App/Opt.hs b/src/Text/Pandoc/App/Opt.hs
index 00b4b5523..6dd19758e 100644
--- a/src/Text/Pandoc/App/Opt.hs
+++ b/src/Text/Pandoc/App/Opt.hs
@@ -20,10 +20,17 @@ 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.Maybe (fromMaybe)
 import GHC.Generics hiding (Meta)
 import Text.Pandoc.Builder (setMeta)
 import Text.Pandoc.Filter (Filter (..))
@@ -34,7 +41,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
@@ -150,16 +159,77 @@ data Opt = Opt
     } deriving (Generic, Show)
 
 instance FromYAML (Opt -> Opt) where
-  parseYAML (Mapping _ _ m) =
-    foldr (.) id <$> mapM doOpt (M.toList m)
+  parseYAML (Mapping _ _ m) = chain doOpt (M.toList m)
   parseYAML n = failAtNode n "Expected a mapping"
 
+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.mapKeys toText m
+    dataDir <- case M.lookup "data-dir" opts of
+      Nothing -> return Nothing
+      Just v -> Just . unpack <$> parseYAML v
+    f <- parseOptions $ M.toList m
+    case M.lookup "defaults" opts of
+      Just v -> do
+        g <- parseDefaults v dataDir
+        return  $ g >=> f
+      Nothing -> return f
+    where
+      toText (Scalar _ (SStr s)) = s
+      toText _ = ""
+  parseYAML n = failAtNode n "Expected a mapping"
+
+parseDefaults :: (PandocMonad m, MonadIO m)
+              => Node Pos
+              -> Maybe FilePath
+              -> Parser (Opt -> StateT DefaultsState m Opt)
+parseDefaults n dataDir = parseDefsNames n >>= \ds -> return $ \o -> do
+  -- get parent defaults:
+  defsParent <- gets $ fromMaybe "" . curDefaults
+  -- get child defaults:
+  defsChildren <- mapM (fullDefaultsPath dataDir) ds
+  -- 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
+  where parseDefsNames x = (parseYAML x >>= \xs -> return $ map unpack xs)
+                       <|> (parseYAML x >>= \x' -> return [unpack x'])
+
+parseOptions :: Monad m
+             => [(Node Pos, Node Pos)]
+             -> Parser (Opt -> StateT DefaultsState m Opt)
+parseOptions ns = do
+  f <- chain doOpt' ns
+  return $ return . f
+
+chain :: Monad m => (a -> m (b -> b)) -> [a] -> m (b -> b)
+chain f = foldM g id
+  where g o n = f n >>= \o' -> return $ o' . o
+
+doOpt' :: (Node Pos, Node Pos) -> Parser (Opt -> Opt)
+doOpt' (k',v) = do
+  k <- parseStringKey k'
+  case k of
+    "defaults" -> return id
+    _ -> doOpt (k',v)
+
 doOpt :: (Node Pos, Node Pos) -> Parser (Opt -> Opt)
 doOpt (k',v) = do
-  k <- case k' of
-         Scalar _ (SStr t) -> return t
-         Scalar _ _ -> failAtNode k' "Non-string key"
-         _ -> failAtNode k' "Non-scalar key"
+  k <- parseStringKey k'
   case k of
     "tab-stop" ->
       parseYAML v >>= \x -> return (\o -> o{ optTabStop = x })
@@ -494,6 +564,12 @@ defaultOpts = Opt
     , optStripComments         = False
     }
 
+parseStringKey ::  Node Pos -> Parser Text
+parseStringKey k = case k of
+  Scalar _ (SStr t) -> return t
+  Scalar _ _ -> failAtNode k "Non-string key"
+  _ -> failAtNode k "Non-scalar key"
+
 yamlToMeta :: Node Pos -> Parser Meta
 yamlToMeta (Mapping _ _ m) =
     either (fail . show) return $ runEverything (yamlMap pMetaString m)
@@ -524,6 +600,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