summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--src/Main.hs6
-rw-r--r--src/Parser.hs4
-rw-r--r--src/Run.hs28
-rw-r--r--src/Run/Monad.hs12
-rw-r--r--src/Test.hs72
-rw-r--r--src/Test/Builtins.hs6
6 files changed, 73 insertions, 55 deletions
diff --git a/src/Main.hs b/src/Main.hs
index 1f15e68..9b0667d 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -151,12 +151,12 @@ main = do
( modules, allModules ) <- parseTestFiles $ map fst files
tests <- forM (zip modules $ map snd files) $ \( Module {..}, mbTestName ) -> do
- return $ map ( , map (first LocalVarName) moduleDefinitions ) $ case mbTestName of
+ return $ case mbTestName of
Nothing -> moduleTests
Just name -> filter ((==name) . testName) moduleTests
- let globalDefs = concatMap (map snd . moduleExportedDefinitions) allModules
+ let globalDefs = evalGlobalDefs $ concatMap (\m -> map (first ( moduleName m, )) $ moduleDefinitions m) allModules
- ok <- allM (\( test, defs ) -> runTest out (optTest opts) test (defs ++ globalDefs)) $
+ ok <- allM (runTest out (optTest opts) globalDefs) $
concat $ replicate (optRepeat opts) $ concat tests
when (not ok) exitFailure
diff --git a/src/Parser.hs b/src/Parser.hs
index 174babb..94e9a12 100644
--- a/src/Parser.hs
+++ b/src/Parser.hs
@@ -68,7 +68,7 @@ parseDefinition = label "symbol definition" $ do
atypes' <- getInferredTypes atypes
L.IndentNone . ( name, ) . SomeExpr . ArgsReq atypes' . FunctionAbstraction <$> replaceDynArgs expr
]
- modify $ \s -> s { testVars = ( name, ( LocalVarName name, someExprType expr )) : testVars s }
+ modify $ \s -> s { testVars = ( name, ( GlobalVarName (testCurrentModuleName s) name, someExprType expr )) : testVars s }
return def
where
getInferredTypes atypes = forM atypes $ \( off, vname, tvar@(TypeVar tvarname) ) -> do
@@ -169,7 +169,7 @@ parseTestFile parsedModules moduleName path = do
Nothing -> do
let initState = TestParserState
{ testVars = concat
- [ map (\( name, value ) -> ( unqualifyName name, ( name, someVarValueType value ))) builtins
+ [ map (\(( mname, name ), value ) -> ( name, ( GlobalVarName mname name, someVarValueType value ))) $ M.toList builtins
]
, testContext = SomeExpr (Undefined "void" :: Expr Void)
, testNextTypeVar = 0
diff --git a/src/Run.hs b/src/Run.hs
index 4cd80a0..1b2f448 100644
--- a/src/Run.hs
+++ b/src/Run.hs
@@ -1,6 +1,7 @@
module Run (
module Run.Monad,
runTest,
+ evalGlobalDefs,
) where
import Control.Applicative
@@ -33,8 +34,8 @@ import Run.Monad
import Test
import Test.Builtins
-runTest :: Output -> TestOptions -> Test -> [ ( FqVarName, SomeExpr ) ] -> IO Bool
-runTest out opts test variables = do
+runTest :: Output -> TestOptions -> GlobalDefs -> Test -> IO Bool
+runTest out opts gdefs test = do
let testDir = optTestDir opts
when (optForce opts) $ removeDirectoryRecursive testDir `catchIOError` \e ->
if isDoesNotExistError e then return () else ioError e
@@ -59,7 +60,8 @@ runTest out opts test variables = do
, teGDB = fst <$> mgdb
}
tstate = TestState
- { tsVars = builtins
+ { tsGlobals = gdefs
+ , tsLocals = []
, tsNodePacketLoss = M.empty
, tsDisconnectedUp = S.empty
, tsDisconnectedBridge = S.empty
@@ -82,19 +84,12 @@ runTest out opts test variables = do
Stopped sig -> err $ T.pack $ "child stopped with signal " ++ show sig
oldHandler <- installHandler processStatusChanged (CatchInfo sigHandler) Nothing
- let withVarExprList (( name, expr ) : rest) act = do
- value <- evalSome expr
- local (fmap $ \s -> s { tsVars = ( name, value ) : tsVars s }) $ do
- withVarExprList rest act
- withVarExprList [] act = act
-
resetOutputTime out
res <- runExceptT $ flip runReaderT (tenv, tstate) $ fromTestRun $ do
- withVarExprList variables $ do
- withInternet $ \_ -> do
- evalBlock =<< eval (testSteps test)
- when (optWait opts) $ do
- void $ outPromptGetLine $ "Test '" <> testName test <> "' completed, waiting..."
+ withInternet $ \_ -> do
+ evalBlock =<< eval (testSteps test)
+ when (optWait opts) $ do
+ void $ outPromptGetLine $ "Test '" <> testName test <> "' completed, waiting..."
void $ installHandler processStatusChanged oldHandler Nothing
@@ -109,6 +104,11 @@ runTest out opts test variables = do
return True
_ -> return False
+
+evalGlobalDefs :: [ (( ModuleName, VarName ), SomeExpr ) ] -> GlobalDefs
+evalGlobalDefs exprs = fix $ \gdefs ->
+ builtins `M.union` M.fromList (map (fmap (evalSomeWith gdefs)) exprs)
+
evalBlock :: TestBlock -> TestRun ()
evalBlock (TestBlock steps) = forM_ steps $ \case
Subnet name parent inner -> do
diff --git a/src/Run/Monad.hs b/src/Run/Monad.hs
index a550070..3fc511a 100644
--- a/src/Run/Monad.hs
+++ b/src/Run/Monad.hs
@@ -16,9 +16,9 @@ import Control.Monad.Except
import Control.Monad.Reader
import Data.Map (Map)
-import Data.Set (Set)
import Data.Scientific
-import qualified Data.Text as T
+import Data.Set (Set)
+import Data.Text qualified as T
import {-# SOURCE #-} GDB
import Network.Ip
@@ -38,7 +38,8 @@ data TestEnv = TestEnv
}
data TestState = TestState
- { tsVars :: [ ( FqVarName, SomeVarValue ) ]
+ { tsGlobals :: GlobalDefs
+ , tsLocals :: [ ( VarName, SomeVarValue ) ]
, tsDisconnectedUp :: Set NetworkNamespace
, tsDisconnectedBridge :: Set NetworkNamespace
, tsNodePacketLoss :: Map NetworkNamespace Scientific
@@ -91,8 +92,9 @@ instance MonadError Failed TestRun where
catchError (TestRun act) handler = TestRun $ catchError act $ fromTestRun . handler
instance MonadEval TestRun where
- askDictionary = asks (tsVars . snd)
- withDictionary f = local (fmap $ \s -> s { tsVars = f (tsVars s) })
+ askGlobalDefs = asks (tsGlobals . snd)
+ askDictionary = asks (tsLocals . snd)
+ withDictionary f = local (fmap $ \s -> s { tsLocals = f (tsLocals s) })
instance MonadOutput TestRun where
getOutput = asks $ teOutput . fst
diff --git a/src/Test.hs b/src/Test.hs
index 82303f8..3808186 100644
--- a/src/Test.hs
+++ b/src/Test.hs
@@ -13,7 +13,7 @@ module Test (
TypeVar(..), SomeExprType(..), someExprType, textSomeExprType,
FunctionType, DynamicType,
- VarValue(..), SomeVarValue(..),
+ VarValue(..), SomeVarValue(..), GlobalDefs,
svvVariables, svvArguments,
someConstValue, fromConstValue,
fromSomeVarValue, textSomeVarValue, someVarValueType,
@@ -21,7 +21,7 @@ module Test (
RecordSelector(..),
ExprListUnpacker(..),
ExprEnumerator(..),
- Expr(..), varExpr, mapExpr, eval, evalSome,
+ Expr(..), varExpr, mapExpr, eval, evalSome, evalSomeWith,
Traced(..), EvalTrace, VarNameSelectors, gatherVars,
AppAnnotation(..),
@@ -36,7 +36,6 @@ import Control.Monad
import Control.Monad.Reader
import Data.Char
-import Data.Bifunctor
import Data.Foldable
import Data.List
import Data.Map (Map)
@@ -105,19 +104,21 @@ textSourceLine SourceLineBuiltin = "<builtin>"
class MonadFail m => MonadEval m where
+ askGlobalDefs :: m GlobalDefs
askDictionary :: m VariableDictionary
withDictionary :: (VariableDictionary -> VariableDictionary) -> m a -> m a
-type VariableDictionary = [ ( FqVarName, SomeVarValue ) ]
+type VariableDictionary = [ ( VarName, SomeVarValue ) ]
lookupVar :: MonadEval m => FqVarName -> m SomeVarValue
-lookupVar name = maybe (fail $ "variable not in scope: '" ++ unpackFqVarName name ++ "'") return . lookup name =<< askDictionary
+lookupVar name = maybe (fail $ "variable not in scope: '" ++ unpackFqVarName name ++ "'") return =<< tryLookupVar name
tryLookupVar :: MonadEval m => FqVarName -> m (Maybe SomeVarValue)
-tryLookupVar name = lookup name <$> askDictionary
+tryLookupVar (LocalVarName name) = lookup name <$> askDictionary
+tryLookupVar (GlobalVarName mname var) = M.lookup ( mname, var ) <$> askGlobalDefs
withVar :: (MonadEval m, ExprType e) => VarName -> e -> m a -> m a
-withVar name value = withDictionary (( LocalVarName name, someConstValue value ) : )
+withVar name value = withDictionary (( name, someConstValue value ) : )
newtype VarName = VarName Text
@@ -292,6 +293,8 @@ data VarValue a = VarValue
, vvFunction :: SourceLine -> FunctionArguments SomeVarValue -> a
}
+type GlobalDefs = Map ( ModuleName, VarName ) SomeVarValue
+
someConstValue :: ExprType a => a -> SomeVarValue
someConstValue = SomeVarValue . VarValue [] mempty . const . const
@@ -389,18 +392,19 @@ mapExpr f = go
Trace expr -> f $ Trace (go expr)
-newtype SimpleEval a = SimpleEval (Reader VariableDictionary a)
+newtype SimpleEval a = SimpleEval (Reader ( GlobalDefs, VariableDictionary ) a)
deriving (Functor, Applicative, Monad)
-runSimpleEval :: SimpleEval a -> VariableDictionary -> a
-runSimpleEval (SimpleEval x) = runReader x
+runSimpleEval :: SimpleEval a -> GlobalDefs -> VariableDictionary -> a
+runSimpleEval (SimpleEval x) = curry $ runReader x
instance MonadFail SimpleEval where
fail = error . ("eval failed: " <>)
instance MonadEval SimpleEval where
- askDictionary = SimpleEval ask
- withDictionary f (SimpleEval inner) = SimpleEval (local f inner)
+ askGlobalDefs = SimpleEval (asks fst)
+ askDictionary = SimpleEval (asks snd)
+ withDictionary f (SimpleEval inner) = SimpleEval (local (fmap f) inner)
eval :: forall m a. MonadEval m => Expr a -> m a
@@ -412,10 +416,11 @@ eval = \case
DynVariable _ _ name -> fail $ "ambiguous type of ‘" <> unpackFqVarName name <> "’"
FunVariable _ sline name -> funFromSomeVarValue sline name =<< lookupVar name
ArgsReq (FunctionArguments req) efun -> do
+ gdefs <- askGlobalDefs
dict <- askDictionary
return $ FunctionType $ \(FunctionArguments args) ->
let used = M.intersectionWith (\value ( vname, _ ) -> ( vname, value )) args req
- FunctionType fun = runSimpleEval (eval efun) (map (first LocalVarName) (toList used) ++ dict)
+ FunctionType fun = runSimpleEval (eval efun) gdefs (toList used ++ dict)
in fun $ FunctionArguments $ args `M.difference` req
ArgsApp eargs efun -> do
FunctionType fun <- eval efun
@@ -428,8 +433,9 @@ eval = \case
FunctionType fun <- eval efun
return $ fun mempty
LambdaAbstraction (TypedVarName name) expr -> do
+ gdefs <- askGlobalDefs
dict <- askDictionary
- return $ \x -> runSimpleEval (eval expr) (( LocalVarName name, someConstValue x ) : dict)
+ return $ \x -> runSimpleEval (eval expr) gdefs (( name, someConstValue x ) : dict)
Pure value -> return value
App _ f x -> eval f <*> eval x
Concat xs -> T.concat <$> mapM eval xs
@@ -441,19 +447,29 @@ eval = \case
Undefined err -> fail err
Trace expr -> Traced <$> gatherVars expr <*> eval expr
+evalToVarValue :: MonadEval m => Expr a -> m (VarValue a)
+evalToVarValue expr = do
+ VarValue
+ <$> gatherVars expr
+ <*> pure mempty
+ <*> (const . const <$> eval expr)
+
+evalFunToVarValue :: MonadEval m => Expr (FunctionType a) -> m (VarValue a)
+evalFunToVarValue expr = do
+ FunctionType fun <- eval expr
+ VarValue
+ <$> gatherVars expr
+ <*> pure (exprArgs expr)
+ <*> pure (const fun)
+
evalSome :: MonadEval m => SomeExpr -> m SomeVarValue
evalSome (SomeExpr expr)
- | IsFunType <- asFunType expr = do
- FunctionType fun <- eval expr
- fmap SomeVarValue $ VarValue
- <$> gatherVars expr
- <*> pure (exprArgs expr)
- <*> pure (const fun)
- | otherwise = do
- fmap SomeVarValue $ VarValue
- <$> gatherVars expr
- <*> pure mempty
- <*> (const . const <$> eval expr)
+ | IsFunType <- asFunType expr = SomeVarValue <$> evalFunToVarValue expr
+ | otherwise = SomeVarValue <$> evalToVarValue expr
+
+evalSomeWith :: GlobalDefs -> SomeExpr -> SomeVarValue
+evalSomeWith gdefs sexpr = runSimpleEval (evalSome sexpr) gdefs []
+
data Traced a = Traced EvalTrace a
@@ -465,20 +481,20 @@ gatherVars = fmap (uniqOn fst . sortOn fst) . helper
where
helper :: forall b. Expr b -> m EvalTrace
helper = \case
- Let _ (TypedVarName var) _ expr -> withDictionary (filter ((LocalVarName var /=) . fst)) $ helper expr
+ Let _ (TypedVarName var) _ expr -> withDictionary (filter ((var /=) . fst)) $ helper expr
Variable _ var
| isInternalVar var -> return []
| otherwise -> maybe [] (\x -> [ (( var, [] ), x ) ]) <$> tryLookupVar var
DynVariable _ _ var -> maybe [] (\x -> [ (( var, [] ), x ) ]) <$> tryLookupVar var
FunVariable _ _ var -> maybe [] (\x -> [ (( var, [] ), x ) ]) <$> tryLookupVar var
- ArgsReq args expr -> withDictionary (filter ((`notElem` map (LocalVarName . fst) (toList args)) . fst)) $ helper expr
+ ArgsReq args expr -> withDictionary (filter ((`notElem` map fst (toList args)) . fst)) $ helper expr
ArgsApp (FunctionArguments args) fun -> do
v <- helper fun
vs <- mapM (\(SomeExpr e) -> helper e) $ M.elems args
return $ concat (v : vs)
FunctionAbstraction expr -> helper expr
FunctionEval efun -> helper efun
- LambdaAbstraction (TypedVarName var) expr -> withDictionary (filter ((LocalVarName var /=) . fst)) $ helper expr
+ LambdaAbstraction (TypedVarName var) expr -> withDictionary (filter ((var /=) . fst)) $ helper expr
Pure _ -> return []
e@(App (AnnRecord sel) _ x)
| Just (var, sels) <- gatherSelectors x
diff --git a/src/Test/Builtins.hs b/src/Test/Builtins.hs
index 29e54af..bf22ff8 100644
--- a/src/Test/Builtins.hs
+++ b/src/Test/Builtins.hs
@@ -9,15 +9,15 @@ import Data.Text (Text)
import Process (Process)
import Test
-builtins :: [ ( FqVarName, SomeVarValue ) ]
-builtins =
+builtins :: GlobalDefs
+builtins = M.fromList
[ fq "send" builtinSend
, fq "flush" builtinFlush
, fq "guard" builtinGuard
, fq "wait" builtinWait
]
where
- fq name impl = ( GlobalVarName (ModuleName [ "$" ]) (VarName name), impl )
+ fq name impl = (( ModuleName [ "$" ], VarName name ), impl )
getArg :: ExprType a => FunctionArguments SomeVarValue -> Maybe ArgumentKeyword -> a
getArg args = fromMaybe (error "parameter mismatch") . getArgMb args
generated by cgit v1.2.3 (git 2.25.1) at 2025-03-09 14:19:27 +0000