summaryrefslogtreecommitdiff
path: root/src/Parser
diff options
context:
space:
mode:
Diffstat (limited to 'src/Parser')
-rw-r--r--src/Parser/Core.hs99
-rw-r--r--src/Parser/Expr.hs82
-rw-r--r--src/Parser/Shell.hs81
-rw-r--r--src/Parser/Statement.hs128
4 files changed, 286 insertions, 104 deletions
diff --git a/src/Parser/Core.hs b/src/Parser/Core.hs
index 5fb4c5f..132dbc8 100644
--- a/src/Parser/Core.hs
+++ b/src/Parser/Core.hs
@@ -2,7 +2,6 @@ module Parser.Core where
import Control.Applicative
import Control.Monad
-import Control.Monad.Identity
import Control.Monad.State
import Data.Map (Map)
@@ -12,40 +11,72 @@ import Data.Set qualified as S
import Data.Text qualified as T
import Data.Text.Lazy qualified as TL
import Data.Typeable
-import Data.Void
import Text.Megaparsec hiding (State)
import Text.Megaparsec.Char
import qualified Text.Megaparsec.Char.Lexer as L
import Network ()
+import Script.Expr
+import Script.Module
import Test
-newtype TestParser a = TestParser (StateT TestParserState (ParsecT Void TestStream Identity) a)
+newtype TestParser a = TestParser (StateT TestParserState (ParsecT CustomTestError TestStream IO) a)
deriving
( Functor, Applicative, Alternative, Monad
, MonadState TestParserState
, MonadPlus
, MonadFail
- , MonadParsec Void TestStream
+ , MonadIO
+ , MonadParsec CustomTestError TestStream
)
type TestStream = TL.Text
-type TestParseError = ParseError TestStream Void
+type TestParseError = ParseError TestStream CustomTestError
-runTestParser :: String -> TestStream -> TestParserState -> TestParser a -> Either (ParseErrorBundle TestStream Void) a
-runTestParser path content initState (TestParser parser) = runIdentity . flip (flip runParserT path) content . flip evalStateT initState $ parser
+data CustomTestError
+ = ModuleNotFound ModuleName
+ | FileNotFound FilePath
+ | ImportModuleError (ParseErrorBundle TestStream CustomTestError)
+ deriving (Eq)
+
+instance Ord CustomTestError where
+ compare (ModuleNotFound a) (ModuleNotFound b) = compare a b
+ compare (ModuleNotFound _) _ = LT
+ compare _ (ModuleNotFound _) = GT
+
+ compare (FileNotFound a) (FileNotFound b) = compare a b
+ compare (FileNotFound _) _ = LT
+ compare _ (FileNotFound _) = GT
+
+ -- Ord instance is required to store errors in Set, but there shouldn't be
+ -- two ImportModuleErrors at the same possition, so "dummy" comparison
+ -- should be ok.
+ compare (ImportModuleError _) (ImportModuleError _) = EQ
+
+instance ShowErrorComponent CustomTestError where
+ showErrorComponent (ModuleNotFound name) = "module ‘" <> T.unpack (textModuleName name) <> "’ not found"
+ showErrorComponent (FileNotFound path) = "file ‘" <> path <> "’ not found"
+ showErrorComponent (ImportModuleError bundle) = "error parsing imported module:\n" <> errorBundlePretty bundle
+
+runTestParser :: TestStream -> TestParserState -> TestParser a -> IO (Either (ParseErrorBundle TestStream CustomTestError) a)
+runTestParser content initState (TestParser parser) = flip (flip runParserT (testSourcePath initState)) content . flip evalStateT initState $ parser
data Toplevel
= ToplevelTest Test
| ToplevelDefinition ( VarName, SomeExpr )
+ | ToplevelExport VarName
+ | ToplevelImport ( ModuleName, VarName )
data TestParserState = TestParserState
- { testVars :: [ ( VarName, SomeExprType ) ]
+ { testSourcePath :: FilePath
+ , testVars :: [ ( VarName, ( FqVarName, SomeExprType )) ]
, testContext :: SomeExpr
, testNextTypeVar :: Int
, testTypeUnif :: Map TypeVar SomeExprType
+ , testCurrentModuleName :: ModuleName
+ , testParseModule :: ModuleName -> ModuleName -> IO (Either CustomTestError Module)
}
newTypeVar :: TestParser TypeVar
@@ -54,25 +85,36 @@ newTypeVar = do
modify $ \s -> s { testNextTypeVar = idx + 1 }
return $ TypeVar $ T.pack $ 'a' : show idx
-lookupVarType :: Int -> VarName -> TestParser SomeExprType
+lookupVarType :: Int -> VarName -> TestParser ( FqVarName, SomeExprType )
lookupVarType off name = do
gets (lookup name . testVars) >>= \case
Nothing -> do
registerParseError $ FancyError off $ S.singleton $ ErrorFail $ T.unpack $
"variable not in scope: `" <> textVarName name <> "'"
vtype <- ExprTypeVar <$> newTypeVar
- modify $ \s -> s { testVars = ( name, vtype ) : testVars s }
- return vtype
- Just t@(ExprTypeVar tvar) -> do
- gets (fromMaybe t . M.lookup tvar . testTypeUnif)
+ let fqName = LocalVarName name
+ modify $ \s -> s { testVars = ( name, ( fqName, vtype )) : testVars s }
+ return ( fqName, vtype )
+ Just ( fqName, t@(ExprTypeVar tvar) ) -> do
+ ( fqName, ) <$> gets (fromMaybe t . M.lookup tvar . testTypeUnif)
Just x -> return x
lookupVarExpr :: Int -> SourceLine -> VarName -> TestParser SomeExpr
lookupVarExpr off sline name = do
- lookupVarType off name >>= \case
- ExprTypePrim (Proxy :: Proxy a) -> return $ SomeExpr $ (Variable sline name :: Expr a)
- ExprTypeVar tvar -> return $ SomeExpr $ DynVariable tvar sline name
- ExprTypeFunction args (_ :: Proxy a) -> return $ SomeExpr $ (FunVariable args sline name :: Expr (FunctionType a))
+ ( fqn, etype ) <- lookupVarType off name
+ case etype of
+ ExprTypePrim (Proxy :: Proxy a) -> return $ SomeExpr $ (Variable sline fqn :: Expr a)
+ ExprTypeVar tvar -> return $ SomeExpr $ DynVariable tvar sline fqn
+ ExprTypeFunction args (_ :: Proxy a) -> return $ SomeExpr $ (FunVariable args sline fqn :: Expr (FunctionType a))
+
+lookupScalarVarExpr :: Int -> SourceLine -> VarName -> TestParser SomeExpr
+lookupScalarVarExpr off sline name = do
+ ( fqn, etype ) <- lookupVarType off name
+ case etype of
+ ExprTypePrim (Proxy :: Proxy a) -> return $ SomeExpr $ (Variable sline fqn :: Expr a)
+ ExprTypeVar tvar -> return $ SomeExpr $ DynVariable tvar sline fqn
+ ExprTypeFunction args (pa :: Proxy a) -> do
+ SomeExpr <$> unifyExpr off pa (FunVariable args sline fqn :: Expr (FunctionType a))
unify :: Int -> SomeExprType -> SomeExprType -> TestParser SomeExprType
unify _ (ExprTypeVar aname) (ExprTypeVar bname) | aname == bname = do
@@ -204,7 +246,7 @@ localState inner = do
put s { testNextTypeVar = testNextTypeVar s', testTypeUnif = testTypeUnif s' }
return x
-toplevel :: (a -> Toplevel) -> TestParser a -> TestParser Toplevel
+toplevel :: (a -> b) -> TestParser a -> TestParser b
toplevel f = return . f <=< L.nonIndented scn
block :: (a -> [b] -> TestParser c) -> TestParser a -> TestParser b -> TestParser c
@@ -221,6 +263,18 @@ listOf item = do
x <- item
(x:) <$> choice [ symbol "," >> listOf item, return [] ]
+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
+
getSourceLine :: TestParser SourceLine
getSourceLine = do
@@ -230,3 +284,12 @@ getSourceLine = do
, T.pack ": "
, TL.toStrict $ TL.takeWhile (/='\n') $ pstateInput pstate
]
+
+
+getOrParseModule :: ModuleName -> TestParser Module
+getOrParseModule name = do
+ current <- gets testCurrentModuleName
+ parseModule <- gets testParseModule
+ (TestParser $ lift $ lift $ parseModule current name) >>= \case
+ Right parsed -> return parsed
+ Left err -> customFailure err
diff --git a/src/Parser/Expr.hs b/src/Parser/Expr.hs
index 5ff3f15..b9b5f01 100644
--- a/src/Parser/Expr.hs
+++ b/src/Parser/Expr.hs
@@ -1,5 +1,6 @@
module Parser.Expr (
identifier,
+ parseModuleName,
varName,
newVarName,
@@ -10,6 +11,8 @@ module Parser.Expr (
literal,
variable,
+ stringExpansion,
+
checkFunctionArguments,
functionArguments,
) where
@@ -34,11 +37,10 @@ import Text.Megaparsec hiding (State)
import Text.Megaparsec.Char
import Text.Megaparsec.Char.Lexer qualified as L
import Text.Megaparsec.Error.Builder qualified as Err
-import Text.Regex.TDFA qualified as RE
-import Text.Regex.TDFA.Text qualified as RE
import Parser.Core
-import Test
+import Script.Expr
+import Script.Expr.Class
reservedWords :: [ Text ]
reservedWords =
@@ -58,6 +60,11 @@ identifier = label "identifier" $ do
]
return ident
+parseModuleName :: TestParser ModuleName
+parseModuleName = do
+ x <- identifier
+ ModuleName . (x :) <$> many (symbol "." >> identifier)
+
varName :: TestParser VarName
varName = label "variable name" $ VarName <$> identifier
@@ -74,7 +81,7 @@ addVarName off (TypedVarName name) = do
Just _ -> registerParseError $ FancyError off $ S.singleton $ ErrorFail $ T.unpack $
T.pack "variable '" <> textVarName name <> T.pack "' already exists"
Nothing -> return ()
- modify $ \s -> s { testVars = ( name, ExprTypePrim @a Proxy ) : testVars s }
+ modify $ \s -> s { testVars = ( name, ( LocalVarName name, ExprTypePrim @a Proxy )) : testVars s }
someExpansion :: TestParser SomeExpr
someExpansion = do
@@ -83,12 +90,12 @@ someExpansion = do
[do off <- stateOffset <$> getParserState
sline <- getSourceLine
name <- VarName . TL.toStrict <$> takeWhile1P Nothing (\x -> isAlphaNum x || x == '_')
- lookupVarExpr off sline name
+ lookupScalarVarExpr off sline name
, between (char '{') (char '}') someExpr
]
-stringExpansion :: ExprType a => Text -> (forall b. ExprType b => Expr b -> [Maybe (Expr a)]) -> TestParser (Expr a)
-stringExpansion tname conv = do
+expressionExpansion :: forall a. ExprType a => Text -> TestParser (Expr a)
+expressionExpansion tname = do
off <- stateOffset <$> getParserState
SomeExpr e <- someExpansion
let err = do
@@ -96,7 +103,10 @@ stringExpansion tname conv = do
[ tname, T.pack " expansion not defined for '", textExprType e, T.pack "'" ]
return $ Undefined "expansion not defined for type"
- maybe err return $ listToMaybe $ catMaybes $ conv e
+ maybe err (return . (<$> e)) $ listToMaybe $ catMaybes [ cast (id :: a -> a), exprExpansionConvTo, exprExpansionConvFrom ]
+
+stringExpansion :: TestParser (Expr Text)
+stringExpansion = expressionExpansion "string"
numberLiteral :: TestParser SomeExpr
numberLiteral = label "number" $ lexeme $ do
@@ -108,6 +118,13 @@ numberLiteral = label "number" $ lexeme $ do
else return $ SomeExpr $ Pure x
]
+boolLiteral :: TestParser SomeExpr
+boolLiteral = label "bool" $ lexeme $ do
+ SomeExpr . Pure <$> choice
+ [ wsymbol "True" *> return True
+ , wsymbol "False" *> return False
+ ]
+
quotedString :: TestParser (Expr Text)
quotedString = label "string" $ lexeme $ do
void $ char '"'
@@ -124,11 +141,7 @@ quotedString = label "string" $ lexeme $ do
, char 't' >> return '\t'
]
(Pure (T.singleton c) :) <$> inner
- ,do e <- stringExpansion (T.pack "string") $ \e ->
- [ cast e
- , fmap (T.pack . show @Integer) <$> cast e
- , fmap (T.pack . show @Scientific) <$> cast e
- ]
+ ,do e <- stringExpansion
(e:) <$> inner
]
Concat <$> inner
@@ -146,19 +159,14 @@ regex = label "regular expression" $ lexeme $ do
, anySingle >>= \c -> return (Pure $ RegexPart $ T.pack ['\\', c])
]
(s:) <$> inner
- ,do e <- stringExpansion (T.pack "regex") $ \e ->
- [ cast e
- , fmap RegexString <$> cast e
- , fmap (RegexString . T.pack . show @Integer) <$> cast e
- , fmap (RegexString . T.pack . show @Scientific) <$> cast e
- ]
+ ,do e <- expressionExpansion (T.pack "regex")
(e:) <$> inner
]
parts <- inner
let testEval = \case
Pure (RegexPart p) -> p
_ -> ""
- case RE.compile RE.defaultCompOpt RE.defaultExecOpt $ T.concat $ map testEval parts of
+ case regexCompile $ T.concat $ map testEval parts of
Left err -> registerParseError $ FancyError off $ S.singleton $ ErrorFail $ T.unpack $ T.concat
[ "failed to parse regular expression: ", T.pack err ]
Right _ -> return ()
@@ -260,11 +268,13 @@ someExpr = join inner <?> "expression"
[ SomeBinOp ((==) @Integer)
, SomeBinOp ((==) @Scientific)
, SomeBinOp ((==) @Text)
+ , SomeBinOp ((==) @Bool)
]
, binary' "/=" (\op xs ys -> length xs /= length ys || or (zipWith op xs ys)) $
[ SomeBinOp ((/=) @Integer)
, SomeBinOp ((/=) @Scientific)
, SomeBinOp ((/=) @Text)
+ , SomeBinOp ((/=) @Bool)
]
, binary ">" $
[ SomeBinOp ((>) @Integer)
@@ -346,6 +356,7 @@ typedExpr = do
literal :: TestParser SomeExpr
literal = label "literal" $ choice
[ numberLiteral
+ , boolLiteral
, SomeExpr <$> quotedString
, SomeExpr <$> regex
, list
@@ -385,18 +396,17 @@ recordSelector (SomeExpr expr) = do
checkFunctionArguments :: FunctionArguments SomeArgumentType
-> Int -> Maybe ArgumentKeyword -> SomeExpr -> TestParser SomeExpr
-checkFunctionArguments (FunctionArguments argTypes) poff kw expr = do
+checkFunctionArguments (FunctionArguments argTypes) poff kw sexpr@(SomeExpr expr) = do
case M.lookup kw argTypes of
Just (SomeArgumentType (_ :: ArgumentType expected)) -> do
- withRecovery registerParseError $ do
- void $ unify poff (ExprTypePrim (Proxy @expected)) (someExprType expr)
- return expr
+ withRecovery (\e -> registerParseError e >> return sexpr) $ do
+ SomeExpr <$> unifyExpr poff (Proxy @expected) expr
Nothing -> do
registerParseError $ FancyError poff $ S.singleton $ ErrorFail $ T.unpack $
case kw of
- Just (ArgumentKeyword tkw) -> "unexpected parameter with keyword `" <> tkw <> "'"
+ Just (ArgumentKeyword tkw) -> "unexpected parameter with keyword ‘" <> tkw <> "’"
Nothing -> "unexpected parameter"
- return expr
+ return sexpr
functionArguments :: (Int -> Maybe ArgumentKeyword -> a -> TestParser b) -> TestParser a -> TestParser a -> (Int -> Text -> TestParser a) -> TestParser (FunctionArguments b)
@@ -415,22 +425,10 @@ functionArguments check param lit promote = do
[ T.pack "multiple unnamed parameters" ]
parseArgs False
- ,do off <- stateOffset <$> getParserState
- x <- identifier
- choice
- [do off' <- stateOffset <$> getParserState
- y <- pparam <|> (promote off' =<< identifier)
- checkAndInsert off' (Just (ArgumentKeyword x)) y $ parseArgs allowUnnamed
-
- ,if allowUnnamed
- then do
- y <- promote off x
- checkAndInsert off Nothing y $ return M.empty
- else do
- registerParseError $ FancyError off $ S.singleton $ ErrorFail $ T.unpack $ T.concat
- [ T.pack "multiple unnamed parameters" ]
- return M.empty
- ]
+ ,do x <- identifier
+ off <- stateOffset <$> getParserState
+ y <- pparam <|> (promote off =<< identifier)
+ checkAndInsert off (Just (ArgumentKeyword x)) y $ parseArgs allowUnnamed
,do return M.empty
]
diff --git a/src/Parser/Shell.hs b/src/Parser/Shell.hs
new file mode 100644
index 0000000..89595e8
--- /dev/null
+++ b/src/Parser/Shell.hs
@@ -0,0 +1,81 @@
+module Parser.Shell (
+ ShellScript,
+ shellScript,
+) where
+
+import Control.Applicative (liftA2)
+import Control.Monad
+
+import Data.Char
+import Data.Text (Text)
+import Data.Text qualified as T
+import Data.Text.Lazy qualified as TL
+
+import Text.Megaparsec
+import Text.Megaparsec.Char
+import Text.Megaparsec.Char.Lexer qualified as L
+
+import Parser.Core
+import Parser.Expr
+import Script.Expr
+import Script.Shell
+
+parseArgument :: TestParser (Expr Text)
+parseArgument = lexeme $ fmap (App AnnNone (Pure T.concat) <$> foldr (liftA2 (:)) (Pure [])) $ some $ choice
+ [ doubleQuotedString
+ , singleQuotedString
+ , escapedChar
+ , stringExpansion
+ , unquotedString
+ ]
+ where
+ specialChars = [ '\"', '\\', '$' ]
+
+ unquotedString :: TestParser (Expr Text)
+ unquotedString = do
+ Pure . TL.toStrict <$> takeWhile1P Nothing (\c -> not (isSpace c) && c `notElem` specialChars)
+
+ doubleQuotedString :: TestParser (Expr Text)
+ doubleQuotedString = do
+ void $ char '"'
+ let inner = choice
+ [ char '"' >> return []
+ , (:) <$> (Pure . TL.toStrict <$> takeWhile1P Nothing (`notElem` specialChars)) <*> inner
+ , (:) <$> escapedChar <*> inner
+ , (:) <$> stringExpansion <*> inner
+ ]
+ App AnnNone (Pure T.concat) . foldr (liftA2 (:)) (Pure []) <$> inner
+
+ singleQuotedString :: TestParser (Expr Text)
+ singleQuotedString = do
+ Pure . TL.toStrict <$> (char '\'' *> takeWhileP Nothing (/= '\'') <* char '\'')
+
+ escapedChar :: TestParser (Expr Text)
+ escapedChar = do
+ void $ char '\\'
+ Pure <$> choice
+ [ char '\\' >> return "\\"
+ , char '"' >> return "\""
+ , char '$' >> return "$"
+ , char 'n' >> return "\n"
+ , char 'r' >> return "\r"
+ , char 't' >> return "\t"
+ ]
+
+parseArguments :: TestParser (Expr [ Text ])
+parseArguments = foldr (liftA2 (:)) (Pure []) <$> many parseArgument
+
+shellStatement :: TestParser (Expr [ ShellStatement ])
+shellStatement = label "shell statement" $ do
+ line <- getSourceLine
+ command <- parseArgument
+ args <- parseArguments
+ return $ fmap (: []) $ ShellStatement
+ <$> command
+ <*> args
+ <*> pure line
+
+shellScript :: TestParser (Expr ShellScript)
+shellScript = do
+ indent <- L.indentLevel
+ fmap ShellScript <$> blockOf indent shellStatement
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
generated by cgit v1.2.3 (git 2.25.1) at 2025-07-02 05:49:25 +0000