zeolite-lang-0.24.0.0: src/Compilation/ProcedureContext.hs
{- -----------------------------------------------------------------------------
Copyright 2019-2021,2023 Kevin P. Barry
Licensed under the Apache License, Version 2.0 (the "License");
you may not use this file except in compliance with the License.
You may obtain a copy of the License at
http://www.apache.org/licenses/LICENSE-2.0
Unless required by applicable law or agreed to in writing, software
distributed under the License is distributed on an "AS IS" BASIS,
WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
See the License for the specific language governing permissions and
limitations under the License.
----------------------------------------------------------------------------- -}
-- Author: Kevin P. Barry [ta0kira@gmail.com]
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE Trustworthy #-}
module Compilation.ProcedureContext (
ExprMap,
ProcedureContext(..),
ReturnValidation(..),
updateArgVariables,
updateReturnVariables,
) where
import Control.Monad (foldM,when)
import Data.List (nub)
import Data.Maybe (fromJust,isJust)
import Lens.Micro hiding (mapped)
import Lens.Micro.TH
import qualified Data.Map as Map
import qualified Data.Set as Set
import Base.CompilerError
import Base.GeneralType
import Base.MergeTree
import Base.Positional
import Compilation.CompilerState
import Types.DefinedCategory
import Types.Function
import Types.Procedure
import Types.TypeCategory
import Types.TypeInstance
type ExprMap c = Map.Map MacroName (Expression c)
data ReturnValidation c =
ValidatePositions {
vpReturns :: Positional (PassedValue c)
} |
ValidateNames {
vnNames :: Positional VariableName,
vnTypes :: Positional (PassedValue c),
vnRemaining :: DeferVariable c
}
deriving (Show)
data ProcedureContext c =
ProcedureContext {
_pcScope :: SymbolScope,
_pcType :: CategoryName,
_pcExtParams :: Positional (ValueParam c),
_pcMembers :: [DefinedMember c],
_pcCategories :: CategoryMap c,
_pcAllFilters :: ParamFilters,
_pcExtFilters :: [ParamFilter c],
_pcParamScopes :: Map.Map ParamName SymbolScope,
_pcFunctions :: Map.Map FunctionName (ScopedFunction c),
_pcVariables :: Map.Map VariableName (VariableValue c),
_pcReturns :: ReturnValidation c,
_pcDeferred :: DeferVariable c,
_pcJumpType :: JumpType,
_pcIsNamed :: Bool,
_pcPrimNamed :: [ReturnVariable],
_pcRequiredTypes :: Set.Set CategoryName,
_pcOutput :: [String],
_pcDisallowInit :: Bool,
_pcLoopSetup :: LoopSetup [String],
_pcCleanupBlocks :: [Maybe (CleanupBlock c [String])],
_pcInCleanup :: Bool,
_pcUsedVars :: [UsedVariable c],
_pcExprMap :: ExprMap c,
_pcReservedMacros :: [(MacroName,[c])],
_pcNoTrace :: Bool,
_pcTestsOnly :: Bool,
_pcTraces :: [String],
_pcParentCall :: Maybe (Positional ParamName,Positional (Maybe (CallArgLabel c), InputValue c))
}
$(makeLenses ''ProcedureContext)
instance (Show c, CollectErrorsM m) =>
CompilerContext c m [String] (ProcedureContext c) where
ccCurrentScope = return . (^. pcScope)
ccResolver = return . AnyTypeResolver . CategoryResolver . (^. pcCategories)
ccSameType ctx t
| ctx ^. pcScope == CategoryScope = return False
| otherwise = ccSelfType ctx >>= return . (== t)
ccSelfType ctx
| ctx ^. pcScope == CategoryScope = compilerErrorM $ "Param " ++ show ParamSelf ++ " not found"
| otherwise = return $ TypeInstance (ctx ^. pcType)
(fmap (singleType . JustParamName False . vpParam) $ ctx ^. pcExtParams)
ccAllFilters = return . (^. pcAllFilters)
ccGetParamScope ctx p = do
case p `Map.lookup` (ctx ^. pcParamScopes) of
(Just s) -> return s
_ -> compilerErrorM $ "Param " ++ show p ++ " not found"
ccAddRequired ctx ts = return $ ctx & pcRequiredTypes <>~ ts
ccGetRequired = return . (^. pcRequiredTypes)
ccGetCategoryFunction ctx c Nothing n = ccGetCategoryFunction ctx c (Just $ ctx ^. pcType) n
ccGetCategoryFunction ctx c (Just t) n = getFunction where
getFunction
-- Same category as the procedure itself.
| t == ctx ^. pcType = checkFunction $ n `Map.lookup` (ctx ^. pcFunctions)
-- A different category than the procedure.
| otherwise = do
(_,ca) <- getCategory (ctx ^. pcCategories) (c,t)
let fa = Map.fromList $ map (\f -> (sfName f,f)) $ getCategoryFunctions ca
checkFunction $ n `Map.lookup` fa
checkFunction (Just f) = do
when (ctx ^. pcDisallowInit && t == ctx ^. pcType && ctx ^. pcScope == CategoryScope) $
compilerErrorM $ "Function " ++ show n ++
" disallowed during initialization" ++ formatFullContextBrace c
when (sfScope f /= CategoryScope) $
compilerErrorM $ "Function " ++ show n ++ " in " ++ show t ++ " cannot be used as a category function"
return f
checkFunction _ =
compilerErrorM $ "Category " ++ show t ++
" does not have a category function named " ++ show n ++
formatFullContextBrace c
ccGetTypeFunction ctx c t n = do
t' <- case ctx ^. pcScope of
CategoryScope -> case t of
Nothing -> compilerErrorM $ "Category " ++ show (ctx ^. pcType) ++
" does not have a category function named " ++ show n ++
formatFullContextBrace c
Just t0 -> return t0
_ -> do
self <- fmap (singleType . JustTypeInstance) $ ccSelfType ctx
case t of
Just t0 -> replaceSelfInstance self t0
Nothing -> return self
f <- getFunction t' t'
when (ctx ^. pcType /= sfType f && ctx ^. pcType /= CategoryNone) $
"In call to " ++ show (sfName f) ++ formatFullContextBrace c ??> checkVisibility (ctx ^. pcScope) (sfVisibility f) f
return f where
checkVisibility _ FunctionVisibilityDefault _ = return ()
checkVisibility CategoryScope v _ = "Function restricted to @type and @value contexts" ??> compilerErrorM (show v)
checkVisibility _ _ f = do
r <- ccResolver ctx
allFilters <- ccAllFilters ctx
self <- fmap (singleType . JustTypeInstance) $ ccSelfType ctx
checkFunctionCallVisibility r allFilters f self
multipleMatchError t2 fs = do
"Multiple matches for function " ++ show n ++ " called on " ++ show t2 ++ formatFullContextBrace c !!>
mapErrorsM (map show fs)
tryMergeFrom fs f = do
mapCompilerM_ (tryMergeFunc f) fs
return f
tryMergeTo fs f = do
mapCompilerM_ (flip tryMergeFunc f) fs
return f
tryMergeFunc f1 f2 = do
f1' <- parsedToFunctionType f1
f2' <- parsedToFunctionType f2
r <- ccResolver ctx
allFilters <- ccAllFilters ctx
silenceErrorsM $ checkFunctionConvert r allFilters Map.empty f2' f1'
getFunction t0 t2 = reduceMergeTree getFromAny getFromAll (getFromSingle t0) t2
getFromAny fs = do
let (Just t') = t -- #self will never be a union.
fs2 <- collectAllM fs <!! "Function " ++ show n ++ " is not available for type " ++ show t' ++ formatFullContextBrace c
case Map.toList $ Map.fromList $ map (\f -> (sfType f,sfContext f)) fs2 of
-- For unions, we want the most general rather than the least
-- general. Since the top level finds the least general, we can
-- only return one match here.
[_] -> collectFirstM $ map (tryMergeTo fs2) fs2 ++ [multipleMatchError t' fs2]
[] -> compilerErrorM $ "Function " ++ show n ++ " is not available for type " ++ show t' ++ formatFullContextBrace c
cs -> "Use an explicit conversion to call " ++ show n ++ " for type " ++ show t' ++ formatFullContextBrace c !!>
mapErrorsM (map (\(t2,c2) -> "Function " ++ show n ++ " in " ++ show t2 ++ formatFullContextBrace c2) cs)
getFromAll fs = do
let (Just t') = t -- #self will never be an intersection.
collectFirstM_ fs <!!
"Function " ++ show n ++ " is not available for type " ++ show t' ++ formatFullContextBrace c
fs2 <- collectAnyM fs
collectFirstM $ map (tryMergeFrom fs2) fs2 ++ [multipleMatchError t' fs2]
getFromSingle t0 (JustParamName _ p) = do
fa <- ccAllFilters ctx
ff <- case p `Map.lookup` fa of
(Just fs) -> return fs
_ -> compilerErrorM $ "Param " ++ show p ++ " not found"
let ts = map tfType $ filter isRequiresFilter ff
let ds = map dfType $ filter isDefinesFilter ff
let fs = map (getFunction t0) ts ++ map (checkDefine t0) ds
collectFirstM_ fs <!!
"Function " ++ show n ++ " not available for param " ++ show p ++ formatFullContextBrace c
fs2 <- collectAnyM fs
collectFirstM $ map (tryMergeFrom fs2) fs2 ++ [multipleMatchError p fs2]
getFromSingle t0 (JustTypeInstance t2)
-- Same category as the procedure itself.
| tiName t2 == ctx ^. pcType =
subAndCheckFunction t0 (tiName t2) (fmap vpParam $ ctx ^. pcExtParams) (tiParams t2) $ n `Map.lookup` (ctx ^. pcFunctions)
-- A different category than the procedure.
| otherwise = do
(_,ca) <- getCategory (ctx ^. pcCategories) (c,tiName t2)
let params = Positional $ map vpParam $ getCategoryParams ca
let fa = Map.fromList $ map (\f -> (sfName f,f)) $ getCategoryFunctions ca
subAndCheckFunction t0 (tiName t2) params (tiParams t2) $ n `Map.lookup` fa
getFromSingle _ _ = compilerErrorM $ "Type " ++ show t ++ " contains unresolved types"
checkDefine t0 t2 = do
(_,ca) <- getCategory (ctx ^. pcCategories) (c,diName t2)
let params = Positional $ map vpParam $ getCategoryParams ca
let fa = Map.fromList $ map (\f -> (sfName f,f)) $ getCategoryFunctions ca
subAndCheckFunction t0 (diName t2) params (diParams t2) $ n `Map.lookup` fa
subAndCheckFunction t0 t2 ps1 ps2 (Just f) = do
when (ctx ^. pcDisallowInit && t2 == ctx ^. pcType) $
compilerErrorM $ "Function " ++ show n ++
" disallowed during initialization" ++ formatFullContextBrace c
when (sfScope f == CategoryScope) $
compilerErrorM $ "Function " ++ show n ++ " in " ++ show t2 ++
" is a category function" ++ formatFullContextBrace c
paired <- processPairs alwaysPair ps1 ps2 <??
"In external function call at " ++ formatFullContext c
let assigned = Map.fromList paired
uncheckedSubFunction assigned f >>= replaceSelfFunction (fixTypeParams t0)
subAndCheckFunction _ t2 _ _ _ =
compilerErrorM $ "Category " ++ show t2 ++
" does not have a type or value function named " ++ show n ++
formatFullContextBrace c
ccCheckValueInit ctx c (TypeInstance t as) ts
| t /= ctx ^. pcType =
compilerErrorM $ "Category " ++ show (ctx ^. pcType) ++ " cannot initialize values from " ++
show t ++ formatFullContextBrace c
| otherwise = "In initialization at " ++ formatFullContext c ??> do
let t' = TypeInstance (ctx ^. pcType) as
r <- ccResolver ctx
allFilters <- ccAllFilters ctx
pa <- fmap Map.fromList $ processPairs alwaysPair (fmap vpParam $ ctx ^. pcExtParams) as
validateTypeInstanceForCall r allFilters t'
-- Check initializer types.
ms <- fmap Positional $ mapCompilerM (subSingle pa) (ctx ^. pcMembers)
-- Do a size comparison first so that the error message is readable.
processPairs_ alwaysPair (fmap mvType ms) ts
processPairs_ (checkInit r allFilters) ms (Positional $ zip ([1..] :: [Int]) $ pValues ts)
return ()
where
checkInit r fa (MemberValue c2 n t0) (i,t1) = do
checkValueAssignment r fa t1 t0 <??
"In initializer " ++ show i ++ " for " ++ show n ++ formatFullContextBrace c2
subSingle pa (DefinedMember c2 _ t2 n _) = do
t2' <- uncheckedSubValueType (getValueForParam pa) t2
return $ MemberValue c2 n t2'
ccGetVariable ctx (UsedVariable c n) =
case n `Map.lookup` (ctx ^. pcVariables) of
(Just (VariableValue _ _ _ (VariableHidden []))) ->
compilerErrorM $ "Variable " ++ show n ++ formatFullContextBrace c ++
" is hidden"
(Just (VariableValue _ _ _ (VariableHidden c2))) ->
compilerErrorM $ "Variable " ++ show n ++ formatFullContextBrace c ++
" was explicitly hidden at " ++ formatFullContext c2
(Just v) -> return v
_ -> compilerErrorM $ "Variable " ++ show n ++ formatFullContextBrace c ++ " is not defined"
ccAddVariable ctx (UsedVariable c n) t = do
case n `Map.lookup` (ctx ^. pcVariables) of
Nothing -> return ()
(Just v) -> compilerErrorM $ "Variable " ++ show n ++
formatFullContextBrace c ++
" is already defined: " ++ show v
return $ ctx & pcVariables <>~ Map.fromList [(n,t)]
ccSetReadOnly ctx v@(UsedVariable c n) = do
(VariableValue c2 s t _) <- ccGetVariable ctx v
return $ ctx & pcVariables %~ Map.insert n (VariableValue c2 s t (VariableReadOnly c))
ccSetDeferred ctx v@(UsedVariable c n) = do
(VariableValue c2 _ t r) <- ccGetVariable ctx v
case r of
VariableReadOnly c3 -> compilerErrorM $ "Variable " ++ show n ++ formatFullContextBrace c2 ++
" cannot be marked as deferred " ++ formatFullContextBrace c ++
" because it is read-only" ++ formatFullContextBrace c3
VariableHidden c3 -> compilerErrorM $ "Variable " ++ show n ++ formatFullContextBrace c2 ++
" cannot be marked as deferred " ++ formatFullContextBrace c ++
" because it is hidden" ++ formatFullContextBrace c3
_ -> return ()
return $ ctx & pcDeferred %~ addDeferred n (PassedValue c t)
ccSetHidden ctx v@(UsedVariable c n) = do
(VariableValue c2 s t _) <- ccGetVariable ctx v
return $ ctx & pcVariables %~ Map.insert n (VariableValue c2 s t (VariableHidden c))
ccCheckVariableInit ctx vs
-- Deferred variables are checked during cleanup inlining.
| ctx ^. pcInCleanup = return ()
| otherwise = do
case ctx ^. pcReturns of
ValidateNames _ _ na -> mapCompilerM_ (checkSingle na) vs
_ -> return ()
mapCompilerM_ (checkSingle $ ctx ^. pcDeferred) vs
where
checkSingle na (UsedVariable c n) =
when (n `checkDeferred` na) $
compilerErrorM $ "Deferred variable " ++ show n ++
" might not be initialized" ++ formatFullContextBrace c
ccWrite ctx ss = return $ ctx & pcOutput <>~ ss
ccGetOutput = return . (^. pcOutput)
ccClearOutput ctx = return $ ctx & pcOutput .~ mempty
ccUpdateAssigned ctx n = return $ ctx & pcReturns %~ updateReturns & pcDeferred %~ updateDeferred where
updateReturns (ValidateNames ns ts ra) = ValidateNames ns ts $ n `removeDeferred` ra
updateReturns rs = rs
updateDeferred = (n `removeDeferred`)
ccAddUsed ctx v
| ctx ^. pcInCleanup = return $ ctx & pcUsedVars <>~ [v]
| otherwise = return ctx
ccInheritStatic ctx [] = return ctx
ccInheritStatic ctx cs = return $ ctx & pcReturns .~ returns & pcJumpType .~ jump & pcUsedVars .~ used & pcDeferred .~ deferred & pcTraces .~ traces where
traces = nub $ ctx ^. pcTraces ++ (concat $ map (^. pcTraces) cs)
used = ctx ^. pcUsedVars ++ (concat $ map (^. pcUsedVars) cs)
deferred = (ctx ^. pcDeferred) `followDeferred` deferred2
(returns,jump) = combineSeries (ctx ^. pcReturns,ctx ^. pcJumpType) (returns2,jump2)
combineSeries (r@(ValidatePositions _),j1) (_,j2) = (r,max j1 j2)
combineSeries (_,j1) (r@(ValidatePositions _),j2) = (r,max j1 j2)
combineSeries (ValidateNames ns ts ra1,j1) (ValidateNames _ _ ra2,j2) = (ValidateNames ns ts $ ra1 `followDeferred` ra2,max j1 j2)
(deferred2,returns2,jump2) = foldr combineParallel (emptyDeferred,ValidateNames (Positional []) (Positional []) emptyDeferred,JumpMax) $
zip3 (map (^. pcDeferred) cs) (map (^. pcReturns) cs) (map (^. pcJumpType) cs)
-- Ignore a branch if it jumps to a higher scope.
combineParallel (_,_,j1) (da2,r,j2) | j1 > NextStatement = (da2,r,min j1 j2)
combineParallel (da1,ValidateNames ns ts ra1,j1) (da2,ValidateNames _ _ ra2,j2) = (branchDeferred [da1,da2],ValidateNames ns ts $ branchDeferred [ra1,ra2],min j1 j2)
combineParallel (da1,r@(ValidatePositions _),j1) (da2,_,j2) = (branchDeferred [da1,da2],r,min j1 j2)
combineParallel (da1,_,j1) (da2,r@(ValidatePositions _),j2) = (branchDeferred [da1,da2],r,min j1 j2)
ccInheritDeferred ctx ds = return $ ctx & pcDeferred .~ deferred where
deferred = (ctx ^. pcDeferred) `followDeferred` ds
ccInheritUsed ctx ctx2 = return $ ctx & pcUsedVars <>~ (ctx2 ^. pcUsedVars)
ccRegisterReturn ctx c vs = do
returns <- check (ctx ^. pcReturns)
return $ ctx & pcReturns .~ returns & pcJumpType .~ JumpReturn
where
check (ValidatePositions rs) = do
let vs' = case vs of
Nothing -> Positional []
Just vs2 -> vs2
-- Check for a count match first, to avoid the default error message.
processPairs_ alwaysPair (fmap pvType rs) vs' <??
"In procedure return at " ++ formatFullContext c
processPairs_ checkReturnType rs (Positional $ zip ([0..] :: [Int]) $ pValues vs') <??
"In procedure return at " ++ formatFullContext c
return (ValidatePositions rs)
where
checkReturnType ta0@(PassedValue _ t0) (n,t) = do
r <- ccResolver ctx
pa <- ccAllFilters ctx
checkValueAssignment r pa t t0 <!!
"Cannot convert " ++ show t ++ " to " ++ show ta0 ++ " in return " ++
show n ++ " at " ++ formatFullContext c
check (ValidateNames ns ts ra) = do
case vs of
Just _ -> check (ValidatePositions ts) >> return ()
Nothing -> mapCompilerM_ alwaysError $ Map.toList $ dvDeferred ra
return (ValidateNames ns ts emptyDeferred)
alwaysError (n,_) = compilerErrorM $ "Named return " ++ show n ++
" might not be initialized" ++
formatFullContextBrace c
ccPrimNamedReturns = return . (^. pcPrimNamed)
ccIsUnreachable ctx
| ctx ^. pcInCleanup = return $ ctx ^. pcJumpType > JumpReturn
| otherwise = return $ ctx ^. pcJumpType > NextStatement
ccIsNamedReturns = return . (^. pcIsNamed)
ccSetJumpType ctx c j
| ctx ^. pcInCleanup && j == JumpBreak =
compilerErrorM $ "Explicit break at " ++ formatFullContext c ++ " not allowed in cleanup"
| ctx ^. pcInCleanup && j == JumpContinue =
compilerErrorM $ "Explicit continue at " ++ formatFullContext c ++ " not allowed in cleanup"
| ctx ^. pcInCleanup && j == JumpReturn =
compilerErrorM $ "Explicit return at " ++ formatFullContext c ++ " not allowed in cleanup"
| otherwise = return $ ctx & pcJumpType %~ max j
ccStartLoop ctx l = return $ ctx & pcLoopSetup .~ l & pcCleanupBlocks %~ (Nothing:)
ccGetLoop = return . (^. pcLoopSetup)
ccStartCleanup ctx c = do
let vars = protectReturns (ctx ^. pcReturns) (ctx ^. pcVariables)
return $ ctx & pcVariables .~ vars & pcInCleanup .~ True where
protectReturns (ValidateNames ns _ _) vs = foldr protect vs (pValues ns)
protectReturns _ vs = vs
protect n vs =
case n `Map.lookup` vs of
Just (VariableValue c2 s@LocalScope t _) -> Map.insert n (VariableValue c2 s t (VariableReadOnly c)) vs
_ -> vs
ccPushCleanup ctx ctx2 = return $ ctx & pcCleanupBlocks %~ (Just cleanup:) & pcTraces .~ traces where
traces = nub $ ctx ^. pcTraces ++ ctx2 ^. pcTraces
cleanup = CleanupBlock (ctx2 ^. pcOutput) (ctx2 ^. pcDeferred) (ctx2 ^. pcUsedVars) (ctx2 ^. pcJumpType) (ctx2 ^. pcRequiredTypes)
ccGetCleanup ctx j = return combined where
combined
| j == NextStatement =
case ctx ^. pcCleanupBlocks of
((Just b):_) -> b
_ -> emptyCleanupBlock
| j == JumpReturn = combine $ map fromJust $ filter isJust $ ctx ^. pcCleanupBlocks
| j == JumpBreak || j == JumpContinue = combine $ map fromJust $ takeWhile isJust $ ctx ^. pcCleanupBlocks
| otherwise = emptyCleanupBlock
combine cs = CleanupBlock (concat $ map csCleanup cs)
(foldr followDeferred (ctx ^. pcDeferred) $ map csDeferred cs)
(concat $ map csUsesVars cs)
(foldr max NextStatement (map csJumpType cs))
(Set.unions $ map csRequires cs)
ccExprLookup ctx c n =
case n `Map.lookup` (ctx ^. pcExprMap) of
Nothing -> compilerErrorM $ "Env expression " ++ show n ++ " is not defined" ++ formatFullContextBrace c
Just e -> do
checkReserved (ctx ^. pcReservedMacros) [(n,c)]
return e
where
checkReserved [] _ = return ()
checkReserved (m@(n2,_):ms) rs
| n2 /= n = checkReserved ms (m:rs)
| otherwise = (mapCompilerM_ singleError (m:rs)) <!!
"Expression macro " ++ show n ++ " references itself"
singleError (n2,c2) = compilerErrorM $ show n2 ++ " expanded at " ++ formatFullContext c2
ccReserveExprMacro ctx c n = return $ ctx & pcReservedMacros %~ ((n,c):)
ccReleaseExprMacro ctx _ n = return $ ctx & pcReservedMacros %~ (filter ((/= n) . fst))
ccSetNoTrace ctx t = return $ ctx & pcNoTrace .~ t
ccGetNoTrace = return . (^. pcNoTrace)
ccGetTestsOnly = return . (^. pcTestsOnly)
ccAddTrace ctx "" = return ctx
ccAddTrace ctx t = return $ ctx & pcTraces <>~ [t]
ccGetTraces = return . (^. pcTraces)
ccCanForward ctx ps as = handle (ctx ^. pcParentCall) where
nameOrError (InputValue _ n) = return n
nameOrError _ = emptyErrorM
handle Nothing = return False
handle (Just (ps0,as0)) = collectFirstM [checkMatch ps0 as0,return False]
checkMatch ps0 as0 = do
as0' <- fmap Positional $ mapCompilerM (nameOrError . snd) $ pValues as0
processPairs_ equalOrError ps0 (Positional ps)
processPairs_ equalOrError as0' (Positional as)
return True
equalOrError x y
| x == y = return ()
| otherwise = emptyErrorM
ccDelegateArgs ctx = handle (ctx ^. pcParentCall) where
nameOrError (l,InputValue _ n) = return (l,n)
nameOrError (_,DiscardInput c) = compilerErrorM $ "Delegation is not allowed with ignored args" ++ formatFullContextBrace c
handle Nothing = compilerErrorM "Delegation is only allowed within function calls"
handle (Just (_,as0)) = fmap Positional $ mapCompilerM nameOrError $ pValues as0
updateReturnVariables :: (Show c, CollectErrorsM m) =>
(Map.Map VariableName (VariableValue c)) ->
Positional (PassedValue c) -> ReturnValues c ->
m (Map.Map VariableName (VariableValue c))
updateReturnVariables ma rs1 rs2 = updated where
updated
| isUnnamedReturns rs2 = return ma
| otherwise = do
rs <- processPairs alwaysPair rs1 (nrNames rs2)
foldr update (return ma) rs where
update (PassedValue c t,r) va = do
va' <- va
case ovName r `Map.lookup` va' of
Nothing -> return $ Map.insert (ovName r) (VariableValue c LocalScope t VariableDefault) va'
(Just v) -> compilerErrorM $ "Variable " ++ show (ovName r) ++
formatFullContextBrace (ovContext r) ++
" is already defined" ++
formatFullContextBrace (vvContext v)
updateArgVariables :: (Show c, CollectErrorsM m) =>
(Map.Map VariableName (VariableValue c)) ->
Positional (PassedValue c, Maybe (CallArgLabel c)) -> ArgValues c ->
m (Map.Map VariableName (VariableValue c))
updateArgVariables ma as1 as2 = do
as <- processPairs alwaysPair as1 (avNames as2)
let as' = filter (not . isDiscardedInput . snd) as
foldM update ma as' where
checkName (Just l) (InputValue c (VariableName n))
| l `matchesCallArgLabel` n = return ()
| otherwise = compilerWarningM $ "Variable " ++ n ++
formatFullContextBrace c ++
" has a different name than arg label " ++ show l
checkName _ _ = return ()
update va ((PassedValue _ t,n),a) = do
let c = ivContext a
case ivName a `Map.lookup` va of
Nothing -> return ()
(Just v) -> compilerErrorM $ "Variable " ++ show (ivName a) ++
formatFullContextBrace c ++
" is already defined" ++
formatFullContextBrace (vvContext v)
checkName n a
return $ Map.insert (ivName a) (VariableValue c LocalScope t (VariableReadOnly c)) va