diff options
-rw-r--r-- | src/Parser/Statement.hs | 25 | ||||
-rw-r--r-- | src/Run.hs | 10 | ||||
-rw-r--r-- | src/Test.hs | 29 |
3 files changed, 34 insertions, 30 deletions
diff --git a/src/Parser/Statement.hs b/src/Parser/Statement.hs index 6dc3c56..21b24a6 100644 --- a/src/Parser/Statement.hs +++ b/src/Parser/Statement.hs @@ -191,19 +191,22 @@ paramOrContext name = fromParamOrContext <$> param name cmdLine :: CommandDef SourceLine cmdLine = param "" -newtype InnerBlock = InnerBlock { fromInnerBlock :: Expr TestBlock } +newtype InnerBlock = InnerBlock { fromInnerBlock :: TestBlock } instance ParamType InnerBlock where + type ParamRep InnerBlock = Expr TestBlock parseParam _ = mzero showParamType _ = "<code block>" + paramExpr = fmap InnerBlock -instance ParamType TestStep where - parseParam _ = mzero - showParamType _ = "<code line>" - -innerBlock :: CommandDef (Expr TestBlock) +innerBlock :: CommandDef TestBlock innerBlock = fromInnerBlock <$> param "" +innerBlockExpr :: CommandDef (Expr TestBlock) +innerBlockExpr = + let CommandDef args fun = param "" + in CommandDef args (Pure . fmap fromInnerBlock . fun) + newtype ExprParam a = ExprParam { fromExprParam :: a } deriving (Functor, Foldable, Traversable) @@ -230,7 +233,7 @@ command name (CommandDef types ctor) = do iparams <- forM params $ \case (_, SomeParam (p :: Proxy p) Nothing) | Just (Refl :: p :~: SourceLine) <- eqT -> return $ SomeParam p $ Identity line - | Just (Refl :: p :~: InnerBlock) <- eqT -> SomeParam p . Identity . InnerBlock <$> restOfParts cmdi partials + | Just (Refl :: p :~: InnerBlock) <- eqT -> SomeParam p . Identity <$> restOfParts cmdi partials (sym, SomeParam p Nothing) -> choice [ SomeParam p . Identity <$> paramDefault p , fail $ "missing " ++ (if null sym then "" else "'" ++ sym ++ "' ") ++ showParamType p @@ -312,19 +315,19 @@ testSubnet :: TestParser (Expr TestBlock) testSubnet = command "subnet" $ Subnet <$> param "" <*> (fromExprParam <$> paramOrContext "of") - <*> innerBlock + <*> innerBlockExpr testNode :: TestParser (Expr TestBlock) testNode = command "node" $ DeclNode <$> param "" <*> (fromExprParam <$> paramOrContext "on") - <*> innerBlock + <*> innerBlockExpr testSpawn :: TestParser (Expr TestBlock) testSpawn = command "spawn" $ Spawn <$> param "as" <*> (bimap fromExprParam fromExprParam <$> paramOrContext "on") - <*> innerBlock + <*> innerBlockExpr testExpect :: TestParser (Expr TestBlock) testExpect = command "expect" $ Expect @@ -332,7 +335,7 @@ testExpect = command "expect" $ Expect <*> (fromExprParam <$> paramOrContext "from") <*> param "" <*> param "capture" - <*> innerBlock + <*> innerBlockExpr testDisconnectNode :: TestParser (Expr TestBlock) testDisconnectNode = command "disconnect_node" $ DisconnectNode @@ -162,18 +162,18 @@ evalBlock (TestBlock steps) = forM_ steps $ \case testStepGuard line vars expr DisconnectNode node inner -> do - withDisconnectedUp (nodeUpstream node) $ evalBlock =<< eval inner + withDisconnectedUp (nodeUpstream node) $ evalBlock inner DisconnectNodes net inner -> do - withDisconnectedBridge (netBridge net) $ evalBlock =<< eval inner + withDisconnectedBridge (netBridge net) $ evalBlock inner DisconnectUpstream net inner -> do case netUpstream net of - Just link -> withDisconnectedUp link $ evalBlock =<< eval inner - Nothing -> evalBlock =<< eval inner + Just link -> withDisconnectedUp link $ evalBlock inner + Nothing -> evalBlock inner PacketLoss loss node inner -> do - withNodePacketLoss node loss $ evalBlock =<< eval inner + withNodePacketLoss node loss $ evalBlock inner Wait -> do void $ outPromptGetLine "Waiting..." diff --git a/src/Test.hs b/src/Test.hs index 772ac28..da4c82d 100644 --- a/src/Test.hs +++ b/src/Test.hs @@ -58,20 +58,21 @@ data Test = Test newtype TestBlock = TestBlock [ TestStep ] deriving (Semigroup, Monoid) -data TestStep = forall a. ExprType a => Let SourceLine (TypedVarName a) (Expr a) (Expr TestBlock) - | forall a. ExprType a => For SourceLine (TypedVarName a) (Expr [ a ]) (Expr TestBlock) - | Subnet (TypedVarName Network) Network (Expr TestBlock) - | DeclNode (TypedVarName Node) Network (Expr TestBlock) - | Spawn (TypedVarName Process) (Either Network Node) (Expr TestBlock) - | Send Process Text - | Expect SourceLine Process (Expr Regex) [ TypedVarName Text ] (Expr TestBlock) - | Flush Process (Maybe Regex) - | Guard SourceLine EvalTrace Bool - | DisconnectNode Node (Expr TestBlock) - | DisconnectNodes Network (Expr TestBlock) - | DisconnectUpstream Network (Expr TestBlock) - | PacketLoss Scientific Node (Expr TestBlock) - | Wait +data TestStep + = forall a. ExprType a => Let SourceLine (TypedVarName a) (Expr a) (Expr TestBlock) + | forall a. ExprType a => For SourceLine (TypedVarName a) (Expr [ a ]) (Expr TestBlock) + | Subnet (TypedVarName Network) Network (Expr TestBlock) + | DeclNode (TypedVarName Node) Network (Expr TestBlock) + | Spawn (TypedVarName Process) (Either Network Node) (Expr TestBlock) + | Send Process Text + | Expect SourceLine Process (Expr Regex) [ TypedVarName Text ] (Expr TestBlock) + | Flush Process (Maybe Regex) + | Guard SourceLine EvalTrace Bool + | DisconnectNode Node TestBlock + | DisconnectNodes Network TestBlock + | DisconnectUpstream Network TestBlock + | PacketLoss Scientific Node TestBlock + | Wait newtype SourceLine = SourceLine Text |