diff options
| -rw-r--r-- | src/Parser.hs | 7 | ||||
| -rw-r--r-- | src/Parser/Core.hs | 2 | ||||
| -rw-r--r-- | src/Parser/Statement.hs | 71 | ||||
| -rw-r--r-- | src/Run.hs | 49 | ||||
| -rw-r--r-- | src/Test.hs | 32 |
5 files changed, 83 insertions, 78 deletions
diff --git a/src/Parser.hs b/src/Parser.hs index e63f854..4b1e69a 100644 --- a/src/Parser.hs +++ b/src/Parser.hs @@ -30,7 +30,7 @@ import Test.Builtins parseTestDefinition :: TestParser Toplevel parseTestDefinition = label "test definition" $ toplevel ToplevelTest $ do - block (\name steps -> return $ Test name $ concat steps) header testStep + block (\name steps -> return $ Test name $ mconcat steps) header testStep where header = do wsymbol "test" lexeme $ TL.toStrict <$> takeWhileP (Just "test name") (/=':') @@ -44,11 +44,10 @@ parseDefinition = label "symbol definition" $ toplevel ToplevelDefinition $ do [ do symbol ":" let finish steps = do - return $ ( name, ) $ SomeVarValue mempty $ \_ _ -> TestBlock $ - concat steps + return $ ( name, SomeExpr $ mconcat steps ) return $ L.IndentSome Nothing finish testStep ] - modify $ \s -> s { testVars = fmap someVarValueType def : testVars s } + modify $ \s -> s { testVars = fmap someExprType def : testVars s } return def parseTestModule :: FilePath -> TestParser Module diff --git a/src/Parser/Core.hs b/src/Parser/Core.hs index 10a572b..57b2eb4 100644 --- a/src/Parser/Core.hs +++ b/src/Parser/Core.hs @@ -39,7 +39,7 @@ runTestParser path content initState (TestParser parser) = runIdentity . flip (f data Toplevel = ToplevelTest Test - | ToplevelDefinition ( VarName, SomeVarValue ) + | ToplevelDefinition ( VarName, SomeExpr ) data TestParserState = TestParserState { testVars :: [ ( VarName, SomeExprType ) ] diff --git a/src/Parser/Statement.hs b/src/Parser/Statement.hs index c7cdf5a..b197be1 100644 --- a/src/Parser/Statement.hs +++ b/src/Parser/Statement.hs @@ -23,7 +23,7 @@ import Process (Process) import Test import Util -letStatement :: TestParser [TestStep] +letStatement :: TestParser (Expr TestBlock) letStatement = do line <- getSourceLine indent <- L.indentLevel @@ -38,9 +38,9 @@ letStatement = do addVarName off tname void $ eol body <- testBlock indent - return [Let line tname e body] + return $ Pure $ TestBlock [ Let line tname e body ] -forStatement :: TestParser [TestStep] +forStatement :: TestParser (Expr TestBlock) forStatement = do line <- getSourceLine ref <- L.indentLevel @@ -62,22 +62,19 @@ forStatement = do let tname = TypedVarName name addVarName voff tname body <- testBlock indent - return [For line tname (unpack <$> e) body] + return $ Pure $ TestBlock [ For line tname (unpack <$> e) body ] -exprStatement :: TestParser [ TestStep ] +exprStatement :: TestParser (Expr TestBlock) exprStatement = do ref <- L.indentLevel off <- stateOffset <$> getParserState SomeExpr expr <- someExpr choice - [ do - continuePartial off ref expr - , do - stmt <- unifyExpr off Proxy expr - return [ ExprStatement stmt ] + [ continuePartial off ref expr + , unifyExpr off Proxy expr ] where - continuePartial :: ExprType a => Int -> Pos -> Expr a -> TestParser [ TestStep ] + continuePartial :: ExprType a => Int -> Pos -> Expr a -> TestParser (Expr TestBlock) continuePartial off ref expr = do symbol ":" void eol @@ -91,7 +88,7 @@ exprStatement = do let fun' = ArgsApp args fun choice [ continuePartial coff indent fun' - , (: []) . ExprStatement <$> unifyExpr coff Proxy fun' + , unifyExpr coff Proxy fun' ] class (Typeable a, Typeable (ParamRep a)) => ParamType a where @@ -189,7 +186,7 @@ cmdLine = param "" data InnerBlock instance ParamType InnerBlock where - type ParamRep InnerBlock = [TestStep] + type ParamRep InnerBlock = Expr TestBlock parseParam _ = mzero showParamType _ = "<code block>" @@ -197,12 +194,12 @@ instance ParamType TestStep where parseParam _ = mzero showParamType _ = "<code line>" -innerBlock :: CommandDef [TestStep] +innerBlock :: CommandDef (Expr TestBlock) innerBlock = CommandDef [("", SomeParam (Proxy @InnerBlock) Proxy)] $ \case [SomeParam Proxy (Identity x)] -> fromJust $ cast x _ -> error "command arguments mismatch" -command :: String -> CommandDef TestStep -> TestParser [TestStep] +command :: String -> CommandDef TestStep -> TestParser (Expr TestBlock) command name (CommandDef types ctor) = do indent <- L.indentLevel line <- getSourceLine @@ -210,7 +207,7 @@ command name (CommandDef types ctor) = do localState $ do restOfLine indent [] line $ map (fmap $ \(SomeParam p@(_ :: Proxy p) Proxy) -> SomeParam p $ Nothing @(ParamRep p)) types where - restOfLine :: Pos -> [(Pos, [(String, SomeParam Maybe)])] -> SourceLine -> [(String, SomeParam Maybe)] -> TestParser [TestStep] + restOfLine :: Pos -> [(Pos, [(String, SomeParam Maybe)])] -> SourceLine -> [(String, SomeParam Maybe)] -> TestParser (Expr TestBlock) restOfLine cmdi partials line params = choice [do void $ lookAhead eol iparams <- forM params $ \case @@ -222,7 +219,7 @@ command name (CommandDef types ctor) = do , fail $ "missing " ++ (if null sym then "" else "'" ++ sym ++ "' ") ++ showParamType p ] (_, SomeParam (p :: Proxy p) (Just x)) -> return $ SomeParam p $ Identity x - return [ctor iparams] + return $ Pure $ TestBlock [ ctor iparams ] ,do symbol ":" scn @@ -232,16 +229,16 @@ command name (CommandDef types ctor) = do ,do tryParams cmdi partials line [] params ] - restOfParts :: Pos -> [(Pos, [(String, SomeParam Maybe)])] -> TestParser [TestStep] + restOfParts :: Pos -> [(Pos, [(String, SomeParam Maybe)])] -> TestParser (Expr TestBlock) restOfParts cmdi [] = testBlock cmdi restOfParts cmdi partials@((partIndent, params) : rest) = do scn pos <- L.indentLevel line <- getSourceLine optional eof >>= \case - Just _ -> return [] + Just _ -> return $ Pure mempty _ | pos < partIndent -> restOfParts cmdi rest - | pos == partIndent -> (++) <$> restOfLine cmdi partials line params <*> restOfParts cmdi partials + | pos == partIndent -> mappend <$> restOfLine cmdi partials line params <*> restOfParts cmdi partials | otherwise -> L.incorrectIndent EQ partIndent pos tryParam sym (SomeParam (p :: Proxy p) cur) = do @@ -258,7 +255,7 @@ command name (CommandDef types ctor) = do ] tryParams _ _ _ _ [] = mzero -testLocal :: TestParser [TestStep] +testLocal :: TestParser (Expr TestBlock) testLocal = do ref <- L.indentLevel wsymbol "local" @@ -268,7 +265,7 @@ testLocal = do indent <- L.indentGuard scn GT ref localState $ testBlock indent -testWith :: TestParser [TestStep] +testWith :: TestParser (Expr TestBlock) testWith = do ref <- L.indentLevel wsymbol "with" @@ -294,25 +291,25 @@ testWith = do modify $ \s -> s { testContext = ctx } testBlock indent -testSubnet :: TestParser [TestStep] +testSubnet :: TestParser (Expr TestBlock) testSubnet = command "subnet" $ Subnet <$> param "" <*> paramOrContext "of" <*> innerBlock -testNode :: TestParser [TestStep] +testNode :: TestParser (Expr TestBlock) testNode = command "node" $ DeclNode <$> param "" <*> paramOrContext "on" <*> innerBlock -testSpawn :: TestParser [TestStep] +testSpawn :: TestParser (Expr TestBlock) testSpawn = command "spawn" $ Spawn <$> param "as" <*> paramOrContext "on" <*> innerBlock -testExpect :: TestParser [TestStep] +testExpect :: TestParser (Expr TestBlock) testExpect = command "expect" $ Expect <$> cmdLine <*> paramOrContext "from" @@ -320,44 +317,44 @@ testExpect = command "expect" $ Expect <*> param "capture" <*> innerBlock -testDisconnectNode :: TestParser [TestStep] +testDisconnectNode :: TestParser (Expr TestBlock) testDisconnectNode = command "disconnect_node" $ DisconnectNode <$> paramOrContext "" <*> innerBlock -testDisconnectNodes :: TestParser [TestStep] +testDisconnectNodes :: TestParser (Expr TestBlock) testDisconnectNodes = command "disconnect_nodes" $ DisconnectNodes <$> paramOrContext "" <*> innerBlock -testDisconnectUpstream :: TestParser [TestStep] +testDisconnectUpstream :: TestParser (Expr TestBlock) testDisconnectUpstream = command "disconnect_upstream" $ DisconnectUpstream <$> paramOrContext "" <*> innerBlock -testPacketLoss :: TestParser [TestStep] +testPacketLoss :: TestParser (Expr TestBlock) testPacketLoss = command "packet_loss" $ PacketLoss <$> param "" <*> paramOrContext "on" <*> innerBlock -testBlock :: Pos -> TestParser [ TestStep ] +testBlock :: Pos -> TestParser (Expr TestBlock) testBlock indent = blockOf indent testStep -blockOf :: Pos -> TestParser [ a ] -> TestParser [ a ] -blockOf indent step = concat <$> go +blockOf :: Monoid a => Pos -> TestParser a -> TestParser a +blockOf indent step = go where go = do scn pos <- L.indentLevel optional eof >>= \case - Just _ -> return [] - _ | pos < indent -> return [] - | pos == indent -> (:) <$> step <*> go + Just _ -> return mempty + _ | pos < indent -> return mempty + | pos == indent -> mappend <$> step <*> go | otherwise -> L.incorrectIndent EQ indent pos -testStep :: TestParser [TestStep] +testStep :: TestParser (Expr TestBlock) testStep = choice [ letStatement , forStatement @@ -33,7 +33,7 @@ import Run.Monad import Test import Test.Builtins -runTest :: Output -> TestOptions -> Test -> [ ( VarName, SomeVarValue ) ] -> IO Bool +runTest :: Output -> TestOptions -> Test -> [ ( VarName, SomeExpr ) ] -> IO Bool runTest out opts test variables = do let testDir = optTestDir opts when (optForce opts) $ removeDirectoryRecursive testDir `catchIOError` \e -> @@ -60,7 +60,7 @@ runTest out opts test variables = do } tstate = TestState { tsNetwork = error "network not initialized" - , tsVars = builtins ++ variables + , tsVars = builtins , tsNodePacketLoss = M.empty , tsDisconnectedUp = S.empty , tsDisconnectedBridge = S.empty @@ -83,11 +83,18 @@ runTest out opts test variables = do Stopped sig -> err $ T.pack $ "child stopped with signal " ++ show sig oldHandler <- installHandler processStatusChanged (CatchInfo sigHandler) Nothing + let withVarExprList (( name, expr ) : rest) act = do + value <- evalSome expr + local (fmap $ \s -> s { tsVars = ( name, value ) : tsVars s }) $ do + withVarExprList rest act + withVarExprList [] act = act + res <- runExceptT $ flip runReaderT (tenv, tstate) $ fromTestRun $ do - withInternet $ \_ -> do - evalSteps (testSteps test) - when (optWait opts) $ do - void $ outPromptGetLine $ "Test '" <> testName test <> "' completed, waiting..." + withVarExprList variables $ do + withInternet $ \_ -> do + evalBlock =<< eval (testSteps test) + when (optWait opts) $ do + void $ outPromptGetLine $ "Test '" <> testName test <> "' completed, waiting..." void $ installHandler processStatusChanged oldHandler Nothing @@ -102,15 +109,15 @@ runTest out opts test variables = do return True _ -> return False -evalSteps :: [TestStep] -> TestRun () -evalSteps = mapM_ $ \case +evalBlock :: TestBlock -> TestRun () +evalBlock (TestBlock steps) = forM_ steps $ \case Let (SourceLine sline) (TypedVarName name) expr inner -> do cur <- asks (lookup name . tsVars . snd) when (isJust cur) $ do outLine OutputError Nothing $ T.pack "variable '" `T.append` textVarName name `T.append` T.pack "' already exists on " `T.append` sline throwError Failed value <- eval expr - withVar name value $ evalSteps inner + withVar name value $ evalBlock =<< eval inner For (SourceLine sline) (TypedVarName name) expr inner -> do cur <- asks (lookup name . tsVars . snd) @@ -119,20 +126,16 @@ evalSteps = mapM_ $ \case throwError Failed value <- eval expr forM_ value $ \i -> do - withVar name i $ evalSteps inner - - ExprStatement expr -> do - TestBlock steps <- eval expr - evalSteps steps + withVar name i $ evalBlock =<< eval inner Subnet name@(TypedVarName vname) parentExpr inner -> do parent <- eval parentExpr withSubnet parent (Just name) $ \net -> do - withVar vname net $ evalSteps inner + withVar vname net $ evalBlock =<< eval inner DeclNode name@(TypedVarName vname) net inner -> do withNode net (Left name) $ \node -> do - withVar vname node $ evalSteps inner + withVar vname node $ evalBlock =<< eval inner Spawn tvname@(TypedVarName vname@(VarName tname)) target inner -> do case target of @@ -144,7 +147,7 @@ evalSteps = mapM_ $ \case let pname = ProcName tname tool = fromMaybe (optDefaultTool opts) (lookup pname $ optProcTools opts) withProcess (Right node) pname Nothing tool $ \p -> do - withVar vname p (evalSteps inner) + withVar vname p $ evalBlock =<< eval inner Send pname expr -> do p <- eval pname @@ -154,7 +157,7 @@ evalSteps = mapM_ $ \case Expect line pname expr captures inner -> do p <- eval pname - expect line p expr captures $ evalSteps inner + expect line p expr captures $ evalBlock =<< eval inner Flush pname expr -> do p <- eval pname @@ -165,22 +168,22 @@ evalSteps = mapM_ $ \case DisconnectNode node inner -> do n <- eval node - withDisconnectedUp (nodeUpstream n) $ evalSteps inner + withDisconnectedUp (nodeUpstream n) $ evalBlock =<< eval inner DisconnectNodes net inner -> do n <- eval net - withDisconnectedBridge (netBridge n) $ evalSteps inner + withDisconnectedBridge (netBridge n) $ evalBlock =<< eval inner DisconnectUpstream net inner -> do n <- eval net case netUpstream n of - Just link -> withDisconnectedUp link $ evalSteps inner - Nothing -> evalSteps inner + 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 $ evalSteps inner + withNodePacketLoss n l $ evalBlock =<< eval inner Wait -> do void $ outPromptGetLine "Waiting..." diff --git a/src/Test.hs b/src/Test.hs index 58c8667..42012d3 100644 --- a/src/Test.hs +++ b/src/Test.hs @@ -46,30 +46,30 @@ import Util data Module = Module { moduleName :: [ Text ] , moduleTests :: [ Test ] - , moduleDefinitions :: [ ( VarName, SomeVarValue ) ] + , moduleDefinitions :: [ ( VarName, SomeExpr ) ] } data Test = Test { testName :: Text - , testSteps :: [TestStep] + , testSteps :: Expr TestBlock } newtype TestBlock = TestBlock [ TestStep ] + deriving (Semigroup, Monoid) -data TestStep = forall a. ExprType a => Let SourceLine (TypedVarName a) (Expr a) [TestStep] - | forall a. ExprType a => For SourceLine (TypedVarName a) (Expr [a]) [TestStep] - | ExprStatement (Expr TestBlock) - | Subnet (TypedVarName Network) (Expr Network) [TestStep] - | DeclNode (TypedVarName Node) (Expr Network) [TestStep] - | Spawn (TypedVarName Process) (Either (Expr Network) (Expr Node)) [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] [TestStep] + | Expect SourceLine (Expr Process) (Expr Regex) [ TypedVarName Text ] (Expr TestBlock) | Flush (Expr Process) (Maybe (Expr Regex)) | Guard SourceLine (Expr Bool) - | DisconnectNode (Expr Node) [TestStep] - | DisconnectNodes (Expr Network) [TestStep] - | DisconnectUpstream (Expr Network) [TestStep] - | PacketLoss (Expr Scientific) (Expr Node) [TestStep] + | DisconnectNode (Expr Node) (Expr TestBlock) + | DisconnectNodes (Expr Network) (Expr TestBlock) + | DisconnectUpstream (Expr Network) (Expr TestBlock) + | PacketLoss (Expr Scientific) (Expr Node) (Expr TestBlock) | Wait newtype SourceLine = SourceLine Text @@ -229,6 +229,12 @@ instance Applicative Expr where pure = Pure (<*>) = App AnnNone +instance Semigroup a => Semigroup (Expr a) where + e <> f = (<>) <$> e <*> f + +instance Monoid a => Monoid (Expr a) where + mempty = Pure mempty + eval :: MonadEval m => Expr a -> m a eval (Variable sline name) = fromSomeVarValue sline name =<< lookupVar name eval (DynVariable _ _ _) = fail "ambiguous type" |