From 321859ab1fe4a6b1f3cc7084b8836474ff872e2b Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Roman=20Smr=C5=BE?= Date: Sun, 29 Sep 2024 14:26:21 +0200 Subject: User-defined test functions without parameters --- erebos-tester.cabal | 40 ++++++++++++++++++++++------------------ src/Main.hs | 6 +++--- src/Parser.hs | 30 ++++++++++++++++++++++++------ src/Parser/Core.hs | 20 ++++++++++++++++---- src/Run.hs | 6 +++--- src/Test.hs | 1 + 6 files changed, 69 insertions(+), 34 deletions(-) diff --git a/erebos-tester.cabal b/erebos-tester.cabal index c3a49e6..a6b3b70 100644 --- a/erebos-tester.cabal +++ b/erebos-tester.cabal @@ -94,24 +94,28 @@ executable erebos-tester-core autogen-modules: Paths_erebos_tester - other-extensions: TemplateHaskell - default-extensions: ExistentialQuantification - FlexibleContexts - FlexibleInstances - GADTs - GeneralizedNewtypeDeriving - ImportQualifiedPost - LambdaCase - MultiParamTypeClasses - MultiWayIf - OverloadedStrings - RankNTypes - RecordWildCards - ScopedTypeVariables - TupleSections - TypeApplications - TypeFamilies - TypeOperators + other-extensions: + TemplateHaskell + default-extensions: + DeriveTraversable + ExistentialQuantification + FlexibleContexts + FlexibleInstances + GADTs + GeneralizedNewtypeDeriving + ImportQualifiedPost + LambdaCase + MultiParamTypeClasses + MultiWayIf + OverloadedStrings + RankNTypes + RecordWildCards + ScopedTypeVariables + TupleSections + TypeApplications + TypeFamilies + TypeOperators + build-depends: bytestring ^>= { 0.10, 0.11, 0.12 }, containers ^>= { 0.6.2.1, 0.7 }, 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