mcm-0.6.4.10: Interpret.hs
-- MCM - Machine Configuration Manager; manages the contents of files and directories
-- Copyright (c) 2013-2016 Anthony Doggett <mcm@interfaces.org.uk>
--
-- Licence:
-- This program is free software: you can redistribute it and/or modify
-- it under the terms of the GNU General Public License as published by
-- the Free Software Foundation, either version 3 of the License, or
-- (at your option) any later version.
--
-- This program is distributed in the hope that it will be useful,
-- but WITHOUT ANY WARRANTY; without even the implied warranty of
-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-- GNU General Public License for more details.
--
-- You should have received a copy of the GNU General Public License
-- along with this program. If not, see <http://www.gnu.org/licenses/>.
module Interpret (run, fullyLoadSectionFromHandle)
where
import Control.Monad (unless, when)
import Data.Either (partitionEithers)
import Data.Maybe (fromMaybe, isNothing)
import Data.List (intercalate)
import qualified Data.Map as Map
import qualified Data.Set as Set
import qualified Data.Text.Lazy as T
import qualified Data.Text.Lazy.IO as TextIO
import qualified Data.Traversable as Traversable
import Numeric(readOct)
import System.Posix.Types(FileMode)
import System.Directory (doesFileExist)
import System.FilePath (combine)
import System.IO (Handle)
import FileCorrector (PathType(..), DirType(..), Path, Permissions(..), emptyPermissions, OwnerP(..), GroupP(..))
import InterpretState
import Parser (mcmLoadAndParse, mcmParse)
import ParserTypes (Import(..), PackagePath, lookupDefine, Section(..), Define(..), Invocation(..), InvocationArgs(..), CondLocal(..), packagePath, Content(..), Group(..), Separator(..), Prepend(..), Append(..), section, imports, InvocationCmd(..), ExpandedInvocationCmd(..), lookupImport, DefName(..), UnexpandedDefName(..), Ident(..), OptArgs(..), Locals(..), Value(..), MCMFile(..), VarsExpand(..))
import VarsParser (expandString)
{- Interpreting stages:
- 0) Parse the initial file to get an initial State
- (Inc. expanding any package-level lets)
- 1) Run through all Imports, importing until everything loaded
- 2) Run Defines, building up basic Path + fragments
- 3) Load templates+raw and complete fragments
- 4) Output fragments (completing Path)
-}
run :: State -> (PackagePath, DefName, Args) -> IO (([Error], [String], Path, [(PackagePath, Group)]), State)
run s0 (pp, defname, args) = do
(is, s1) <- case fst $ runInterpret s0 (lookupSection pp) of
Just _ -> return ([], s0)
Nothing -> loadSection s0 pp
s2 <- loadImports' s1 is
let (_, s3) = runInterpret s2 (interpret0 (pp, defname, args))
(templatesAndRaws, s4) <- loadFiles s3
let (_, s5) = runInterpret s4 (generate templatesAndRaws)
return (getResult s5, s5)
-- Interpret the given (Section, DefineName, Args)
interpret0 :: (PackagePath, DefName, Args) -> Interpret ()
interpret0 (pp, defname, args) = do
sect <- lookupSection pp
(PLSection sect' plets) <- case sect of
Just z -> return z
Nothing -> do
addError $ "Section \"" ++ show pp ++ "\" not found in imported files."
return $ PLSection (Section [] Map.empty Map.empty) (AllLocals Map.empty)
case lookupDefine sect' defname of
Just d' -> interpret pp plets defname d' args
Nothing -> addError $ "Define \"" ++ show defname ++ "\" not found in Section " ++ show pp
-- Should now have everything, so complete paths and output
generate :: Map.Map FilePath T.Text -> Interpret ()
generate templatesAndRaws = do
let expander = fullExpandOne templatesAndRaws
expandAllPending expander
loadFiles :: State -> IO (Map.Map FilePath T.Text, State)
loadFiles s = do
let toLoad = getLoadFiles s
(SearchPath sp) = getSearchPath s
loadOne :: FilePath -> IO (FilePath, Maybe T.Text)
loadOne f = do
c <- keepTrying (loadOne' f) sp
return (f, c)
loadOne' :: FilePath -> FilePath -> IO (Maybe T.Text)
loadOne' f d = do
let f' = combine d f
e <- doesFileExist f'
if e
then do
r <- TextIO.readFile f'
return $ Just r
else return Nothing
loaded <- mapM loadOne toLoad
let tryFromMaybe :: (FilePath, Maybe T.Text) -> Interpret (FilePath, T.Text)
tryFromMaybe (name, Just c) = return (name, c)
tryFromMaybe (name, Nothing) = do
addError $ "File not found in search path: " ++ name
return (name, T.empty)
(loaded', s') = runInterpret s (mapM tryFromMaybe loaded)
return (Map.fromList loaded', s')
loadSection :: State -> PackagePath -> IO ([Import], State)
loadSection s0 pp = do
let (SearchPath sp) = getSearchPath s0
fpsect <- keepTrying (loadSect pp) sp
let fpsect' = fromMaybe ("dummy", MCMFile pp (Section [] Map.empty Map.empty)) fpsect
(_, s1) = runInterpret s0 (addNewSection pp fpsect')
is = imports (section $ snd fpsect')
return (is, s1)
fullyLoadSectionFromHandle :: FilePath -> Handle -> PackagePath -> State -> IO State
fullyLoadSectionFromHandle handleName h pp s0 = do
t <- TextIO.hGetContents h
loadImports $ snd $ runInterpret s0 $ addNewSection pp $
case mcmParse t of
Right a -> (handleName, a)
Left e -> error $ intercalate "\n" (("Error parsing " ++ handleName ++ ":"):e)
-- Add the given section
-- and an error if the requested pp is not among them
-- and return the one requested by pp
addNewSection :: PackagePath -> (FilePath, MCMFile) -> Interpret ()
addNewSection pp (fp, ss) = do
addSectionOrError ss
r <- lookupSection pp
case r of
Nothing -> do
addError $ "Section " ++ show pp ++ " not found in " ++ fp
let dummy = MCMFile pp (Section [] Map.empty Map.empty)
addSectionOrError dummy
return ()
Just _ -> return ()
-- Add the given section, or an error that it's aleady defined
addSectionOrError :: MCMFile -> Interpret ()
addSectionOrError (MCMFile name sect@(Section _ plets _)) = do
s0 <- lookupSection name
case s0 of
Nothing -> do
plets' <- solve' name (AllLocals Map.empty) plets []
addSection (name, PLSection sect plets')
Just _ -> addError $ "Section " ++ show name ++ " already defined."
-- Try the given action repeatedly until one succeeds or all fail
keepTrying :: Monad m => (a -> m (Maybe b)) -> [a] -> m (Maybe b)
keepTrying _ [] = return Nothing
keepTrying f (x:xs) = do
r <- f x
case r of
Just _ -> return r
Nothing -> keepTrying f xs
loadSect :: PackagePath -> FilePath -> IO (Maybe (FilePath, MCMFile))
loadSect pp fp = do
let f = combine fp (packagePath pp)
e <- doesFileExist f
if e
then do
r <- mcmLoadAndParse f
return $ Just (f, r)
else return Nothing
-- Interpret the given Define using the given args
interpret :: PackagePath -> PackageLets -> DefName -> Define -> Args -> Interpret ()
interpret pp (AllLocals plets) dName d args = do
args' <- checkForMissingArgs dName (defArgs d) args
let expectedargs = Set.fromList(defArgs d ++ Map.keys (fromOptArgs . defOptargs $ d))
givenargs = Map.keysSet . fromArgs $ args'
checkForExtraArgs expectedargs givenargs
combined <- unionLocals (fromArgs args') plets
let uppercaseConsts =
Map.fromList [((Ident . T.pack) "COMMA", Expanded $ T.pack ",")
,((Ident . T.pack) "NEWLINE", Expanded $ T.pack "\n")
,((Ident . T.pack) "SPACE", Expanded $ T.pack " ")
,((Ident . T.pack) "TAB", Expanded $ T.pack "\t")
]
combined' = Args $ combined `Map.union` uppercaseConsts
pushLocation pp dName
al <- solve pp d combined'
mapM_ (invoke pp al) (defInvokes d)
popLocation
invoke :: PackagePath -> AllLocals -> Invocation -> Interpret ()
invoke pp al (Invocation icmd iargs) = do
as <- expand pp al iargs
let as' = Args as
icmd' <- expandInvocationCmd pp al icmd
alreadySeen <- logInvokeOf (icmd', pp, as')
unless alreadySeen $ do
let (doit, expectedArgSet) = invokationTable icmd' pp as'
case expectedArgSet of
Just expecArgSet -> checkForExtraArgs expecArgSet (Map.keysSet . fromInvocationArgs $ iargs)
Nothing -> return ()
doit
toIdentSet :: [String] -> Set.Set Ident
toIdentSet = Set.fromList . map (Ident . T.pack)
invokationTable :: ExpandedInvocationCmd -> PackagePath -> Args -> (Interpret (), Maybe (Set.Set Ident))
invokationTable ExInvDir pp as =
(if allExpanded as then invokeDir as else invokeLater PendingPath pp as
,Just $ toIdentSet ["path", "owner", "group", "mode", "manage"]
)
invokationTable ExInvFile pp as =
(if allExpanded as then invokeFile as else invokeLater PendingFile pp as
,Just $ toIdentSet ["path", "owner", "group", "mode", "content"]
)
invokationTable ExInvSymlink pp as =
(if allExpanded as then invokeSymlink as else invokeLater PendingSymlink pp as
,Just $ toIdentSet ["path", "owner", "group", "mode", "link"]
)
invokationTable ExInvAbsent pp as =
(if allExpanded as then invokeAbsent as else invokeLater PendingAbsent pp as
,Just $ toIdentSet ["path"]
)
invokationTable ExInvFragment pp as =
(if allExpanded as then invokeFragment pp as else invokeLater PendingFragment pp as
,Just $ toIdentSet ["group", "name", "content"]
)
-- NB. MUST return an "invoke now" - cannot put off for later (but don't need to)
invokationTable (ExInvLocal d) pp as =
(interpret0 (pp, d, as), Nothing)
invokationTable (ExInvImport i d) pp as = (interpretImport, Nothing)
where
interpretImport = do
thisSection <- lookupSection pp
let thisSection' = fromMaybe (error $ "Internal error: could not lookup own section: " ++ show pp) thisSection
impPP = lookupImport (imports.pl2section $ thisSection') i
case impPP of
Nothing -> addError $ "Import " ++ show i ++ " not found."
Just impPP' -> interpret0 (impPP', d, as)
readFileMode :: String -> Interpret (Maybe FileMode)
readFileMode s = case readOct s of
[(x, "")] -> return $ Just x
_ -> do
addError $ "Failed to parse mode: " ++ s
return Nothing
parsePermissions :: Args -> Interpret Permissions
parsePermissions as = do
let l = lookupExpanded as . Ident . T.pack
o = l "owner"
g = l "group"
m = l "mode"
m' <- case m of
Nothing -> return Nothing
Just s -> readFileMode $ T.unpack s
o' <- case o of
Nothing -> return Nothing
Just s -> do
s' <- parseOwner s
return $ Just $ OwnerP (s, s')
g' <- case g of
Nothing -> return Nothing
Just s -> do
s' <- parseGroup s
return $ Just $ GroupP (s, s')
let perm = Perm m' o' g'
return perm
-- To be called only once all args are Expanded
invokeDir :: Args -> Interpret ()
invokeDir as = do
let l = lookupExpanded as . Ident . T.pack
p = l "path"
--t = Map.findWithDefault (Expanded $ T.pack "full") (T.pack "manage") as
t = l "manage"
perm <- parsePermissions as
t' <- case t of
Just e | e == T.pack "full" -> return Full
Just e | e == T.pack "partial" -> return Partial
Nothing -> return Full
_ -> do
addError $ "Invalid Directory manage type: " ++ show t
return Partial
case p of
Just p' -> iAddPath (T.unpack p') (Dir t') perm
Nothing -> addError "No path specified for directory"
-- To be called only once all args are Expanded
invokeSymlink :: Args -> Interpret ()
invokeSymlink as = do
let l = lookupExpanded as . Ident . T.pack
p = l "path"
i = l "link"
perm@(Perm m o g) <- parsePermissions as
perm' <- if isNothing m
then return perm
else do
addError $ "It is not possible to set the mode of a symbolic link."
++ " Please explicitly set the mode of the destination instead."
return (Perm Nothing o g)
i' <- case i of
Nothing -> do
addError "No link specified for symlink"
return T.empty
Just c -> return c
case p of
Just p' -> iAddPath (T.unpack p') (Symlink $ T.unpack i') perm'
Nothing -> addError "No path specified for symlink"
invokeFile :: Args -> Interpret ()
invokeFile as = do
let l = lookupExpanded as . Ident . T.pack
p = l "path"
t = l "content"
perm <- parsePermissions as
t' <- case t of
Nothing -> do
addError "No content specified for file"
return T.empty
Just c -> return c
case p of
Just p' -> iAddPath (T.unpack p') (File t') perm
Nothing -> addError "No path specified for file"
invokeAbsent :: Args -> Interpret ()
invokeAbsent as = do
let l = lookupExpanded as . Ident . T.pack
p = l "path"
case p of
Just p' -> iAddPath (T.unpack p') Absent emptyPermissions
Nothing -> addError "What is it that should be absent?"
invokeFragment :: PackagePath -> Args -> Interpret ()
invokeFragment pp as = do
let l = lookupExpanded as . Ident . T.pack
g = l "group"
c = l "content"
n = l "name"
g' <- case g of
Just s -> return s
Nothing -> do
addError "No group specified for Fragment"
return $ T.pack "defaultGroup"
c' <- case c of
Just s -> return s
Nothing -> do
addError "No content specified for Fragment"
return $ T.pack "defaultContent"
addFragment pp (Group g') (fromMaybe c' n) c'
checkForExtraArgs :: Set.Set Ident -> Set.Set Ident -> Interpret ()
checkForExtraArgs expected actual =
let difference = actual `Set.difference` expected
in
unless (Set.null difference) $
addError $ "Unexpected argument(s): " ++ show (Set.toList difference)
checkForMissingArgs :: DefName -> [Ident] -> Args -> Interpret Args
checkForMissingArgs dName required args@(Args as) =
let missing = Set.fromList required `Set.difference` Map.keysSet as
dummy = Expanded $ T.pack "missingArg"
in
if Set.null missing then return args
else do
addError $ "Missing argument(s) in call of " ++ show dName
++ "(): " ++ show (Set.toList missing)
return $ Args $ as `Map.union` Map.fromList (map (\m -> (m, dummy)) required)
-- Suppose that State has been initialised
-- with the very first loaded file (stdin and/or first file loaded).
-- Load all Sections referenced in the Imports
loadImports :: State -> IO State
loadImports s0 = do
let (imps, s1) = runInterpret s0 allImports
loadImports' s1 imps
loadImports' :: State -> [Import] -> IO State
loadImports' s0 [] = return s0
loadImports' s0 (Import pp _:is) = do
let (sect, s1) = runInterpret s0 (lookupSection pp)
(newis, s2) <- case sect of
Just _ -> return ([], s1) -- No new imports (already loaded)
Nothing -> loadSection s1 pp
loadImports' s2 (is++newis)
unionLocals :: Map.Map Ident a -> Map.Map Ident a -> Interpret (Map.Map Ident a)
unionLocals a b =
let u = a `Map.union` b
i = a `Map.intersection` b
in do
unless (Map.null i) $ mapM_ (\k -> addError $ "local \"" ++ show k ++ "\" is defined multiple times") (Map.keys i)
return u
insertLocal :: Ident -> a -> Map.Map Ident a -> Interpret (Map.Map Ident a)
insertLocal k v m = do
when (k `Map.member` m) $ addError $ "local \"" ++ show k ++ "\" is defined multiple times"
return $ Map.insert k v m
-- NB. Given args must take precedence over optargs
solve :: PackagePath -> Define -> Args -> Interpret AllLocals
solve pp d (Args a) =
let (OptArgs a1) = defOptargs d
(Locals a2) = defLocals d
a1' = Map.filterWithKey (\k _ -> Map.notMember k a) a1
alreadySolved = AllLocals a
in do
alreadySolved' <- solve' pp alreadySolved a1' []
solve' pp alreadySolved' a2 (defCondlocals d)
--solve': AllLocals = solved already, Map = tosolve, [CondLocal] = conditionals
solve' :: PackagePath -> AllLocals -> Map.Map Ident [Content] -> [CondLocal] -> Interpret AllLocals
solve' pp (AllLocals al) c [] = do
expanded <- solveExpand pp al (Map.toList c) []
return $ AllLocals expanded
solve' pp al c (CondLocal cond alts:xs) = do
solution <- evaluateCond pp al c cond
let solveFor (Locals x) = do
combined <- unionLocals c x
solve' pp al combined xs
defaultSolve = if Map.null alts
then return al
else solveFor $ snd $ Map.elemAt 0 alts
case solution of
Nothing -> defaultSolve
Just s -> case Map.lookup (Value s) alts of
Just a -> solveFor a
Nothing -> do
addError $ "Error evaluating " ++ show cond ++ ": expected one of " ++ (show . Map.keys) alts ++ " but got " ++ show solution ++ "."
defaultSolve
-- Step 3: Expand any remaining @var-s
-- Need to trap recursion (as it can't terminate)
solveExpand :: PackagePath -> Map.Map Ident Expander -> [(Ident, [Content])] -> [(Ident, [Content])] -> Interpret (Map.Map Ident Expander)
solveExpand _ solved [] [] = return solved
solveExpand pp s [] unsolved = do
let process e = case e of
Right _ -> error "Unexpected state within solveExpand"
Left e' -> addError e'
errors <- mapM (expandOne pp (AllLocals s) . snd) unsolved
mapM_ process errors
return s
solveExpand pp s ((a,b):xs) u = do
expanded <- expandOne pp (AllLocals s) b
case expanded of
Right b' -> do
combined <- insertLocal a b' s
solveExpand pp combined (u++xs) []
Left _ -> solveExpand pp s xs ((a,b):u) -- Todo: it might be worth saving the error (_) on the unsolved list
-- Solve the given conditional (case variable)
evaluateCond :: PackagePath -> AllLocals -> Map.Map Ident [Content] -> Ident -> Interpret (Maybe T.Text)
evaluateCond pp (AllLocals al) unsolvedlocals s =
case Map.lookup s al of
Just (Expanded e) -> return $ Just e
_ -> case Map.lookup s unsolvedlocals of
Just b -> do
b' <- expandOne pp (AllLocals al) b
case b' of
Left e -> do
addError $ "Failed to expand " ++ show b ++ " for the case expression \"" ++ show s ++ "\": " ++ e
return Nothing
Right (Expanded b'') -> return $ Just b''
Right _ -> do
addError $ "Failed to expand " ++ show b ++ " for the case expression \"" ++ show s ++ "\" as case expansions must be simple"
return Nothing
Nothing -> do
addError $ "Failed to find definition for case variable \"" ++ show s ++ "\""
return Nothing
{- Simultaneous equations :(
- I need way of saying "solve [Content] to a string now if you can",
- and otherwise store the equations for solving later.
- Content -> Resolution:
- CWord -> now (solve first with al)
- CLine -> now (solve first with al)
- CFile -> later (requires IO; solve now and later with al)
- CFragments -> later (need to generate all fragments first; solve now and later with al; enumerate dependent fragments for dependency-calculating)
- CRawFile -> later (requires IO; can solve with al now though)
- Perhaps it would help to have loaded all templates & raw files in advance?
- I still need to do fragments later though (once generated).
-}
expandOne :: PackagePath -> AllLocals -> [Content] -> Interpret (Either String Expander)
expandOne _ _ [] = return $ Right $ Expanded $ T.pack ""
expandOne _ _ [CEmpty] = return $ Right $ Expanded $ T.pack ""
expandOne _ _ [CNewline] = return $ Right $ Expanded $ T.pack "\n"
expandOne _ _ [CRawString s] = return $ Right $ Expanded s
expandOne _ al [CString w] = return $ expandStringFromAl al w
expandOne _ al [CExplicitString w] = return $ expandStringFromAl al w
expandOne _ al [CRawFile f] =
case expandStringFromAl al f of
Right (Expanded s) -> do
let s' = T.unpack s
addToLoad s'
return $ Right $ ERawFile s'
Right _ -> return $ Left "Only simple expansions supported for filenames"
Left e -> return $ Left e
expandOne _ al [CFile f] =
case expandStringFromAl al f of
Right (Expanded s) -> do
let s' = T.unpack s
addToLoad s'
return $ Right $ EFile s' al
Right _ -> return $ Left "Only simple expansions supported for filenames"
Left e -> return $ Left e
expandOne pp al [CFragments (Group g) (Prepend prepend) (Append append) (Separator sep)] = do
g' <- case expandStringFromAl al g of
Right (Expanded s) ->
return s
Right _ -> do
addError "Only simple expansions supported for group identifiers"
return $ T.pack "complicatedGroupExpansion"
Left e -> do
addError e
return $ T.pack "erroneousGroupExpansion"
prepend' <- case expandStringFromAl al prepend of
Right (Expanded s) ->
return s
Right _ -> do
addError "Only simple expansions supported for fragment prepend strings"
return $ T.pack "complicatedPrependExpansion"
Left e -> do
addError e
return $ T.pack "erroneousPrependExpansion"
append' <- case expandStringFromAl al append of
Right (Expanded s) ->
return s
Right _ -> do
addError "Only simple expansions supported for fragment append strings"
return $ T.pack "complicatedAppendExpansion"
Left e -> do
addError e
return $ T.pack "erroneousAppendExpansion"
sep' <- case expandStringFromAl al sep of
Right (Expanded s) ->
return s
Right _ -> do
addError "Only simple expansions supported for fragment separators"
return $ T.pack "complicatedSeparatorExpansion"
Left e -> do
addError e
return $ T.pack "erroneousSeparatorExpansion"
return $ Right $ EFragments pp (Group g') (Prepend prepend') (Append append') (Separator sep')
expandOne pp al xs = do
singles <- mapM (expandOne pp al . (:[])) xs
case partitionEithers singles of
([], successes) -> return $ Right $ collapseExpander successes
(e:_, _) -> return $ Left e
expand :: PackagePath -> AllLocals -> InvocationArgs -> Interpret (Map.Map Ident Expander)
expand pp al (InvocationArgs iargs) = Traversable.mapM expand' iargs
where
expand' :: [Content] -> Interpret Expander
expand' iarg = do
x <- expandOne pp al iarg
case x of
Left e -> do
addError e
return $ Expanded $ T.pack "erroneousExpansion"
Right y -> return y
expandInvocationCmd' :: PackagePath -> AllLocals -> UnexpandedDefName -> Interpret DefName
expandInvocationCmd' pp al ud@(UnexpandedDefName u) = do
x <- expandOne pp al [CString u]
case x of
Left e -> do
addError e
return $ DefName $ T.pack "erroneousExpansion"
Right (Expanded y) -> return $ DefName y
Right _ -> do
addError $ "Failed to fully expand: " ++ show ud
return $ DefName $ T.pack "erroneousExpansion"
expandInvocationCmd :: PackagePath -> AllLocals -> InvocationCmd -> Interpret ExpandedInvocationCmd
expandInvocationCmd _ _ InvFile = return ExInvFile
expandInvocationCmd _ _ InvDir = return ExInvDir
expandInvocationCmd _ _ InvAbsent = return ExInvAbsent
expandInvocationCmd _ _ InvFragment = return ExInvFragment
expandInvocationCmd _ _ InvSymlink = return ExInvSymlink
expandInvocationCmd pp al (InvLocal u) = do
d <- expandInvocationCmd' pp al u
return $ ExInvLocal d
expandInvocationCmd pp al (InvImport i u) = do
d <- expandInvocationCmd' pp al u
return $ ExInvImport i d
allExpanded :: Args -> Bool
allExpanded (Args m) = allExpanded' (Map.elems m)
where
allExpanded' :: [Expander] -> Bool
allExpanded' [] = True
allExpanded' (Expanded _ :xs) = allExpanded' xs
allExpanded' _ = False
lookupExpanded :: Args -> Ident -> Maybe T.Text
lookupExpanded (Args as) s = fromExpanded $ Map.lookup s as
where
fromExpanded :: Maybe Expander -> Maybe T.Text
fromExpanded Nothing = Nothing
fromExpanded (Just (Expanded e)) = Just e
fromExpanded e = error $ "lookupExpanded should only ever be called when all args are fully expanded, but got: " ++ show e
fullExpandOne :: Map.Map FilePath T.Text -> Expander -> Interpret Expander
fullExpandOne _ e@(Expanded _) = return e
fullExpandOne templatesAndRaws (EFile fp al) = do
let l = Map.lookup fp templatesAndRaws
case l of
Just s -> case expandStringFromAl al s of
Left err -> do
addError $ "Error parsing template '" ++ fp ++ "': " ++ err
return $ Expanded $ T.pack "erroneousTemplate"
Right s' -> return s'
Nothing -> do
addError $ "Internal program error: template \""++fp++"\" not found."
return $ Expanded $ T.pack "erroneousTemplate2"
-- EFragments pp, g and s are fully expanded; assume that all fragments have been generated
fullExpandOne _ (EFragments pp g (Prepend p) (Append a) (Separator s)) = do
frags <- takeFragments pp g
return $ Expanded $ T.intercalate s $ map (\f -> p `T.append` f `T.append` a) frags
fullExpandOne templatesAndRaws (ERawFile fp) = do
let l = Map.lookup fp templatesAndRaws
case l of
Just s -> return $ Expanded s
Nothing -> do
addError $ "Internal program error: raw \""++fp++"\" not found."
return $ Expanded $ T.pack "erroneousRaw2"
fullExpandOne templatesAndRaws (EMulti es) = do
es' <- mapM (fullExpandOne templatesAndRaws) es
let r = foldr1 (\(Expanded a) (Expanded b) -> Expanded (a `T.append` b)) es'
return r
-- Assume that everything expands perfectly
-- Run invocations in the order supplied (completing Path)
expandAllPending :: (Expander -> Interpret Expander) -> Interpret ()
expandAllPending expander = do
invocations <- takeAllLaters
mapM_ expandAndInvoke invocations
where
expandAndInvoke (cmd, pp, as) = do
(cmd', pp', as') <- expandit (cmd, pp, as)
expandAllPending' cmd' pp' as'
expandit :: (PendingCmd, PackagePath, Args)
-> Interpret (PendingCmd, PackagePath, Args)
expandit (cmd, pp, Args as) = do
as' <- Traversable.mapM expander as
return (cmd, pp, Args as')
expandAllPending' :: PendingCmd -> PackagePath -> Args -> Interpret ()
expandAllPending' PendingFile _ = invokeFile
expandAllPending' PendingPath _ = invokeDir
expandAllPending' PendingSymlink _ = invokeSymlink
expandAllPending' PendingAbsent _ = invokeAbsent
expandAllPending' PendingFragment pp = invokeFragment pp
expandStringFromAl :: AllLocals -> T.Text -> Either String Expander
expandStringFromAl (AllLocals al) =
expandString $ VarsExpand (\i _ -> i `Map.lookup` al) Expanded collapseExpander (\a _ -> Expanded a)