summaryrefslogtreecommitdiff
path: root/src/Parser
diff options
context:
space:
mode:
Diffstat (limited to 'src/Parser')
-rw-r--r--src/Parser/Core.hs3
-rw-r--r--src/Parser/Expr.hs12
-rw-r--r--src/Parser/Shell.hs81
-rw-r--r--src/Parser/Statement.hs82
4 files changed, 129 insertions, 49 deletions
diff --git a/src/Parser/Core.hs b/src/Parser/Core.hs
index 132dbc8..f44e721 100644
--- a/src/Parser/Core.hs
+++ b/src/Parser/Core.hs
@@ -201,7 +201,8 @@ unifyExpr off pa expr = if
SomeExpr context <- gets testContext
context' <- unifyExpr off atype context
return $ Just ( kw, SomeExpr context' )
- return (FunctionEval $ ArgsApp (FunctionArguments $ M.fromAscList defaults) expr)
+ sline <- getSourceLine
+ return (FunctionEval sline $ ArgsApp (FunctionArguments $ M.fromAscList defaults) expr)
| Just (Refl :: DynamicType :~: b) <- eqT
, Undefined msg <- expr
diff --git a/src/Parser/Expr.hs b/src/Parser/Expr.hs
index 3700602..b9b5f01 100644
--- a/src/Parser/Expr.hs
+++ b/src/Parser/Expr.hs
@@ -118,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 '"'
@@ -261,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)
@@ -347,6 +356,7 @@ typedExpr = do
literal :: TestParser SomeExpr
literal = label "literal" $ choice
[ numberLiteral
+ , boolLiteral
, SomeExpr <$> quotedString
, SomeExpr <$> regex
, list
@@ -394,7 +404,7 @@ checkFunctionArguments (FunctionArguments argTypes) poff kw sexpr@(SomeExpr 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 sexpr
diff --git a/src/Parser/Shell.hs b/src/Parser/Shell.hs
index 0f34fee..ffc8cf1 100644
--- a/src/Parser/Shell.hs
+++ b/src/Parser/Shell.hs
@@ -3,6 +3,7 @@ module Parser.Shell (
shellScript,
) where
+import Control.Applicative (liftA2)
import Control.Monad
import Data.Char
@@ -19,15 +20,18 @@ 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
+parseTextArgument :: TestParser (Expr Text)
+parseTextArgument = lexeme $ fmap (App AnnNone (Pure T.concat) <$> foldr (liftA2 (:)) (Pure [])) $ some $ choice
[ doubleQuotedString
- , escapedChar
+ , singleQuotedString
+ , standaloneEscapedChar
, stringExpansion
, unquotedString
]
where
- specialChars = [ '\"', '\\', '$' ]
+ specialChars = [ '"', '\'', '\\', '$', '#', '|', '>', '<', ';', '[', ']', '{', '}', '(', ')', '*', '?', '~', '&', '!' ]
+
+ stringSpecialChars = [ '"', '\\', '$' ]
unquotedString :: TestParser (Expr Text)
unquotedString = do
@@ -38,36 +42,75 @@ parseArgument = lexeme $ fmap (App AnnNone (Pure T.concat) <$> foldr (liftA2 (:)
void $ char '"'
let inner = choice
[ char '"' >> return []
- , (:) <$> (Pure . TL.toStrict <$> takeWhile1P Nothing (`notElem` specialChars)) <*> inner
- , (:) <$> escapedChar <*> inner
+ , (:) <$> (Pure . TL.toStrict <$> takeWhile1P Nothing (`notElem` stringSpecialChars)) <*> inner
+ , (:) <$> stringEscapedChar <*> inner
, (:) <$> stringExpansion <*> inner
]
App AnnNone (Pure T.concat) . foldr (liftA2 (:)) (Pure []) <$> inner
- escapedChar :: TestParser (Expr Text)
- escapedChar = do
+ singleQuotedString :: TestParser (Expr Text)
+ singleQuotedString = do
+ Pure . TL.toStrict <$> (char '\'' *> takeWhileP Nothing (/= '\'') <* char '\'')
+
+ stringEscapedChar :: TestParser (Expr Text)
+ stringEscapedChar = do
void $ char '\\'
- Pure <$> choice
- [ char '\\' >> return "\\"
- , char '"' >> return "\""
- , char '$' >> return "$"
- , char 'n' >> return "\n"
+ fmap Pure $ choice $
+ map (\c -> char c >> return (T.singleton c)) stringSpecialChars ++
+ [ char 'n' >> return "\n"
, char 'r' >> return "\r"
, char 't' >> return "\t"
+ , return "\\"
+ ]
+
+ standaloneEscapedChar :: TestParser (Expr Text)
+ standaloneEscapedChar = do
+ void $ char '\\'
+ fmap Pure $ choice $
+ map (\c -> char c >> return (T.singleton c)) specialChars ++
+ [ char ' ' >> return " "
]
-parseArguments :: TestParser (Expr [ Text ])
+parseArgument :: TestParser (Expr ShellArgument)
+parseArgument = choice
+ [ fmap ShellArgument <$> parseTextArgument
+ ]
+
+parseArguments :: TestParser (Expr [ ShellArgument ])
parseArguments = foldr (liftA2 (:)) (Pure []) <$> many parseArgument
-shellStatement :: TestParser (Expr [ ShellStatement ])
-shellStatement = label "shell statement" $ do
- command <- parseArgument
+parseCommand :: TestParser (Expr ShellCommand)
+parseCommand = label "shell statement" $ do
+ line <- getSourceLine
+ command <- parseTextArgument
args <- parseArguments
- return $ fmap (: []) $ ShellStatement
+ return $ ShellCommand
<$> command
<*> args
+ <*> pure line
+
+parsePipeline :: Maybe (Expr ShellPipeline) -> TestParser (Expr ShellPipeline)
+parsePipeline mbupper = do
+ cmd <- parseCommand
+ let pipeline =
+ case mbupper of
+ Nothing -> fmap (\ecmd -> ShellPipeline ecmd Nothing) cmd
+ Just upper -> liftA2 (\ecmd eupper -> ShellPipeline ecmd (Just eupper)) cmd upper
+ choice
+ [ do
+ osymbol "|"
+ parsePipeline (Just pipeline)
+
+ , do
+ return pipeline
+ ]
+
+parseStatement :: TestParser (Expr [ ShellStatement ])
+parseStatement = do
+ line <- getSourceLine
+ fmap ((: []) . flip ShellStatement line) <$> parsePipeline Nothing
shellScript :: TestParser (Expr ShellScript)
shellScript = do
indent <- L.indentLevel
- fmap ShellScript <$> blockOf indent shellStatement
+ fmap ShellScript <$> blockOf indent parseStatement
diff --git a/src/Parser/Statement.hs b/src/Parser/Statement.hs
index 7c2977d..9b02770 100644
--- a/src/Parser/Statement.hs
+++ b/src/Parser/Statement.hs
@@ -1,5 +1,6 @@
module Parser.Statement (
testStep,
+ testBlock,
) where
import Control.Monad
@@ -43,7 +44,7 @@ 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 = do
@@ -68,23 +69,52 @@ forStatement = do
body <- testBlock indent
return $ (\xs f -> mconcat $ map f xs)
<$> (unpack <$> e)
- <*> LambdaAbstraction tname body
+ <*> LambdaAbstraction tname (TestBlockStep EmptyTestBlock . Scope <$> body)
shellStatement :: TestParser (Expr (TestBlock ()))
shellStatement = do
ref <- L.indentLevel
wsymbol "shell"
- wsymbol "as"
- pname <- newVarName
- wsymbol "on"
- node <- typedExpr
- symbol ":"
- void eol
- void $ L.indentGuard scn GT ref
- script <- shellScript
- cont <- testBlock ref
- return $ TestBlockStep EmptyTestBlock <$>
- (SpawnShell pname <$> node <*> script <*> LambdaAbstraction pname cont)
+ 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
@@ -145,13 +175,6 @@ instance ExprType a => ParamType (TypedVarName a) where
paramNewVariables _ var = SomeNewVariables [ var ]
paramNewVariablesEmpty _ = SomeNewVariables @a []
-instance ExprType a => ParamType (Expr a) where
- parseParam _ = do
- off <- stateOffset <$> getParserState
- SomeExpr e <- literal <|> between (symbol "(") (symbol ")") someExpr
- unifyExpr off Proxy e
- showParamType _ = "<" ++ T.unpack (textExprType @a Proxy) ++ ">"
-
instance ParamType a => ParamType [a] where
type ParamRep [a] = [ParamRep a]
parseParam _ = listOf (parseParam @a Proxy)
@@ -187,8 +210,8 @@ instance (ParamType a, ParamType b) => ParamType (Either a b) where
instance ExprType a => ParamType (Traced a) where
type ParamRep (Traced a) = Expr a
- parseParam _ = parseParam (Proxy @(Expr a))
- showParamType _ = showParamType (Proxy @(Expr a))
+ parseParam _ = parseParam (Proxy @(ExprParam a))
+ showParamType _ = showParamType (Proxy @(ExprParam a))
paramExpr = Trace
data SomeParam f = forall a. ParamType a => SomeParam (Proxy a) (f (ParamRep a))
@@ -261,14 +284,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)
@@ -351,7 +374,8 @@ 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 = do
@@ -377,7 +401,7 @@ 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 = command "subnet" $ Subnet
@@ -395,6 +419,7 @@ testSpawn :: TestParser (Expr (TestBlock ()))
testSpawn = command "spawn" $ Spawn
<$> param "as"
<*> (bimap fromExprParam fromExprParam <$> paramOrContext "on")
+ <*> (maybe [] fromExprParam <$> param "args")
<*> innerBlockFun
testExpect :: TestParser (Expr (TestBlock ()))
@@ -402,6 +427,7 @@ testExpect = command "expect" $ Expect
<$> cmdLine
<*> (fromExprParam <$> paramOrContext "from")
<*> param ""
+ <*> (maybe 1 fromExprParam <$> param "timeout")
<*> param "capture"
<*> innerBlockFunList
generated by cgit v1.2.3 (git 2.25.1) at 2025-10-17 00:09:46 +0000