summaryrefslogtreecommitdiff
path: root/src/Parser
diff options
context:
space:
mode:
Diffstat (limited to 'src/Parser')
-rw-r--r--src/Parser/Core.hs5
-rw-r--r--src/Parser/Expr.hs10
-rw-r--r--src/Parser/Shell.hs92
-rw-r--r--src/Parser/Statement.hs32
4 files changed, 100 insertions, 39 deletions
diff --git a/src/Parser/Core.hs b/src/Parser/Core.hs
index 132dbc8..786fb2e 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
@@ -235,7 +236,7 @@ osymbol str = void $ try $ (string (TL.pack str) <* notFollowedBy operatorChar)
wsymbol str = void $ try $ (string (TL.pack str) <* notFollowedBy wordChar) <* sc
operatorChar :: (MonadParsec e s m, Token s ~ Char) => m (Token s)
-operatorChar = satisfy $ (`elem` ['.', '+', '-', '*', '/', '='])
+operatorChar = satisfy $ (`elem` [ '.', '+', '-', '*', '/', '=', '<', '>', '|' ])
{-# INLINE operatorChar #-}
localState :: TestParser a -> TestParser a
diff --git a/src/Parser/Expr.hs b/src/Parser/Expr.hs
index 079cfba..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
diff --git a/src/Parser/Shell.hs b/src/Parser/Shell.hs
index 09f953c..105edfa 100644
--- a/src/Parser/Shell.hs
+++ b/src/Parser/Shell.hs
@@ -20,16 +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
, singleQuotedString
- , escapedChar
+ , standaloneEscapedChar
, stringExpansion
, unquotedString
]
where
- specialChars = [ '\"', '\\', '$' ]
+ specialChars = [ '"', '\'', '\\', '$', '#', '|', '>', '<', ';', '[', ']'{-, '{', '}' -}, '(', ')'{-, '*', '?', '~', '&', '!' -} ]
+
+ stringSpecialChars = [ '"', '\\', '$' ]
unquotedString :: TestParser (Expr Text)
unquotedString = do
@@ -40,8 +42,8 @@ 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
@@ -50,30 +52,82 @@ parseArgument = lexeme $ fmap (App AnnNone (Pure T.concat) <$> foldr (liftA2 (:)
singleQuotedString = do
Pure . TL.toStrict <$> (char '\'' *> takeWhileP Nothing (/= '\'') <* char '\'')
- escapedChar :: TestParser (Expr Text)
- escapedChar = do
+ 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 "\\"
]
-parseArguments :: TestParser (Expr [ Text ])
+ standaloneEscapedChar :: TestParser (Expr Text)
+ standaloneEscapedChar = do
+ void $ char '\\'
+ fmap T.singleton . Pure <$> printChar
+
+parseRedirection :: TestParser (Expr ShellArgument)
+parseRedirection = choice
+ [ do
+ osymbol "<"
+ fmap ShellRedirectStdin <$> parseTextArgument
+ , do
+ osymbol ">"
+ fmap (ShellRedirectStdout False) <$> parseTextArgument
+ , do
+ osymbol ">>"
+ fmap (ShellRedirectStdout True) <$> parseTextArgument
+ , do
+ osymbol "2>"
+ fmap (ShellRedirectStderr False) <$> parseTextArgument
+ , do
+ osymbol "2>>"
+ fmap (ShellRedirectStderr True) <$> parseTextArgument
+ ]
+
+parseArgument :: TestParser (Expr ShellArgument)
+parseArgument = choice
+ [ parseRedirection
+ , 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 27e7b92..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,7 +69,7 @@ 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
@@ -108,7 +109,7 @@ shellStatement = do
void eol
void $ L.indentGuard scn GT ref
script <- shellScript
- cont <- testBlock ref
+ cont <- fmap Scope <$> testBlock ref
let expr | Just pname <- mbpname = LambdaAbstraction pname cont
| otherwise = const <$> cont
return $ TestBlockStep EmptyTestBlock <$>
@@ -174,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)
@@ -216,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))
@@ -290,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)
@@ -380,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
@@ -406,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
@@ -432,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-12-16 19:35:10 +0000