1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
|
module Test.Builtins (
builtins,
) where
import Data.Map qualified as M
import Data.Maybe
import Data.Text (Text)
import Process (Process)
import Test
builtins :: [ ( VarName, SomeVarValue ) ]
builtins =
[ ( VarName "send", builtinSend )
, ( VarName "flush", builtinFlush )
, ( VarName "guard", builtinGuard )
, ( VarName "wait", builtinWait )
]
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 (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 $ VarValue [] (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 $ VarValue [] (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 $ VarValue [] (FunctionArguments $ M.singleton Nothing (SomeArgumentType (RequiredArgument @Bool))) $
\sline args -> TestBlock [ Guard sline (getArgVars args Nothing) (getArg args Nothing) ]
builtinWait :: SomeVarValue
builtinWait = someConstValue $ TestBlock [ Wait ]
|