zeolite-lang-0.13.0.0: src/Compilation/ProcedureContext.hs
{- -----------------------------------------------------------------------------
Copyright 2019-2021 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 (when)
import Lens.Micro hiding (mapped)
import Lens.Micro.TH
import Data.Maybe (fromJust,isJust)
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.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 :: Map.Map VariableName (PassedValue c)
}
deriving (Show)
data ProcedureContext c =
ProcedureContext {
_pcScope :: SymbolScope,
_pcType :: CategoryName,
_pcExtParams :: Positional (ValueParam c),
_pcIntParams :: Positional (ValueParam c),
_pcMembers :: [DefinedMember c],
_pcCategories :: CategoryMap c,
_pcAllFilters :: ParamFilters,
_pcExtFilters :: [ParamFilter c],
_pcIntFilters :: [ParamFilter c],
_pcParamScopes :: Map.Map ParamName SymbolScope,
_pcFunctions :: Map.Map FunctionName (ScopedFunction c),
_pcVariables :: Map.Map VariableName (VariableValue c),
_pcReturns :: ReturnValidation 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
}
$(makeLenses ''ProcedureContext)
instance (Show c, CollectErrorsM m) =>
CompilerContext c m [String] (ProcedureContext c) where
ccCurrentScope = return . (^. pcScope)
ccResolver = return . AnyTypeResolver . CategoryResolver . (^. pcCategories)
ccSameType ctx = return . (== same) where
same = 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 ++ " does not exist"
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 = getFunction t where
getFunction (Just t2) = reduceMergeTree getFromAny getFromAll getFromSingle t2
getFunction Nothing = do
let ps = fmap (singleType . JustParamName False . vpParam) $ ctx ^. pcExtParams
getFunction (Just $ singleType $ JustTypeInstance $ TypeInstance (ctx ^. pcType) ps)
getFromAny _ =
compilerErrorM $ "Use explicit type conversion to call " ++ show n ++ " from " ++ show t
getFromAll ts = do
collectFirstM ts <!!
"Function " ++ show n ++ " not available for type " ++ show t ++ formatFullContextBrace c
getFromSingle (JustParamName _ p) = do
fa <- ccAllFilters ctx
fs <- case p `Map.lookup` fa of
(Just fs) -> return fs
_ -> compilerErrorM $ "Param " ++ show p ++ " does not exist"
let ts = map tfType $ filter isRequiresFilter fs
let ds = map dfType $ filter isDefinesFilter fs
collectFirstM (map (getFunction . Just) ts ++ map checkDefine ds) <!!
"Function " ++ show n ++ " not available for param " ++ show p ++ formatFullContextBrace c
getFromSingle (JustTypeInstance t2)
-- Same category as the procedure itself.
| tiName t2 == ctx ^. pcType =
subAndCheckFunction (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 (tiName t2) params (tiParams t2) $ n `Map.lookup` fa
getFromSingle _ = compilerErrorM $ "Type " ++ show t ++ " contains unresolved types"
checkDefine 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 (diName t2) params (diParams t2) $ n `Map.lookup` fa
subAndCheckFunction 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
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 ps
| 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
pa2 <- fmap Map.fromList $ processPairs alwaysPair (fmap vpParam $ ctx ^. pcIntParams) ps
let pa' = Map.union pa pa2
validateTypeInstance r allFilters t'
-- Check internal param substitution.
let mapped = Map.fromListWith (++) $ map (\f -> (pfParam f,[pfFilter f])) (ctx ^. pcIntFilters)
let positional = map (getFilters mapped) (map vpParam $ pValues $ ctx ^. pcIntParams)
assigned <- fmap Map.fromList $ processPairs alwaysPair (fmap vpParam $ ctx ^. pcIntParams) ps
subbed <- fmap Positional $ mapErrorsM (assignFilters assigned) positional
processPairs_ (validateAssignment r allFilters) ps subbed
-- Check initializer types.
ms <- fmap Positional $ mapErrorsM (subSingle pa') (ctx ^. pcMembers)
processPairs_ (checkInit r allFilters) ms (Positional $ zip ([1..] :: [Int]) $ pValues ts)
return ()
where
getFilters fm n =
case n `Map.lookup` fm of
(Just fs) -> fs
_ -> []
assignFilters fm fs = do
mapErrorsM (uncheckedSubFilter $ getValueForParam fm) fs
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 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))
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
-- Returns are checked during cleanup inlining.
| ctx ^. pcInCleanup = return ()
| otherwise =
case ctx ^. pcReturns of
ValidateNames _ _ na -> mapErrorsM_ (checkSingle na) vs
_ -> return ()
where
checkSingle na (UsedVariable c n) =
when (n `Map.member` na) $
compilerErrorM $ "Named return " ++ 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 %~ update where
update (ValidateNames ns ts ra) = ValidateNames ns ts $ Map.delete n ra
update rs = rs
ccAddUsed ctx v
| ctx ^. pcInCleanup = return $ ctx & pcUsedVars <>~ [v]
| otherwise = return ctx
ccInheritReturns ctx cs = return $ ctx & pcReturns .~ returns & pcJumpType .~ jump & pcUsedVars .~ used where
used = ctx ^. pcUsedVars ++ (concat $ map (^. pcUsedVars) cs)
(returns,jump) = combineSeries (ctx ^. pcReturns,ctx ^. pcJumpType) inherited
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 $ Map.intersection ra1 ra2,max j1 j2)
inherited = foldr combineParallel (ValidateNames (Positional []) (Positional []) Map.empty,JumpMax) $ zip (map (^. pcReturns) cs) (map (^. pcJumpType) cs)
-- Ignore a branch if it jumps to a higher scope.
combineParallel (_,j1) (r,j2) | j1 > NextStatement = (r,min j1 j2)
combineParallel (ValidateNames ns ts ra1,j1) (ValidateNames _ _ ra2,j2) = (ValidateNames ns ts $ Map.union ra1 ra2,min j1 j2)
combineParallel (r@(ValidatePositions _),j1) (_,j2) = (r,min j1 j2)
combineParallel (_,j1) (r@(ValidatePositions _),j2) = (r,min j1 j2)
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 -> mapErrorsM_ alwaysError $ Map.toList ra
return (ValidateNames ns ts Map.empty)
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:) where
cleanup = CleanupBlock (ctx2 ^. pcOutput) (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)
(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 = (mapErrorsM_ 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)
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) -> 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
foldr update (return ma) as' where
update (PassedValue c t,a) va = do
va' <- va
case ivName a `Map.lookup` va' of
Nothing -> return $ Map.insert (ivName a) (VariableValue c LocalScope t (VariableReadOnly c)) va'
(Just v) -> compilerErrorM $ "Variable " ++ show (ivName a) ++
formatFullContextBrace (ivContext a) ++
" is already defined" ++
formatFullContextBrace (vvContext v)