diff options
Diffstat (limited to 'src/Parser/Statement.hs')
| -rw-r--r-- | src/Parser/Statement.hs | 128 |
1 files changed, 84 insertions, 44 deletions
diff --git a/src/Parser/Statement.hs b/src/Parser/Statement.hs index 4bed1ef..474fa03 100644 --- a/src/Parser/Statement.hs +++ b/src/Parser/Statement.hs @@ -1,5 +1,6 @@ module Parser.Statement ( testStep, + testBlock, ) where import Control.Monad @@ -21,11 +22,14 @@ import qualified Text.Megaparsec.Char.Lexer as L import Network (Network, Node) import Parser.Core import Parser.Expr +import Parser.Shell import Process (Process) +import Script.Expr +import Script.Expr.Class import Test import Util -letStatement :: TestParser (Expr TestBlock) +letStatement :: TestParser (Expr (TestBlock ())) letStatement = do line <- getSourceLine indent <- L.indentLevel @@ -40,9 +44,9 @@ letStatement = do addVarName off tname void $ eol body <- testBlock indent - return $ Let line tname e body + return $ Let line tname e (TestBlockStep EmptyTestBlock . Scope <$> body) -forStatement :: TestParser (Expr TestBlock) +forStatement :: TestParser (Expr (TestBlock ())) forStatement = do ref <- L.indentLevel wsymbol "for" @@ -65,9 +69,54 @@ forStatement = do body <- testBlock indent return $ (\xs f -> mconcat $ map f xs) <$> (unpack <$> e) - <*> LambdaAbstraction tname body + <*> LambdaAbstraction tname (TestBlockStep EmptyTestBlock . Scope <$> body) -exprStatement :: TestParser (Expr TestBlock) +shellStatement :: TestParser (Expr (TestBlock ())) +shellStatement = do + ref <- L.indentLevel + wsymbol "shell" + parseParams ref Nothing Nothing + + where + parseParamKeyword kw prev = do + off <- stateOffset <$> getParserState + wsymbol kw + when (isJust prev) $ do + registerParseError $ FancyError off $ S.singleton $ ErrorFail $ + "unexpected parameter with keyword β" <> kw <> "β" + + parseParams ref mbpname mbnode = choice + [ do + parseParamKeyword "as" mbpname + pname <- newVarName + parseParams ref (Just pname) mbnode + + , do + parseParamKeyword "on" mbnode + node <- typedExpr + parseParams ref mbpname (Just node) + + , do + off <- stateOffset <$> getParserState + symbol ":" + node <- case mbnode of + Just node -> return node + Nothing -> do + registerParseError $ FancyError off $ S.singleton $ ErrorFail $ + "missing parameter with keyword βonβ" + return $ Undefined "" + + void eol + void $ L.indentGuard scn GT ref + script <- shellScript + cont <- fmap Scope <$> testBlock ref + let expr | Just pname <- mbpname = LambdaAbstraction pname cont + | otherwise = const <$> cont + return $ TestBlockStep EmptyTestBlock <$> + (SpawnShell mbpname <$> node <*> script <*> expr) + ] + +exprStatement :: TestParser (Expr (TestBlock ())) exprStatement = do ref <- L.indentLevel off <- stateOffset <$> getParserState @@ -77,11 +126,11 @@ exprStatement = do , unifyExpr off Proxy expr ] where - continuePartial :: ExprType a => Int -> Pos -> Expr a -> TestParser (Expr TestBlock) + continuePartial :: ExprType a => Int -> Pos -> Expr a -> TestParser (Expr (TestBlock ())) continuePartial off ref expr = do symbol ":" void eol - (fun :: Expr (FunctionType TestBlock)) <- unifyExpr off Proxy expr + (fun :: Expr (FunctionType (TestBlock ()))) <- unifyExpr off Proxy expr scn indent <- L.indentGuard scn GT ref blockOf indent $ do @@ -129,7 +178,7 @@ instance ExprType a => ParamType (TypedVarName a) where instance ExprType a => ParamType (Expr a) where parseParam _ = do off <- stateOffset <$> getParserState - SomeExpr e <- literal <|> variable <|> between (symbol "(") (symbol ")") someExpr + SomeExpr e <- literal <|> between (symbol "(") (symbol ")") someExpr unifyExpr off Proxy e showParamType _ = "<" ++ T.unpack (textExprType @a Proxy) ++ ">" @@ -227,10 +276,10 @@ paramOrContext name = fromParamOrContext <$> param name cmdLine :: CommandDef SourceLine cmdLine = param "" -newtype InnerBlock a = InnerBlock { fromInnerBlock :: [ a ] -> TestBlock } +newtype InnerBlock a = InnerBlock { fromInnerBlock :: [ a ] -> TestBlock () } instance ExprType a => ParamType (InnerBlock a) where - type ParamRep (InnerBlock a) = ( [ TypedVarName a ], Expr TestBlock ) + type ParamRep (InnerBlock a) = ( [ TypedVarName a ], Expr (TestBlock ()) ) parseParam _ = mzero showParamType _ = "<code block>" paramExpr ( vars, expr ) = fmap InnerBlock $ helper vars $ const <$> expr @@ -242,14 +291,14 @@ instance ExprType a => ParamType (InnerBlock a) where combine f (x : xs) = f x xs combine _ [] = error "inner block parameter count mismatch" -innerBlock :: CommandDef TestBlock +innerBlock :: CommandDef (TestStep ()) innerBlock = ($ ([] :: [ Void ])) <$> innerBlockFun -innerBlockFun :: ExprType a => CommandDef (a -> TestBlock) +innerBlockFun :: ExprType a => CommandDef (a -> TestStep ()) innerBlockFun = (\f x -> f [ x ]) <$> innerBlockFunList -innerBlockFunList :: ExprType a => CommandDef ([ a ] -> TestBlock) -innerBlockFunList = fromInnerBlock <$> param "" +innerBlockFunList :: ExprType a => CommandDef ([ a ] -> TestStep ()) +innerBlockFunList = (\ib -> Scope . fromInnerBlock ib) <$> param "" newtype ExprParam a = ExprParam { fromExprParam :: a } deriving (Functor, Foldable, Traversable) @@ -263,7 +312,7 @@ instance ExprType a => ParamType (ExprParam a) where showParamType _ = "<" ++ T.unpack (textExprType @a Proxy) ++ ">" paramExpr = fmap ExprParam -command :: String -> CommandDef TestStep -> TestParser (Expr TestBlock) +command :: String -> CommandDef (TestStep ()) -> TestParser (Expr (TestBlock ())) command name (CommandDef types ctor) = do indent <- L.indentLevel line <- getSourceLine @@ -271,7 +320,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 (Expr TestBlock) + restOfLine :: Pos -> [(Pos, [(String, SomeParam Maybe)])] -> SourceLine -> [(String, SomeParam Maybe)] -> TestParser (Expr (TestBlock ())) restOfLine cmdi partials line params = choice [do void $ lookAhead eol let definedVariables = mconcat $ map (someParamVars . snd) params @@ -288,7 +337,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 $ (TestBlock . (: [])) <$> ctor iparams + return $ (TestBlockStep EmptyTestBlock) <$> ctor iparams ,do symbol ":" scn @@ -298,7 +347,7 @@ command name (CommandDef types ctor) = do ,do tryParams cmdi partials line [] params ] - restOfParts :: Pos -> [(Pos, [(String, SomeParam Maybe)])] -> TestParser (Expr TestBlock) + restOfParts :: Pos -> [(Pos, [(String, SomeParam Maybe)])] -> TestParser (Expr (TestBlock ())) restOfParts cmdi [] = testBlock cmdi restOfParts cmdi partials@((partIndent, params) : rest) = do scn @@ -324,7 +373,7 @@ command name (CommandDef types ctor) = do ] tryParams _ _ _ _ [] = mzero -testLocal :: TestParser (Expr TestBlock) +testLocal :: TestParser (Expr (TestBlock ())) testLocal = do ref <- L.indentLevel wsymbol "local" @@ -332,9 +381,10 @@ testLocal = do void $ eol indent <- L.indentGuard scn GT ref - localState $ testBlock indent + localState $ do + fmap (TestBlockStep EmptyTestBlock . Scope) <$> testBlock indent -testWith :: TestParser (Expr TestBlock) +testWith :: TestParser (Expr (TestBlock ())) testWith = do ref <- L.indentLevel wsymbol "with" @@ -358,27 +408,28 @@ testWith = do indent <- L.indentGuard scn GT ref localState $ do modify $ \s -> s { testContext = ctx } - testBlock indent + fmap (TestBlockStep EmptyTestBlock . Scope) <$> testBlock indent -testSubnet :: TestParser (Expr TestBlock) +testSubnet :: TestParser (Expr (TestBlock ())) testSubnet = command "subnet" $ Subnet <$> param "" <*> (fromExprParam <$> paramOrContext "of") <*> innerBlockFun -testNode :: TestParser (Expr TestBlock) +testNode :: TestParser (Expr (TestBlock ())) testNode = command "node" $ DeclNode <$> param "" <*> (fromExprParam <$> paramOrContext "on") <*> innerBlockFun -testSpawn :: TestParser (Expr TestBlock) +testSpawn :: TestParser (Expr (TestBlock ())) testSpawn = command "spawn" $ Spawn <$> param "as" <*> (bimap fromExprParam fromExprParam <$> paramOrContext "on") + <*> (maybe [] fromExprParam <$> param "args") <*> innerBlockFun -testExpect :: TestParser (Expr TestBlock) +testExpect :: TestParser (Expr (TestBlock ())) testExpect = command "expect" $ Expect <$> cmdLine <*> (fromExprParam <$> paramOrContext "from") @@ -386,47 +437,36 @@ testExpect = command "expect" $ Expect <*> param "capture" <*> innerBlockFunList -testDisconnectNode :: TestParser (Expr TestBlock) +testDisconnectNode :: TestParser (Expr (TestBlock ())) testDisconnectNode = command "disconnect_node" $ DisconnectNode <$> (fromExprParam <$> paramOrContext "") <*> innerBlock -testDisconnectNodes :: TestParser (Expr TestBlock) +testDisconnectNodes :: TestParser (Expr (TestBlock ())) testDisconnectNodes = command "disconnect_nodes" $ DisconnectNodes <$> (fromExprParam <$> paramOrContext "") <*> innerBlock -testDisconnectUpstream :: TestParser (Expr TestBlock) +testDisconnectUpstream :: TestParser (Expr (TestBlock ())) testDisconnectUpstream = command "disconnect_upstream" $ DisconnectUpstream <$> (fromExprParam <$> paramOrContext "") <*> innerBlock -testPacketLoss :: TestParser (Expr TestBlock) +testPacketLoss :: TestParser (Expr (TestBlock ())) testPacketLoss = command "packet_loss" $ PacketLoss <$> (fromExprParam <$> paramOrContext "") <*> (fromExprParam <$> paramOrContext "on") <*> innerBlock -testBlock :: Pos -> TestParser (Expr TestBlock) +testBlock :: Pos -> TestParser (Expr (TestBlock ())) testBlock indent = blockOf indent testStep -blockOf :: Monoid a => Pos -> TestParser a -> TestParser a -blockOf indent step = go - where - go = do - scn - pos <- L.indentLevel - optional eof >>= \case - Just _ -> return mempty - _ | pos < indent -> return mempty - | pos == indent -> mappend <$> step <*> go - | otherwise -> L.incorrectIndent EQ indent pos - -testStep :: TestParser (Expr TestBlock) +testStep :: TestParser (Expr (TestBlock ())) testStep = choice [ letStatement , forStatement + , shellStatement , testLocal , testWith , testSubnet |