summaryrefslogtreecommitdiff
path: root/src/Parser
diff options
context:
space:
mode:
Diffstat (limited to 'src/Parser')
-rw-r--r--src/Parser/Core.hs12
-rw-r--r--src/Parser/Expr.hs21
-rw-r--r--src/Parser/Shell.hs73
-rw-r--r--src/Parser/Statement.hs30
4 files changed, 116 insertions, 20 deletions
diff --git a/src/Parser/Core.hs b/src/Parser/Core.hs
index abd8b96..d90f227 100644
--- a/src/Parser/Core.hs
+++ b/src/Parser/Core.hs
@@ -255,6 +255,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
diff --git a/src/Parser/Expr.hs b/src/Parser/Expr.hs
index 5d60973..54f2757 100644
--- a/src/Parser/Expr.hs
+++ b/src/Parser/Expr.hs
@@ -11,6 +11,8 @@ module Parser.Expr (
literal,
variable,
+ stringExpansion,
+
checkFunctionArguments,
functionArguments,
) where
@@ -94,8 +96,8 @@ someExpansion = do
, 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 :: ExprType a => Text -> (forall b. ExprType b => Expr b -> [ Maybe (Expr a) ]) -> TestParser (Expr a)
+expressionExpansion tname conv = do
off <- stateOffset <$> getParserState
SomeExpr e <- someExpansion
let err = do
@@ -105,6 +107,13 @@ stringExpansion tname conv = do
maybe err return $ listToMaybe $ catMaybes $ conv e
+stringExpansion :: TestParser (Expr Text)
+stringExpansion = expressionExpansion (T.pack "string") $ \e ->
+ [ cast e
+ , fmap (T.pack . show @Integer) <$> cast e
+ , fmap (T.pack . show @Scientific) <$> cast e
+ ]
+
numberLiteral :: TestParser SomeExpr
numberLiteral = label "number" $ lexeme $ do
x <- L.scientific
@@ -131,11 +140,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
@@ -153,7 +158,7 @@ regex = label "regular expression" $ lexeme $ do
, anySingle >>= \c -> return (Pure $ RegexPart $ T.pack ['\\', c])
]
(s:) <$> inner
- ,do e <- stringExpansion (T.pack "regex") $ \e ->
+ ,do e <- expressionExpansion (T.pack "regex") $ \e ->
[ cast e
, fmap RegexString <$> cast e
, fmap (RegexString . T.pack . show @Integer) <$> cast e
diff --git a/src/Parser/Shell.hs b/src/Parser/Shell.hs
new file mode 100644
index 0000000..0f34fee
--- /dev/null
+++ b/src/Parser/Shell.hs
@@ -0,0 +1,73 @@
+module Parser.Shell (
+ ShellScript,
+ shellScript,
+) where
+
+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
+ , 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
+
+ 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
+ command <- parseArgument
+ args <- parseArguments
+ return $ fmap (: []) $ ShellStatement
+ <$> command
+ <*> args
+
+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 1846fdb..7c2977d 100644
--- a/src/Parser/Statement.hs
+++ b/src/Parser/Statement.hs
@@ -21,6 +21,7 @@ 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
@@ -69,6 +70,22 @@ forStatement = do
<$> (unpack <$> e)
<*> LambdaAbstraction tname 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)
+
exprStatement :: TestParser (Expr (TestBlock ()))
exprStatement = do
ref <- L.indentLevel
@@ -413,22 +430,11 @@ testPacketLoss = command "packet_loss" $ PacketLoss
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 = choice
[ letStatement
, forStatement
+ , shellStatement
, testLocal
, testWith
, testSubnet
generated by cgit v1.2.3 (git 2.25.1) at 2025-04-24 18:04:25 +0000