@@ -20,10 +20,17 @@ module Text.Pandoc.App.Opt (
2020 Opt(..)
2121 , LineEnding (..)
2222 , IpynbOutput (..)
23+ , DefaultsState (..)
2324 , defaultOpts
2425 , addMeta
26+ , applyDefaults
27+ , fullDefaultsPath
2528 ) where
29+import Control.Monad.Except (MonadIO, liftIO, throwError, (>=>), foldM)
30+import Control.Monad.State.Strict (StateT, modify, gets)
31+import System.FilePath ( addExtension, (</>), takeExtension )
2632import Data.Char (isLower, toLower)
33+import Data.Maybe (fromMaybe)
2734import GHC.Generics hiding (Meta)
2835import Text.Pandoc.Builder (setMeta)
2936import Text.Pandoc.Filter (Filter (..))
@@ -34,7 +41,9 @@ import Text.Pandoc.Options (TopLevelDivision (TopLevelDefault),
3441 ReferenceLocation (EndOfDocument),
3542 ObfuscationMethod (NoObfuscation),
3643 CiteMethod (Citeproc))
37−import Text.Pandoc.Shared (camelCaseStrToHyphenated)
44+import Text.Pandoc.Class (readFileLazy, fileExists, setVerbosity, PandocMonad)
45+import Text.Pandoc.Error (PandocError (PandocParseError, PandocSomeError))
46+import Text.Pandoc.Shared (camelCaseStrToHyphenated, defaultUserDataDirs, findM, ordNub)
3847import qualified Text.Pandoc.Parsing as P
3948import Text.Pandoc.Readers.Metadata (yamlMap)
4049import Text.Pandoc.Class.PandocPure
@@ -150,16 +159,77 @@ data Opt = Opt
150159 } deriving (Generic, Show)
151160
152161instance FromYAML (Opt -> Opt) where
153− parseYAML (Mapping _ _ m) =
154− foldr (.) id <$> mapM doOpt (M.toList m)
162+ parseYAML (Mapping _ _ m) = chain doOpt (M.toList m)
155163 parseYAML n = failAtNode n "Expected a mapping"
156164
165+data DefaultsState = DefaultsState
166+ {
167+ curDefaults :: Maybe FilePath -- currently parsed file
168+ , inheritanceGraph :: [[FilePath]] -- defaults file inheritance graph
169+ } deriving (Show)
170+
171+instance (PandocMonad m, MonadIO m)
172+ => FromYAML (Opt -> StateT DefaultsState m Opt) where
173+ parseYAML (Mapping _ _ m) = do
174+ let opts = M.mapKeys toText m
175+ dataDir <- case M.lookup "data-dir" opts of
176+ Nothing -> return Nothing
177+ Just v -> Just . unpack <$> parseYAML v
178+ f <- parseOptions $ M.toList m
179+ case M.lookup "defaults" opts of
180+ Just v -> do
181+ g <- parseDefaults v dataDir
182+ return $ g >=> f
183+ Nothing -> return f
184+ where
185+ toText (Scalar _ (SStr s)) = s
186+ toText _ = ""
187+ parseYAML n = failAtNode n "Expected a mapping"
188+
189+parseDefaults :: (PandocMonad m, MonadIO m)
190+ => Node Pos
191+ -> Maybe FilePath
192+ -> Parser (Opt -> StateT DefaultsState m Opt)
193+parseDefaults n dataDir = parseDefsNames n >>= \ds -> return $ \o -> do
194+ -- get parent defaults:
195+ defsParent <- gets $ fromMaybe "" . curDefaults
196+ -- get child defaults:
197+ defsChildren <- mapM (fullDefaultsPath dataDir) ds
198+ -- expand parent in defaults inheritance graph by children:
199+ defsGraph <- gets inheritanceGraph
200+ let defsGraphExp = expand defsGraph defsChildren defsParent
201+ modify $ \defsState -> defsState{ inheritanceGraph = defsGraphExp }
202+ -- check for cyclic inheritance:
203+ if cyclic defsGraphExp
204+ then throwError $
205+ PandocSomeError $ T.pack $
206+ "Error: Circular defaults file reference in " ++
207+ "'" ++ defsParent ++ "'"
208+ else foldM applyDefaults o defsChildren
209+ where parseDefsNames x = (parseYAML x >>= \xs -> return $ map unpack xs)
210+ <|> (parseYAML x >>= \x' -> return [unpack x'])
211+
212+parseOptions :: Monad m
213+ => [(Node Pos, Node Pos)]
214+ -> Parser (Opt -> StateT DefaultsState m Opt)
215+parseOptions ns = do
216+ f <- chain doOpt' ns
217+ return $ return . f
218+
219+chain :: Monad m => (a -> m (b -> b)) -> [a] -> m (b -> b)
220+chain f = foldM g id
221+ where g o n = f n >>= \o' -> return $ o' . o
222+
223+doOpt' :: (Node Pos, Node Pos) -> Parser (Opt -> Opt)
224+doOpt' (k',v) = do
225+ k <- parseStringKey k'
226+ case k of
227+ "defaults" -> return id
228+ _ -> doOpt (k',v)
229+
157230doOpt :: (Node Pos, Node Pos) -> Parser (Opt -> Opt)
158231doOpt (k',v) = do
159− k <- case k' of
160− Scalar _ (SStr t) -> return t
161− Scalar _ _ -> failAtNode k' "Non-string key"
162− _ -> failAtNode k' "Non-scalar key"
232+ k <- parseStringKey k'
163233 case k of
164234 "tab-stop" ->
165235 parseYAML v >>= \x -> return (\o -> o{ optTabStop = x })
@@ -494,6 +564,12 @@ defaultOpts = Opt
494564 , optStripComments = False
495565 }
496566
567+parseStringKey :: Node Pos -> Parser Text
568+parseStringKey k = case k of
569+ Scalar _ (SStr t) -> return t
570+ Scalar _ _ -> failAtNode k "Non-string key"
571+ _ -> failAtNode k "Non-scalar key"
572+
497573yamlToMeta :: Node Pos -> Parser Meta
498574yamlToMeta (Mapping _ _ m) =
499575 either (fail . show) return $ runEverything (yamlMap pMetaString m)
@@ -524,6 +600,52 @@ readMetaValue s
524600 | s == "FALSE" = MetaBool False
525601 | otherwise = MetaString $ T.pack s
526602
603+-- | Apply defaults from --defaults file.
604+applyDefaults :: (PandocMonad m, MonadIO m)
605+ => Opt
606+ -> FilePath
607+ -> StateT DefaultsState m Opt
608+applyDefaults opt file = do
609+ setVerbosity $ optVerbosity opt
610+ modify $ \defsState -> defsState{ curDefaults = Just file }
611+ inp <- readFileLazy file
612+ case decode1 inp of
613+ Right f -> f opt
614+ Left (errpos, errmsg) -> throwError $
615+ PandocParseError $ T.pack $
616+ "Error parsing " ++ file ++ " line " ++
617+ show (posLine errpos) ++ " column " ++
618+ show (posColumn errpos) ++ ":\n" ++ errmsg
619+
620+fullDefaultsPath :: (PandocMonad m, MonadIO m)
621+ => Maybe FilePath
622+ -> FilePath
623+ -> m FilePath
624+fullDefaultsPath dataDir file = do
625+ let fp = if null (takeExtension file)
626+ then addExtension file "yaml"
627+ else file
628+ dataDirs <- liftIO defaultUserDataDirs
629+ let fps = fp : case dataDir of
630+ Nothing -> map (</> ("defaults" </> fp))
631+ dataDirs
632+ Just dd -> [dd </> "defaults" </> fp]
633+ fromMaybe fp <$> findM fileExists fps
634+
635+-- | In a list of lists, append another list in front of every list which
636+-- starts with specific element.
637+expand :: Ord a => [[a]] -> [a] -> a -> [[a]]
638+expand [] ns n = fmap (\x -> x : [n]) ns
639+expand ps ns n = concatMap (ext n ns) ps
640+ where
641+ ext x xs p = case p of
642+ (l : _) | x == l -> fmap (: p) xs
643+ _ -> [p]
644+
645+cyclic :: Ord a => [[a]] -> Bool
646+cyclic = any hasDuplicate
647+ where
648+ hasDuplicate xs = length (ordNub xs) /= length xs
527649
528650-- see https://github.com/jgm/pandoc/pull/4083
529651-- using generic deriving caused long compilation times