summaryrefslogtreecommitdiff
path: root/src/Test
diff options
context:
space:
mode:
Diffstat (limited to 'src/Test')
-rw-r--r--src/Test/Builtins.hs27
1 files changed, 20 insertions, 7 deletions
diff --git a/src/Test/Builtins.hs b/src/Test/Builtins.hs
index 69579bc..5f9f890 100644
--- a/src/Test/Builtins.hs
+++ b/src/Test/Builtins.hs
@@ -4,9 +4,11 @@ module Test.Builtins (
import Data.Map qualified as M
import Data.Maybe
+import Data.Proxy
+import Data.Scientific
import Data.Text (Text)
-import Process (Process)
+import Process
import Script.Expr
import Test
@@ -14,7 +16,9 @@ builtins :: GlobalDefs
builtins = M.fromList
[ fq "send" builtinSend
, fq "flush" builtinFlush
+ , fq "ignore" builtinIgnore
, fq "guard" builtinGuard
+ , fq "multiply_timeout" builtinMultiplyTimeout
, fq "wait" builtinWait
]
where
@@ -25,11 +29,7 @@ getArg args = fromMaybe (error "parameter mismatch") . getArgMb args
getArgMb :: ExprType a => FunctionArguments SomeVarValue -> Maybe ArgumentKeyword -> Maybe a
getArgMb (FunctionArguments args) kw = do
- fromSomeVarValue SourceLineBuiltin (LocalVarName (VarName "")) =<< M.lookup kw args
-
-getArgVars :: FunctionArguments SomeVarValue -> Maybe ArgumentKeyword -> [ (( FqVarName, [ Text ] ), SomeVarValue ) ]
-getArgVars (FunctionArguments args) kw = do
- maybe [] svvVariables $ M.lookup kw args
+ fromSomeVarValue (CallStack []) (LocalVarName (VarName "")) =<< M.lookup kw args
builtinSend :: SomeVarValue
builtinSend = SomeVarValue $ VarValue [] (FunctionArguments $ M.fromList atypes) $
@@ -49,9 +49,22 @@ builtinFlush = SomeVarValue $ VarValue [] (FunctionArguments $ M.fromList atypes
, ( Just "matching", SomeArgumentType (OptionalArgument @Regex) )
]
+builtinIgnore :: SomeVarValue
+builtinIgnore = SomeVarValue $ VarValue [] (FunctionArguments $ M.fromList atypes) $
+ \_ args -> TestBlockStep EmptyTestBlock $ CreateObject (Proxy @IgnoreProcessOutput) ( getArg args (Just "from"), getArgMb args (Just "matching") )
+ where
+ atypes =
+ [ ( Just "from", SomeArgumentType (ContextDefault @Process) )
+ , ( Just "matching", SomeArgumentType (OptionalArgument @Regex) )
+ ]
+
builtinGuard :: SomeVarValue
builtinGuard = SomeVarValue $ VarValue [] (FunctionArguments $ M.singleton Nothing (SomeArgumentType (RequiredArgument @Bool))) $
- \sline args -> TestBlockStep EmptyTestBlock $ Guard sline (getArgVars args Nothing) (getArg args Nothing)
+ \stack args -> TestBlockStep EmptyTestBlock $ Guard stack (getArg args Nothing)
+
+builtinMultiplyTimeout :: SomeVarValue
+builtinMultiplyTimeout = SomeVarValue $ VarValue [] (FunctionArguments $ M.singleton (Just "by") (SomeArgumentType (RequiredArgument @Scientific))) $
+ \_ args -> TestBlockStep EmptyTestBlock $ CreateObject (Proxy @MultiplyTimeout) (getArg args (Just "by"))
builtinWait :: SomeVarValue
builtinWait = someConstValue $ TestBlockStep EmptyTestBlock Wait