diff options
Diffstat (limited to 'src/Parser')
| -rw-r--r-- | src/Parser/Expr.hs | 10 | ||||
| -rw-r--r-- | src/Parser/Shell.hs | 8 | ||||
| -rw-r--r-- | src/Parser/Statement.hs | 31 |
3 files changed, 33 insertions, 16 deletions
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 0f34fee..89595e8 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 @@ -22,6 +23,7 @@ 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 @@ -44,6 +46,10 @@ parseArgument = lexeme $ fmap (App AnnNone (Pure T.concat) <$> foldr (liftA2 (:) ] 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 '\\' @@ -61,11 +67,13 @@ 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 diff --git a/src/Parser/Statement.hs b/src/Parser/Statement.hs index 812c559..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 @@ -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 @@ -98,12 +99,6 @@ shellStatement = do , do off <- stateOffset <$> getParserState symbol ":" - pname <- case mbpname of - Just pname -> return pname - Nothing -> do - registerParseError $ FancyError off $ S.singleton $ ErrorFail $ - "missing parameter with keyword ‘as’" - return $ TypedVarName (VarName "") node <- case mbnode of Just node -> return node Nothing -> do @@ -114,9 +109,11 @@ 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 <$> - (SpawnShell pname <$> node <*> script <*> LambdaAbstraction pname cont) + (SpawnShell mbpname <$> node <*> script <*> expr) ] exprStatement :: TestParser (Expr (TestBlock ())) @@ -294,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) @@ -384,7 +381,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 @@ -410,7 +408,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 @@ -428,6 +426,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 ())) |