summaryrefslogtreecommitdiff
path: root/src/Test
diff options
context:
space:
mode:
Diffstat (limited to 'src/Test')
-rw-r--r--src/Test/Builtins.hs34
1 files changed, 22 insertions, 12 deletions
diff --git a/src/Test/Builtins.hs b/src/Test/Builtins.hs
index a676a35..6dba707 100644
--- a/src/Test/Builtins.hs
+++ b/src/Test/Builtins.hs
@@ -4,33 +4,39 @@ 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 Script.Expr
import Test
-builtins :: [ ( VarName, SomeVarValue ) ]
-builtins =
- [ ( VarName "send", builtinSend )
- , ( VarName "flush", builtinFlush )
- , ( VarName "guard", builtinGuard )
- , ( VarName "wait", builtinWait )
+builtins :: GlobalDefs
+builtins = M.fromList
+ [ fq "send" builtinSend
+ , fq "flush" builtinFlush
+ , fq "guard" builtinGuard
+ , fq "multiply_timeout" builtinMultiplyTimeout
+ , fq "wait" builtinWait
]
+ where
+ fq name impl = (( ModuleName [ "$" ], VarName name ), impl )
getArg :: ExprType a => FunctionArguments SomeVarValue -> Maybe ArgumentKeyword -> a
getArg args = fromMaybe (error "parameter mismatch") . getArgMb args
getArgMb :: ExprType a => FunctionArguments SomeVarValue -> Maybe ArgumentKeyword -> Maybe a
getArgMb (FunctionArguments args) kw = do
- fromSomeVarValue SourceLineBuiltin (VarName "") =<< M.lookup kw args
+ fromSomeVarValue SourceLineBuiltin (LocalVarName (VarName "")) =<< M.lookup kw args
-getArgVars :: FunctionArguments SomeVarValue -> Maybe ArgumentKeyword -> [ (( VarName, [ Text ] ), SomeVarValue ) ]
+getArgVars :: FunctionArguments SomeVarValue -> Maybe ArgumentKeyword -> [ (( FqVarName, [ Text ] ), SomeVarValue ) ]
getArgVars (FunctionArguments args) kw = do
maybe [] svvVariables $ M.lookup kw args
builtinSend :: SomeVarValue
builtinSend = SomeVarValue $ VarValue [] (FunctionArguments $ M.fromList atypes) $
- \_ args -> TestBlock [ Send (getArg args (Just "to")) (getArg args Nothing) ]
+ \_ args -> TestBlockStep EmptyTestBlock $ Send (getArg args (Just "to")) (getArg args Nothing)
where
atypes =
[ ( Just "to", SomeArgumentType (ContextDefault @Process) )
@@ -39,7 +45,7 @@ builtinSend = SomeVarValue $ VarValue [] (FunctionArguments $ M.fromList atypes)
builtinFlush :: SomeVarValue
builtinFlush = SomeVarValue $ VarValue [] (FunctionArguments $ M.fromList atypes) $
- \_ args -> TestBlock [ Flush (getArg args (Just "from")) (getArgMb args (Just "matching")) ]
+ \_ args -> TestBlockStep EmptyTestBlock $ Flush (getArg args (Just "from")) (getArgMb args (Just "matching"))
where
atypes =
[ ( Just "from", SomeArgumentType (ContextDefault @Process) )
@@ -48,7 +54,11 @@ builtinFlush = SomeVarValue $ VarValue [] (FunctionArguments $ M.fromList atypes
builtinGuard :: SomeVarValue
builtinGuard = SomeVarValue $ VarValue [] (FunctionArguments $ M.singleton Nothing (SomeArgumentType (RequiredArgument @Bool))) $
- \sline args -> TestBlock [ Guard sline (getArgVars args Nothing) (getArg args Nothing) ]
+ \sline args -> TestBlockStep EmptyTestBlock $ Guard sline (getArgVars args Nothing) (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 $ TestBlock [ Wait ]
+builtinWait = someConstValue $ TestBlockStep EmptyTestBlock Wait