summaryrefslogtreecommitdiff
path: root/src/Test
diff options
context:
space:
mode:
Diffstat (limited to 'src/Test')
-rw-r--r--src/Test/Builtins.hs45
1 files changed, 42 insertions, 3 deletions
diff --git a/src/Test/Builtins.hs b/src/Test/Builtins.hs
index 9deb2df..9babb9e 100644
--- a/src/Test/Builtins.hs
+++ b/src/Test/Builtins.hs
@@ -2,12 +2,51 @@ module Test.Builtins (
builtins,
) where
+import Data.Map qualified as M
+import Data.Maybe
+import Data.Text (Text)
+import Data.Typeable
+
+import Process (Process)
import Test
builtins :: [ ( VarName, SomeVarValue ) ]
builtins =
- [ ( VarName "wait", SomeVarValue builtinWait )
+ [ ( VarName "send", builtinSend )
+ , ( VarName "flush", builtinFlush )
+ , ( VarName "guard", builtinGuard )
+ , ( VarName "wait", builtinWait )
]
-builtinWait :: TestBlock
-builtinWait = TestBlock [ Wait ]
+getArg :: Typeable a => FunctionArguments SomeExpr -> Maybe ArgumentKeyword -> (Expr a)
+getArg args = fromMaybe (error "parameter mismatch") . getArgMb args
+
+getArgMb :: Typeable a => FunctionArguments SomeExpr -> Maybe ArgumentKeyword -> Maybe (Expr a)
+getArgMb (FunctionArguments args) kw = do
+ SomeExpr expr <- M.lookup kw args
+ cast expr
+
+builtinSend :: SomeVarValue
+builtinSend = SomeVarValue (FunctionArguments $ M.fromList atypes) $
+ \_ args -> TestBlock [ Send (getArg args (Just "to")) (getArg args Nothing) ]
+ where
+ atypes =
+ [ ( Just "to", SomeArgumentType (ContextDefault @Process) )
+ , ( Nothing, SomeArgumentType (RequiredArgument @Text) )
+ ]
+
+builtinFlush :: SomeVarValue
+builtinFlush = SomeVarValue (FunctionArguments $ M.fromList atypes) $
+ \_ args -> TestBlock [ Flush (getArg args (Just "from")) (getArgMb args (Just "matching")) ]
+ where
+ atypes =
+ [ ( Just "from", SomeArgumentType (ContextDefault @Process) )
+ , ( Just "matching", SomeArgumentType (OptionalArgument @Regex) )
+ ]
+
+builtinGuard :: SomeVarValue
+builtinGuard = SomeVarValue (FunctionArguments $ M.singleton Nothing (SomeArgumentType (RequiredArgument @Bool))) $
+ \sline args -> TestBlock [ Guard sline (getArg args Nothing) ]
+
+builtinWait :: SomeVarValue
+builtinWait = SomeVarValue mempty $ const . const $ TestBlock [ Wait ]