CSPM-Interpreter 0.4.4.1 → 0.5.1.0

raw patch · 7 files changed

+63/−62 lines, 7 filesdep ~CSPM-CoreLanguagedep ~CSPM-FrontendPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: CSPM-CoreLanguage, CSPM-Frontend

API changes (from Hackage documentation)

Files

• CSPM-Interpreter.cabal +5/−5
• src/CSPM/Interpreter.hs +9/−1
• src/CSPM/Interpreter/Eval.hs +17/−10
• src/CSPM/Interpreter/Hash.hs +1/−1
• src/CSPM/Interpreter/PatternCompiler.hs +1/−1
• src/CSPM/Interpreter/Test/CLI.hs +21/−20
• src/CSPM/Interpreter/Types.hs +9/−24

@@ -1,5 +1,5 @@ Name:                CSPM-Interpreter-Version:             0.4.4.1+Version:             0.5.1.0  Synopsis:            An interpreter for CSPM Description:@@ -15,17 +15,16 @@ License-File:        LICENSE Author:              2010 - 2011 Marc Fontaine Maintainer:          Marc Fontaine <fontaine@cs.uni-duesseldorf.de>-Homepage:            http://www.stups.uni-duesseldorf.de/~fontaine/csp Stability:           experimental-Tested-With:         GHC == 7.0.2+Tested-With:         GHC == 7.0.3  cabal-Version:       >= 1.10 build-type: Simple Extra-source-files: Library   Build-Depends:-    CSPM-Frontend >= 0.6 && < 0.7-    ,CSPM-CoreLanguage >= 0.2 && < 0.3+    CSPM-Frontend >= 0.7 && < 0.8+    ,CSPM-CoreLanguage >= 0.3 && < 0.4     ,base >= 4.0 && < 5.0     ,containers >= 0.4 && < 0.5     ,mtl (>= 2.0 && < 2.1 ) || (>= 1.1 && < 1.2)@@ -55,3 +54,4 @@     CSPM.Interpreter.SSet     Data.Digest.Pure.MD5     Data.Digest.Pure.HashMD5+    Paths_CSPM_Interpreter

@@ -15,13 +15,15 @@ module CSPM.Interpreter (    runFile-  ,evalTest+  ,evalString+  ,evalFile   ,getSigma   ,prepareAST   ,runInterpreter   ,runInterpreterP   ,module CSPM.Interpreter.Types   ,module CSPM.Interpreter.Bindings+  ,interpreterVersion ) where @@ -34,7 +36,13 @@  import Language.CSPM.AST as AST +import Paths_CSPM_Interpreter (version)+import Data.Version (Version) import Data.IntMap as IntMap++-- | The version of the CSPM-Interpreter library+interpreterVersion :: Version+interpreterVersion = version  -- | Run the interpreter for a given module and top-level identifier. runInterpreter :: AST.Module INT -> AST.UniqueIdent -> (Value, Env)

