diff options
Diffstat (limited to 'src')
| -rw-r--r-- | src/Parser/Core.hs | 9 | ||||
| -rw-r--r-- | src/Parser/Statement.hs | 6 | ||||
| -rw-r--r-- | src/Test.hs | 3 | ||||
| -rw-r--r-- | src/Test/Builtins.hs | 27 |
4 files changed, 27 insertions, 18 deletions
diff --git a/src/Parser/Core.hs b/src/Parser/Core.hs index f40889a..cb66529 100644 --- a/src/Parser/Core.hs +++ b/src/Parser/Core.hs @@ -139,13 +139,14 @@ unifyExpr off pa expr = if showType ( Just (ArgumentKeyword kw), SomeArgumentType atype ) = "`" <> kw <> " <" <> textExprType atype <> ">'" err = parseError . FancyError off . S.singleton . ErrorFail . T.unpack - defaults <- forM (M.toAscList remaining) $ \case - arg@(_, SomeArgumentType NoDefault) -> err $ "missing " <> showType arg <> " argument" - (kw, SomeArgumentType (ExprDefault def)) -> return (kw, SomeExpr def) + defaults <- fmap catMaybes $ forM (M.toAscList remaining) $ \case + arg@(_, SomeArgumentType RequiredArgument) -> err $ "missing " <> showType arg <> " argument" + (_, SomeArgumentType OptionalArgument) -> return Nothing + (kw, SomeArgumentType (ExprDefault def)) -> return $ Just ( kw, SomeExpr def ) (kw, SomeArgumentType atype@ContextDefault) -> do SomeExpr context <- gets testContext context' <- unifyExpr off atype context - return (kw, SomeExpr context') + return $ Just ( kw, SomeExpr context' ) return (FunctionEval $ ArgsApp (FunctionArguments $ M.fromAscList defaults) expr) | Just (Refl :: DynamicType :~: b) <- eqT diff --git a/src/Parser/Statement.hs b/src/Parser/Statement.hs index 67ffd76..c7cdf5a 100644 --- a/src/Parser/Statement.hs +++ b/src/Parser/Statement.hs @@ -320,11 +320,6 @@ testExpect = command "expect" $ Expect <*> param "capture" <*> innerBlock -testFlush :: TestParser [TestStep] -testFlush = command "flush" $ Flush - <$> paramOrContext "from" - <*> param "" - testDisconnectNode :: TestParser [TestStep] testDisconnectNode = command "disconnect_node" $ DisconnectNode <$> paramOrContext "" @@ -372,7 +367,6 @@ testStep = choice , testNode , testSpawn , testExpect - , testFlush , testDisconnectNode , testDisconnectNodes , testDisconnectUpstream diff --git a/src/Test.hs b/src/Test.hs index b8b44ed..719e3e2 100644 --- a/src/Test.hs +++ b/src/Test.hs @@ -312,7 +312,8 @@ funFromSomeVarValue sline name (SomeVarValue args (value :: SourceLine -> args - data SomeArgumentType = forall a. ExprType a => SomeArgumentType (ArgumentType a) data ArgumentType a - = NoDefault + = RequiredArgument + | OptionalArgument | ExprDefault (Expr a) | ContextDefault diff --git a/src/Test/Builtins.hs b/src/Test/Builtins.hs index 774ad70..6c6c2f0 100644 --- a/src/Test/Builtins.hs +++ b/src/Test/Builtins.hs @@ -3,6 +3,7 @@ module Test.Builtins ( ) where import Data.Map qualified as M +import Data.Maybe import Data.Text (Text) import Data.Typeable @@ -12,15 +13,18 @@ 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 -> a -getArg (FunctionArguments args) kw = - case M.lookup kw args of - Just (SomeExpr expr) | Just expr' <- cast expr -> expr' - _ -> error "parameter mismatch" +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) $ @@ -28,11 +32,20 @@ builtinSend = SomeVarValue (FunctionArguments $ M.fromList atypes) $ where atypes = [ ( Just "to", SomeArgumentType (ContextDefault @Process) ) - , ( Nothing, SomeArgumentType (NoDefault @Text) ) + , ( 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 (NoDefault @Bool))) $ +builtinGuard = SomeVarValue (FunctionArguments $ M.singleton Nothing (SomeArgumentType (RequiredArgument @Bool))) $ \sline args -> TestBlock [ Guard sline (getArg args Nothing) ] builtinWait :: SomeVarValue |