module CSPM.Evaluator.DeclBind (
bindDecls,
) where
import Data.List (partition)
import CSPM.DataStructures.Names
import CSPM.DataStructures.Syntax
import CSPM.DataStructures.Types
import CSPM.Evaluator.BuiltInFunctions
import CSPM.Evaluator.Dot
import CSPM.Evaluator.Exceptions
import CSPM.Evaluator.Expr
import CSPM.Evaluator.Monad
import CSPM.Evaluator.PatBind
import CSPM.Evaluator.Profiler
import CSPM.Evaluator.Values
import CSPM.Evaluator.ValueSet
import Util.Annotated
import Util.Monad
bindDecls :: [TCDecl] -> EvaluationMonad [(Name, EvaluationMonad Value)]
bindDecls ds = do
registerCall <- maybeRegisterCall
nvs <- concatMapM bindDecl ds
let eventsName = builtInName "Events"
(eventNvs, normalNvs) = partition (\x -> fst x == eventsName) nvs
computeEvents vs = registerCall eventsName $ do
vss <- sequence (map snd eventNvs)
return $ VSet $ infiniteUnions $ vs : map (\ (VSet s) -> s) vss
isChannelDecl (Channel _ _) = True
isChannelDecl _ = False
if or (map (isChannelDecl . unAnnotate) ds) then do
VSet vs <- lookupVar eventsName
return $ (eventsName, computeEvents vs) : normalNvs
else return nvs
bindDecl :: TCDecl -> EvaluationMonad [(Name, EvaluationMonad Value)]
bindDecl (an@(An _ _ (FunBind n ms _))) = do
parentScope <- getParentScopeIdentifier
registerCall <- maybeRegisterCall
let
matches = map unAnnotate ms
argGroupCount = head (map (\ (Match pss e) -> length pss) matches)
collectArgs :: Int -> [[Value]] -> EvaluationMonad Value
collectArgs 0 ass_ =
let
scopeName = scopeId n argGroups parentScope
argGroups = reverse ass_
tryMatches [] = throwError $
funBindPatternMatchFailureMessage (loc an) n argGroups
tryMatches (Match pss e : ms) =
let
bindResult = zipWith bindAll pss argGroups
(bindResults, boundValuess) = unzip bindResult
binds = concat boundValuess
in
if not (and bindResults) then tryMatches ms
else
addScopeAndBind binds $ updateParentScopeIdentifier scopeName $ do
v <- registerCall n $ eval e
case v of
VProc p -> return $ VProc $ PProcCall (procName scopeName) p
_ -> return $ v
in tryMatches matches
collectArgs number ass = do
st <- gets id
let fid = FMatchBind n (reverse ass) parentScope
return $ VFunction fid $ \ vs ->
(if profilerActive st then
modify (\ st' -> st {
profilerState = profilerState st'
})
else modify (\ _ -> st)) $ collectArgs (number1) (vs:ass)
return $ [(n, collectArgs argGroupCount [])]
bindDecl (an@(An _ _ (PatBind p e _))) = do
parentScope <- getParentScopeIdentifier
registerCall <- maybeRegisterCall
let [(n, ForAll _ t)] = getSymbolTable an
scopeName = scopeId n [] parentScope
ev = maybeSave t $ updateParentScopeIdentifier scopeName $ do
v <- registerCall n $ eval e
case bind p v of
(True, [(n', val)]) | n == n' -> return $!
case val of
VProc p -> VProc $ PProcCall (procName scopeName) p
_ -> val
(False, _) -> throwError $
patternMatchFailureMessage (loc an) p v
return $ [(n, ev)]
bindDecl (an@(An _ _ (Channel ns me))) = do
registerCall <- maybeRegisterCall
let
mkChan :: Name -> EvaluationMonad Value
mkChan n = registerCall n $ do
fields <- case me of
Just e -> eval e >>= evalTypeExprToList n
Nothing -> return []
let arity = fromIntegral (length fields)
return $! tupleFromList [VDot [VChannel n], VInt arity, tupleFromList (map VSet fields)]
eventSetValue :: EvaluationMonad Value
eventSetValue = do
ss <- mapM (\ n -> do
(_, _, fields) <- dataTypeInfo n
let fs = fromList [VChannel n] : elems fields
return $ cartesianProduct CartDot fs) ns
return $ VSet (infiniteUnions ss)
return $ (builtInName "Events", eventSetValue) : [(n, mkChan n) | n <- ns]
bindDecl (an@(An _ _ (DataType n cs))) = do
registerCall <- maybeRegisterCall
let
mkDataTypeClause :: DataTypeClause Name -> (Name, EvaluationMonad Value)
mkDataTypeClause (DataTypeClause nc me) = (nc, do
vss <- case me of
Just e -> eval e >>= evalTypeExprToList nc
Nothing -> return []
let arity = fromIntegral (length vss)
return $ tupleFromList [VDot [VDataType nc], VInt arity, tupleFromList (map VSet vss)])
computeSetOfValues :: EvaluationMonad Value
computeSetOfValues =
let
mkSet nc = do
(_, _, fields) <- dataTypeInfo nc
let fs = fromList [VDataType nc] : elems fields
return $ cartesianProduct CartDot fs
in registerCall n $ do
vs <- mapM mkSet [nc | DataTypeClause nc _ <- map unAnnotate cs]
return $ VSet (infiniteUnions vs)
return $ (n, computeSetOfValues):(map mkDataTypeClause (map unAnnotate cs))
bindDecl (an@(An _ _ (SubType n cs))) = do
registerCall <- maybeRegisterCall
let
computeSetOfValues =
let
mkSet (DataTypeClause nc me) = do
(_, _, fields) <- dataTypeInfo nc
fs <- case me of
Just e -> eval e >>= evalTypeExprToList nc
Nothing -> return []
let s = cartesianProduct CartDot (fromList [VDataType nc] : fs)
vs <- mapM productionsSet (toList s)
return (infiniteUnions vs)
in registerCall n $ do
vs <- mapM (mkSet . unAnnotate) cs
return $ VSet (infiniteUnions vs)
return $ [(n, computeSetOfValues)]
bindDecl (an@(An _ _ (NameType n e))) = do
registerCall <- maybeRegisterCall
return $ [(n, registerCall n $ do
v <- eval e
sets <- evalTypeExprToList n v
case sets of
[s] -> return $ VSet s
_ -> return $ VSet $ cartesianProduct CartDot sets)]
bindDecl (an@(An _ _ (Assert _))) = return []
bindDecl (an@(An _ _ (External ns))) = return []
bindDecl (an@(An _ _ (Transparent ns))) = return []
bindDecl (an@(An _ _ (TimedSection (Just tn) f ds))) = do
nds <- concatMapM bindDecl ds
let packageDecl :: EvaluationMonad Value -> EvaluationMonad Value
packageDecl value = do
st <- gets id
func <- case f of
Just f -> do
VFunction _ wrappedFunc <- eval f
let func (UserEvent v) = c
where VInt c = runEvaluator st (wrappedFunc [v])
return func
Nothing -> return $ \ (UserEvent _) -> 1
return $! runEvaluator st $ setTimedCSP tn func value
return $! map (\ (n,d) -> (n, packageDecl d)) nds
bindDecl (an@(An _ _ (PrintStatement _))) = return []
evalTypeExpr :: Value -> ValueSet
evalTypeExpr (VSet s) = s
evalTypeExpr (VTuple vs) = cartesianProduct CartTuple (map evalTypeExpr (elems vs))
evalTypeExprToList :: Name -> Value -> EvaluationMonad [ValueSet]
evalTypeExprToList n (VDot vs) = concatMapM (evalTypeExprToList n) vs
evalTypeExprToList n v = splitIntoFields False n (evalTypeExpr v)