module CSPM.Evaluator.Values (
Value(..), UProc, UProcOperator, Proc(..), CSPOperator(..),
ProcOperator(..), Event(..), EventSet,
ScopeIdentifier(..), FunctionIdentifier(..),
compareValues,
procName, scopeId, annonymousScopeId,
valueEventToEvent,
noSave, maybeSave, removeThunk, lookupVar,
tupleFromList,
trimValueForProcessName,
module Data.Array,
) where
import CSPM.DataStructures.Names
import CSPM.DataStructures.Syntax
import CSPM.DataStructures.Types
import CSPM.Evaluator.Monad
import CSPM.Evaluator.ProcessValues
import qualified CSPM.Evaluator.ValueSet as S
import Data.Array
import qualified Data.Foldable as F
import Data.Hashable
import qualified Data.Map as M
import Prelude hiding (lookup)
import Util.Exception
import Util.Prelude
type UProc = UnCompiledProc
type UProcOperator = UnCompiledProcOperator
data Value =
VInt Int
| VChar Char
| VBool Bool
| VTuple (Array Int Value)
| VDot [Value]
| VChannel Name
| VDataType Name
| VList [Value]
| VMap (M.Map Value Value)
| VSet S.ValueSet
| VFunction FunctionIdentifier ([Value] -> EvaluationMonad Value)
| VProc UProc
| VThunk (EvaluationMonad Value)
data ScopeIdentifier =
SFunctionBind {
scopeFunctionName :: Name,
scopeFunctionArguments :: [[Value]],
parentScopeIdentifier :: Maybe ScopeIdentifier
}
| SVariableBind {
variablesBound :: [Value],
parentScopeIdentifier :: Maybe ScopeIdentifier
}
instance Eq ScopeIdentifier where
SFunctionBind n1 vss1 p1 == SFunctionBind n2 vss2 p2 =
n1 == n2 && vss1 == vss2 && p1 == p2
SVariableBind vs1 p1 == SVariableBind vs2 p2 =
vs1 == vs2 && p1 == p2
instance Hashable ScopeIdentifier where
hash (SFunctionBind n1 args1 p1) =
combine 1 (combine (hash n1) (combine (hash args1) (hash p1)))
hash (SVariableBind vs1 p1) = combine 2 (combine (hash vs1) (hash p1))
instance Ord ScopeIdentifier where
compare (SFunctionBind n1 vss1 p1) (SFunctionBind n2 vss2 p2) =
compare n1 n2 `thenCmp` compare vss1 vss2 `thenCmp` compare p1 p2
compare (SFunctionBind _ _ _) _ = LT
compare _ (SFunctionBind _ _ _) = GT
compare (SVariableBind vs1 p1) (SVariableBind vs2 p2) =
compare vs1 vs2 `thenCmp` compare p1 p2
data FunctionIdentifier =
FBuiltInFunction {
functionName :: Name,
arguments :: [Value]
}
| FLambda {
lambdaExpression :: Exp Name,
parentFunctionIdentifier :: Maybe ScopeIdentifier
}
| FMatchBind {
functionName :: Name,
argumentGroups :: [[Value]],
scopeIdentifier :: Maybe ScopeIdentifier
}
instance Eq FunctionIdentifier where
FBuiltInFunction n1 vs1 == FBuiltInFunction n2 vs2 =
n1 == n2 && vs1 == vs2
FLambda e1 parent1 == FLambda e2 parent2 =
e1 == e2 && parent1 == parent2
FMatchBind n1 args1 parent1 == FMatchBind n2 args2 parent2 =
n1 == n2 && args1 == args2 && parent1 == parent2
_ == _ = False
instance Hashable FunctionIdentifier where
hash (FBuiltInFunction n1 vs) = combine 2 (combine (hash n1) (hash vs))
hash (FLambda expr parent) =
combine 3 (combine (hash (show expr)) (hash parent))
hash (FMatchBind n vs parent) =
combine 4 (combine (hash n) (combine (hash vs) (hash parent)))
instance Ord FunctionIdentifier where
compare (FBuiltInFunction n1 args1) (FBuiltInFunction n2 args2) =
compare n1 n2 `thenCmp` compare args1 args2
compare (FBuiltInFunction _ _) _ = LT
compare _ (FBuiltInFunction _ _) = GT
compare (FLambda e1 parent1) (FLambda e2 parent2) =
compare parent1 parent2 `thenCmp` compare e1 e2
compare (FLambda _ _) _ = LT
compare _ (FLambda _ _) = GT
compare (FMatchBind n1 vs1 parent1) (FMatchBind n2 vs2 parent2) =
compare n1 n2 `thenCmp` compare parent1 parent2 `thenCmp` compare vs1 vs2
tupleFromList :: [Value] -> Value
tupleFromList vs = VTuple $! listArray (0, length vs 1) vs
noSave :: EvaluationMonad Value -> EvaluationMonad Value
noSave prog = do
pn <- getParentScopeIdentifier
tok <- gets timedSection
return $ VThunk $ modify (\ st -> st {
CSPM.Evaluator.Monad.parentScopeIdentifier = pn,
timedSection = tok }) prog
maybeSave :: Type -> EvaluationMonad Value -> EvaluationMonad Value
maybeSave TProc prog = noSave prog
maybeSave _ prog = prog
removeThunk :: Value -> EvaluationMonad Value
removeThunk (VThunk p) = p
removeThunk v = return v
lookupVar :: Name -> EvaluationMonad Value
lookupVar n = lookupVarMaybeThunk n >>= removeThunk
instance (Ix i, Hashable a) => Hashable (Array i a) where
hash arr = F.foldr combine 0 (fmap hash arr)
instance Hashable Value where
hash (VInt i) = combine 1 (hash i)
hash (VBool b) = combine 2 (hash b)
hash (VChar c) = combine 3 (hash c)
hash (VTuple vs) = combine 5 (hash vs)
hash (VDot vs) = combine 6 (hash vs)
hash (VChannel n) = combine 7 (hash n)
hash (VDataType n) = combine 8 (hash n)
hash (VList vs) = combine 9 (hash vs)
hash (VSet vset) = combine 10 (hash vset)
hash (VFunction id _) = combine 11 (hash id)
hash (VProc p) = combine 12 (hash p)
hash (VMap m) = combine 13 (hash (M.toList m))
instance Eq Value where
VInt i1 == VInt i2 = i1 == i2
VBool b1 == VBool b2 = b1 == b2
VChar c1 == VChar c2 = c1 == c2
VTuple vs1 == VTuple vs2 = vs1 == vs2
VDot vs1 == VDot vs2 = vs1 == vs2
VChannel n1 == VChannel n2 = n1 == n2
VDataType n1 == VDataType n2 = n1 == n2
VList vs1 == VList vs2 = vs1 == vs2
VSet s1 == VSet s2 = s1 == s2
VProc p1 == VProc p2 = p1 == p2
VFunction id1 _ == VFunction id2 _ = id1 == id2
VMap m1 == VMap m2 = m1 == m2
v1 == v2 = False
compareValues :: Value -> Value -> Maybe Ordering
compareValues (VInt i1) (VInt i2) = Just (compare i1 i2)
compareValues (VChar c1) (VChar c2) = Just (compare c1 c2)
compareValues (VBool b1) (VBool b2) = Just (compare b1 b2)
compareValues (VTuple vs1) (VTuple vs2) =
let
(l, u) = bounds vs1
cmp ix | ix > u = EQ
cmp ix = compare (vs1!ix) (vs2!ix) `thenCmp` cmp (ix+1)
in Just (cmp 0)
compareValues (VList vs1) (VList vs2) =
let
cmp [] [] = Just EQ
cmp [] (y:ys) = Just LT
cmp (x:xs) [] = Just GT
cmp (x:xs) (y:ys) | x == y = cmp xs ys
cmp (x:xs) (y:ys) =
Nothing
in cmp vs1 vs2
compareValues (VSet s1) (VSet s2) = S.compareValueSets s1 s2
compareValues (VMap m1) (VMap m2) =
let cmp v1 v2 =
case compareValues v1 v2 of
Just LT -> True
Just EQ -> True
_ -> False
in if m1 == m2 then Just EQ
else if M.isSubmapOfBy cmp m1 m2 then Just LT
else if M.isSubmapOfBy cmp m2 m1 then Just GT
else Nothing
compareValues (VChannel n1) (VChannel n2) =
if n1 == n2 then Just EQ else Nothing
compareValues (VDataType n1) (VDataType n2) =
if n1 == n2 then Just EQ else Nothing
compareValues (VDot vs1) (VDot vs2) =
if vs1 == vs2 then Just EQ else Nothing
compareValues v1 v2 = panic $ "Cannot compare two values"
instance Ord Value where
compare (VInt i1) (VInt i2) = compare i1 i2
compare (VChar c1) (VChar c2) = compare c1 c2
compare (VBool b1) (VBool b2) = compare b1 b2
compare (VTuple vs1) (VTuple vs2) = compare vs1 vs2
compare (VList vs1) (VList vs2) = compare vs1 vs2
compare (VSet s1) (VSet s2) = compare s1 s2
compare (VMap m1) (VMap m2) = compare m1 m2
compare (VDot vs1) (VDot vs2) = compare vs1 vs2
compare (VChannel n) (VChannel n') = compare n n'
compare (VDataType n) (VDataType n') = compare n n'
compare (VProc p1) (VProc p2) = compare p1 p2
compare (VFunction id1 _) (VFunction id2 _) = compare id1 id2
compare v1 v2 = panic $
"Internal sets - cannot order "
procName :: ScopeIdentifier -> ProcName
procName = ProcName
scopeId :: Name -> [[Value]] -> Maybe ScopeIdentifier -> ScopeIdentifier
scopeId n vss pn = SFunctionBind n (map (map trimValueForProcessName) vss) pn
annonymousScopeId :: [Value] -> Maybe ScopeIdentifier -> ScopeIdentifier
annonymousScopeId vss pn = SVariableBind (map trimValueForProcessName vss) pn
valueEventToEvent :: Value -> Event
valueEventToEvent = UserEvent
errorThunk = panic "Trimmed value function evaluated"
trimFunctionIdentifier :: FunctionIdentifier -> FunctionIdentifier
trimFunctionIdentifier (FBuiltInFunction n args) =
FBuiltInFunction n (map trimValueForProcessName args)
trimFunctionIdentifier (FLambda e p) = FLambda e p
trimFunctionIdentifier (FMatchBind n args p) =
FMatchBind n (map (map trimValueForProcessName) args) p
trimValueForProcessName :: Value -> Value
trimValueForProcessName (VInt i) = VInt i
trimValueForProcessName (VChar c) = VChar c
trimValueForProcessName (VBool b) = VBool b
trimValueForProcessName (VTuple vs) = VTuple (fmap trimValueForProcessName vs)
trimValueForProcessName (VList vs) = VList (map trimValueForProcessName vs)
trimValueForProcessName (VSet s) =
VSet $ S.fromList $ map trimValueForProcessName $ S.toList s
trimValueForProcessName (VMap m) = VMap $ M.fromList $
map (\ (v1, v2) -> (trimValueForProcessName v1, trimValueForProcessName v2))
(M.toList m)
trimValueForProcessName (VDot vs) = VDot $ map trimValueForProcessName vs
trimValueForProcessName (VChannel n) = VChannel n
trimValueForProcessName (VDataType n) = VDataType n
trimValueForProcessName (VFunction id _) =
VFunction (trimFunctionIdentifier id) errorThunk
trimValueForProcessName (VProc p) = VProc (trimProcess p)