From 1c5cc6281d1320b3ad3ee586368c0c1dacce0cbe Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Roman=20Smr=C5=BE?= <roman.smrz@seznam.cz>
Date: Wed, 18 Aug 2021 22:00:27 +0200
Subject: Parser of test scripts

---
 src/Parser.hs | 131 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 131 insertions(+)
 create mode 100644 src/Parser.hs

(limited to 'src/Parser.hs')

diff --git a/src/Parser.hs b/src/Parser.hs
new file mode 100644
index 0000000..97a64fc
--- /dev/null
+++ b/src/Parser.hs
@@ -0,0 +1,131 @@
+module Parser (
+    parseTestFile,
+) where
+
+import Control.Monad.State
+
+import Data.Char
+import Data.Set (Set)
+import qualified Data.Set as S
+import Data.Text (Text)
+import qualified Data.Text.Lazy as TL
+import qualified Data.Text.Lazy.IO as TL
+import Data.Void
+
+import Text.Megaparsec hiding (State)
+import Text.Megaparsec.Char
+import qualified Text.Megaparsec.Char.Lexer as L
+import Text.Regex.TDFA (defaultCompOpt, defaultExecOpt)
+import Text.Regex.TDFA.String
+
+import System.Exit
+
+import Test
+
+type TestParser = ParsecT Void TestStream (State (Set ProcName))
+
+type TestStream = TL.Text
+
+scn :: TestParser ()
+scn = L.space space1 empty empty
+
+sc :: TestParser ()
+sc = L.space (void $ takeWhile1P Nothing f) empty empty
+    where f x = x == ' ' || x == '\t'
+
+wordChar :: TestParser (Token TestStream)
+wordChar = alphaNumChar <|> char '_'
+
+lexeme :: TestParser a -> TestParser a
+lexeme = L.lexeme sc
+
+symbol :: String -> TestParser ()
+symbol = void . L.symbol sc . TL.pack
+
+wsymbol :: String -> TestParser ()
+wsymbol str = void $ lexeme $ string (TL.pack str) <* notFollowedBy wordChar
+
+toplevel :: TestParser a -> TestParser a
+toplevel = L.nonIndented scn
+
+block :: (a -> [b] -> TestParser c) -> TestParser a -> TestParser b -> TestParser c
+block merge header item = L.indentBlock scn $ do
+    h <- header
+    choice
+        [ do try $ void $ lexeme $ char ':'
+             return $ L.IndentSome Nothing (merge h) item
+        , L.IndentNone <$> merge h []
+        ]
+
+nodeName :: TestParser NodeName
+nodeName = label "network node name" $ lexeme $ do
+    c <- lowerChar
+    cs <- takeWhileP Nothing (\x -> isAlphaNum x || x == '_' || x == '-')
+    return $ NodeName $ TL.toStrict (c `TL.cons` cs)
+
+procName :: TestParser ProcName
+procName = label "process name" $ lexeme $ do
+    c <- lowerChar
+    cs <- takeWhileP Nothing (\x -> isAlphaNum x || x == '_' || x == '-')
+    return $ ProcName $ TL.toStrict (c `TL.cons` cs)
+
+quotedString :: TestParser Text
+quotedString = label "string" $ lexeme $ do
+    symbol "\""
+    str <- takeWhileP Nothing (/='"')
+    symbol "\""
+    return $ TL.toStrict str
+
+regex :: TestParser Regex
+regex = label "regular expression" $ lexeme $ do
+    symbol "/"
+    pat <- takeWhileP Nothing (/='/')
+    symbol "/"
+    case compile defaultCompOpt defaultExecOpt ("^" ++ TL.unpack pat ++ "$") of
+         Left err -> fail err
+         Right re -> return re
+
+testSpawn :: TestParser TestStep
+testSpawn = do
+    wsymbol "spawn"
+    wsymbol "on"
+    nname <- nodeName
+    wsymbol "as"
+    pname <- procName
+    return $ Spawn pname nname
+
+testSend :: TestParser TestStep
+testSend = do
+    wsymbol "send"
+    line <- quotedString
+    wsymbol "to"
+    pname <- procName
+    return $ Send pname line
+
+testExpect :: TestParser TestStep
+testExpect = do
+    wsymbol "expect"
+    re <- regex
+    wsymbol "from"
+    pname <- procName
+    return $ Expect pname re
+
+parseTestDefinition :: TestParser Test
+parseTestDefinition = label "test definition" $ toplevel $ do
+    block (\name steps -> return $ Test name steps) header (testSpawn <|> testSend <|> testExpect)
+    where header = do
+              wsymbol "test"
+              lexeme $ TL.toStrict <$> takeWhileP (Just "test name") (/=':')
+
+parseTestDefinitions :: TestParser [Test]
+parseTestDefinitions = do
+    tests <- many parseTestDefinition
+    eof
+    return tests
+
+parseTestFile :: FilePath -> IO [Test]
+parseTestFile path = do
+    content <- TL.readFile path
+    case evalState (runParserT parseTestDefinitions path content) S.empty of
+         Left err -> putStr (errorBundlePretty err) >> exitFailure
+         Right tests -> return tests
-- 
cgit v1.2.3