Remove ExprStatement in favor of using Expr TestBlock

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
diff --git a/src/Run.hs b/src/Run.hs
index 2fa1989..e704dcf 100644
--- a/src/Run.hs
+++ b/src/Run.hs
@@ -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"