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.hs90
-rw-r--r--src/Parser/Statement.hs12
4 files changed, 87 insertions, 30 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 89595e8..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,32 +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
+parseCommand :: TestParser (Expr ShellCommand)
+parseCommand = label "shell statement" $ do
line <- getSourceLine
- command <- parseArgument
+ 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 474fa03..9b02770 100644
--- a/src/Parser/Statement.hs
+++ b/src/Parser/Statement.hs
@@ -175,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)
@@ -217,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))
@@ -434,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 11:55:01 +0000