@@ -117,7 +117,6 @@   IntSet -> return $ VAllInts -}   IntSet -> return $ VSet $ Set.fromList $ map VInt [0..100] --ToDo: fix this !!-  ProcSet -> throwFeatureNotImplemented "Proc datatype" $ Just $ srcLoc expr   TupleExp l -> mapM eval l >>= return . VTuple   Parens e -> eval e   AndExp a b -> do@@ -127,6 +126,7 @@     av <- evalBool a     if av then return $ VBool True else eval b   NotExp e -> evalBool e >>= return . VBool . not+  NegExp e -> evalInt e >>= return . VInt . negate   Fun1 bi e -> builtIn1 bi e   Fun2 bi a b -> builtIn2 bi a b   DotTuple l -> mapM eval l >>= return . VDotTuple . concatMap flatTuple@@ -284,7 +284,7 @@ builtIn1 :: LBuiltIn -> LExp -> EM Value builtIn1 op expr    = case lBuiltInToConst op of-    F_Seq -> evalSet expr >>= return . VAllSequents+    F_Seq -> evalSet expr >>= return . VAllSequences     F_card -> do       s <- evalSet expr       return $ VInt $ fromIntegral $ Set.size s@@ -459,9 +459,15 @@                              (Just $ srcLoc i) Nothing     Assert {} -> return ()     Transparent names ->  forM_ names $ \n -> bindIdentM n cspIdentityFunction-    SubType _ _ -> throwFeatureNotImplemented "subtype declarations" $ Just $ srcLoc decl+    SubType tname constrList -> do+{-+       subtypes are like data types except that we do not bind the constructs+       todo : check subtype declaration is correct, i.e. it really declares subtype+-}+       constrs <- mapM (constrDecl False) constrList+       bindIdentM tname (VDataType constrs )     DataType tname constrList -> do-       constrs <- mapM constrDecl constrList+       constrs <- mapM (constrDecl True) constrList        bindIdentM tname (VDataType constrs )     NameType tname t -> do       finalEnv <- asks snd@@ -482,8 +488,8 @@                 Just l -> runEnv finalEnv $ evalTypeDef l              } -constrDecl :: LConstructor -> DeclM Types.Constructor-constrDecl (unLabel -> AST.Constructor ident td) = do+constrDecl :: Bool -> LConstructor -> DeclM Types.Constructor+constrDecl performBinding (unLabel -> AST.Constructor ident td) = do   finalEnv <- asks snd   let     cl = case td of@@ -494,12 +500,12 @@                (AST.uniqueIdentId $ AST.unUIdent $ unLabel ident)                (AST.realName $ AST.unUIdent $ unLabel ident)                cl -  bindIdentM ident $ VConstructor constr+  when performBinding $ bindIdentM ident $ VConstructor constr   return constr -evalTypeDef :: LTypeDef -> EM [FieldSet]+evalTypeDef :: LTypeDef -> EM [FieldSet] -- <- this is too restrictive ? evalTypeDef t = case unLabel t of-  TypeDot l  -> mapM evalFieldSet l+  TypeDot l  -> mapM evalFieldSet l -- <- meight be a tuple of one   TypeTuple l -> do     el <- mapM evalFieldSet l     -- cross-product@@ -515,8 +521,9 @@ -- todo : fixthis when we have ClosureExpressions -- todo: this does not work for constructors that have fields     VDataType constrList -> return $ SSet.fromList $ map VConstructor constrList+    VNameType _ -> throwInternalError "nametype not implemented" (Just $ srcLoc expr) $ Just v     VAllInts -> return $ SSet.fromList $ map VInt [0..10] --todo-    _ -> throwTypingError "valueToEventSet " (Just $ srcLoc expr) $ Just v+    _ -> throwTypingError "evalFieldSet" (Just $ srcLoc expr) $ Just v  switchedOffProc :: LExp -> EM Process switchedOffProc (unLabel -> ExprWithFreeNames free expr) = do

@@ -62,7 +62,7 @@    VChannel c -> mixInt (hs "VChannel") $ chanId c    VUnit -> hs "VUnit"    VAllInts -> hs "VAllInts"-   VAllSequents s -> foldHash (hs "VAllSequents" ) $ Set.toAscList s+   VAllSequences s -> foldHash (hs "VAllSequences" ) $ Set.toAscList s --   VAllEvents -> hs "VAllEvents"    VConstructor c -> mix (hs "VConstructor") $ hash c    VDataType d -> foldHash (hs "VDataType") d

@@ -53,7 +53,7 @@       IntPat i -> return (Nothing, path $ IntSel i)       TruePat  -> return (Nothing, path TrueSel )       FalsePat -> return (Nothing, path FalseSel )-      WildCard -> return (Nothing, path SelectThis )+      WildCard -> [] -- return (Nothing, path SelectThis )       VarPat x -> return (Just x , path SelectThis )       ConstrPat x -> return (Nothing, path $ ConstrSel $ unUIdent $ unLabel x)       Also l -> concatMap (cp path) l

