module CSPM.Interpreter.Types
where
import qualified Language.CSPM.AST as AST
import Language.CSPM.SrcLoc (SrcLoc)
import qualified CSPM.CoreLanguage as Core
import CSPM.Interpreter.SSet (SSet)
import Data.Digest.Pure.HashMD5 as HashMD5
import Data.IntMap as IntMap (IntMap,empty)
import qualified Control.Monad.Reader as Reader
import Control.Monad.Reader
import Control.Exception
import qualified Data.List as List
import Data.Typeable
import Data.Set (Set)
import Data.Map (Map)
import Data.Ord
import Data.Function
data INT
type Event = [Field]
type instance Core.Event INT = Event
type instance Core.EventSet INT = ClosureSet
type instance Core.RenamingRelation INT = RenamingRelation
type instance Core.ClosureState INT = ClosureState
type Field = Value
type instance Core.Field INT = Field
type FieldSet = SSet Field
type instance Core.FieldSet INT = FieldSet
type Process = Core.Process INT
type instance Core.ExtProcess INT = SwitchedOffProc
type Digest = HashMD5.MD5Digest
type instance Core.Prefix INT = PrefixState
type instance Core.PrefixState INT = GenericBufferPrefix
deriving instance Eq Process
deriving instance Ord Process
deriving instance Show Process
data ClosureSet
= ClosureSet {
closureSetTrie :: PrefixTrie
,closureSetDigest :: Digest
} deriving (Show)
instance Ord ClosureSet where
compare = comparing closureSetDigest
instance Eq ClosureSet where
(==) = on (==) closureSetDigest
data RenamingRelation
= RenamingRelation {
renamingPairs :: Set (Event,Event)
,renamingDomain :: Set Event
,renamingRange :: Set Event
,renamingDigest :: Digest
} deriving (Show)
instance Ord RenamingRelation where
compare = comparing renamingDigest
instance Eq RenamingRelation where
(==) = on (==) renamingDigest
data ClosureState
= ClosureStateNormal {
origClosureSet :: ClosureSet
,currentPrefixTrie :: PrefixTrie
}
| ClosureStateFailed { origClosureSet :: ClosureSet }
| ClosureStateSucc {
origClosureSet :: ClosureSet
,currentPrefixTrie :: PrefixTrie
}
deriving (Show,Eq,Ord)
data SwitchedOffProc
= SwitchedOffProc {
switchedOffDigest :: Digest
,switchedOffExpr :: AST.LExp
,switchedOffProcess :: Process
}
instance Ord SwitchedOffProc where
compare = comparing switchedOffDigest
instance Eq SwitchedOffProc where
(==) = on (==) switchedOffDigest
instance Show SwitchedOffProc where
show f = "(SwitchedOff " ++ (show $ switchedOffDigest f) ++ ")"
data PrefixState = PrefixState {
prefixEnv :: Env
,prefixFields :: [AST.LCommField]
,prefixBody :: AST.LExp
,prefixRHS :: Process
,prefixDigest :: Digest
,prefixPatternFailed :: Bool
}
instance Ord PrefixState where
compare = comparing prefixDigest
instance Eq PrefixState where
a == b = prefixDigest a == prefixDigest b
instance Show PrefixState where
show f = "(PrefixState " ++ (show $ prefixDigest f) ++ ")"
data GenericBufferPrefix
= GBOut [Value] PrefixState
| GBInput PrefixState
| GBInputGuard FieldSet PrefixState
| GBInputGeneric [Value] PrefixState
| GBFinished PrefixState
deriving (Show,Eq,Ord)
type Bindings = IntMap Value
data Env = Env {
argBindings :: Bindings
,letBindings :: Bindings
,letDigests :: IntMap Digest
}
initialEnvirionment :: IO Env
initialEnvirionment = return emptyEnvirionment
emptyEnvirionment :: Env
emptyEnvirionment = Env {
argBindings = IntMap.empty
,letBindings = IntMap.empty
,letDigests = IntMap.empty
}
newtype EM x = EM { unEM ::Reader Env x }
deriving (Monad,MonadReader Env)
getArgBindings :: Env -> Bindings
getArgBindings = argBindings
getLetBindings :: Env -> Bindings
getLetBindings = letBindings
setArgBindings :: Env -> Bindings -> Env
setArgBindings env b = env {argBindings=b}
setLetBindings :: Env -> Bindings -> Env
setLetBindings env b = env {letBindings=b}
getEnv :: EM Env
getEnv = Reader.ask
class Monad m => Eval m where
evalM :: AST.LExp -> m Value
data Value =
VInt Integer
| VBool Bool
| VList [Value]
| VTuple [Value]
| VDotTuple [Value]
| VSet (Set Value)
| VClosure ClosureSet
| VFun FunClosure
| VProcess Process
| VChannel Channel
| VUnit
| VAllInts
| VAllSequents (Set Value)
| VConstructor Constructor
| VDataType [Constructor]
| VNameType [FieldSet]
| VPartialApplied FunClosure [Value]
deriving (Ord,Eq)
data FunClosure = FunClosure {
getFunCases :: [AST.FunCase]
,getFunEnv :: Env
,getFunArgNum :: Int
,getFunId :: Digest
}
instance Eq FunClosure where
a == b = getFunId a == getFunId b
instance Ord FunClosure where
compare a b = compare (getFunId a) (getFunId b)
instance Show FunClosure where
show f = "(FunClosure " ++ (show $ getFunId f) ++ ")"
data Constructor = Constructor {
constrId ::Int
,constrName :: String
,constrFields :: [FieldSet]
} deriving (Show,Eq,Ord)
data Channel = Channel
{
chanId :: Int
,chanName :: String
,chanLen :: Int
,chanFields :: [FieldSet]
} deriving (Show,Eq,Ord)
isChannelField :: Field -> Bool
isChannelField (VChannel {} ) = True
isChannelField _ = False
getChannel :: Field -> Channel
getChannel (VChannel x) = x
getChannel _ = error "Eval.hs : getChannel on non-Channel"
instance Show Value where
show v = case v of
VInt i -> "(VInt " ++ show i ++ ")"
VBool b -> "(VBool " ++ show b ++ ")"
VList l -> "(VList " ++ show l ++ ")"
VTuple l -> "(VTuple " ++ show l ++ ")"
VDotTuple l -> "(VDotTuple " ++ show l ++ ")"
VSet s -> "(VSet " ++ show s ++ ")"
VClosure s -> "(VClosure " ++ show s ++ ")"
VProcess p -> "(VProcess " ++ show p ++ ")"
VChannel c -> "(VChannel " ++ show c ++ ")"
VFun _ -> "(VFun Functionclosure)"
VUnit -> "VUnit"
VAllInts -> "VAllInts"
VAllSequents _ -> "VAllSequents "
VConstructor c -> "(VConstructor " ++ (show $ constrName c) ++ ")"
VDataType l
-> "(VDataType " ++ (concat $ List.intersperse " " $ map (show . constrName) l ) ++")"
VNameType _ -> "VNameType"
VPartialApplied {} -> "(Partially applyed function)"
data PrefixTrie
= PTNil
| PTAny PrefixTrie
| PTMap (Map Value PrefixTrie)
| PTRec (Set Value) PrefixTrie
| PTSingle Value PrefixTrie
| PTClosure PrefixTrie
deriving (Show,Eq,Ord)
data InterpreterError
= ScriptError {errMsg :: String, errLoc :: Maybe SrcLoc, errVal :: Maybe Value}
| FeatureNotImplemented {errMsg :: String, errLoc :: Maybe SrcLoc }
| TypingError {errMsg :: String, errLoc :: Maybe SrcLoc, errVal :: Maybe Value}
| InternalError {errMsg :: String, errLoc :: Maybe SrcLoc, errVal :: Maybe Value }
| PatternMatchError {errMsg :: String ,errLoc :: Maybe SrcLoc}
deriving (Show,Typeable)
throwScriptError :: String -> Maybe SrcLoc -> Maybe Value -> a
throwScriptError m l v = throw $ ScriptError m l v
throwFeatureNotImplemented :: String -> Maybe SrcLoc -> a
throwFeatureNotImplemented m l = throw $ FeatureNotImplemented m l
throwTypingError :: String -> Maybe SrcLoc -> Maybe Value -> a
throwTypingError m l v = throw $ TypingError m l v
throwInternalError :: String -> Maybe SrcLoc -> Maybe Value -> a
throwInternalError m l v = throw $ InternalError m l v
throwPatternMatchError :: String -> Maybe SrcLoc -> a
throwPatternMatchError m l = throw $ PatternMatchError m l
instance Exception InterpreterError