summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--src/Run.hs30
-rw-r--r--src/Run/Monad.hs2
-rw-r--r--src/Test.hs42
-rw-r--r--src/Test/Builtins.hs24
4 files changed, 54 insertions, 44 deletions
diff --git a/src/Run.hs b/src/Run.hs
index e704dcf..845f655 100644
--- a/src/Run.hs
+++ b/src/Run.hs
@@ -159,12 +159,11 @@ evalBlock (TestBlock steps) = forM_ steps $ \case
p <- eval pname
expect line p expr captures $ evalBlock =<< eval inner
- Flush pname expr -> do
- p <- eval pname
- flush p expr
+ Flush p regex -> do
+ flush p regex
- Guard line expr -> do
- testStepGuard line expr
+ Guard line vars expr -> do
+ testStepGuard line vars expr
DisconnectNode node inner -> do
n <- eval node
@@ -273,10 +272,9 @@ tryMatch re (x:xs) | Right (Just (_, _, _, capture)) <- regexMatch re x = Just (
| otherwise = fmap (x:) <$> tryMatch re xs
tryMatch _ [] = Nothing
-exprFailed :: Text -> SourceLine -> Maybe ProcName -> Expr a -> TestRun ()
-exprFailed desc (SourceLine sline) pname expr = do
+exprFailed :: Text -> SourceLine -> Maybe ProcName -> EvalTrace -> TestRun ()
+exprFailed desc (SourceLine sline) pname exprVars = do
let prompt = maybe T.empty textProcName pname
- exprVars <- gatherVars expr
outLine OutputMatchFail (Just prompt) $ T.concat [desc, T.pack " failed on ", sline]
forM_ exprVars $ \((name, sel), value) ->
outLine OutputMatchFail (Just prompt) $ T.concat
@@ -312,19 +310,17 @@ expect (SourceLine sline) p expr tvars inner = do
throwError Failed
outProc OutputMatch p line
- local (fmap $ \s -> s { tsVars = zip vars (map (SomeVarValue mempty . const . const) capture) ++ tsVars s }) inner
+ local (fmap $ \s -> s { tsVars = zip vars (map (SomeVarValue [] mempty . const . const) capture) ++ tsVars s }) inner
- Nothing -> exprFailed (T.pack "expect") (SourceLine sline) (Just $ procName p) expr
+ Nothing -> exprFailed (T.pack "expect") (SourceLine sline) (Just $ procName p) =<< gatherVars expr
-flush :: Process -> Maybe (Expr Regex) -> TestRun ()
-flush p mbexpr = do
- mbre <- sequence $ fmap eval mbexpr
+flush :: Process -> Maybe Regex -> TestRun ()
+flush p mbre = do
atomicallyTest $ do
writeTVar (procOutput p) =<< case mbre of
Nothing -> return []
Just re -> filter (either error isNothing . regexMatch re) <$> readTVar (procOutput p)
-testStepGuard :: SourceLine -> Expr Bool -> TestRun ()
-testStepGuard sline expr = do
- x <- eval expr
- when (not x) $ exprFailed (T.pack "guard") sline Nothing expr
+testStepGuard :: SourceLine -> EvalTrace -> Bool -> TestRun ()
+testStepGuard sline vars x = do
+ when (not x) $ exprFailed (T.pack "guard") sline Nothing vars
diff --git a/src/Run/Monad.hs b/src/Run/Monad.hs
index 1890572..54600f0 100644
--- a/src/Run/Monad.hs
+++ b/src/Run/Monad.hs
@@ -96,7 +96,7 @@ instance MonadEval TestRun where
lookupVar name = maybe (fail $ "variable not in scope: '" ++ unpackVarName name ++ "'") return =<< asks (lookup name . tsVars . snd)
rootNetwork = asks $ tsNetwork . snd
- withVar name value = local (fmap $ \s -> s { tsVars = ( name, SomeVarValue mempty $ const $ const value ) : tsVars s })
+ withVar name value = local (fmap $ \s -> s { tsVars = ( name, SomeVarValue [] mempty $ const $ const value ) : tsVars s })
instance MonadOutput TestRun where
getOutput = asks $ teOutput . fst
diff --git a/src/Test.hs b/src/Test.hs
index 1407ffa..28ea71c 100644
--- a/src/Test.hs
+++ b/src/Test.hs
@@ -14,7 +14,8 @@ module Test (
RecordSelector(..),
ExprListUnpacker(..),
ExprEnumerator(..),
- Expr(..), eval, gatherVars, evalSome,
+ Expr(..), eval, evalSome,
+ EvalTrace, VarNameSelectors, gatherVars,
AppAnnotation(..),
ArgumentKeyword(..), FunctionArguments(..),
@@ -64,8 +65,8 @@ data TestStep = forall a. ExprType a => Let SourceLine (TypedVarName a) (Expr a)
| Spawn (TypedVarName Process) (Either (Expr Network) (Expr Node)) (Expr TestBlock)
| Send (Expr Process) (Expr Text)
| Expect SourceLine (Expr Process) (Expr Regex) [ TypedVarName Text ] (Expr TestBlock)
- | Flush (Expr Process) (Maybe (Expr Regex))
- | Guard SourceLine (Expr Bool)
+ | Flush Process (Maybe Regex)
+ | Guard SourceLine EvalTrace Bool
| DisconnectNode (Expr Node) (Expr TestBlock)
| DisconnectNodes (Expr Network) (Expr TestBlock)
| DisconnectUpstream (Expr Network) (Expr TestBlock)
@@ -141,7 +142,7 @@ instance ExprType TestBlock where
textExprValue _ = "<test block>"
-data FunctionType a = FunctionType (FunctionArguments SomeExpr -> a)
+data FunctionType a = FunctionType (FunctionArguments SomeVarValue -> a)
instance ExprType a => ExprType (FunctionType a) where
textExprType _ = "function type"
@@ -177,10 +178,14 @@ textSomeExprType (ExprTypeVar (TypeVar name)) = name
textSomeExprType (ExprTypeFunction _ r) = "function:" <> textExprType r
-data SomeVarValue = forall a. ExprType a => SomeVarValue (FunctionArguments SomeArgumentType) (SourceLine -> FunctionArguments SomeExpr -> a)
+data SomeVarValue = forall a. ExprType a => SomeVarValue
+ { svvVariables :: EvalTrace
+ , svvArguments :: FunctionArguments SomeArgumentType
+ , svvFunction :: SourceLine -> FunctionArguments SomeVarValue -> a
+ }
fromSomeVarValue :: forall a m. (ExprType a, MonadFail m) => SourceLine -> VarName -> SomeVarValue -> m a
-fromSomeVarValue sline name (SomeVarValue args (value :: SourceLine -> args -> b)) = do
+fromSomeVarValue sline name (SomeVarValue _ args (value :: SourceLine -> args -> b)) = do
maybe (fail err) return $ do
guard $ anull args
cast $ value sline mempty
@@ -189,12 +194,12 @@ fromSomeVarValue sline name (SomeVarValue args (value :: SourceLine -> args -> b
if anull args then textExprType @b Proxy else "function type" ]
textSomeVarValue :: SourceLine -> SomeVarValue -> Text
-textSomeVarValue sline (SomeVarValue args value)
+textSomeVarValue sline (SomeVarValue _ args value)
| anull args = textExprValue $ value sline mempty
| otherwise = "<function>"
someVarValueType :: SomeVarValue -> SomeExprType
-someVarValueType (SomeVarValue args (_ :: SourceLine -> args -> a))
+someVarValueType (SomeVarValue _ args (_ :: SourceLine -> args -> a))
| anull args = ExprTypePrim (Proxy @a)
| otherwise = ExprTypeFunction args (Proxy @a)
@@ -240,8 +245,9 @@ eval = \case
Variable sline name -> fromSomeVarValue sline name =<< lookupVar name
DynVariable _ _ _ -> fail "ambiguous type"
FunVariable _ sline name -> funFromSomeVarValue sline name =<< lookupVar name
- ArgsApp args efun -> do
+ ArgsApp eargs efun -> do
FunctionType fun <- eval efun
+ args <- mapM evalSome eargs
return $ FunctionType $ \args' -> fun (args <> args')
FunctionEval efun -> do
FunctionType fun <- eval efun
@@ -258,12 +264,18 @@ eval = \case
Undefined err -> fail err
evalSome :: MonadEval m => SomeExpr -> m SomeVarValue
-evalSome (SomeExpr expr) = SomeVarValue mempty . const . const <$> eval expr
+evalSome (SomeExpr expr) = SomeVarValue
+ <$> gatherVars expr
+ <*> pure mempty
+ <*> (const . const <$> eval expr)
+
+type VarNameSelectors = ( VarName, [ Text ] )
+type EvalTrace = [ ( VarNameSelectors, SomeVarValue ) ]
-gatherVars :: forall a m. MonadEval m => Expr a -> m [ (( VarName, [ Text ] ), SomeVarValue ) ]
+gatherVars :: forall a m. MonadEval m => Expr a -> m EvalTrace
gatherVars = fmap (uniqOn fst . sortOn fst) . helper
where
- helper :: forall b. Expr b -> m [ (( VarName, [ Text ] ), SomeVarValue ) ]
+ helper :: forall b. Expr b -> m EvalTrace
helper = \case
Variable _ var -> (: []) . (( var, [] ), ) <$> lookupVar var
DynVariable _ _ var -> (: []) . (( var, [] ), ) <$> lookupVar var
@@ -277,7 +289,7 @@ gatherVars = fmap (uniqOn fst . sortOn fst) . helper
e@(App (AnnRecord sel) _ x)
| Just (var, sels) <- gatherSelectors x
-> do
- val <- SomeVarValue mempty . const . const <$> eval e
+ val <- SomeVarValue [] mempty . const . const <$> eval e
return [ (( var, sels ++ [ sel ] ), val ) ]
| otherwise -> do
helper x
@@ -300,7 +312,7 @@ newtype ArgumentKeyword = ArgumentKeyword Text
deriving (Show, Eq, Ord, IsString)
newtype FunctionArguments a = FunctionArguments (Map (Maybe ArgumentKeyword) a)
- deriving (Show, Semigroup, Monoid)
+ deriving (Show, Semigroup, Monoid, Functor, Foldable, Traversable)
anull :: FunctionArguments a -> Bool
anull (FunctionArguments args) = M.null args
@@ -313,7 +325,7 @@ exprArgs (ArgsApp (FunctionArguments applied) expr) =
exprArgs _ = error "exprArgs on unexpected type"
funFromSomeVarValue :: forall a m. (ExprType a, MonadFail m) => SourceLine -> VarName -> SomeVarValue -> m (FunctionType a)
-funFromSomeVarValue sline name (SomeVarValue args (value :: SourceLine -> args -> b)) = do
+funFromSomeVarValue sline name (SomeVarValue _ args (value :: SourceLine -> args -> b)) = do
maybe (fail err) return $ do
guard $ not $ anull args
FunctionType <$> cast (value sline)
diff --git a/src/Test/Builtins.hs b/src/Test/Builtins.hs
index 9babb9e..926bdbc 100644
--- a/src/Test/Builtins.hs
+++ b/src/Test/Builtins.hs
@@ -5,7 +5,6 @@ module Test.Builtins (
import Data.Map qualified as M
import Data.Maybe
import Data.Text (Text)
-import Data.Typeable
import Process (Process)
import Test
@@ -18,17 +17,20 @@ builtins =
, ( VarName "wait", builtinWait )
]
-getArg :: Typeable a => FunctionArguments SomeExpr -> Maybe ArgumentKeyword -> (Expr a)
+getArg :: ExprType a => FunctionArguments SomeVarValue -> Maybe ArgumentKeyword -> a
getArg args = fromMaybe (error "parameter mismatch") . getArgMb args
-getArgMb :: Typeable a => FunctionArguments SomeExpr -> Maybe ArgumentKeyword -> Maybe (Expr a)
+getArgMb :: ExprType a => FunctionArguments SomeVarValue -> Maybe ArgumentKeyword -> Maybe a
getArgMb (FunctionArguments args) kw = do
- SomeExpr expr <- M.lookup kw args
- cast expr
+ fromSomeVarValue (SourceLine "") (VarName "") =<< M.lookup kw args
+
+getArgVars :: FunctionArguments SomeVarValue -> Maybe ArgumentKeyword -> [ (( VarName, [ Text ] ), SomeVarValue ) ]
+getArgVars (FunctionArguments args) kw = do
+ maybe [] svvVariables $ M.lookup kw args
builtinSend :: SomeVarValue
-builtinSend = SomeVarValue (FunctionArguments $ M.fromList atypes) $
- \_ args -> TestBlock [ Send (getArg args (Just "to")) (getArg args Nothing) ]
+builtinSend = SomeVarValue [] (FunctionArguments $ M.fromList atypes) $
+ \_ args -> TestBlock [ Send (Pure (getArg args (Just "to"))) (Pure (getArg args Nothing)) ]
where
atypes =
[ ( Just "to", SomeArgumentType (ContextDefault @Process) )
@@ -36,7 +38,7 @@ builtinSend = SomeVarValue (FunctionArguments $ M.fromList atypes) $
]
builtinFlush :: SomeVarValue
-builtinFlush = SomeVarValue (FunctionArguments $ M.fromList atypes) $
+builtinFlush = SomeVarValue [] (FunctionArguments $ M.fromList atypes) $
\_ args -> TestBlock [ Flush (getArg args (Just "from")) (getArgMb args (Just "matching")) ]
where
atypes =
@@ -45,8 +47,8 @@ builtinFlush = SomeVarValue (FunctionArguments $ M.fromList atypes) $
]
builtinGuard :: SomeVarValue
-builtinGuard = SomeVarValue (FunctionArguments $ M.singleton Nothing (SomeArgumentType (RequiredArgument @Bool))) $
- \sline args -> TestBlock [ Guard sline (getArg args Nothing) ]
+builtinGuard = SomeVarValue [] (FunctionArguments $ M.singleton Nothing (SomeArgumentType (RequiredArgument @Bool))) $
+ \sline args -> TestBlock [ Guard sline (getArgVars args Nothing) (getArg args Nothing) ]
builtinWait :: SomeVarValue
-builtinWait = SomeVarValue mempty $ const . const $ TestBlock [ Wait ]
+builtinWait = SomeVarValue [] mempty $ const . const $ TestBlock [ Wait ]
generated by cgit v1.2.3 (git 2.25.1) at 2024-12-22 07:29:46 +0000