CSPM-Interpreter (empty) → 0.1.0.0
raw patch · 20 files changed
+2837/−0 lines, 20 filesdep +CSPM-CoreLanguagedep +CSPM-Frontenddep +arraysetup-changed
Dependencies added: CSPM-CoreLanguage, CSPM-Frontend, array, base, containers, mtl, syb
Files
- CSPM-Interpreter.cabal +62/−0
- License +0/−0
- Setup.hs +3/−0
- src/CSPM/Interpreter.hs +52/−0
- src/CSPM/Interpreter/Bindings.hs +43/−0
- src/CSPM/Interpreter/ClosureSet.hs +164/−0
- src/CSPM/Interpreter/CoreInstances.hs +163/−0
- src/CSPM/Interpreter/Eval.hs +697/−0
- src/CSPM/Interpreter/GenericBufferPrefix.hs +99/−0
- src/CSPM/Interpreter/Hash.hs +146/−0
- src/CSPM/Interpreter/PatternMatcher.hs +217/−0
- src/CSPM/Interpreter/Prefix.hs +76/−0
- src/CSPM/Interpreter/PrepareAST.hs +125/−0
- src/CSPM/Interpreter/Renaming.hs +95/−0
- src/CSPM/Interpreter/SSet.hs +149/−0
- src/CSPM/Interpreter/Test/CLI.hs +139/−0
- src/CSPM/Interpreter/Types.hs +304/−0
- src/Data/Digest/Pure/HashMD5.hs +99/−0
- src/Data/Digest/Pure/MD5.hs +178/−0
- src/Main.hs +26/−0
+ CSPM-Interpreter.cabal view
@@ -0,0 +1,62 @@+Name: CSPM-Interpreter+Version: 0.1.0.0++Synopsis: An interpreter for CSPM+Description:+ This module contains an interpreter for CSPM+ and instance declarations than implement the interface defined in+ the package CSPM-CoreLanguage.+ All type family instances that belong to this implementation+ are indexed with the phantom-type 'INT' ('INT' == interpreter).+ The operational semantics of core-CSP is defined in a separate package.++License: BSD3+category: Language+License-File: License+Author: 2010 Marc Fontaine+Maintainer: Marc Fontaine <fontaine@cs.uni-duesseldorf.de>+cabal-Version: >= 1.6+build-type: Simple+Extra-source-files:+Library+ Build-Depends:+ CSPM-Frontend >= 0.3.0.0+ ,CSPM-CoreLanguage >= 0.1 && <= 0.2+ ,base >= 4.0 && < 5.0+ ,containers >= 0.3 && < 0.4+ ,mtl >= 1.1 && < 1.2+ ,array >= 0.3 && <0.4+ ,syb >= 0.1 && < 0.2+ + GHC-Options: -funbox-strict-fields -O2 -Wall+ Extensions: DeriveDataTypeable, GeneralizedNewtypeDeriving+ Hs-Source-Dirs: src+ Exposed-modules:+ CSPM.Interpreter+ CSPM.Interpreter.Types+ CSPM.Interpreter.Eval+ CSPM.Interpreter.CoreInstances+ CSPM.Interpreter.Hash+ CSPM.Interpreter.ClosureSet+ CSPM.Interpreter.Test.CLI+ Other-modules:+ CSPM.Interpreter.Renaming+ CSPM.Interpreter.PrepareAST+ CSPM.Interpreter.Bindings+ CSPM.Interpreter.PatternMatcher+ CSPM.Interpreter.Prefix+ CSPM.Interpreter.GenericBufferPrefix+ CSPM.Interpreter.SSet+ Data.Digest.Pure.MD5+ Data.Digest.Pure.HashMD5++Executable cspmEval+ Build-Depends:+ CSPM-Frontend >= 0.3.0.0+ ,CSPM-CoreLanguage >= 0.1 && <= 0.2+ ,base >= 4.0+ + GHC-Options: -funbox-strict-fields -O2 -Wall+ Extensions: DeriveDataTypeable, GeneralizedNewtypeDeriving+ Hs-Source-Dirs: src+ Main-is: Main.hs
+ License view
+ Setup.hs view
@@ -0,0 +1,3 @@+#!/usr/bin/env runhaskell+import Distribution.Simple+main = defaultMain
+ src/CSPM/Interpreter.hs view
@@ -0,0 +1,52 @@+----------------------------------------------------------------------------+-- |+-- Module : CSPM.Interpreter+-- Copyright : (c) Fontaine 2008+-- License : BSD+-- +-- Maintainer : Fontaine@cs.uni-duesseldorf.de+-- Stability : experimental+-- Portability : GHC-only+--+-- An API for the Interpreter.+--+----------------------------------------------------------------------------++module CSPM.Interpreter+(+ runFile+ ,evalTest+ ,getAllEvents+ ,prepareAST+ ,runInterpreter+ ,module CSPM.Interpreter.Types+ ,module CSPM.Interpreter.Bindings+ ,module CSPM.Interpreter.CoreInstances+)+where++import CSPM.Interpreter.Types+import CSPM.Interpreter.CoreInstances ()+import CSPM.Interpreter.Bindings+import CSPM.Interpreter.Eval+import CSPM.Interpreter.Hash (hs)+import CSPM.Interpreter.PrepareAST+import CSPM.Interpreter.Test.CLI++import Language.CSPM.AST as AST++import Data.IntMap as IntMap++-- | Run the interpreter for a given module and top-level identifier.+runInterpreter :: AST.LModule -> AST.UniqueIdent -> IO (Process,Env)+runInterpreter ast entry = do+ initEnv <- initialEnvirionment+ let+ env = processDeclList (hs "TopLevelEnvirionment") initEnv+ $ AST.moduleDecls $ unLabel ast+ val :: Value+ val = (IntMap.!) (getLetBindings env) $ AST.uniqueIdentId entry+ case val of+ VProcess x -> return (x,env)+ _ -> throwTypingError "entrypoint is not a CSPM-process" (Just $ AST.bindingLoc entry)+ $ Just val
+ src/CSPM/Interpreter/Bindings.hs view
@@ -0,0 +1,43 @@+----------------------------------------------------------------------------+-- |+-- Module : CSPM.Interpreter.Bindings+-- Copyright : (c) Fontaine 2008+-- License : BSD+-- +-- Maintainer : Fontaine@cs.uni-duesseldorf.de+-- Stability : experimental+-- Portability : GHC-only+--+----------------------------------------------------------------------------+module CSPM.Interpreter.Bindings+where++import CSPM.Interpreter.Types+import Language.CSPM.AST hiding (Bindings)++import Control.Exception+import Control.Monad.Reader+import Data.IntMap as IntMap+import Data.List as List++lookupIdent :: LIdent -> EM Value+lookupIdent i = do+ b <- getEnv+ let binds = case bindType $ unUIdent $ unLabel i of+ LetBound -> getLetBindings b+ NotLetBound -> getArgBindings b+ case (IntMap.lookup (identId i) binds) of+ Just v -> return v+ Nothing -> throw $ InternalError ("Bindings lookup failure :" ++ show i) Nothing Nothing++bindIdent :: LIdent -> Value -> Bindings -> Bindings+bindIdent key value bind = IntMap.insert (identId key) value bind++emptyBindings :: Bindings+emptyBindings = IntMap.empty ++lookupAllChannels :: EM [Channel]+lookupAllChannels = do+ letBinds <- liftM getLetBindings getEnv+ return $ List.map getChannel $ List.filter isChannelField + $ IntMap.elems letBinds
+ src/CSPM/Interpreter/ClosureSet.hs view
@@ -0,0 +1,164 @@+----------------------------------------------------------------------------+-- |+-- Module : CSPM.Interpreter.ClosureSets+-- Copyright : (c) Fontaine 2009+-- License : BSD+-- +-- Maintainer : Fontaine@cs.uni-duesseldorf.de+-- Stability : experimental+-- Portability : GHC-only+--+-- Utility functions dealing with closure sets.+--+----------------------------------------------------------------------------+{-+todo: redo this+todo: add testcases+this is all much to complex+-}+module CSPM.Interpreter.ClosureSet+where++import CSPM.Interpreter.Types as Types+import CSPM.Interpreter.SSet as SSet+import CSPM.Interpreter.Hash as Hash++import Data.List as List+import Data.Set (Set)+import qualified Data.Set as Set+import qualified Data.Map as Map+import Data.Maybe+import Data.Ord++memberPrefixTrie :: [Field] -> PrefixTrie -> Bool+memberPrefixTrie [] PTNil = True+memberPrefixTrie _ (PTClosure _) = True+memberPrefixTrie [] t+ = throwInternalError ("memberPrefix : number of fields mismatch" ++ show t)+ Nothing Nothing+memberPrefixTrie (_h:r) (PTAny t) = memberPrefixTrie r t+memberPrefixTrie (h:r) (PTMap m) = case Map.lookup h m of+ Just t -> memberPrefixTrie r t+ Nothing -> False+memberPrefixTrie (h:r) (PTRec set t)+ = if h `Set.member` set then memberPrefixTrie r t else False+memberPrefixTrie (h:r) (PTSingle v t)+ = if h == v then memberPrefixTrie r t else False++prefixTrieNext :: PrefixTrie -> Field -> Maybe PrefixTrie+prefixTrieNext t field = case t of+ PTNil -> throwInternalError+ ("prefixTrieNext number of fields mismatch PTNil" ++ show field) Nothing Nothing+ PTAny new -> Just new+ PTMap m -> case Map.lookup field m of+ Just new -> Just new+ Nothing -> Nothing+ PTRec s new -> if field `Set.member` s then Just new else Nothing+ PTSingle v new -> if field == v then Just new else Nothing++closureStateNext :: ClosureState -> Field -> ClosureState+closureStateNext closure field = case closure of+ ClosureStateFailed {} -> closure+ ClosureStateSucc {}+ -> closure {currentPrefixTrie = fromJust ptNext }+ ClosureStateNormal {} -> case prefixTrieNext (currentPrefixTrie closure) field of+ Nothing -> ClosureStateFailed {origClosureSet = origClosureSet closure}+ Just (PTClosure p) -> ClosureStateSucc+ {currentPrefixTrie = p, origClosureSet = origClosureSet closure}+ Just pt -> closure { currentPrefixTrie = pt}+ where ptNext = prefixTrieNext (currentPrefixTrie closure) field+++setToClosure :: Set Value -> ClosureSet+setToClosure = mkClosureSet . setToPrefixTrie++mkClosureSet :: PrefixTrie -> ClosureSet+mkClosureSet x+ = ClosureSet {+ closureSetTrie = x+ ,closureSetDigest = mix (hs "ClosureSet") $ hash x }++setToPrefixTrie :: Set Value -> PrefixTrie+setToPrefixTrie = worker . map fromTuple . Set.toList+ where+ fromTuple (VDotTuple l ) = l+ fromTuple x = [x] -- channel a and [|{a}|] apears in one evans example++ worker :: [[Value]] -> PrefixTrie+ worker [] = throwInternalError "setToPrefixTrie worker []" Nothing Nothing+ worker [[]] = PTNil+ worker l = let+ sl = sortBy (comparing head) l+ grps :: [[[Value]]]+ grps = groupBy (\a b -> (head a) == (head b)) sl+ withkeys :: [(Value,PrefixTrie)]+ withkeys = map (\g -> (head $ head g, worker $ map tail g)) grps+ in PTMap $ Map.fromList withkeys++closureToSet :: ClosureSet -> Set Value+closureToSet = prefixTrieToSet . closureSetTrie+++hackValueToEvent :: Value -> Event+hackValueToEvent (VDotTuple l ) = l+hackValueToEvent x = [x] -- channel a and [|{a}|] apears in one evans example++{- todo : this is too lowlevel -}+prefixTrieToSet :: PrefixTrie -> Set Value+prefixTrieToSet trie+ = Set.fromList $ worker [] [] trie+ where+ worker :: [Value] -> [Value] -> PrefixTrie -> [Value]+ worker acc path t = case t of+ PTNil -> (VDotTuple $ reverse path) : acc+ PTAny {} -> throwFeatureNotImplemented "cannot enumerate PTAny (Set,Seq,INT)"+ Nothing Nothing+ PTMap m -> foldl' (add path) acc $ Map.assocs m+ PTRec s t -> foldl' (add path) acc $ zip (Set.elems s) $ repeat t+ PTSingle v t -> worker acc (v:path) t+ PTClosure l -> worker acc path l+ add :: [Value] -> [Value] -> (Value,PrefixTrie) -> [Value]+ add path acc (val,t) = worker acc (val:path) t+{- {|a,b,c|} -}+mkEventClosure :: [Value] -> EM ClosureSet+mkEventClosure l = if List.null l+ then throwScriptError "mkEventClosure : empty ClosureSet" Nothing Nothing+ else return $ mkClosureSet $ ptUnions $ map valueToPT l++{-+convert the things inside a {| |} to a prefix trie+-}+valueToPT :: Value -> PrefixTrie+valueToPT v = case v of+ VChannel c -> fieldsToPT [v] $ (SSet.Total : chanFields c)+ VDotTuple [] -> throwScriptError "valueToPT : empty dot-tuple" Nothing Nothing+ VDotTuple l@(VChannel c : t) -> fieldsToPT l (SSet.Total : chanFields c)+ VDotTuple l -> throwScriptError "valueToPT : dot-tuple does not start with a channel"+ Nothing $ Just v+ _ -> throwScriptError "valueToPT: cannot make a event-closure of value" + Nothing $ Just v++{- fieldsToPT is a kind of zip -}+fieldsToPT :: [Value] -> [FieldSet] -> PrefixTrie+fieldsToPT (v:vr) (f:fr) = if v `SSet.member` f+ then PTSingle v $ fieldsToPT vr fr+ else throwScriptError "fieldsToPT : value outside channel definition" Nothing (Just v)+fieldsToPT [] f+ = PTClosure $ foldr ( \(SSet.Proper s) pt -> PTRec s pt) PTNil f+fieldsToPT v []+ = throwScriptError "fieldsToPT : more fields than declared in channel definition"+ Nothing (Just $ VDotTuple v)+++{-+todo :+more efficent, direkt implementation+without converting to intermediate sets+-}+ptUnions :: [PrefixTrie] -> PrefixTrie+ptUnions = setToPrefixTrie . Set.unions . map prefixTrieToSet+++singleEventToClosureSet :: Event -> ClosureSet+singleEventToClosureSet e+ = mkClosureSet $ foldr PTSingle PTNil $ e
+ src/CSPM/Interpreter/CoreInstances.hs view
@@ -0,0 +1,163 @@+----------------------------------------------------------------------------+-- |+-- Module : CSPM.Interpreter.CoreInstances+-- Copyright : (c) Fontaine 2008+-- License : BSD+-- +-- Maintainer : Fontaine@cs.uni-duesseldorf.de+-- Stability : experimental+-- Portability : GHC-only+--+-- This module defines some class instances that make the interpreter+-- an implementation of the interface defined in package CSPM-CoreLanguage.+--+----------------------------------------------------------------------------++{-# LANGUAGE StandaloneDeriving, FlexibleInstances, FlexibleContexts #-}+{-# LANGUAGE TypeSynonymInstances #-}+module CSPM.Interpreter.CoreInstances+(+)+where++import CSPM.CoreLanguage as Core+import CSPM.CoreLanguage.Field+import CSPM.CoreLanguage.Event++import CSPM.Interpreter.Types as Types+import CSPM.Interpreter.Eval as Eval+import CSPM.Interpreter.ClosureSet as ClosureSet+import CSPM.Interpreter.Renaming as Renaming+import CSPM.Interpreter.GenericBufferPrefix as Prefix+import CSPM.Interpreter.SSet (SSet)+import qualified CSPM.Interpreter.SSet as SSet++import qualified Data.Set as Set+import qualified Data.Map as Map+import Data.List as List+import Data.Maybe++--instance EqOrd INT+--instance CSP1 INT+--instance CSP2 INT+--instance FShow INT++deriving instance Show (Core.TTE INT)++noInstance :: String -> a+noInstance i+ = throwInternalError ("interpreter core-instances : no instance : " ++ i) Nothing Nothing++instance BE INT where+ eventEq _ty = (==)+ member _ty event c = ClosureSet.memberPrefixTrie event $ closureSetTrie c+{-+these functions are only needed for the total-event-view+they are not needed for field-wise computation of events+todo: make a seperate class for these functions++ intersection _ty = SSet.intersection+ difference _ty = SSet.difference+ union _ty = SSet.union+ null _ty = SSet.null+ singleton _ty = SSet.singleton+ insert _ty = SSet.insert+ delete _ty = SSet.delete+ eventSetToList _ty = SSet.toList+ allEvents = error "CoreInstances : BE :allEvents"+-}+ intersection _ty = noInstance "BE : intersection"+ difference _ty = noInstance "BE : difference"+ union _ty = noInstance "BE : union"+ null _ty = noInstance "BE : null "+ singleton _ty = noInstance "BE : singleton"+ insert _ty = noInstance "BE : insert"+ delete _ty = noInstance "BE : delete"+ eventSetToList _ty = map hackValueToEvent . Set.toList . closureToSet+ allEvents = noInstance "BE :allEvents"+ isInRenaming _ty = Renaming.isInRelation+ isInRenamingDomain _ty e rel = Set.member e $ renamingDomain rel+ isInRenamingRange _ty e rel = Set.member e $ renamingRange rel+ getRenamingDomain _ty = Set.toList . renamingDomain+ getRenamingRange _ty = Set.toList . renamingRange+ imageRenaming _ty = Renaming.imageRenaming2+ preImageRenaming _ty = Renaming.imageRenaming1+ singleEventToClosureSet _ty = ClosureSet.singleEventToClosureSet++instance BF INT where+ fieldEq _ty = (==)+ member _ty = SSet.member+ intersection _ty = SSet.intersection+ difference _ty = SSet.difference+ union _ty = SSet.union+ null _ty = SSet.null+ singleton _ty = SSet.singleton+ insert _ty = SSet.insert+ delete _ty = SSet.delete+ fieldSetToList _ty = SSet.toList+ fieldSetFromList _ty = SSet.fromList++ joinFields _ty = id+ splitFields _ty = id+ channelLen _ty (VChannel c) = chanLen c++ closureStateInit _ty c+ = ClosureStateNormal {origClosureSet = c ,currentPrefixTrie = closureSetTrie c}++ closureStateNext _ty = ClosureSet.closureStateNext++ closureRestore _ty closure = origClosureSet closure++ viewClosureFields _ty c = case c of+ ClosureStateFailed {} -> SSet.Empty+ _ -> case currentPrefixTrie c of+ PTAny _ -> SSet.Total+ PTMap m -> SSet.Proper $ Map.keysSet m+ PTRec s _ -> SSet.Proper s+ PTSingle v _ -> SSet.singleton v+ viewClosureState _ty closure = case closure of+ ClosureStateNormal {} -> MaybeInClosure+ ClosureStateFailed {} -> NotInClosure+ ClosureStateSucc {} -> InClosure+ seenPrefixInClosure ty closure = case closure of+ ClosureStateNormal {} -> True+ ClosureStateFailed {} -> False+ ClosureStateSucc {} -> True+ prefixStateInit _ty = Prefix.initPrefix+ prefixStateNext _ty = Prefix.prefixStateNext+ prefixStateFinalize _ty = Prefix.prefixStateFinalize+ viewPrefixState _ty = Prefix.viewPrefixState++{-+todo:+better modelling of prefix with multiple fields+(all fields == one event) level+-}+instance BL INT where+ prefixNext p _event = Just $ prefixRHS p -- todo maybe sanity check with _event+ switchOn = switchedOffProcess+++instance ShowEvent Types.Event where+ showEvent l = concat $ intersperse "." $ List.map showValue l++showValue :: Value -> String+showValue f = case f of+ VChannel chan -> chanName chan+ VInt i -> show i+ VBool True -> "true"+ VBool False -> "false"+ VConstructor c -> constrName c+ VTuple l -> "(" ++ listBody l ++ ")"+ VSet l -> "{" ++ (listBody $ Set.toList l) ++ "}"+ VList l -> "<" ++ listBody l ++ ">"+ VDotTuple l -> (concat $ intersperse "." $ List.map showValue l)+ _ -> throwFeatureNotImplemented ("showValue : missing match : " ++ show f) Nothing+ where+ listBody = concat . intersperse "," . List.map showValue++instance ShowTTE (TTE INT) where+ showTTE t = case t of+ TickEvent -> "tick"+ TauEvent -> "tau"+ SEvent e -> showEvent e
+ src/CSPM/Interpreter/Eval.hs view
@@ -0,0 +1,697 @@+----------------------------------------------------------------------------+-- |+-- Module : CSPM.Interpreter.Eval+-- Copyright : (c) Fontaine 2009+-- License : BSD+-- +-- Maintainer : Fontaine@cs.uni-duesseldorf.de+-- Stability : experimental+-- Portability : GHC-only+--+-- The main eval function of the Interpreter.+--+----------------------------------------------------------------------------+{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE BangPatterns #-}+module CSPM.Interpreter.Eval+(+ eval+ ,getAllEvents+ ,processDeclList+ ,runEM+ ,evalOutField+ ,evalFieldSet+ ,evalProcess+)+where++import qualified CSPM.CoreLanguage as Core++import Language.CSPM.AST as AST hiding (Bindings)+import qualified Language.CSPM.Frontend as Frontend++import CSPM.Interpreter.Types as Types+import CSPM.Interpreter.Bindings as Bindings+import CSPM.Interpreter.PatternMatcher+import CSPM.Interpreter.Hash as Hash+import CSPM.Interpreter.SSet as SSet+import CSPM.Interpreter.ClosureSet as ClosureSet+import CSPM.Interpreter.Renaming as Renaming++import Data.Digest.Pure.HashMD5 as HashClass++import Control.Arrow+import qualified Control.Monad.Reader as Reader+import Control.Monad.RWS.Lazy as RWS hiding (guard)+import Control.Monad hiding (guard)+import Data.Ord+import Data.List as List+import qualified Data.Set as Set+import Data.Set (Set)+import qualified Data.Map as Map+import qualified Data.IntMap as IntMap+import qualified Data.List as List+import Debug.Trace++-- | Evaluate an expression in an envirionment.+runEval :: Env -> AST.LExp -> Value+runEval env expr = runEM (eval expr) env++-- | Run the 'EM' monad with a given envirionment.+runEM :: EM x -> Env -> x+runEM action env = Reader.runReader (unEM action) env++runEnv :: Env -> EM x -> x+runEnv env action = Reader.runReader (unEM action) env++{- todo : check whether the order of the cases influences efficency. -}++-- | Evaluate an expression in the 'EM' monad.+eval :: LExp -> EM Value+eval expr = case unLabel expr of+ Var v -> lookupIdent v+ IntExp i -> return $ VInt i+ SetEnum s -> do+ l <- mapM eval s+ return $ VSet $ Set.fromList l+ ListEnum l -> mapM eval l >>= return . VList+ SetOpen _ -> throwFeatureNotImplemented "open sets" $ Just $ srcLoc expr+ ListOpen s -> do+ -- todo : this can easily give non-termination+ -- maybe use an enumerator here ?+ x <- evalInt s+ return $ VList $ map VInt [x..]+ SetClose (a,b) -> do+ s <- evalInt a+ e <- evalInt b+ return $ VSet $ Set.fromList $ map VInt [s..e]+ ListClose (a,b) -> do+ s <- evalInt a+ e <- evalInt b+ return $ VList $ map VInt [s..e]+ SetComprehension (el,comps) -> do+ l <- evalSetComp ret comps + return $ VSet l+ where ret = mapM eval el >>= return . Set.fromList+ ListComprehension (el, comps) -> do+ l <- evalListComp (mapM eval el) comps+ return $ VList l+ ClosureComprehension (el, comps) -> do+ l <- evalListComp (mapM eval el) comps+ ClosureSet.mkEventClosure l >>= return . VClosure+ LetI decls freenames e -> do+ env <- getEnv+ let digest = closureDigest expr env freenames+ return $ runEval (processDeclList digest env decls) e+ Ifte cond t e -> do+ c <- evalBool cond+ if c then eval t else eval e+ CallFunction fkt args -> do+ f <- eval fkt+ parameter <- mapM eval $ concat args+ functionCall f parameter+ CallBuiltIn bi [[e]] -> builtIn1 bi e+ CallBuiltIn bi [[a,b]] -> builtIn2 bi a b+ CallBuiltIn _ _+ -> throwScriptError "calling builtIn with worng number of args"+ (Just $ srcLoc expr) Nothing+ Lambda {} -> throwInternalError "not expection Constructor Lambda"+ (Just $ srcLoc expr) $ Nothing+ LambdaI freeNames patL body -> do+ env <- getEnv+ return $ VFun $ FunClosure {+ getFunCases = [FunCaseI patL body]+ ,getFunEnv = env+ ,getFunArgNum = length patL+ ,getFunId = closureDigest expr env freeNames+ }+ Stop -> return $ VProcess $ Core.stop+ Skip -> return $ VProcess $ Core.skip+ CTrue -> return $ VBool True+ Events -> liftM VClosure evalAllEvents+ CFalse -> return $ VBool False+ BoolSet -> return $ VSet $ Set.fromList [VBool True,VBool False]+{-+ many prob test contain unboundet INT+ IntSet -> return $ VAllInts+-}+ IntSet -> return $ VSet $ Set.fromList $ map VInt [0..100]+ TupleExp l -> mapM eval l >>= return . VTuple+ Parens e -> eval e+ AndExp a b -> do+ av <- evalBool a+ if av then eval b else return $ VBool False+ OrExp a b -> do+ av <- evalBool a+ if av then return $ VBool True else eval b+ NotExp e -> evalBool e >>= return . VBool . not+ Fun1 bi e -> builtIn1 bi e+ Fun2 bi a b -> builtIn2 bi a b+ DotTuple l -> mapM eval l >>= return . VDotTuple . concatMap flatTuple+ where+ flatTuple (VDotTuple l ) = l+ flatTuple x = [x]+ Closure l -> mapM eval l >>= ClosureSet.mkEventClosure >>= return . VClosure+ ProcSharing s a b+ -> liftM3 Core.sharing+ (switchedOffProc a)+ (evalClosureExp s)+ (switchedOffProc b)+ >>= return . VProcess+ ProcAParallel aLeft aRight pLeft pRight+ -> liftM4 Core.aparallel+ (evalClosureExp aLeft)+ (evalClosureExp aRight)+ (switchedOffProc pLeft)+ (switchedOffProc pRight)+ >>= return . VProcess+ ProcLinkParallel l p q+ -> liftM3 Core.linkParallel+ (evalLinkList l)+ (switchedOffProc p)+ (switchedOffProc q)+ >>= return . VProcess+ ProcRenaming rlist gen proc -> do+ pairs <- case gen of+ Nothing -> mapM evalRenaming rlist+ Just gen -> evalListComp (mapM evalRenaming rlist ) $ unLabel gen+ p <- switchedOffProc proc+ return $ VProcess $ Core.renaming (toRenaming pairs) p+ where+ evalRenaming :: LRename -> EM (Value,Value)+ evalRenaming (unLabel -> Rename a b) = liftM2 (,) (eval a) (eval b)+ ProcRepSequence comp p+ -> evalProcCompL p comp >>= return . VProcess . Core.repSeq+ ProcRepInternalChoice comp p+ -> evalProcCompS p comp >>= return . VProcess . Core.repInternalChoice+ ProcRepExternalChoice comp p+ -> evalProcCompS p comp >>= return . VProcess . Core.repExternalChoice+ ProcRepInterleave comp p+ -> evalProcCompS p comp >>= return . VProcess . Core.repInterleave+ ProcRepAParallel comp c p+ -> evalListComp ret (unLabel comp) + >>= return . VProcess . Core.repAParallel+ where ret = do { x <- evalClosureExp c; y <- switchedOffProc p; return [(x,y)]}+ ProcRepLinkParallel comp link p+ -> liftM2 Core.repLinkParallel+ (evalLinkList link)+ (evalProcCompL p comp)+ >>= return . VProcess+ ProcRepSharing comp closure p -> do+ l <- evalProcCompS p comp+ c <- evalClosureExp closure+ return $ VProcess $ Core.repSharing c l+ PrefixI free chan fields body -> do+ env <- getEnv + return $ VProcess $ Core.prefix $ PrefixState {+ prefixEnv = env+ ,prefixFields = chanOut:fields+ ,prefixBody = body+ ,prefixRHS = throwInternalError "prefixRHS undefiend" (Just $ srcLoc expr) Nothing+ ,prefixDigest = closureDigest body env free+ ,prefixPatternFailed = False+ }+ where chanOut = setNode chan $ OutComm chan+ ExprWithFreeNames body en+ -> throwInternalError "didn't expect ExprWithFreeNames" (Just $ srcLoc expr) Nothing+ _ -> throwFeatureNotImplemented "hit catch-all case of eval function"+ $ Just $ srcLoc expr ++evalBool :: LExp -> EM Bool+evalBool e = do+ v <- eval e+ case v of+ VBool b -> return b+ _ -> throwTypingError "expecting type Bool" (Just $ srcLoc e) $ Just v+++evalInt :: LExp -> EM Integer+evalInt e = do+ v <- eval e+ case v of+ VInt b -> return b+ _ -> throwTypingError "expecting type Integer" (Just $ srcLoc e) $ Just v++evalList :: LExp -> EM [Value]+evalList e = do+ v <- eval e+ case v of+ VList l -> return l++-- used in mydemos/SimpleRepAlphParallel.csp SYSTEM+ VDataType l -> return $ map VConstructor l++-- because of a hack in RepAParalle+ VSet l -> return $ Set.toList l+-- because of a hack in evalProcCompS+ VClosure c -> return $ Set.toList $ closureToSet c++ _ -> throwTypingError "expecting type List" (Just $ srcLoc e) $ Just v++setFromValue :: Value -> EM (Set Value)+setFromValue v = case setFromValueM v of+ Just l -> return l+ Nothing -> throwTypingError "expecting type Set" Nothing $ Just v++evalSet :: LExp -> EM (Set Value)+evalSet e = do+ v <- eval e+ case setFromValueM v of+ Just l -> return l+ Nothing -> throwTypingError "expecting type Set" (Just $ srcLoc e) $ Just v++setFromValueM :: Value -> Maybe (Set Value)+setFromValueM v = case v of+ VSet l -> Just l+ VClosure c -> Just $ closureToSet c+ VDataType l -> Just $ Set.fromList --used in basin_olderog_bank.csp+ $ map VConstructor l+ _ -> Nothing++evalProcess :: LExp -> EM Process+evalProcess e = do+ v <- eval e+ case v of+ VProcess p -> return p+ _ -> throwTypingError "expecting type Process" (Just $ srcLoc e) $ Just v++evalClosureExp :: LExp -> EM ClosureSet+evalClosureExp e = do+ v <- eval e+ case v of+ VClosure x -> return x+-- VAllEvents -> evalAllEvents+ VSet s -> return $ setToClosure s+ _ -> throwTypingError "expecting type Event-Closure" (Just $ srcLoc e) $ Just v++listFromValue :: Value -> EM [Value]+listFromValue (VList l) = return l+listFromValue v = throwTypingError "expecting type List" Nothing $ Just v++processFromValue :: Value -> EM Process+processFromValue (VProcess p) = return p+processFromValue v = throwTypingError "expecting type Process" Nothing $ Just v++builtIn1 :: LBuiltIn -> LExp -> EM Value+builtIn1 op expr + = case lBuiltInToConst op of+ F_Seq -> evalSet expr >>= return . VAllSequents+ F_card -> do+ s <- evalSet expr+ return $ VInt $ fromIntegral $ Set.size s+ F_empty -> evalSet expr >>= return . VBool . Set.null+ F_head -> do+ l <- evalList expr+ case l of+ [] -> throwScriptError "head of empty list" (Just $ srcLoc expr) Nothing+ h:_tail -> return h+ F_tail -> do+ l <- evalList expr+ case l of+ [] -> throwScriptError "tail of empty list" (Just $ srcLoc expr) Nothing+ _head:rest -> return $ VList rest+ F_length -> evalList expr >>= return . VInt . fromIntegral . List.length+ F_Len2 -> evalList expr >>= return . VInt . fromIntegral . List.length+ F_Union -> do+ s <- evalSet expr + setList <- mapM setFromValue $ Set.elems s+ return $ VSet $ Set.unions setList+ F_Inter -> do+ s <- evalSet expr + setList <- mapM setFromValue $ Set.elems s+ case setList of+ [] -> throwScriptError "intersection of empty set of sets" + (Just $ srcLoc expr) Nothing+ l -> return $ VSet $ List.foldl1' Set.intersection l+ F_set -> evalList expr >>= return . VSet . Set.fromList+ F_Set -> do+ s <- evalSet expr+ return $ VSet $ Set.fromList $ map (VSet . Set.fromList ) + $ List.subsequences $ Set.toList s+ F_concat -> do+ l <- evalList expr >>= mapM listFromValue+ return $ VList $ List.concat l+ F_null -> do+ l <- evalList expr+ return $ VBool (List.null l)+ F_CHAOS -> liftM (VProcess . Core.chaos) $ evalClosureExp expr+ c -> throwInternalError "malformed AST1" (Just $ srcLoc expr) Nothing++builtIn2 :: LBuiltIn -> LExp -> LExp -> EM Value+builtIn2 op a b =+ case lBuiltInToConst op of+ F_union -> setOp Set.union+ F_inter -> setOp Set.intersection+ F_diff -> setOp Set.difference+ F_member -> do+ av <- eval a+ s <- evalSet b+ return $ VBool $ Set.member av s+ F_Seq -> throwFeatureNotImplemented "builtIn2 FSeq" Nothing+ F_elem -> do+ av <- eval a+ l <- evalList b+ return $ VBool $ List.elem av l+ F_Concat -> do+ x <- evalList a+ y <- evalList b+ return $ VList $ x ++y+ F_Mult -> intOp (*)+ F_Div -> intOp div+ F_Mod -> intOp mod+ F_Add -> intOp (+)+ F_Sub -> intOp (-)+ F_Eq -> do+ x <- eval a+ y <- eval b+ return $ VBool (x == y)+ F_NEq -> do+ x <- eval a+ y <- eval b+ return $ VBool (x /= y)+ F_GE -> intCmp (>=)+ F_LE -> intCmp (<=)+ F_LT -> intCmp (<)+ F_GT -> intCmp (>)+ F_Sequential -> procOp Core.seq+ F_Interrupt -> procOp Core.interrupt+ F_ExtChoice -> do+ x <- switchedOffProc a+ y <- switchedOffProc b+ return $ VProcess $ Core.externalChoice x y+ F_Timeout -> procOp Core.timeout+ F_IntChoice -> do+ x <- switchedOffProc a+ y <- switchedOffProc b+ return $ VProcess $ Core.internalChoice x y+ F_Interleave -> do+ x <- switchedOffProc a+ y <- switchedOffProc b+ return $ VProcess $ Core.interleave x y+ F_Hiding -> do+ proc <- switchedOffProc a+ hidden <- evalClosureExp b+ return $ VProcess $ Core.hide hidden proc+ F_Guard -> do+ cond <- evalBool a+ if cond then liftM VProcess $ switchedOffProc b+ else return $ VProcess Core.stop+ c -> throwInternalError "malformed AST2" Nothing Nothing+ where+ intOp :: (Integer -> Integer -> Integer) -> EM Value+ intOp o = do+ x <- evalInt a+ y <- evalInt b+ return $ VInt $ o x y+ intCmp :: (Integer -> Integer -> Bool) -> EM Value+ intCmp rel = do+ x <- evalInt a+ y <- evalInt b+ return $ VBool $ rel x y+ setOp :: (Set Value -> Set Value -> Set Value) -> EM Value+ setOp o = do+ x <- evalSet a+ y <- evalSet b+ return $ VSet $ o x y+ procOp :: (Process -> Process -> Process) -> EM Value+ procOp o = do+ x <- switchedOffProc a+ y <- switchedOffProc b+ return $ VProcess $ o x y++type DeclM x = RWS (Digest,Env) () (Bindings, IntMap.IntMap Digest) x+ +processDeclList :: Digest -> Env -> [LDecl] -> Env+processDeclList digest oldEnv decls =+-- todo :: really do a lot of testing that we do not end in a loop here+ let+ ((),(newBinds,newDigests),()) = runRWS action (digest,newEnv) + (getLetBindings oldEnv, letDigests oldEnv)+ action = mapM_ processDecl decls+ newEnv = oldEnv { letBindings = newBinds, letDigests = newDigests}+ in newEnv++bindIdentM :: LIdent -> Value -> DeclM ()+bindIdentM i v = do+ d <- asks fst+ modify $ \(values,digests) ->+ (bindIdent i v values+ ,IntMap.insert (identId i) (HashClass.mixInt d $ identId i) digests)++processDecl :: LDecl -> DeclM ()+processDecl decl = do + case unLabel decl of+ PatBind pat expr -> do+ finalEnv <- asks snd+ let rhs = runEval finalEnv expr -- evaluate the righthand side+ modify $ first $ \oldBinds -> tryMatchLazy oldBinds pat rhs+ digest <- asks fst+ forM_ (boundNames pat) $ \i -> modify $ second+ $ IntMap.insert (identId i) (HashClass.mixInt digest $ identId i)+ FunBind i cases -> do+ finalEnv <- asks snd+ digest <- asks fst+ bindIdentM i $ VFun $ FunClosure {+ getFunCases = cases + ,getFunEnv = finalEnv+ ,getFunArgNum = length $ (\(FunCaseI pl _) -> pl) $ head cases+ ,getFunId = mixInt digest $ AST.unNodeId $ AST.nodeId decl+ }+ -- Just Ignore+ AssertRef _ _ _ -> return ()+ AssertBool _ -> return ()+ Transparent names -> forM_ names $ \n -> bindIdentM n cspIdentityFunction+ SubType _ _ -> throwFeatureNotImplemented "subtype declarations" $ Just $ srcLoc decl+ DataType tname constrList -> do+ constrs <- mapM constrDecl constrList+ bindIdentM tname (VDataType constrs )+ NameType tname t -> do+ finalEnv <- asks snd+ bindIdentM tname (VNameType $ runEnv finalEnv $ evalTypeDef t)+ Print _expr -> return ()+ AST.Channel idList t -> do+ finalEnv <- asks snd+ forM_ idList $ \i -> bindIdentM i $ VChannel $ Types.Channel {+ chanId = AST.uniqueIdentId $ AST.unUIdent $ unLabel i+ ,chanName = AST.realName $ AST.unUIdent $ AST.unLabel i+ ,chanLen = case t of+ Nothing -> 1+ Just t -> case unLabel t of+ TypeTuple l -> 2+ TypeDot l -> length l +1+ ,chanFields = case t of+ Nothing -> []+ Just l -> runEnv finalEnv $ evalTypeDef l+ }++constrDecl :: LConstructor -> DeclM Types.Constructor+constrDecl (unLabel -> AST.Constructor ident td) = do+ finalEnv <- asks snd+ let+ cl = case td of+ Nothing -> []+ Just l -> runEnv finalEnv $ evalTypeDef l++ constr = Types.Constructor+ (AST.uniqueIdentId $ AST.unUIdent $ unLabel ident)+ (AST.realName $ AST.unUIdent $ unLabel ident)+ cl + bindIdentM ident $ VConstructor constr+ return constr++evalTypeDef :: LTypeDef -> EM [FieldSet]+evalTypeDef t = case unLabel t of+ TypeDot l -> mapM evalFieldSet l+ TypeTuple l -> do+ el <- mapM evalFieldSet l+ -- cross-product+ return [SSet.fromList $ map VTuple $ sequence $ map SSet.toList el]++evalFieldSet :: LExp -> EM FieldSet+evalFieldSet expr = do+ v <- eval expr+ case v of+ VInt {} -> return $ SSet.singleton v+ VChannel {} -> return $ SSet.singleton v+ VSet s -> return $ SSet.Proper s+-- todo : fixthis when we have ClosureExpressions+-- todo: this does not work for constructors that have fields+ VDataType constrList -> return $ SSet.fromList $ map VConstructor constrList+ VAllInts -> return $ SSet.fromList $ map VInt [0..10] --todo+ _ -> throwTypingError "valueToEventSet " (Just $ srcLoc expr) $ Just v++switchedOffProc :: LExp -> EM Process+switchedOffProc (unLabel -> ExprWithFreeNames free expr) = do+ env <- getEnv+ return $ Core.switchedOff $ SwitchedOffProc {+ switchedOffDigest = (closureDigest expr env free)+ ,switchedOffExpr = expr+ ,switchedOffProcess = runEM (evalProcess expr) env+ }+switchedOffProc exp+ = throwInternalError "cannot determine free variables" (Just $ srcLoc exp) Nothing++evalOutField :: LExp -> EM Field+evalOutField expr = do+ v <- eval expr+ case v of+ VInt {} -> return v+ VChannel {} -> return v+ VConstructor {} -> return v+ VTuple {} -> return v + VDotTuple {} -> return v -- todo : fix for genric buffers+ VBool {} -> return v+{-+todo: support lists and sets as channel fields+write test for VSet and VList+-}+ VSet {} -> return v+ VList {} -> return v ++ _ -> throwTypingError "Eval.hs : evalOutField" (Just $ srcLoc expr) $ Just v+++{- redo this: most procComprehensions work on sets ! -}+evalProcCompL :: LExp -> LCompGenList -> EM [Process]+evalProcCompL p comp = evalListComp ret $ unLabel comp+ where+ ret = do+ r <- switchedOffProc p+ return [r]++{-+fdr does not remove duplicates from replicatesProc compostions +see examples/CSP/FDRFeatureTests/ReplicatedInterleaveSetDef.csp+-}+evalProcCompS :: LExp -> LCompGenList -> EM [Process]+evalProcCompS = evalProcCompL+{-+evalProcCompS p comp+ = (evalSetComp ret $ unLabel comp)+ >>= (mapM processFromValue) . Set.toList+ where+{- we intermediatley wrap processes with VProcess +if we make evalSetComp polymorphic we get the following error+src/Language/CSPM/Interpreter/Eval.hs:536:0:+ Contexts differ in length+ (Use -XRelaxedPolyRec to allow this)+-}+ ret = switchedOffProc p >>= return . Set.singleton . VProcess +-}++evalListComp :: EM [x] -> [LCompGen] -> EM [x]+evalListComp ret [] = ret+evalListComp ret (h:t) = case unLabel h of+ Guard g -> do+ b <- evalBool g+ if b then evalListComp ret t+ else return []+ Generator pat gen -> do+ list <- evalList gen+ rets <- mapM (evalCompPat pat) list+ return $ concat rets+ where+ evalCompPat pat val = do+ e <- getEnv+ case tryMatchStrict (getArgBindings e) pat val of+ Nothing -> return []+ Just newBinds + -> return $ runEM+ (evalListComp ret t) + (setArgBindings e newBinds)++evalSetComp :: EM (Set Value) -> [LCompGen] -> EM (Set Value)+evalSetComp ret [] = ret+evalSetComp ret (h:t) = case unLabel h of+ Guard g -> do+ b <- evalBool g+ if b then evalSetComp ret t+ else return Set.empty+ Generator pat gen -> do+ set <- evalSet gen+ rets <- mapM (evalCompPat pat) $ Set.elems set+ return $ Set.unions rets+ where+ evalCompPat pat val = do+ e <- getEnv+ case tryMatchStrict (getArgBindings e) pat val of+ Nothing -> return Set.empty+ Just newBinds + -> return $ runEM+ (evalSetComp ret t) + (setArgBindings e newBinds)++evalAllEvents :: EM ClosureSet+evalAllEvents = do+ channels <- lookupAllChannels+ ClosureSet.mkEventClosure $ map VChannel channels++getAllEvents :: Env -> ClosureSet+getAllEvents = runEM evalAllEvents++cspIdentityFunction :: Value+cspIdentityFunction = VFun $ FunClosure {+ getFunCases = [funCase]+ ,getFunEnv = emptyEnvirionment+ ,getFunArgNum = 1+ ,getFunId = Hash.hash "cspIdentityFunction"+ }+ where+ funCase = FunCaseI [ labeled $ VarPat someId] (labeled $ Var someId)+ someId = labeled $ UIdent $ UniqueIdent {+ uniqueIdentId = -1+ ,bindingSide = e+ ,bindingLoc = e+ ,idType = e+ ,realName = e+ ,newName = e+ ,prologMode = e+ ,bindType = NotLetBound }+ e = throwInternalError "use identityFunction magic constants" Nothing Nothing++evalLinkList :: LLinkList -> EM RenamingRelation+evalLinkList l = case unLabel l of+ LinkList x -> liftM toRenaming $ mapM evalLink x+ LinkListComprehension gen links+ -> liftM toRenaming $ evalListComp (mapM evalLink links ) gen+ where+ evalLink :: LLink -> EM (Value,Value)+ evalLink (unLabel -> Link a b) = liftM2 (,) (eval a) (eval b)++functionCall :: Value -> [Value] -> EM (Value)+functionCall v arguments = case v of+ VFun fkt -> callFkt fkt arguments+ VPartialApplied fkt oldArgs -> callFkt fkt (oldArgs ++ arguments)+ f -> throwTypingError "calling non-function" Nothing $ Just f+ where+ tryFunCases :: [FunCase] -> [Value] -> Env -> Value+ tryFunCases [] _ _ = throwPatternMatchError "no matching function case" Nothing+ tryFunCases ((FunCaseI parameter fktBody) : moreCases) args env =+ case matchList parameter args (getArgBindings env) of+ Just newBinds -> runEval (setArgBindings env newBinds) fktBody+ Nothing -> tryFunCases moreCases args env+ tryFunCases (FunCase {} : _) _ _+ = throwInternalError "not expecting FunCase-Constructor" Nothing Nothing++ matchList :: [LPattern] -> [Value] -> Bindings -> Maybe Bindings+ matchList patList valList env+ = foldM (\e (pat,val) -> tryMatchStrict e pat val) + env (zip patList valList)++{-+ going from+ callFkt fkt args = return $ tryFunCases (getFunCases fkt) args (getFunEnv fkt)+ to the version which supports partial application+ costs ca 17 % in the fibonacci -example+-}+ callFkt :: FunClosure -> [Value] -> EM Value+ callFkt fkt args+ = case compare haveArgs needArgs of+ EQ -> return $ tryFunCases (getFunCases fkt) args (getFunEnv fkt)+ GT -> do+ f2 <- callFkt fkt $ take needArgs args+ functionCall f2 $ drop needArgs args+ LT -> return $ VPartialApplied fkt args+ where+ haveArgs = length args+ needArgs = getFunArgNum fkt
+ src/CSPM/Interpreter/GenericBufferPrefix.hs view
@@ -0,0 +1,99 @@+----------------------------------------------------------------------------+-- |+-- Module : CSPM.Interpreter.GenricBufferPrefix+-- Copyright : (c) Fontaine 2009+-- License : BSD+-- +-- Maintainer : Fontaine@cs.uni-duesseldorf.de+-- Stability : experimental+-- Portability : GHC-only+--+-- A wrapper around CSPM.Interpreter.Prefix with support for generic buffers.+--+----------------------------------------------------------------------------+{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE BangPatterns #-}++module CSPM.Interpreter.GenericBufferPrefix+(+ initPrefix+ ,viewPrefixState+ ,prefixStateNext+ ,prefixStateFinalize+)+where++import qualified CSPM.CoreLanguage as Core+import Language.CSPM.AST as AST hiding (Bindings)++import CSPM.Interpreter.Types as Types+import CSPM.Interpreter.Bindings as Bindings+import CSPM.Interpreter.PatternMatcher+import CSPM.Interpreter.Eval+import qualified CSPM.Interpreter.Prefix as BasePrefix+import CSPM.Interpreter.SSet as SSet++import Data.List as List+import Control.Monad++initPrefix :: PrefixState -> GenericBufferPrefix+initPrefix = lookAhead . BasePrefix.initPrefix++viewPrefixState :: GenericBufferPrefix -> Core.PrefixFieldView INT+viewPrefixState p = case p of+ GBOut (h:_) _ -> Core.FieldOut h+ GBOut [] _ -> error "GenericBuffer.hs : viewPrefixState : internal error : empty buffer"+ GBInput _ -> Core.FieldIn+ GBInputGuard g _ -> Core.FieldGuard g+ GBInputGeneric _ _ -> Core.FieldIn+ GBFinished _ -> error "GenericBuffer.hs : viewPrefixState : no fields left"+ +prefixStateNext :: GenericBufferPrefix -> Field -> Maybe GenericBufferPrefix+prefixStateNext gbPrefix field = case gbPrefix of+ GBOut [h] p -> do+ guard $ h == field+ liftM lookAhead $ BasePrefix.prefixStateNext p (error "GenericBufferDummyFields")+ GBOut (h:t) p -> do+ guard $ h == field+ return $ GBOut t p+ GBInput p -> liftM lookAhead $ BasePrefix.prefixStateNext p field+ GBInputGuard g p -> do+ guard $ field `SSet.member` g+ liftM lookAhead $ BasePrefix.prefixStateNext p field+ GBInputGeneric b p -> return $ GBInputGeneric (field:b) p+ GBFinished _ -> error "GenericBuffer.hs : prefixStateNext : no fields left"++prefixStateFinalize :: GenericBufferPrefix -> Maybe PrefixState+prefixStateFinalize gbPrefix = case gbPrefix of+ GBInputGeneric buffer p -> case buffer of+ [] -> error "GenericBuffer.hs : empty dot tuple"+ [v] -> BasePrefix.prefixStateNext p v >>= BasePrefix.prefixStateFinalize+ l -> BasePrefix.prefixStateNext p (VDotTuple $ reverse l)+ >>= BasePrefix.prefixStateFinalize+ GBFinished p -> BasePrefix.prefixStateFinalize p+ _ -> error "GenericBuffer.hs : stateError"++lookAhead :: PrefixState -> GenericBufferPrefix+lookAhead p | List.null $ prefixFields p = GBFinished p+lookAhead p | isLastInputField p = GBInputGeneric [] p+lookAhead p = case BasePrefix.viewPrefixState p of+ Core.FieldOut v -> case v of+ (VDotTuple l) -> GBOut (splitTuple l) p+ x -> GBOut [x] p+ Core.FieldIn -> GBInput p+ Core.FieldGuard g -> GBInputGuard g p++isLastInputField :: PrefixState -> Bool+isLastInputField (PrefixState {+ prefixFields = [unLabel -> InComm (unLabel -> VarPat _ )] + }) = True+{- todo : fields that end with wildcard c?_ -> x -}+isLastInputField _ = False++splitTuple :: [Value] -> [Value]+splitTuple [] = []+splitTuple l@(h:t) = case h of+ VConstructor c | not $ List.null $ constrFields c+ -> VDotTuple (take len l) : splitTuple (drop len l)+ where len = 1 + (length $ constrFields c)+ _ -> h : splitTuple t
+ src/CSPM/Interpreter/Hash.hs view
@@ -0,0 +1,146 @@+----------------------------------------------------------------------------+-- |+-- Module : CSPM.Interpreter.Hash+-- Copyright : (c) Fontaine 2008+-- License : BSD+-- +-- Maintainer : Fontaine@cs.uni-duesseldorf.de+-- Stability : experimental+-- Portability : GHC-only+-- +-- Instances of the Hash class for interpreter types and core language types+--+----------------------------------------------------------------------------+{-# LANGUAGE TypeSynonymInstances,FlexibleInstances #-}++module CSPM.Interpreter.Hash+(+ mix+ ,mix3+ ,MD5Digest (..)+ ,Hash (..)+ ,hs+ ,closureDigest+ ,mixInt+)+where++import CSPM.CoreLanguage hiding (PrefixState, Event)++import qualified Language.CSPM.AST as AST+import CSPM.Interpreter.Types as Types+import CSPM.Interpreter.SSet++import Data.Digest.Pure.HashMD5+import Data.Digest.Pure.MD5++import qualified Data.Set as Set+import qualified Data.IntMap as IntMap+import qualified Data.Map as Map++hs :: String -> Digest+hs = hash++instance Hash Value where+ hash = hashValue++hashValue :: Value -> Digest+hashValue v = case v of+ VInt i -> if i == fromIntegral int+ then mixInt (hs "VInt") int+ else error $ "Hash.hs : integer out of bounds" ++ show i+ where int = fromIntegral i+ VBool True -> hs "VBool True"+ VBool False -> hs "VBool False"+ VList l -> foldHash (hs "VList") l+ VTuple l -> foldHash (hs "VTuple") l+ VDotTuple l -> foldHash (hs "VDotTuple") l+ VSet s -> foldHash (hs "VSet") $ Set.toAscList s+ VClosure c -> mix (hs "VClosure") $ hash c+ VFun f -> mix (hs "VFun") $ hash f+ VProcess p -> hashProcess p+ VChannel c -> mixInt (hs "VChannel") $ chanId c+ VUnit -> hs "VUnit"+ VAllInts -> hs "VAllInts"+ VAllSequents s -> foldHash (hs "VAllSequents" ) $ Set.toAscList s+-- VAllEvents -> hs "VAllEvents"+ VConstructor c -> mix (hs "VConstructor") $ hash c+ VDataType d -> foldHash (hs "VDataType") d+ VNameType _d -> error "Hash : hash nametype " --foldHash (hs "VNameType") d+ VPartialApplied f l -> mix3 (hs "VPartialApplied") (hash f) (hash l)++-- todo :: cache the digests in the envrionments+instance Hash AST.LExp where+ hash expr = mixInt (hs "AST.LExp") $ AST.unNodeId $ AST.nodeId expr++closureDigest :: AST.LExp -> Env -> AST.FreeNames -> Digest+closureDigest expr env free = foldHash (hs "closureDigest") ( (hash expr) : binds)+ where+ binds = map lookupAndHash $ IntMap.elems free+ {- todo : remove distinction between LetBound and NotLetBound+ store precomputed CspCore.Digest in Bindings -}+ lookupAndHash :: AST.UniqueIdent -> Digest+ lookupAndHash ident+ = mixInt h i+ where+ !i = AST.uniqueIdentId ident+ !h = case AST.bindType ident of+ AST.NotLetBound -> case IntMap.lookup i (argBindings env) of+ Just val -> hash val+ Nothing -> err+ AST.LetBound -> case IntMap.lookup i (letDigests env) of+ Just d -> d+ Nothing -> err++ err = error ( "Hash.hs Bindings lookup failure :" + ++ "\n\n" ++ show expr+ ++ "\n\n" ++ show free+ ++ "\n\n" ++ show ident+ ++ "\n\n" ++ (show $ argBindings env)+ )+++hashProcess :: Types.Process -> Digest+hashProcess proc = case proc of+ Prefix e -> mix (hs "Prefix") $ hash e+ ExternalChoice a b -> mix3 (hs "ExtChoice") (hash a) (hash b)+ InternalChoice a b -> mix3 (hs "InternalChoice") (hash a) (hash b)+ Interleave a b -> mix3 (hs "Interleave") (hash a) (hash b)+ Interrupt a b -> mix3 (hs "Interrupt") (hash a) (hash b)+ Timeout a b -> mix3 (hs "Timeout") (hash a) (hash b)+ Sharing a e b -> mix (hs "Sharing") $ mix3 (hash a) (hash e) (hash b)+ AParallel c1 c2 p q -> mix3 (hs "AParalle") (hash c1) $ mix3 (hash c2) (hash p) (hash q)+ Seq a b -> mix3 (hs "Seq") (hash a) (hash b)+ Hide s e -> mix3 (hs "Hide") (hash s) $ hash e+ Stop -> hs "Stop"+ Skip -> hs "Skip"+ Omega -> hs "Omega"+ AProcess i -> mixInt (hs "AProcess") i+ SwitchedOff p -> mix (hs "SwitchedOff") $ hash p+ RepAParallel l -> foldHash (hs "RepAParallel") l+ Renaming r p -> mix3 (hs "Renaming") (hash r) (hash p)+ Chaos c -> mix (hs "Chaos") $ hash c+ LinkParallel c p q -> mix (hs "LinkParallel") $ mix3 (hash c) (hash p) (hash q)++instance Hash Types.Process where hash = hashProcess+instance Hash PrefixState where hash = prefixDigest+instance Hash SwitchedOffProc where hash = switchedOffDigest+instance Hash Types.ClosureSet where hash = closureSetDigest+instance Hash Types.RenamingRelation where hash = renamingDigest+instance Hash Constructor where hash c = mixInt (hs "Constructor") $ constrId c+instance Hash FunClosure where hash = getFunId+++hashEventSlice :: SSet Event -> Digest+hashEventSlice x = case x of+ Total -> hs "EventSlice Total"+ Empty -> hs "EventSlice Empty"+ (Proper x) -> foldHash (hs "EventSlice") $ Set.elems x++instance Hash PrefixTrie where+ hash p = case p of+ PTNil -> hs "PTNil"+ PTAny l -> mix (hs "PTAny") $ hash l+ PTMap l -> foldHash (hs "PTMap") $ Map.assocs l+ PTRec s t -> mix (hs "PRRec") $ foldHash (hash t) $ Set.toList s+ PTClosure t -> mix (hs "PTClosure") $ hash t
+ src/CSPM/Interpreter/PatternMatcher.hs view
@@ -0,0 +1,217 @@+----------------------------------------------------------------------------+-- |+-- Module : CSPM.Interpreter.PatternMatcher+-- Copyright : (c) Fontaine 2008+-- License : BSD+-- +-- Maintainer : Fontaine@cs.uni-duesseldorf.de+-- Stability : experimental+-- Portability : GHC-only+--+-- Execute the selectors of a compilied pattern with a Value.+--+----------------------------------------------------------------------------+{-+todo :+Compiling selectors to pattern meight be an over-kill.+maybe its simpler and faster to implement direct pattern-matching+-}+{-# LANGUAGE BangPatterns, ViewPatterns #-}+module CSPM.Interpreter.PatternMatcher+(+ match+,tryMatchStrict+,tryMatchLazy+,boundNames+)+where++import Language.CSPM.AST as AST hiding (Bindings)+import CSPM.Interpreter.Types as Types+import CSPM.Interpreter.Bindings++import Data.Maybe+import qualified Data.Set as Set+import Control.Exception+import Data.Array.IArray as Array+import qualified Data.List as List++failedMatch :: Maybe Value+failedMatch = Nothing++typeError :: String -> Value -> Maybe Value+typeError x v = throwTypingError ("error in pattern-match : "++ x) Nothing $ Just v++-- todo make match strict !BangPattern+match :: Value -> Selector -> Maybe Value+match (VInt a) (IntSel b) = if a==b then return VUnit else failedMatch+match v (IntSel _) = typeError "expecting Int" v++match (VBool True) TrueSel = return VUnit+match (VBool False) TrueSel = failedMatch+match v TrueSel = typeError "expecting Bool" v++match (VBool True) FalseSel = failedMatch+match (VBool False) FalseSel = return VUnit+match v FalseSel = typeError "expecting Bool" v++match x SelectThis = return x++match (VChannel ch) (ConstrSel ident)+ = if AST.uniqueIdentId ident == chanId ch then return VUnit else failedMatch+match (VConstructor (Types.Constructor i _ _)) (ConstrSel ident)+ = if AST.uniqueIdentId ident == i then return VUnit else failedMatch+match v (ConstrSel c) = typeError ("expecting constructor " ++ show c) v+-- | DotSel Int Int Selector++match (VSet _) (SingleSetSel _)+ = throwFeatureNotImplemented "single set pattern" Nothing+match v (SingleSetSel _) = typeError "expecting a set" v++match (VSet s) EmptySetSel+ = if Set.null s then return VUnit else failedMatch+match v EmptySetSel = typeError "expecting a set" v++-- todo : really test this+match (VList l) p = case p of+ ListIthSel i next -> match (l !! i) next+ ListLengthSel 0 _next+ -> if null l then return VUnit else failedMatch+ ListLengthSel len next+ -> if length l == len then matchList len l next else failedMatch+ _ -> matchList (length l) l p+++match t@(VTuple b) (TupleLengthSel len next)+ = if length b == len then match t next else typeError "tuple wrong arity" t+match v (TupleLengthSel _ n) = typeError "expecting tuple" v++match (VTuple b) (TupleIthSel i next) = match (b !! i) next+match v (TupleIthSel _ n) = typeError "expecting tuple" v++match (VDotTuple l) (DotSel i next) = match (l !! i) next+match v (DotSel _ _) = typeError "expecting dot-tuple" v++match v p+ = throwInternalError ("hit catchall case of pattern-matcher :" ++ show (v,p))+ Nothing $ Just v++matchList :: Int -> [Value] -> Selector -> Maybe Value+matchList s !l !sel = case sel of+ SelectThis -> return $ VList l+ HeadSel next+ -> if null l then failedMatch else match (head l) next+ HeadNSel len next+ -> if s >= len+ then matchList len (take len l) next+ else failedMatch+ PrefixSel offset len next+ -> if s >= offset + len+ then matchList len (take len $ drop offset l) next+ else failedMatch+ TailSel next + -> if not $ null l then matchList (s-1) (tail l) next else failedMatch+ SliceSel offsetL offsetR next+ -> if s >= offsetL + offsetR+ then+ let+ newLen = s - offsetL -offsetR + in matchList newLen (take newLen $ drop offsetL l) next + else failedMatch+ SuffixSel offset len next+ -> if s >= offset + len+ then + let+ offsetLeft = s - offset - len+ in matchList len (take len $ drop offsetLeft l) next+ else failedMatch+ ListLengthSel len next+ -> if s == len then matchList s l next else failedMatch+ ListIthSel i next -> match (l !! i) next+ other -> throwTypingError ("matchList : not excpecting a List :" ++ show other)+ Nothing (Just $ VList l)+++{-+If we force the result we first force the value we match against+and then we check all selectors !+We must be careful about lazyness/strictness here !+todo: maybe use ST-Transformer to fold over the array / do some optimisations+avoid detour via lists++-}++-- | tryMatchStrict returns Nothing or a new Binding+tryMatchStrict :: Bindings -> LPattern -> Value -> Maybe Bindings+tryMatchStrict !binds p !val = case unLabel p of+ VarPat ident -> Just $ bindIdent ident val binds++ Selector sel ident -> case match val sel of+ Nothing -> Nothing+ Just valPart -> case ident of+ Nothing -> Just binds+ Just i -> Just $ bindIdent i valPart binds++ Selectors selectorL identArray -> do+ values <- matchGroup val selectorL+ let + addBind b i = case identArray Array.! i of + Just n -> bindIdent n (values Array.! i) b+ Nothing -> b+ return $ List.foldl' addBind binds $ Array.indices identArray+ _ -> throwInternalError "PatternMatcher : unsupported Pattern in strict match"+ (Just $ srcLoc p) Nothing++-- | tryMatchLazy allways return a new Binding, but may throw a error when+-- | any value in the binding is forced +-- | forcing one of the values causes all the selectors being tested++{-+todo : Fix THISBUG:+If we have Selectors which all do not bind a new Ident,+still should to force the value , so that we can detect a failing match+-}++tryMatchLazy :: Bindings -> LPattern -> Value -> Bindings+tryMatchLazy binds p@(unLabel -> VarPat ident) val+ = bindIdent ident val binds+tryMatchLazy binds p@(unLabel -> Selector sel ident) val+ = case ident of+ Just i -> bindIdent i valPart binds+ Nothing -> binds -- THISBUG+ where+ valPart = case match val sel of+ Just v -> v+ Nothing -> throwPatternMatchError "pattern-match failure" (Just $ srcLoc p) $ Just val++tryMatchLazy binds sel@(unLabel -> Selectors selectorss identArray) val+ = List.foldl' addBind binds $ Array.indices identArray+ where+ values = case matchGroup val selectorss of+ Just x -> x+ Nothing -> throwPatternMatchError "pattern-match failure"+ (Just $ srcLoc sel) $ Just val+ addBind b i = case identArray Array.! i of + Just n -> bindIdent n (values Array.! i) b+ Nothing -> b -- THISBUG+tryMatchLazy _ p v+ = throwInternalError "PatternMatcher : unsupported Pattern in lazyMatch"+ (Just $ srcLoc p) $ Just v++{-+If we force one of the values, we also have to force all+of the corresponding linear selectors !!+todo : for efficiency specialize this for small selectors+-}+matchGroup :: Value -> Array Int Selector -> Maybe (Array Int Value)+matchGroup val sel = do+ l <- mapM (match val) $ Array.elems sel+ return $ Array.listArray (Array.bounds sel) l+++boundNames :: LPattern -> [LIdent]+boundNames pat = case unLabel pat of+ VarPat i -> [i]+ Selector _ Nothing -> []+ Selector _ (Just i) -> [i]+ x@(Selectors {}) -> catMaybes $ Array.elems $ idents x
+ src/CSPM/Interpreter/Prefix.hs view
@@ -0,0 +1,76 @@+----------------------------------------------------------------------------+-- |+-- Module : CSPM.Interpreter.Prefix+-- Copyright : (c) Fontaine 2009+-- License : BSD+-- +-- Maintainer : Fontaine@cs.uni-duesseldorf.de+-- Stability : experimental+-- Portability : GHC-only+--+--+--+----------------------------------------------------------------------------+{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE BangPatterns #-}+module CSPM.Interpreter.Prefix+(+ initPrefix+ ,viewPrefixState+ ,prefixStateNext+ ,prefixStateFinalize+)+where++import CSPM.Interpreter.Types as Types+import CSPM.Interpreter.Bindings as Bindings+import CSPM.Interpreter.PatternMatcher+import CSPM.Interpreter.Eval+import CSPM.Interpreter.SSet as SSet++import qualified CSPM.CoreLanguage as Core+import Language.CSPM.AST as AST hiding (Bindings)++import Data.List as List+import Control.Monad++initPrefix :: PrefixState -> PrefixState+initPrefix = id++viewNextPrefixField :: PrefixState -> CommField+viewNextPrefixField = unLabel . head . prefixFields++viewPrefixState :: PrefixState -> Core.PrefixFieldView INT+viewPrefixState p | List.null $ prefixFields p+ = throwScriptError "viewPrefixState: no fields" Nothing Nothing+viewPrefixState p = case viewNextPrefixField p of+ OutComm out -> Core.FieldOut $ runEM (evalOutField out) env+ InComm pat -> Core.FieldIn+ InCommGuarded _pat g -> Core.FieldGuard $ runEM (evalFieldSet g) env+ where env = prefixEnv p++prefixStateNext :: PrefixState -> Field -> Maybe PrefixState+prefixStateNext p field | List.null $ prefixFields p+ = throwScriptError "prefixStateNext no fields" Nothing Nothing+prefixStateNext p field = case viewNextPrefixField p of+{- todo ::+ we must check that the Field is OK here+ we should use the lookahead scheme of the GenericBufferPrefix+-}+ OutComm out -> return $ p { prefixFields = tail $ prefixFields p }+ InComm pat -> prefixBindInput field pat+ InCommGuarded pat g -> prefixBindInput field pat+ where+ env = prefixEnv p+ prefixBindInput field pat = do+ newBinds <- tryMatchStrict (argBindings env) pat field+ return p {+ prefixFields = tail $ prefixFields p+ ,prefixEnv = setArgBindings env newBinds }++prefixStateFinalize :: PrefixState -> Maybe PrefixState+prefixStateFinalize p | prefixPatternFailed p = Nothing+prefixStateFinalize p | not $ List.null $ prefixFields p+ = throwScriptError "prefixStateFinalize: unsynchronized fields left" Nothing Nothing+prefixStateFinalize p+ = Just $ p { prefixRHS = runEM (evalProcess $ prefixBody p) (prefixEnv p) }
+ src/CSPM/Interpreter/PrepareAST.hs view
@@ -0,0 +1,125 @@+----------------------------------------------------------------------------+-- |+-- Module : CSPM.Interpreter.PrepareAST+-- Copyright : (c) Fontaine 2008+-- License : BSD+-- +-- Maintainer : Fontaine@cs.uni-duesseldorf.de+-- Stability : experimental+-- Portability : GHC-only+--+-- These are preprocessing steps which are specific for the interpreter.+-- Those steps of general use are in the CSPM-Frontend-package+--+----------------------------------------------------------------------------+{-# LANGUAGE ViewPatterns #-}+module CSPM.Interpreter.PrepareAST+(+ prepareAST+)+where++import Language.CSPM.AST as AST+import qualified Language.CSPM.Frontend as Frontend++import Data.Generics.Schemes (everywhere)+import Data.Generics.Aliases (mkT)+import Data.Generics.Basics (Data)++prepareAST :: LModule -> LModule+prepareAST ast = replaceFunCase $ addFreeNames ast+{-+ReplaceFunCase with funCaseNew.+This is a quickfix+In CSPM Syntax we have tree cases: fun(x)(y) fun(x,y) and fun((x,y))+we want to map them to : fun x y and fun (x,y) in Haskell-Syntax.+-}+replaceFunCase :: LModule -> LModule+replaceFunCase ast = everywhere (mkT compFC) ast+ where+ compFC :: FunCase -> FunCase+ compFC (FunCase args expr)= FunCaseI (concat args) expr+ compFC (FunCaseI _ _) + = error "Internal Error : Did not expect FunCaseI in parse result"+{-+ flatArgs args = case args of+ [x] -> x+ _ -> map wrapTuple args++ wrapTuple [a] = a -- one-element lists are not Tuples ?+ wrapTuple x =(AST.labeled . TuplePat) x+-}+++-- | Perform a freename analyzis for the body of prefixOperations+-- | and expressions that can become process-closures.+-- | This is ugly !!.+addFreeNames :: LModule -> LModule+addFreeNames ast = everywhere trans ast+ where+ trans :: Data a => a-> a+ trans = mkT mkExp -- . mkT mkFunBind++ fn :: LExp -> LExp+ fn expr = setNode expr+ $ ExprWithFreeNames (Frontend.computeFreeNames expr) expr++{-+ mkFunBind :: Decl -> Decl+ mkFunBind (FunBind i c) = FunBindI i (Frontend.computeFreeNames c) c+ mkFunBind o = o+-}++ mkExp :: Exp -> Exp+ mkExp expr = case expr of+ Let decls e+ -> LetI decls (Frontend.computeFreeNames (decls,expr)) e+ Lambda p e+ -> LambdaI (Frontend.computeFreeNames (p,e)) p e+ PrefixExp c f p+ -> PrefixI (Frontend.computeFreeNames (c,f,p) ) c f p+ ProcSharing s a b+ -> ProcSharing s (fn a) (fn b)+ ProcAParallel l r a b+ -> ProcAParallel l r (fn a) (fn b)+ ProcLinkParallel l a b+ -> ProcLinkParallel l (fn a) (fn b)+ ProcRenaming r gen p+ -> ProcRenaming r gen $ fn p+ ProcRepSequence l p + -> ProcRepSequence l $ fn p+ ProcRepInternalChoice l p+ -> ProcRepInternalChoice l $ fn p+ ProcRepInterleave l p+ -> ProcRepInterleave l $ fn p+ ProcRepExternalChoice l p+ -> ProcRepExternalChoice l $ fn p+ ProcRepAParallel l a p+ -> ProcRepAParallel l a $ fn p+ ProcRepLinkParallel l e p+ -> ProcRepLinkParallel l e $ fn p+ ProcRepSharing l e p+ -> ProcRepSharing l e $ fn p+-- this is really ugly+ CallBuiltIn x@(unLabel -> BuiltIn bi) [[a,b]]+ -> let constr = CallBuiltIn x in case bi of+ F_Sequential -> constr [[fn a,fn b]]+ F_Interrupt -> constr [[fn a,fn b]]+ F_ExtChoice -> constr [[fn a,fn b]]+ F_Timeout -> constr [[fn a,fn b]]+ F_IntChoice -> constr [[fn a,fn b]]+ F_Interleave -> constr [[fn a,fn b]]+ F_Hiding -> constr [[fn a,b]]+ _ -> constr [[a,b]]+ Fun2 x@(unLabel -> BuiltIn bi) a b+ -> let constr = Fun2 x in case bi of+ F_Sequential -> constr (fn a) (fn b)+ F_Interrupt -> constr (fn a) (fn b)+ F_ExtChoice -> constr (fn a) (fn b)+ F_Timeout -> constr (fn a) (fn b)+ F_IntChoice -> constr (fn a) (fn b)+ F_Interleave -> constr (fn a) (fn b)+ F_Hiding -> constr (fn a) b+ F_Guard -> constr a (fn b)+ _ -> constr a b+ other -> other
+ src/CSPM/Interpreter/Renaming.hs view
@@ -0,0 +1,95 @@+----------------------------------------------------------------------------+-- |+-- Module : CSPM.Interpreter.Renaming+-- Copyright : (c) Fontaine 2009+-- License : BSD+-- +-- Maintainer : Fontaine@cs.uni-duesseldorf.de+-- Stability : experimental+-- Portability : GHC-only+--+-- Utility functions dealing with renaming relations.+----------------------------------------------------------------------------+{-+naive implementation of a renaming relation.+todo: mode efficent implementation+-}+module CSPM.Interpreter.Renaming+where++import CSPM.Interpreter.Types as Types+import CSPM.Interpreter.Hash as Hash+import CSPM.Interpreter.ClosureSet++import qualified Data.List as List+import Data.Set (Set)+import qualified Data.Set as Set+import qualified Data.Map as Map++{- todo speedup using hashing -}+toRenaming :: [(Value,Value)]-> RenamingRelation+toRenaming s = RenamingRelation {+ renamingPairs = pairs+ ,renamingDigest = renameDigest pairs+ ,renamingDomain = Set.map fst pairs+ ,renamingRange = Set.map snd pairs+ } where+ pairs = Set.unions $ map pairToRel s+ pairToRel :: (Value,Value) -> Set (Event,Event)+ pairToRel (a,b) = Set.fromList $ do+ (VDotTuple p1) <- Set.toList $ prefixTrieToSet $ valueToPT a+ return (p1, newPrefix ++ drop plen p1)+ where+ plen = prefixLen a + newPrefix = valueToPrefix b++ valueToPrefix :: Value -> [Value]+ valueToPrefix v = case v of+ VChannel _ -> [v]+ VDotTuple l@(VChannel _ : _) -> l+ VDotTuple [] -> throwScriptError "toRenaming1 : empty dot-tuple" Nothing Nothing+ VDotTuple _ -> throwScriptError "toRenaming1 : dot-tuple does not start with a channel"+ Nothing (Just v)+ _ -> throwScriptError "toRenaming1 : cannot make renaming"+ Nothing $ Just v++ prefixLen :: Value -> Int+ prefixLen v = case v of+ VChannel _ -> 1+ VDotTuple l@(VChannel _ : _) -> length l+ VDotTuple [] -> throwScriptError "toRenaming2 : empty dot-tuple" Nothing Nothing+ VDotTuple _ -> throwScriptError "toRenaming2 : dot-tuple does not start with a channel"+ Nothing (Just v)+ _ -> throwScriptError "toRenaming2 : cannot make renaming"+ Nothing $ Just v++renameDigest :: Set (Event,Event) -> Digest+renameDigest pairs+ = mix3 (hs "RenamingRelation")+ (hash $ map fst $ Set.toList pairs)+ (hash $ map snd $ Set.toList pairs)++{-+inverseRenaming :: RenamingRelation -> RenamingRelation+inverseRenaming r+ = RenamingRelation {+ renamingPairs = pairs+ ,renamingDigest = renameDigest pairs+ ,renamingDomain = renamingRange r+ ,renamingRange = renamingDomain r } + where+ pairs = Set.map (\(a,b) -> (b,a)) $ renamingPairs r+-}++{- sets have actually no advantage because we convert to lists anyway -} ++imageRenaming1 :: RenamingRelation -> Event -> [Event]+imageRenaming1 relation prefix+ = List.map snd $ List.filter (\(x,_) -> x == prefix) $ Set.toList $ renamingPairs relation++imageRenaming2 :: RenamingRelation -> Event -> [Event]+imageRenaming2 relation prefix+ = List.map fst $ List.filter (\(_,x) -> x == prefix) $ Set.toList $ renamingPairs relation++isInRelation :: RenamingRelation -> Event -> Event -> Bool+isInRelation rel a b = (a,b) `Set.member` renamingPairs rel
+ src/CSPM/Interpreter/SSet.hs view
@@ -0,0 +1,149 @@+----------------------------------------------------------------------------+-- |+-- Module : CSPM.Interpreter.SSet+-- Copyright : (c) Fontaine 2009+-- License : BSD+-- +-- Maintainer : Fontaine@cs.uni-duesseldorf.de+-- Stability : experimental+-- Portability : GHC-only+--+-- +--+----------------------------------------------------------------------------++{-+probably obsolete++Sets extended with a symbolic representations for+Empty maps+Total maps+and the difference of a total map and an normal map.+do we need a fiths case PosNeg Set Set ?+this is a general datastructure that deserves its own package+think of this in terms of the corresponding boolsche expressions !+-}+module CSPM.Interpreter.SSet+where++import Data.Set (Set)+import qualified Data.Set as Set+import qualified Data.List as List++data SSet a=+ Proper { fromProper :: (Set a)}+ | Empty+ | Total+ | Inverse { fromInverse :: (Set a)}+ deriving (Eq,Ord)++instance (Show a) => Show (SSet a) where+ show (Proper m) = "(Set ::" ++ show (Set.toList m) ++ ")"+ show Empty = "EmptySet"+ show Total = "TotalSet"+ show (Inverse _) = "InverseSet"++intersection :: Ord a => SSet a -> SSet a -> SSet a++intersection(Proper s1) (Proper s2)+ = let t = Set.intersection s1 s2 in + if (Set.null t) then Empty else Proper t+intersection (Proper _) Empty = Empty+intersection (Proper m1) Total = Proper m1+intersection Total (Proper m2) = Proper m2+intersection Total Total = Total+intersection Empty Empty = Empty+intersection Empty (Proper _) = Empty+intersection Total Empty = Empty+intersection Empty Total = Empty+intersection Empty (Inverse _) = Empty+intersection (Inverse _) Empty= Empty+-- representation for diff not implemented+intersection (Inverse s1) (Proper s2) = Proper $ Set.difference s2 s1+intersection (Proper s1) (Inverse s2) = Proper $ Set.difference s1 s2+intersection a@(Inverse _) Total = a+intersection Total a@(Inverse _) = a+intersection (Inverse s1) (Inverse s2) = Inverse $ Set.union s1 s2++difference :: Ord a => SSet a -> SSet a -> SSet a+difference(Proper s1) (Proper s2)+ = let t = Set.difference s1 s2 in + if (Set.null t) then Empty else Proper t++difference a@(Proper _) Empty = a+difference (Proper _) Total = Empty+difference Total (Proper m2) = Inverse m2+difference Total Total = Empty+difference Empty Empty = Empty+difference Empty (Proper _) = Empty+difference Total Empty = Total+difference Empty Total = Empty+difference Empty (Inverse _) = Empty+difference a@ (Inverse _) Empty= a+-- representation for diff not implemented+difference (Inverse a) (Proper b) = Inverse $ Set.union a b+difference (Proper a) (Inverse b) = Inverse $ Set.union a b+difference (Inverse _) Total = Empty+difference Total (Inverse s) = Proper s+difference (Inverse a) (Inverse b) = Inverse $ Set.union a b++member :: Ord a => a -> SSet a -> Bool+member x (Proper s) = Set.member x s+member _ Empty = False+member _ Total = True+member x (Inverse s) = not $ Set.member x s++union :: Ord a => SSet a -> SSet a -> SSet a++union(Proper s1) (Proper s2) = Proper $ Set.union s1 s2+union a@(Proper _) Empty = a+union (Proper _) Total = Total+union Total (Proper _) = Total+union Total Total = Total+union Empty Empty = Empty+union Empty a@(Proper _) = a+union Total Empty = Total+union Empty Total = Total++union Empty a@(Inverse _) = a+union a@(Inverse _) Empty = a+-- representation for diff not implemented+union (Inverse i) (Proper s) = Inverse $ Set.difference i s+union (Proper s) (Inverse i) = Inverse $ Set.difference i s+union (Inverse _) Total = Total+union Total (Inverse _) = Total+union (Inverse s1) (Inverse s2) = Inverse $ Set.intersection s1 s2++fromList :: Ord a => [a] -> SSet a+fromList = Proper . Set.fromList++unions :: Ord a => [SSet a] -> SSet a+unions l = List.foldl' union Empty l ++singleton :: Ord a => a -> SSet a+singleton = Proper . Set.singleton ++toList :: SSet a -> [a]+toList m = case m of+ Proper s -> Set.toList s+ Empty -> []+ Total -> error "SSet.hs : toList Total"+ Inverse _ -> error "SSet.hs : toList Inverse"++null :: SSet a -> Bool+null Empty = True+null (Proper m)+ = if (Set.null m) then error "SSet.hs : isAllwayEmpty :: not symbolic"+ else False+null _ = False+++insert :: Ord a => a -> SSet a -> SSet a+insert e sy = case sy of+ Proper s -> Proper $ Set.insert e s+ _ -> error "SSet.hs : todo: implement insert"++delete :: Ord a => a -> SSet a -> SSet a+delete e sy = case sy of+ Proper s -> Proper $ Set.delete e s+ _ -> error "SSet.hs : todo: implement delete"
+ src/CSPM/Interpreter/Test/CLI.hs view
@@ -0,0 +1,139 @@+----------------------------------------------------------------------------+-- |+-- Module : CSPM.Interpreter.Test.CLI+-- Copyright : (c) Fontaine 2008+-- License : BSD+-- +-- Maintainer : Fontaine@cs.uni-duesseldorf.de+-- Stability : experimental+-- Portability : GHC-only+--+-- This is mainly useful for testing the functional sub language.+-- This module does not allow tracing of processes+-- (tracing is implemented in an other package).+--+-- 'runFile' loads a CSPM-specification from a file and evaluates an expression in+-- the context of that specification.+--+-- Example:+--+-- 'runFile' fib.csp fib(10)+--+-- where the file fib.csp contains:+-- fib(x)= if x <2 then 1 else fib(x-1)+fib(x-2)+--+-- 'runFile' writes to 'stdout' and handles some exceptions.+--+----------------------------------------------------------------------------++module CSPM.Interpreter.Test.CLI+(+ evalTest+ ,runFile+)++where+import Language.CSPM.Frontend+import qualified Language.CSPM.AST as AST++import CSPM.Interpreter.Eval+import qualified CSPM.Interpreter.Types as Types+import CSPM.Interpreter.Types+ (Value,initialEnvirionment,getLetBindings)+import CSPM.Interpreter.PrepareAST (prepareAST)+import CSPM.Interpreter.Hash+import CSPM.Interpreter.CoreInstances ()++import System.Exit+import System.CPUTime++import Control.Monad+import qualified Data.IntMap as IntMap+import qualified Data.Map as Map+import Data.Maybe++-- | Load a specification from a file and evaluate an expression in the context.+-- Print the result to 'stdout' and handle some exceptions.+runFile :: FilePath -> String -> IO ()+runFile fileName expr+ = handleLexError lexErrorHandler+ $ handleParseError parseErrorHandler+ $ handleRenameError renameErrorHandler $+ do+ val <- evalTest fileName expr+ putStrLn $ show val+ exitSuccess++-- | Load a specification from a file and evaluate an expression in the context.+evalTest :: FilePath -> String -> IO Value+evalTest fileName expr = liftM fst $ evalEnv fileName expr++{- Todo: clean up the mess below -}+++evalEnv :: FilePath -> String -> IO (Value,Types.Env)+evalEnv fileName expr = do+ srcPlain <- readFile fileName+{- this is a hack:+we simply append the expression to be evaluated at the end of the sourcefile+and parse both together in one go+todo : fix+-}+ let src = srcPlain ++ "\n--patch entrypoint\ntest__entry = " ++expr ++"\n" ++-- putStrLn $ "Reading File " ++ fileName+ _startTime <- (return $ length src) >> getCPUTime+ tokenList <- lexInclude src >>= eitherToExc+ _time_have_tokens <- getCPUTime++ ast <- eitherToExc $ parse fileName tokenList+ _time_have_ast <- getCPUTime++ renaming <- eitherToExc $ getRenaming ast+ let astNew = prepareAST $ applyRenaming renaming ast+ case astNew of Labeled {} -> return () -- force astNew ?+ _time_have_renaming <- getCPUTime++-- putStrLn $ "Parsing OK"+-- putStrLn $ "lextime : " ++ showTime (time_have_tokens - startTime)+-- putStrLn $ "parsetime : " ++ showTime(time_have_ast - time_have_tokens)+-- putStrLn $ "renamingtime : " ++ showTime (time_have_renaming - time_have_ast)+-- putStrLn $ "total : " ++ showTime(time_have_ast - startTime)++ time_start_execute <- getCPUTime+ initEnv <- initialEnvirionment+ let+ entry :: AST.UniqueIdent+ entry = fromJust $ Map.lookup "test__entry" $ (\(x,_,_) -> x) renaming+ astP :: LModule+ astP = compilePattern astNew+ env = processDeclList (hs "TopLevelEnvirionment") initEnv+ $ AST.moduleDecls $ unLabel astP+ val :: Value+ val = (IntMap.!) (getLetBindings env) $ AST.uniqueIdentId entry+-- forM_ (IntMap.elems $ getLetBindings env) $ \p -> putStrLn $ show p+ putStrLn $ show val+ time_finish_execute <- getCPUTime+ putStrLn $ "execution time : " ++ showTime(time_finish_execute - time_start_execute)+ return (val,env)++showTime :: Integer -> String+showTime a = show (div a 1000000000) ++ "ms"++parseErrorHandler :: ParseError -> IO ()+parseErrorHandler err = do+ putStrLn "ParseError : "+ putStrLn $ show err+ exitFailure++lexErrorHandler :: LexError -> IO ()+lexErrorHandler err = do+ putStrLn "LexError : "+ putStrLn $ show err+ exitFailure++renameErrorHandler :: RenameError -> IO ()+renameErrorHandler err = do + putStrLn "RenamingError : "+ putStrLn $ show err+ exitFailure
+ src/CSPM/Interpreter/Types.hs view
@@ -0,0 +1,304 @@+----------------------------------------------------------------------------+-- |+-- Module : CSPM.Interpreter.Types+-- Copyright : (c) Fontaine 2008+-- License : BSD+-- +-- Maintainer : Fontaine@cs.uni-duesseldorf.de+-- Stability : experimental+-- Portability : GHC-only+--+-- Definitions of most of the types used in the interpreter.+-- Also Instance declarations for the core language type families.+-- 'INT' is the type (index) for the CSPM interpreter.+--+----------------------------------------------------------------------------+{-# LANGUAGE TypeSynonymInstances,TypeFamilies #-}+{-# LANGUAGE EmptyDataDecls #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE StandaloneDeriving #-}++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 CoreField.PrefixState 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+-- ,prefixLastInputBuffer :: [Value]+-- ,prefixOutputBuffer :: [Value]+ }++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 -- todo : merge argBindings and letBindings+ ,letBindings :: Bindings + ,letDigests :: IntMap Digest+ }++initialEnvirionment :: IO Env+initialEnvirionment = return emptyEnvirionment++emptyEnvirionment :: Env+emptyEnvirionment = Env {+ argBindings = IntMap.empty+ ,letBindings = IntMap.empty+ ,letDigests = IntMap.empty+ }++{- +xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx+this is worng !+we must not omit let bound identifier !!+the fix is to statically compute, which parts of the envirionment are+relevant and compare exactly those+-}++{-+instance Ord Env where+ compare a b = compare (argBindings a) (argBindings b)+instance Eq Env where+ (==) a b = argBindings a == argBindings b+-}+-- xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx++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+-- cspm-special features+ | VAllInts+ | VAllSequents (Set Value)+-- | VAllEvents+ | 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] -- these are the fields proper excluding the channel itself+ } 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 "+-- VAllEvents -> "VAllEvents"+ 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 --rectangular closuresets (e.g. channels)+-- | PTInt PrefixTrie -- any Int field : todo generarlise this+ | 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
+ src/Data/Digest/Pure/HashMD5.hs view
@@ -0,0 +1,99 @@+{-# LANGUAGE BangPatterns #-}+-----------------------------------------------------------------------------+--+-- Module : Data.Digest.Pure.HashMD5+-- License : BSD3+-- Stability : experimental+-- Portability : portable, requires bang patterns and ByteString+-- Tested with : GHC-6.12.2+--+-- Use the MD5-rounds to compute hash-values for data-structures.+-----------------------------------------------------------------------------++module Data.Digest.Pure.HashMD5+ (+ MD5Digest+ , Hash(..)+ , md5Init+ , mixRaw+ , mix+ , mix3+ , mix4+ , mix5+ , mixInt+ , foldHash+ ) where++import Data.Digest.Pure.MD5+import Data.Char++{-# INLINE mix5 #-}+mix5 a (MD5Digest w0 w1 w2 w3) (MD5Digest w4 w5 w6 w7)+ (MD5Digest w8 w9 w10 w11) (MD5Digest w12 w13 w14 w15)+ = mixRaw a w0 w1 w2 w3 w4 w5 w6 w7 w8 w9 w10 w11 w12 w13 w14 w15++{-# INLINE mix4 #-}+mix4 :: MD5Digest -> MD5Digest -> MD5Digest -> MD5Digest -> MD5Digest+mix4 a b c d = mix5 md5Init a b c d++{-# INLINE mix3 #-}+mix3 :: MD5Digest -> MD5Digest -> MD5Digest -> MD5Digest+mix3 a b c = mix5 md5Init md5Init a b c++{-# INLINE mix #-}+mix :: MD5Digest -> MD5Digest -> MD5Digest+mix a b = mix5 md5Init md5Init md5Init a b++class Hash a where+ hash :: a -> MD5Digest++-- instance Monoid HashMD5+instance Hash MD5Digest where+ hash = id+ +instance Hash Char where+ hash c = mixRaw md5Init (fromIntegral $ ord c) 234124 23415 3452 0 0 0 0+ 0 0 0 0 0 0 0 0++instance (Hash a, Hash b) => Hash (a,b) where+ hash (a, b) = mix (hash a) (hash b)++instance (Hash a, Hash b, Hash c) => Hash (a, b, c) where+ hash (a, b, c) = mix3 (hash a) (hash b) (hash c)++instance (Hash a, Hash b, Hash c, Hash d) => Hash (a, b, c, d) where+ hash (a, b, c, d) = mix4 (hash a) (hash b) (hash c) (hash d)+++hashString :: String -> MD5Digest+hashString+ = foldHash $ mixRaw md5Init 234 42 21 23 0 0 0 0 0 0 0 0 0 0 0 0++instance Hash a => Hash [a] where+ hash = foldHash (hashString "Prelude.List standart")++foldHash :: Hash a => MD5Digest -> [a] -> MD5Digest+foldHash !acc [] = acc+foldHash !acc [a] = mix acc (hash a)+foldHash !acc [a,b] = mix3 acc (hash a) (hash b)+foldHash !acc [a,b,c] = mix4 acc (hash a) (hash b) (hash c)+foldHash !acc (a:b:c:d:rest) = foldHash (mix5 acc (hash a) (hash b) (hash c) (hash d)) rest++{-# inline mixInt #-}+mixInt :: MD5Digest -> Int -> MD5Digest+mixInt h i = mixRaw h (fromIntegral i) 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0++{-+foldInt :: Hash64 -> [Int] -> Hash64+foldInt !acc [] = acc+foldInt !acc [a] = mixRaw acc (fromIntegral a) 0 0 0+foldInt !acc [a,b] = mixRaw acc (fromIntegral a) (fromIntegral b) 0 0+foldInt !acc [a,b,c]+ = mixRaw acc (fromIntegral a) (fromIntegral b) (fromIntegral c) 0+foldInt !acc [a,b,c,d]+ = mixRaw acc (fromIntegral a) (fromIntegral b) (fromIntegral c) (fromIntegral d)+foldInt !acc (a:b:c:d:rest)+ = foldInt+ (mixRaw acc (fromIntegral a) (fromIntegral b) (fromIntegral c) (fromIntegral d))+ rest+-}
+ src/Data/Digest/Pure/MD5.hs view
@@ -0,0 +1,178 @@+{-# LANGUAGE BangPatterns #-}+-----------------------------------------------------------------------------+-- Module : Data.Digest.Pure.MD5+-- License : BSD3+--+-- Stability : experimental+-- Portability : portable, requires bang patterns and ByteString+-- Tested with : GHC-6.8.1+--+-- This is taken from the pureMD5 package but stripped down to remove some dependencies.+-- Ideally one would extend pureMD5 or move this to a seperate package.+-- Original Author is : Thomas.DuBuisson@gmail.com+--+-----------------------------------------------------------------------------++module Data.Digest.Pure.MD5+ (+ MD5Digest (..)+ , mixRaw+ , md5Init+ ) where++import Data.List+import Data.Word+import Data.Bits+import Numeric++data MD5Digest = MD5Digest !Word32 !Word32 !Word32 !Word32+ deriving (Ord, Eq)++md5Init :: MD5Digest+md5Init = MD5Digest h0 h1 h2 h3+ where+ h0 = 0x67452301+ h1 = 0xEFCDAB89+ h2 = 0x98BADCFE+ h3 = 0x10325476++{-# INLINE applyMD5RoundsRaw #-}+applyMD5RoundsRaw ::+ MD5Digest+ -> Word32 -> Word32 -> Word32 -> Word32+ -> Word32 -> Word32 -> Word32 -> Word32+ -> Word32 -> Word32 -> Word32 -> Word32+ -> Word32 -> Word32 -> Word32 -> Word32+ -> MD5Digest+applyMD5RoundsRaw+ (MD5Digest a b c d)+ !w0 !w1 !w2 !w3 + !w4 !w5 !w6 !w7+ !w8 !w9 !w10 !w11 + !w12 !w13 !w14 !w15+ = {-# SCC "applyMD5RoundsRaw" #-}+ let -- Round 1+ !r0 = ff a b c d w0 7 3614090360+ !r1 = ff d r0 b c w1 12 3905402710+ !r2 = ff c r1 r0 b w2 17 606105819+ !r3 = ff b r2 r1 r0 w3 22 3250441966+ !r4 = ff r0 r3 r2 r1 w4 7 4118548399+ !r5 = ff r1 r4 r3 r2 w5 12 1200080426+ !r6 = ff r2 r5 r4 r3 w6 17 2821735955+ !r7 = ff r3 r6 r5 r4 w7 22 4249261313+ !r8 = ff r4 r7 r6 r5 w8 7 1770035416+ !r9 = ff r5 r8 r7 r6 w9 12 2336552879+ !r10 = ff r6 r9 r8 r7 w10 17 4294925233+ !r11 = ff r7 r10 r9 r8 w11 22 2304563134+ !r12 = ff r8 r11 r10 r9 w12 7 1804603682+ !r13 = ff r9 r12 r11 r10 w13 12 4254626195+ !r14 = ff r10 r13 r12 r11 w14 17 2792965006+ !r15 = ff r11 r14 r13 r12 w15 22 1236535329+ -- Round 2+ !r16 = gg r12 r15 r14 r13 w1 5 4129170786+ !r17 = gg r13 r16 r15 r14 w6 9 3225465664+ !r18 = gg r14 r17 r16 r15 w11 14 643717713+ !r19 = gg r15 r18 r17 r16 w0 20 3921069994+ !r20 = gg r16 r19 r18 r17 w5 5 3593408605+ !r21 = gg r17 r20 r19 r18 w10 9 38016083+ !r22 = gg r18 r21 r20 r19 w15 14 3634488961+ !r23 = gg r19 r22 r21 r20 w4 20 3889429448+ !r24 = gg r20 r23 r22 r21 w9 5 568446438+ !r25 = gg r21 r24 r23 r22 w14 9 3275163606+ !r26 = gg r22 r25 r24 r23 w3 14 4107603335+ !r27 = gg r23 r26 r25 r24 w8 20 1163531501+ !r28 = gg r24 r27 r26 r25 w13 5 2850285829+ !r29 = gg r25 r28 r27 r26 w2 9 4243563512+ !r30 = gg r26 r29 r28 r27 w7 14 1735328473+ !r31 = gg r27 r30 r29 r28 w12 20 2368359562+ -- Round 3+ !r32 = hh r28 r31 r30 r29 w5 4 4294588738+ !r33 = hh r29 r32 r31 r30 w8 11 2272392833+ !r34 = hh r30 r33 r32 r31 w11 16 1839030562+ !r35 = hh r31 r34 r33 r32 w14 23 4259657740+ !r36 = hh r32 r35 r34 r33 w1 4 2763975236+ !r37 = hh r33 r36 r35 r34 w4 11 1272893353+ !r38 = hh r34 r37 r36 r35 w7 16 4139469664+ !r39 = hh r35 r38 r37 r36 w10 23 3200236656+ !r40 = hh r36 r39 r38 r37 w13 4 681279174+ !r41 = hh r37 r40 r39 r38 w0 11 3936430074+ !r42 = hh r38 r41 r40 r39 w3 16 3572445317+ !r43 = hh r39 r42 r41 r40 w6 23 76029189+ !r44 = hh r40 r43 r42 r41 w9 4 3654602809+ !r45 = hh r41 r44 r43 r42 w12 11 3873151461+ !r46 = hh r42 r45 r44 r43 w15 16 530742520+ !r47 = hh r43 r46 r45 r44 w2 23 3299628645+ -- Round 4+ !r48 = ii r44 r47 r46 r45 w0 6 4096336452+ !r49 = ii r45 r48 r47 r46 w7 10 1126891415+ !r50 = ii r46 r49 r48 r47 w14 15 2878612391+ !r51 = ii r47 r50 r49 r48 w5 21 4237533241+ !r52 = ii r48 r51 r50 r49 w12 6 1700485571+ !r53 = ii r49 r52 r51 r50 w3 10 2399980690+ !r54 = ii r50 r53 r52 r51 w10 15 4293915773+ !r55 = ii r51 r54 r53 r52 w1 21 2240044497+ !r56 = ii r52 r55 r54 r53 w8 6 1873313359+ !r57 = ii r53 r56 r55 r54 w15 10 4264355552+ !r58 = ii r54 r57 r56 r55 w6 15 2734768916+ !r59 = ii r55 r58 r57 r56 w13 21 1309151649+ !r60 = ii r56 r59 r58 r57 w4 6 4149444226+ !r61 = ii r57 r60 r59 r58 w11 10 3174756917+ !r62 = ii r58 r61 r60 r59 w2 15 718787259+ !r63 = ii r59 r62 r61 r60 w9 21 3951481745+ in MD5Digest r60 r63 r62 r61+ where+ f !x !y !z = (x .&. y) .|. ((complement x) .&. z)+ {-# INLINE f #-}+ g !x !y !z = (x .&. z) .|. (y .&. (complement z))+ {-# INLINE g #-}+ h !x !y !z = (x `xor` y `xor` z)+ {-# INLINE h #-}+ i !x !y !z = y `xor` (x .|. (complement z))+ {-# INLINE i #-}+ ff a b c d !x s ac = {-# SCC "ff" #-}+ let !a' = f b c d + x + ac + a+ !a'' = rotateL a' s+ in a'' + b+ {-# INLINE ff #-}+ gg a b c d !x s ac = {-# SCC "gg" #-}+ let !a' = g b c d + x + ac + a+ !a'' = rotateL a' s+ in a'' + b+ {-# INLINE gg #-}+ hh a b c d !x s ac = {-# SCC "hh" #-}+ let !a' = h b c d + x + ac + a+ !a'' = rotateL a' s+ in a'' + b+ {-# INLINE hh #-}+ ii a b c d !x s ac = {-# SCC "ii" #-}+ let !a' = i b c d + x + ac + a+ !a'' = rotateL a' s+ in a'' + b+ {-# INLINE ii #-}+++infix 9 .<.+(.<.) :: Word8 -> Int -> Word32+(.<.) w i = (fromIntegral w) `shiftL` i++-- | mix one Digest and 16 words by applying the md5-rounds+mixRaw ::+ MD5Digest+ -> Word32 -> Word32 -> Word32 -> Word32+ -> Word32 -> Word32 -> Word32 -> Word32+ -> Word32 -> Word32 -> Word32 -> Word32+ -> Word32 -> Word32 -> Word32 -> Word32+ -> MD5Digest+{- mix is the same as applyMD5RoundsRaw, except without INLINE pragma -}+mixRaw = applyMD5RoundsRaw++----- Some quick and dirty instances follow -----++-- todo: this is not offical+instance Show MD5Digest where+ show (MD5Digest a b c d) = "HashMD5_"++ toHex a ++ toHex b ++ toHex c ++ toHex d+ where+ toHex :: Integral a => a -> String+ toHex a = reverse $ take 8 $ hex a where+ hex x = (digits !! (fromIntegral (x `mod` 16))) : hex ( x `div` 16)+ digits = "0123456789ABCDEF"
+ src/Main.hs view
@@ -0,0 +1,26 @@+----------------------------------------------------------------------------+-- |+-- Module : CSPM.Interpreter.Test.Main+-- Copyright : (c) Fontaine 2010+-- License : BSD+-- +-- Maintainer : Fontaine@cs.uni-duesseldorf.de+-- Stability : experimental+-- Portability : GHC-only+--+-- Very rudimentary comand line interface to the interpreter.+----------------------------------------------------------------------------++module Main+where++import CSPM.Interpreter.Test.CLI+import System.Environment (getArgs)+-- | main-funtion for the command line.+-- (no help and no nothing)+main :: IO ()+main = do+ l <- getArgs+ case l of+ [filePath, expression] -> runFile filePath expression+ _ -> putStrLn "please start with two arguments: filename + expression"