summaryrefslogtreecommitdiff
path: root/src/Test/Builtins.hs
blob: 6c6c2f0e426f76bec552147c710e443434326f5f (plain)
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
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 "send", builtinSend )
    , ( VarName "flush", builtinFlush )
    , ( VarName "guard", builtinGuard )
    , ( VarName "wait", builtinWait )
    ]

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 Nothing) ]
  where
    atypes =
        [ ( Just "from", SomeArgumentType (ContextDefault @Process) )
        , ( Nothing, 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 ]