@@ -28,9 +28,9 @@  module CSPM.Interpreter.Test.CLI (-   evalTest-  ,runFile-  ,evalEnv+  runFile+  ,evalFile+  ,evalString )  where@@ -62,43 +62,44 @@       $ handleParseError parseErrorHandler         $ handleRenameError renameErrorHandler $   do-    val <- evalTest fileName expr-    putStrLn $ show val+    res <- evalFile False (Just fileName) expr+    putStrLn $ show $ fst res     exitSuccess --- | Load a specification from a file and evaluate an expression in the context.-evalTest ::-     FilePath -- ^ CSPM specification-  -> String -- ^ a CSPM expression-  -> IO Value -- ^ the result-evalTest fileName expr = liftM fst $ evalEnv False (Just fileName) expr- {- Todo: clean up the mess below -} --- | Evaluate an expression in an optional context.-evalEnv ::+-- | Evaluate an expression, optionall load a context from a file+evalFile ::      Bool -- ^ verbose output ?   -> Maybe FilePath -- ^ optional specification to load into context   -> String -- ^ a CSPM expression   -> IO (Value, Types.Env)-evalEnv verbose context expr = do-  srcPlain <- case context of+evalFile verbose context expr = do+  plainSrc <- case context of     Just path -> readFile path     Nothing -> return ""-  let fileName = fromMaybe "expression" context+  evalString verbose plainSrc (fromMaybe "expression" context) expr++-- | Evaluate an expression, optionall load a context from a string+evalString ::+     Bool -- ^ verbose output ?+  -> String -- ^ String containg CSPM specification (may be empty)+  -> String       -- ^ name of the specification for error-reporting+  -> String -- ^ a CSPM expression+  -> IO (Value, Types.Env)+evalString verbose specSrc specName expr = do {- 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"  +  let src = specSrc ++ "\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+  ast <- eitherToExc $ parse specName tokenList   _time_have_ast <- getCPUTime    (renamedAst, renaming) <- eitherToExc $ renameModule ast

@@ -1,9 +1,9 @@ ---------------------------------------------------------------------------- -- | -- Module      :  CSPM.Interpreter.Types--- Copyright   :  (c) Fontaine 2008--- License     :  BSD--- +-- Copyright   :  (c) Fontaine 2008 - 2011+-- License     :  BSD3+-- -- Maintainer  :  Fontaine@cs.uni-duesseldorf.de -- Stability   :  experimental -- Portability :  GHC-only@@ -41,6 +41,7 @@ import Data.Function  data INT+  deriving Typeable  type Event = [Field] type instance Core.Event INT = Event@@ -67,7 +68,7 @@   = ClosureSet {     closureSetTrie :: PrefixTrie    ,closureSetDigest :: Digest-   } deriving (Show)+   } deriving (Show, Typeable)  instance Ord ClosureSet where   compare = comparing closureSetDigest@@ -145,7 +146,7 @@    argBindings :: Bindings -- todo : merge argBindings and letBindings   ,letBindings :: Bindings    ,letDigests :: IntMap Digest-  }+  } deriving Typeable  emptyEnvirionment :: Env emptyEnvirionment = Env {@@ -154,22 +155,6 @@   ,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) @@ -205,13 +190,13 @@  | VUnit -- cspm-special features  | VAllInts- | VAllSequents (Set Value)+ | VAllSequences (Set Value) --  | VAllEvents  | VConstructor Constructor  | VDataType [Constructor]  | VNameType [FieldSet]  | VPartialApplied FunClosure [Value]- deriving (Ord,Eq)+ deriving (Ord, Eq, Typeable)  data FunClosure = FunClosure {    getFunCases :: [AST.FunCase]@@ -268,7 +253,7 @@     VFun _ -> "(VFun Functionclosure)"     VUnit -> "VUnit"     VAllInts -> "VAllInts"-    VAllSequents _  -> "VAllSequents "+    VAllSequences _  -> "VAllSequences" --  VAllEvents -> "VAllEvents"     VConstructor c -> "(VConstructor " ++ (show $ constrName c) ++ ")"     VDataType l