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 testWait :: TestParser TestStep testWait = do wsymbol "wait" return $ Wait parseTestDefinition :: TestParser Test parseTestDefinition = label "test definition" $ toplevel $ do block (\name steps -> return $ Test name steps) header (testSpawn <|> testSend <|> testExpect <|> testWait) 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