diff options
Diffstat (limited to 'src/Test')
-rw-r--r-- | src/Test/Builtins.hs | 45 |
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 ] |