diff options
Diffstat (limited to 'src')
| -rw-r--r-- | src/Parser/Statement.hs | 79 | ||||
| -rw-r--r-- | src/Run.hs | 30 | ||||
| -rw-r--r-- | src/Test.hs | 18 | ||||
| -rw-r--r-- | src/Test/Builtins.hs | 2 |
4 files changed, 68 insertions, 61 deletions
diff --git a/src/Parser/Statement.hs b/src/Parser/Statement.hs index b197be1..6dc3c56 100644 --- a/src/Parser/Statement.hs +++ b/src/Parser/Statement.hs @@ -6,6 +6,7 @@ import Control.Monad import Control.Monad.Identity import Control.Monad.State +import Data.Bifunctor import Data.Kind import Data.Maybe import Data.Set qualified as S @@ -104,6 +105,10 @@ class (Typeable a, Typeable (ParamRep a)) => ParamType a where paramFromSomeExpr :: proxy a -> SomeExpr -> Maybe (ParamRep a) paramFromSomeExpr _ (SomeExpr e) = cast e + paramExpr :: ParamRep a -> Expr a + default paramExpr :: ParamRep a ~ a => ParamRep a -> Expr a + paramExpr = Pure + instance ParamType SourceLine where parseParam _ = mzero showParamType _ = "<source line>" @@ -125,6 +130,7 @@ instance ParamType a => ParamType [a] where showParamType _ = showParamType @a Proxy ++ " [, " ++ showParamType @a Proxy ++ " ...]" paramDefault _ = return [] paramFromSomeExpr _ se@(SomeExpr e) = cast e <|> ((:[]) <$> paramFromSomeExpr @a Proxy se) + paramExpr = sequenceA . fmap paramExpr instance ParamType a => ParamType (Maybe a) where type ParamRep (Maybe a) = Maybe (ParamRep a) @@ -132,6 +138,7 @@ instance ParamType a => ParamType (Maybe a) where showParamType _ = showParamType @a Proxy paramDefault _ = return Nothing paramFromSomeExpr _ se = Just <$> paramFromSomeExpr @a Proxy se + paramExpr = sequenceA . fmap paramExpr instance (ParamType a, ParamType b) => ParamType (Either a b) where type ParamRep (Either a b) = Either (ParamRep a) (ParamRep b) @@ -144,49 +151,49 @@ instance (ParamType a, ParamType b) => ParamType (Either a b) where (_ : _) -> fail "" showParamType _ = showParamType @a Proxy ++ " or " ++ showParamType @b Proxy paramFromSomeExpr _ se = (Left <$> paramFromSomeExpr @a Proxy se) <|> (Right <$> paramFromSomeExpr @b Proxy se) + paramExpr = either (fmap Left . paramExpr) (fmap Right . paramExpr) data SomeParam f = forall a. ParamType a => SomeParam (Proxy a) (f (ParamRep a)) -data CommandDef a = CommandDef [(String, SomeParam Proxy)] ([SomeParam Identity] -> a) +data CommandDef a = CommandDef [(String, SomeParam Proxy)] ([SomeParam Identity] -> Expr a) instance Functor CommandDef where - fmap f (CommandDef types ctor) = CommandDef types (f . ctor) + fmap f (CommandDef types ctor) = CommandDef types (fmap f . ctor) instance Applicative CommandDef where - pure x = CommandDef [] (\case [] -> x; _ -> error "command arguments mismatch") - CommandDef types1 ctor1 <*> CommandDef types2 ctor2 = - CommandDef (types1 ++ types2) $ \params -> - let (params1, params2) = splitAt (length types1) params - in ctor1 params1 $ ctor2 params2 + pure x = CommandDef [] (\case [] -> Pure x; _ -> error "command arguments mismatch") + CommandDef types1 ctor1 <*> CommandDef types2 ctor2 = + CommandDef (types1 ++ types2) $ \params -> + let (params1, params2) = splitAt (length types1) params + in ctor1 params1 <*> ctor2 params2 param :: forall a. ParamType a => String -> CommandDef a param name = CommandDef [(name, SomeParam (Proxy @a) Proxy)] $ \case - [SomeParam Proxy (Identity x)] -> fromJust $ cast x + [SomeParam Proxy (Identity x)] -> paramExpr $ fromJust $ cast x _ -> error "command arguments mismatch" -data ParamOrContext a +newtype ParamOrContext a = ParamOrContext { fromParamOrContext :: a } + deriving (Functor, Foldable, Traversable) instance ParamType a => ParamType (ParamOrContext a) where - type ParamRep (ParamOrContext a) = ParamRep a - parseParam _ = parseParam @a Proxy + type ParamRep (ParamOrContext a) = ParamOrContext (ParamRep a) + parseParam _ = ParamOrContext <$> parseParam @a Proxy showParamType _ = showParamType @a Proxy paramDefault _ = gets testContext >>= \case se@(SomeExpr ctx) - | Just e <- paramFromSomeExpr @a Proxy se -> return e + | Just e <- paramFromSomeExpr @a Proxy se -> return (ParamOrContext e) | otherwise -> fail $ showParamType @a Proxy <> " not available from context type '" <> T.unpack (textExprType ctx) <> "'" + paramExpr = sequenceA . fmap paramExpr paramOrContext :: forall a. ParamType a => String -> CommandDef a -paramOrContext name = CommandDef [(name, SomeParam (Proxy @(ParamOrContext a)) Proxy)] $ \case - [SomeParam Proxy (Identity x)] -> fromJust $ cast x - _ -> error "command arguments mismatch" +paramOrContext name = fromParamOrContext <$> param name cmdLine :: CommandDef SourceLine cmdLine = param "" -data InnerBlock +newtype InnerBlock = InnerBlock { fromInnerBlock :: Expr TestBlock } instance ParamType InnerBlock where - type ParamRep InnerBlock = Expr TestBlock parseParam _ = mzero showParamType _ = "<code block>" @@ -195,9 +202,19 @@ instance ParamType TestStep where showParamType _ = "<code line>" innerBlock :: CommandDef (Expr TestBlock) -innerBlock = CommandDef [("", SomeParam (Proxy @InnerBlock) Proxy)] $ \case - [SomeParam Proxy (Identity x)] -> fromJust $ cast x - _ -> error "command arguments mismatch" +innerBlock = fromInnerBlock <$> param "" + +newtype ExprParam a = ExprParam { fromExprParam :: a } + deriving (Functor, Foldable, Traversable) + +instance ExprType a => ParamType (ExprParam a) where + type ParamRep (ExprParam a) = Expr a + parseParam _ = do + off <- stateOffset <$> getParserState + SomeExpr e <- literal <|> variable <|> between (symbol "(") (symbol ")") someExpr + unifyExpr off Proxy e + showParamType _ = "<" ++ T.unpack (textExprType @a Proxy) ++ ">" + paramExpr = fmap ExprParam command :: String -> CommandDef TestStep -> TestParser (Expr TestBlock) command name (CommandDef types ctor) = do @@ -213,13 +230,13 @@ 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 <$> restOfParts cmdi partials + | Just (Refl :: p :~: InnerBlock) <- eqT -> SomeParam p . Identity . InnerBlock <$> restOfParts cmdi partials (sym, SomeParam p Nothing) -> choice [ SomeParam p . Identity <$> paramDefault p , fail $ "missing " ++ (if null sym then "" else "'" ++ sym ++ "' ") ++ showParamType p ] (_, SomeParam (p :: Proxy p) (Just x)) -> return $ SomeParam p $ Identity x - return $ Pure $ TestBlock [ ctor iparams ] + return $ (TestBlock . (: [])) <$> ctor iparams ,do symbol ":" scn @@ -294,48 +311,48 @@ testWith = do testSubnet :: TestParser (Expr TestBlock) testSubnet = command "subnet" $ Subnet <$> param "" - <*> paramOrContext "of" + <*> (fromExprParam <$> paramOrContext "of") <*> innerBlock testNode :: TestParser (Expr TestBlock) testNode = command "node" $ DeclNode <$> param "" - <*> paramOrContext "on" + <*> (fromExprParam <$> paramOrContext "on") <*> innerBlock testSpawn :: TestParser (Expr TestBlock) testSpawn = command "spawn" $ Spawn <$> param "as" - <*> paramOrContext "on" + <*> (bimap fromExprParam fromExprParam <$> paramOrContext "on") <*> innerBlock testExpect :: TestParser (Expr TestBlock) testExpect = command "expect" $ Expect <$> cmdLine - <*> paramOrContext "from" + <*> (fromExprParam <$> paramOrContext "from") <*> param "" <*> param "capture" <*> innerBlock testDisconnectNode :: TestParser (Expr TestBlock) testDisconnectNode = command "disconnect_node" $ DisconnectNode - <$> paramOrContext "" + <$> (fromExprParam <$> paramOrContext "") <*> innerBlock testDisconnectNodes :: TestParser (Expr TestBlock) testDisconnectNodes = command "disconnect_nodes" $ DisconnectNodes - <$> paramOrContext "" + <$> (fromExprParam <$> paramOrContext "") <*> innerBlock testDisconnectUpstream :: TestParser (Expr TestBlock) testDisconnectUpstream = command "disconnect_upstream" $ DisconnectUpstream - <$> paramOrContext "" + <$> (fromExprParam <$> paramOrContext "") <*> innerBlock testPacketLoss :: TestParser (Expr TestBlock) testPacketLoss = command "packet_loss" $ PacketLoss - <$> param "" - <*> paramOrContext "on" + <$> (fromExprParam <$> paramOrContext "") + <*> (fromExprParam <$> paramOrContext "on") <*> innerBlock @@ -128,8 +128,7 @@ evalBlock (TestBlock steps) = forM_ steps $ \case forM_ value $ \i -> do withVar name i $ evalBlock =<< eval inner - Subnet name@(TypedVarName vname) parentExpr inner -> do - parent <- eval parentExpr + Subnet name@(TypedVarName vname) parent inner -> do withSubnet parent (Just name) $ \net -> do withVar vname net $ evalBlock =<< eval inner @@ -140,7 +139,7 @@ evalBlock (TestBlock steps) = forM_ steps $ \case Spawn tvname@(TypedVarName vname@(VarName tname)) target inner -> do case target of Left net -> withNode net (Right tvname) go - Right node -> go =<< eval node + Right node -> go node where go node = do opts <- asks $ teOptions . fst @@ -149,14 +148,11 @@ evalBlock (TestBlock steps) = forM_ steps $ \case withProcess (Right node) pname Nothing tool $ \p -> do withVar vname p $ evalBlock =<< eval inner - Send pname expr -> do - p <- eval pname - line <- eval expr + Send p line -> do outProc OutputChildStdin p line send p line - Expect line pname expr captures inner -> do - p <- eval pname + Expect line p expr captures inner -> do expect line p expr captures $ evalBlock =<< eval inner Flush p regex -> do @@ -166,23 +162,18 @@ evalBlock (TestBlock steps) = forM_ steps $ \case testStepGuard line vars expr DisconnectNode node inner -> do - n <- eval node - withDisconnectedUp (nodeUpstream n) $ evalBlock =<< eval inner + withDisconnectedUp (nodeUpstream node) $ evalBlock =<< eval inner DisconnectNodes net inner -> do - n <- eval net - withDisconnectedBridge (netBridge n) $ evalBlock =<< eval inner + withDisconnectedBridge (netBridge net) $ evalBlock =<< eval inner DisconnectUpstream net inner -> do - n <- eval net - case netUpstream n of + case netUpstream net of Just link -> withDisconnectedUp link $ evalBlock =<< eval inner Nothing -> evalBlock =<< eval inner PacketLoss loss node inner -> do - l <- eval loss - n <- eval node - withNodePacketLoss n l $ evalBlock =<< eval inner + withNodePacketLoss node loss $ evalBlock =<< eval inner Wait -> do void $ outPromptGetLine "Waiting..." @@ -211,9 +202,8 @@ withNetwork net inner = do tcpdump $ inner net -withNode :: Expr Network -> Either (TypedVarName Node) (TypedVarName Process) -> (Node -> TestRun a) -> TestRun a -withNode netexpr tvname inner = do - net <- eval netexpr +withNode :: Network -> Either (TypedVarName Node) (TypedVarName Process) -> (Node -> TestRun a) -> TestRun a +withNode net tvname inner = do node <- newNode net (either fromTypedVarName fromTypedVarName tvname) either (flip withVar node . fromTypedVarName) (const id) tvname $ inner node diff --git a/src/Test.hs b/src/Test.hs index 28ea71c..772ac28 100644 --- a/src/Test.hs +++ b/src/Test.hs @@ -60,17 +60,17 @@ newtype TestBlock = TestBlock [ TestStep ] 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) (Expr Network) (Expr TestBlock) - | DeclNode (TypedVarName Node) (Expr Network) (Expr TestBlock) - | Spawn (TypedVarName Process) (Either (Expr Network) (Expr Node)) (Expr TestBlock) - | Send (Expr Process) (Expr Text) - | Expect SourceLine (Expr Process) (Expr Regex) [ TypedVarName Text ] (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 (Expr Node) (Expr TestBlock) - | DisconnectNodes (Expr Network) (Expr TestBlock) - | DisconnectUpstream (Expr Network) (Expr TestBlock) - | PacketLoss (Expr Scientific) (Expr Node) (Expr TestBlock) + | DisconnectNode Node (Expr TestBlock) + | DisconnectNodes Network (Expr TestBlock) + | DisconnectUpstream Network (Expr TestBlock) + | PacketLoss Scientific Node (Expr TestBlock) | Wait newtype SourceLine = SourceLine Text diff --git a/src/Test/Builtins.hs b/src/Test/Builtins.hs index 926bdbc..36f88e8 100644 --- a/src/Test/Builtins.hs +++ b/src/Test/Builtins.hs @@ -30,7 +30,7 @@ getArgVars (FunctionArguments args) kw = do builtinSend :: SomeVarValue builtinSend = SomeVarValue [] (FunctionArguments $ M.fromList atypes) $ - \_ args -> TestBlock [ Send (Pure (getArg args (Just "to"))) (Pure (getArg args Nothing)) ] + \_ args -> TestBlock [ Send (getArg args (Just "to")) (getArg args Nothing) ] where atypes = [ ( Just "to", SomeArgumentType (ContextDefault @Process) ) |