From 321859ab1fe4a6b1f3cc7084b8836474ff872e2b Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Roman=20Smr=C5=BE?= <roman.smrz@seznam.cz>
Date: Sun, 29 Sep 2024 14:26:21 +0200
Subject: User-defined test functions without parameters
---
src/Main.hs | 6 +++---
src/Parser.hs | 30 ++++++++++++++++++++++++------
src/Parser/Core.hs | 20 ++++++++++++++++----
src/Run.hs | 6 +++---
src/Test.hs | 1 +
5 files changed, 47 insertions(+), 16 deletions(-)
(limited to 'src')
diff --git a/src/Main.hs b/src/Main.hs
index 61afbd8..42b2e5b 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -149,11 +149,11 @@ main = do
out <- startOutput (optVerbose opts) useColor
tests <- forM files $ \(path, mbTestName) -> do
- Module { .. } <- parseTestFile path
- return $ case mbTestName of
+ Module {..} <- parseTestFile path
+ return $ map ( , moduleDefinitions ) $ case mbTestName of
Nothing -> moduleTests
Just name -> filter ((==name) . testName) moduleTests
- ok <- allM (runTest out $ optTest opts) $
+ ok <- allM (uncurry $ runTest out $ optTest opts) $
concat $ replicate (optRepeat opts) $ concat tests
when (not ok) exitFailure
diff --git a/src/Parser.hs b/src/Parser.hs
index 6d6809b..e63f854 100644
--- a/src/Parser.hs
+++ b/src/Parser.hs
@@ -6,7 +6,6 @@ module Parser (
import Control.Monad
import Control.Monad.State
-import Control.Monad.Writer
import Data.Map qualified as M
import Data.Maybe
@@ -17,6 +16,7 @@ import Data.Text.Lazy.IO qualified as TL
import Text.Megaparsec hiding (State)
import Text.Megaparsec.Char
+import Text.Megaparsec.Char.Lexer qualified as L
import System.Directory
import System.Exit
@@ -28,13 +28,29 @@ import Parser.Statement
import Test
import Test.Builtins
-parseTestDefinition :: TestParser ()
+parseTestDefinition :: TestParser Toplevel
parseTestDefinition = label "test definition" $ toplevel ToplevelTest $ do
block (\name steps -> return $ Test name $ concat steps) header testStep
where header = do
wsymbol "test"
lexeme $ TL.toStrict <$> takeWhileP (Just "test name") (/=':')
+parseDefinition :: TestParser Toplevel
+parseDefinition = label "symbol definition" $ toplevel ToplevelDefinition $ do
+ def <- localState $ L.indentBlock scn $ do
+ wsymbol "def"
+ name <- varName
+ choice
+ [ do
+ symbol ":"
+ let finish steps = do
+ return $ ( name, ) $ SomeVarValue mempty $ \_ _ -> TestBlock $
+ concat steps
+ return $ L.IndentSome Nothing finish testStep
+ ]
+ modify $ \s -> s { testVars = fmap someVarValueType def : testVars s }
+ return def
+
parseTestModule :: FilePath -> TestParser Module
parseTestModule absPath = do
moduleName <- choice
@@ -51,12 +67,14 @@ parseTestModule absPath = do
, do
return $ [ T.pack $ takeBaseName absPath ]
]
- (_, toplevels) <- listen $ many $ choice
+ toplevels <- many $ choice
[ parseTestDefinition
+ , parseDefinition
]
- let moduleTests = catMaybes $ map (\case ToplevelTest x -> Just x; {- _ -> Nothing -}) toplevels
+ let moduleTests = catMaybes $ map (\case ToplevelTest x -> Just x; _ -> Nothing) toplevels
+ moduleDefinitions = catMaybes $ map (\case ToplevelDefinition x -> Just x; _ -> Nothing) toplevels
eof
- return Module { .. }
+ return Module {..}
parseTestFile :: FilePath -> IO Module
parseTestFile path = do
@@ -70,7 +88,7 @@ parseTestFile path = do
, testNextTypeVar = 0
, testTypeUnif = M.empty
}
- (res, _) = runWriter $ flip (flip runParserT path) content $ flip evalStateT initState $ parseTestModule absPath
+ res = runTestParser path content initState $ parseTestModule absPath
case res of
Left err -> putStr (errorBundlePretty err) >> exitFailure
diff --git a/src/Parser/Core.hs b/src/Parser/Core.hs
index cb66529..10a572b 100644
--- a/src/Parser/Core.hs
+++ b/src/Parser/Core.hs
@@ -1,8 +1,9 @@
module Parser.Core where
+import Control.Applicative
import Control.Monad
+import Control.Monad.Identity
import Control.Monad.State
-import Control.Monad.Writer
import Data.Map (Map)
import Data.Map qualified as M
@@ -20,14 +21,25 @@ import qualified Text.Megaparsec.Char.Lexer as L
import Network ()
import Test
-type TestParser = StateT TestParserState (ParsecT Void TestStream (Writer [ Toplevel ]))
+newtype TestParser a = TestParser (StateT TestParserState (ParsecT Void TestStream Identity) a)
+ deriving
+ ( Functor, Applicative, Alternative, Monad
+ , MonadState TestParserState
+ , MonadPlus
+ , MonadFail
+ , MonadParsec Void TestStream
+ )
type TestStream = TL.Text
type TestParseError = ParseError TestStream Void
+runTestParser :: String -> TestStream -> TestParserState -> TestParser a -> Either (ParseErrorBundle TestStream Void) a
+runTestParser path content initState (TestParser parser) = runIdentity . flip (flip runParserT path) content . flip evalStateT initState $ parser
+
data Toplevel
= ToplevelTest Test
+ | ToplevelDefinition ( VarName, SomeVarValue )
data TestParserState = TestParserState
{ testVars :: [ ( VarName, SomeExprType ) ]
@@ -191,8 +203,8 @@ localState inner = do
put s
return x
-toplevel :: (a -> Toplevel) -> TestParser a -> TestParser ()
-toplevel f = tell . (: []) . f <=< L.nonIndented scn
+toplevel :: (a -> Toplevel) -> TestParser a -> TestParser Toplevel
+toplevel f = return . f <=< L.nonIndented scn
block :: (a -> [b] -> TestParser c) -> TestParser a -> TestParser b -> TestParser c
block merge header item = L.indentBlock scn $ do
diff --git a/src/Run.hs b/src/Run.hs
index b67c287..1cb04bb 100644
--- a/src/Run.hs
+++ b/src/Run.hs
@@ -33,8 +33,8 @@ import Run.Monad
import Test
import Test.Builtins
-runTest :: Output -> TestOptions -> Test -> IO Bool
-runTest out opts test = do
+runTest :: Output -> TestOptions -> Test -> [ ( VarName, SomeVarValue ) ] -> IO Bool
+runTest out opts test variables = do
let testDir = optTestDir opts
when (optForce opts) $ removeDirectoryRecursive testDir `catchIOError` \e ->
if isDoesNotExistError e then return () else ioError e
@@ -60,7 +60,7 @@ runTest out opts test = do
}
tstate = TestState
{ tsNetwork = error "network not initialized"
- , tsVars = builtins
+ , tsVars = builtins ++ variables
, tsNodePacketLoss = M.empty
, tsDisconnectedUp = S.empty
, tsDisconnectedBridge = S.empty
diff --git a/src/Test.hs b/src/Test.hs
index 719e3e2..24a4c72 100644
--- a/src/Test.hs
+++ b/src/Test.hs
@@ -46,6 +46,7 @@ import Util
data Module = Module
{ moduleName :: [ Text ]
, moduleTests :: [ Test ]
+ , moduleDefinitions :: [ ( VarName, SomeVarValue ) ]
}
data Test = Test
--
cgit v1.2.3