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