summaryrefslogtreecommitdiff
path: root/src/Test
diff options
context:
space:
mode:
authorRoman Smrž <roman.smrz@seznam.cz>2024-11-13 19:54:04 +0100
committerRoman Smrž <roman.smrz@seznam.cz>2024-11-13 21:22:45 +0100
commit1a8b4fbabdb1e3426f0da93817f93071b5985f2e (patch)
tree22a439dd447746ca57bff6ccc3021d2d8776b27e /src/Test
parent0b6880a6b4e7366bd0c66a6d44ca1c50e3ca6334 (diff)
Keep track of used variables alongside evaluated expressions
Diffstat (limited to 'src/Test')
-rw-r--r--src/Test/Builtins.hs24
1 files changed, 13 insertions, 11 deletions
diff --git a/src/Test/Builtins.hs b/src/Test/Builtins.hs
index 9babb9e..926bdbc 100644
--- a/src/Test/Builtins.hs
+++ b/src/Test/Builtins.hs
@@ -5,7 +5,6 @@ module Test.Builtins (
import Data.Map qualified as M
import Data.Maybe
import Data.Text (Text)
-import Data.Typeable
import Process (Process)
import Test
@@ -18,17 +17,20 @@ builtins =
, ( VarName "wait", builtinWait )
]
-getArg :: Typeable a => FunctionArguments SomeExpr -> Maybe ArgumentKeyword -> (Expr a)
+getArg :: ExprType a => FunctionArguments SomeVarValue -> Maybe ArgumentKeyword -> a
getArg args = fromMaybe (error "parameter mismatch") . getArgMb args
-getArgMb :: Typeable a => FunctionArguments SomeExpr -> Maybe ArgumentKeyword -> Maybe (Expr a)
+getArgMb :: ExprType a => FunctionArguments SomeVarValue -> Maybe ArgumentKeyword -> Maybe a
getArgMb (FunctionArguments args) kw = do
- SomeExpr expr <- M.lookup kw args
- cast expr
+ 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 (FunctionArguments $ M.fromList atypes) $
- \_ args -> TestBlock [ Send (getArg args (Just "to")) (getArg args Nothing) ]
+builtinSend = SomeVarValue [] (FunctionArguments $ M.fromList atypes) $
+ \_ args -> TestBlock [ Send (Pure (getArg args (Just "to"))) (Pure (getArg args Nothing)) ]
where
atypes =
[ ( Just "to", SomeArgumentType (ContextDefault @Process) )
@@ -36,7 +38,7 @@ builtinSend = SomeVarValue (FunctionArguments $ M.fromList atypes) $
]
builtinFlush :: SomeVarValue
-builtinFlush = SomeVarValue (FunctionArguments $ M.fromList atypes) $
+builtinFlush = SomeVarValue [] (FunctionArguments $ M.fromList atypes) $
\_ args -> TestBlock [ Flush (getArg args (Just "from")) (getArgMb args (Just "matching")) ]
where
atypes =
@@ -45,8 +47,8 @@ builtinFlush = SomeVarValue (FunctionArguments $ M.fromList atypes) $
]
builtinGuard :: SomeVarValue
-builtinGuard = SomeVarValue (FunctionArguments $ M.singleton Nothing (SomeArgumentType (RequiredArgument @Bool))) $
- \sline args -> TestBlock [ Guard sline (getArg args Nothing) ]
+builtinGuard = SomeVarValue [] (FunctionArguments $ M.singleton Nothing (SomeArgumentType (RequiredArgument @Bool))) $
+ \sline args -> TestBlock [ Guard sline (getArgVars args Nothing) (getArg args Nothing) ]
builtinWait :: SomeVarValue
-builtinWait = SomeVarValue mempty $ const . const $ TestBlock [ Wait ]
+builtinWait = SomeVarValue [] mempty $ const . const $ TestBlock [ Wait ]