From bbf1fd0846fa51f74ef01399ab005d4d847becce Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Roman=20Smr=C5=BE?= Date: Sat, 23 May 2026 21:45:02 +0200 Subject: Refactor test filtering to its own function and type --- src/Main.hs | 42 ++++++--------- src/Parser/Core.hs | 22 +++++++- src/Run.hs | 72 +++++++++++++++++++------- src/Test.hs | 1 + src/TestMode.hs | 26 ++++++---- test/asset/run/tags.et | 38 ++++++++++++++ test/script/definition.et | 2 + test/script/list.et | 5 +- test/script/output.et | 10 ++-- test/script/run.et | 129 +++++++++++++++++++++++++++++++++++++++------- 10 files changed, 264 insertions(+), 83 deletions(-) create mode 100644 test/asset/run/tags.et diff --git a/src/Main.hs b/src/Main.hs index 9969109..b2e4171 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -2,7 +2,7 @@ module Main (main) where import Control.Monad -import Data.List +import Data.Char import Data.Maybe import Data.Text (Text) import Data.Text qualified as T @@ -20,11 +20,9 @@ import System.Posix.Types import Config import Output +import Parser.Core import Process import Run -import Script.Module -import Script.Var -import Test import TestMode import Util import Version @@ -194,27 +192,11 @@ main = do | otherwise = OutputStyleQuiet out <- startOutput outputStyle useColor - LoadedModules {..} <- loadModules (map fst files) - - let excludedTests = optExclude opts ++ map (snd . fst) (filter (\( ( _, _ ), ts ) -> any (\(Tag _ t) -> textVarName t `elem` optExclude opts) ts) lmTags) - tests <- filter ((`notElem` excludedTests) . testName) <$> if null otests - then fmap concat $ forM (zip lmModules files) $ \( Module {..}, ( filePath, mbTestName )) -> do - case mbTestName of - Nothing -> return moduleTests - Just name - | Just test <- find ((name ==) . testName) moduleTests - -> return [ test ] - | otherwise - -> do - hPutStrLn stderr $ "Test ‘" <> T.unpack name <> "’ not found in ‘" <> filePath <> "’" - exitFailure - else forM otests $ \name -> if - | Just test <- find ((name ==) . testName) $ concatMap moduleTests lmModules - -> return test - | otherwise - -> do - hPutStrLn stderr $ "Test ‘" <> T.unpack name <> "’ not found" - exitFailure + lm@LoadedModules {..} <- exitOnError =<< loadModules files + + let tfSelect = if null otests then Nothing else Just otests + tfExclude = optExclude opts + tests <- exitOnError $ filterTests TestFilter {..} lm tcpdump <- case optCmdlineTcpdump opts of TcpdumpAuto -> findExecutable "tcpdump" @@ -228,6 +210,16 @@ main = do concat $ replicate (optRepeat opts) tests when (not ok) exitFailure +exitOnError :: Either CustomTestError a -> IO a +exitOnError (Left err) = do + hPutStrLn stderr $ capitalize $ showCustomTestError err + exitFailure + where + capitalize (c : cs) = toUpper c : cs + capitalize [] = [] +exitOnError (Right x) = do + return x + foreign export ccall testerMain :: IO () testerMain :: IO () testerMain = main diff --git a/src/Parser/Core.hs b/src/Parser/Core.hs index 7831682..25c7346 100644 --- a/src/Parser/Core.hs +++ b/src/Parser/Core.hs @@ -9,6 +9,7 @@ import Data.Map (Map) import Data.Map qualified as M import Data.Maybe import Data.Set qualified as S +import Data.Text (Text) import Data.Text qualified as T import Data.Text.Lazy qualified as TL import Data.Typeable @@ -40,6 +41,8 @@ type TestParseError = ParseError TestStream CustomTestError data CustomTestError = ModuleNotFound ModuleName | FileNotFound FilePath + | TestNotFound Text (Maybe FilePath) + | TestOrTagNotFound Text (Maybe FilePath) | ImportModuleError (ParseErrorBundle TestStream CustomTestError) deriving (Eq) @@ -52,15 +55,30 @@ instance Ord CustomTestError where compare (FileNotFound _) _ = LT compare _ (FileNotFound _) = GT + compare (TestNotFound a a') (TestNotFound b b') = compare ( a, a' ) ( b, b' ) + compare (TestNotFound _ _ ) _ = LT + compare _ (TestNotFound _ _ ) = GT + + compare (TestOrTagNotFound a a') (TestOrTagNotFound b b') = compare ( a, a' ) ( b, b' ) + compare (TestOrTagNotFound _ _ ) _ = LT + compare _ (TestOrTagNotFound _ _ ) = GT + -- Ord instance is required to store errors in Set, but there shouldn't be -- two ImportModuleErrors at the same possition, so "dummy" comparison -- should be ok. compare (ImportModuleError _) (ImportModuleError _) = EQ instance ShowErrorComponent CustomTestError where - showErrorComponent (ModuleNotFound name) = "module ‘" <> T.unpack (textModuleName name) <> "’ not found" - showErrorComponent (FileNotFound path) = "file ‘" <> path <> "’ not found" showErrorComponent (ImportModuleError bundle) = "error parsing imported module:\n" <> errorBundlePretty bundle + showErrorComponent err = showCustomTestError err + +showCustomTestError :: CustomTestError -> String +showCustomTestError = \case + ModuleNotFound name -> "module ‘" <> T.unpack (textModuleName name) <> "’ not found" + FileNotFound path -> "file ‘" <> path <> "’ not found" + TestNotFound tname mbpath -> "test ‘" <> T.unpack tname <> "’ not found" <> maybe "" (\path -> " in ‘" <> path <> "’") mbpath + TestOrTagNotFound tname mbpath -> "test or tag ‘" <> T.unpack tname <> "’ not found" <> maybe "" (\path -> " in ‘" <> path <> "’") mbpath + ImportModuleError bundle -> errorBundlePretty bundle runTestParser :: TestStream -> TestParserState -> TestParser a -> IO (Either (ParseErrorBundle TestStream CustomTestError) a) runTestParser content initState (TestParser parser) = flip (flip runParserT (testSourcePath initState)) content . flip evalStateT initState $ parser diff --git a/src/Run.hs b/src/Run.hs index e43265a..e1bab46 100644 --- a/src/Run.hs +++ b/src/Run.hs @@ -1,9 +1,13 @@ module Run ( module Run.Monad, runTest, + LoadedModules(..), - loadModules, loadModulesErr, + loadModules, evalGlobalDefs, + + TestFilter(..), + filterTests, ) where import Control.Applicative @@ -15,6 +19,8 @@ import Control.Monad.Reader import Control.Monad.Writer import Data.Bifunctor +import Data.Either +import Data.List import Data.Map qualified as M import Data.Maybe import Data.Proxy @@ -22,6 +28,7 @@ import Data.Scientific import Data.Set qualified as S import Data.Text (Text) import Data.Text qualified as T +import Data.Typeable import System.Directory import System.Exit @@ -30,8 +37,6 @@ import System.Posix.Process import System.Posix.Signals import System.Process -import Text.Megaparsec (errorBundlePretty, showErrorComponent) - import GDB import Network import Network.Ip @@ -149,27 +154,24 @@ data LoadedModules = LoadedModules , lmGlobalDefs :: GlobalDefs } -loadModules :: [ FilePath ] -> IO LoadedModules +loadModules :: [ ( FilePath, Maybe Text ) ] -> IO (Either CustomTestError LoadedModules) loadModules files = do - loadModulesErr files >>= \case - Right res -> do - return res - Left err -> do - case err of - ImportModuleError bundle -> - putStr (errorBundlePretty bundle) - _ -> do - putStrLn (showErrorComponent err) - exitFailure - -loadModulesErr :: [ FilePath ] -> IO (Either CustomTestError LoadedModules) -loadModulesErr files = do - parseTestFiles files >>= \case - Right ( lmModules, allModules ) -> do + parseTestFiles (map fst files) >>= \case + Right ( modules, allModules ) -> return $ do + lmModules <- forM (zip files modules) $ \( ( path, tsel ), m ) -> do + tests <- case tsel of + Nothing -> return $ moduleTests m + Just tname + | Just test <- find ((tname ==) . testName) (moduleTests m) + -> return [ test ] + | otherwise + -> throwError $ TestNotFound tname (Just path) + return m { moduleTests = tests } + let lmGlobalDefs = evalGlobalDefs $ concatMap (\m -> map (first ( moduleName m, )) $ moduleDefinitions m) allModules evalTags test = map (\e -> runSimpleEval (eval e) lmGlobalDefs []) $ testTags test lmTags = concatMap (\Module {..} -> map (\test -> ( ( moduleName, testName test ), evalTags test )) moduleTests) lmModules - return $ Right $ LoadedModules {..} + Right $ LoadedModules {..} Left err -> do return $ Left err @@ -177,6 +179,36 @@ loadModulesErr files = do evalGlobalDefs :: [ (( ModuleName, VarName ), SomeExpr ) ] -> GlobalDefs evalGlobalDefs exprs = builtins `M.union` M.fromList exprs + +data TestFilter = TestFilter + { tfSelect :: Maybe [ Text ] + , tfExclude :: [ Text ] + } + +filterTests :: TestFilter -> LoadedModules -> Either CustomTestError [ Test ] +filterTests TestFilter {..} LoadedModules {..} = do + let allTests = concatMap (\m -> ( moduleName m, ) <$> moduleTests m) lmModules + let evalTerm :: Text -> Either CustomTestError (Either Text Tag) + evalTerm t = + case find ((VarName t ==) . snd . fst) $ M.toList lmGlobalDefs of + Just ( _, SomeExpr (expr :: Expr etype)) + | Just (Refl :: etype :~: Tag) <- eqT + -> return $ Right $ runSimpleEval (eval expr) lmGlobalDefs [] + Nothing + | Just _ <- find ((t ==) . testName . snd) allTests + -> return $ Left t + _ -> + throwError $ TestOrTagNotFound t Nothing + exclude <- partitionEithers <$> mapM evalTerm tfExclude + let matches ( tnames, tags ) ( mname, test ) = + testName test `elem` tnames || maybe False (any (`elem` tags)) (lookup ( mname, testName test ) lmTags) + map snd . filter (not . matches exclude) <$> case tfSelect of + Nothing -> return allTests + Just tnames -> do + selected <- partitionEithers <$> mapM evalTerm tnames + return $ filter (matches selected) allTests + + runBlock :: TestBlock () -> TestRun () runBlock EmptyTestBlock = return () runBlock (TestBlockStep prev step) = runBlock prev >> runStep step diff --git a/src/Test.hs b/src/Test.hs index d16b997..61f2e3d 100644 --- a/src/Test.hs +++ b/src/Test.hs @@ -31,6 +31,7 @@ data Test = Test } data Tag = Tag ModuleName VarName + deriving (Eq) instance ExprType Tag where textExprType _ = "Tag" diff --git a/src/TestMode.hs b/src/TestMode.hs index d4c7790..6a74b10 100644 --- a/src/TestMode.hs +++ b/src/TestMode.hs @@ -118,6 +118,10 @@ showError prefix = \case cmdOut $ prefix <> " module-not-found" <> textModuleName moduleName FileNotFound notFoundPath -> do cmdOut $ prefix <> " file-not-found " <> T.pack notFoundPath + TestNotFound tname mbfile -> do + cmdOut $ prefix <> " test-not-found " <> tname <> maybe "" ((" " <>) . T.pack) mbfile + TestOrTagNotFound tname mbfile -> do + cmdOut $ prefix <> " test-or-tag-not-found " <> tname <> maybe "" ((" " <>) . T.pack) mbfile ImportModuleError bundle -> do #if MIN_VERSION_megaparsec(9,7,0) mapM_ (cmdOut . T.pack) $ lines $ errorBundlePrettyWith showParseError bundle @@ -134,7 +138,7 @@ showError prefix = \case cmdLoad :: Command cmdLoad = do [ path ] <- asks tmiParams - liftIO (loadModulesErr [ T.unpack path ]) >>= \case + liftIO (loadModules [ ( T.unpack path, Nothing ) ]) >>= \case Right modules -> do modify $ \s -> s { tmsModules = Just modules } cmdOut "load-done" @@ -143,7 +147,7 @@ cmdLoad = do cmdLoadConfig :: Command cmdLoadConfig = do Just config <- asks tmiConfig - liftIO (getConfigTestFiles config >>= loadModulesErr) >>= \case + liftIO (getConfigTestFiles config >>= loadModules . (map (, Nothing ))) >>= \case Right modules -> do modify $ \s -> s { tmsModules = Just modules } cmdOut "load-config-done" @@ -151,14 +155,16 @@ cmdLoadConfig = do cmdRun :: Command cmdRun = do - [ name ] <- asks tmiParams - Just LoadedModules {..} <- gets tmsModules - case find ((name ==) . testName) $ concatMap moduleTests lmModules of - Nothing -> cmdOut "run-not-found" - Just test -> do - runSingleTest test >>= \case - True -> cmdOut "run-done" - False -> cmdOut "run-failed" + params <- asks tmiParams + let ( select, exclude ) = fmap (map (T.drop 1)) $ partition (("^" /=) . T.take 1) params + Just lm <- gets tmsModules + case filterTests (TestFilter (if select == [ "*" ] then Nothing else Just select) exclude) lm of + Left err -> showError "run-failed" err + Right tests -> do + forM_ tests $ \test -> do + res <- runSingleTest test + cmdOut $ "run-test-result " <> testName test <> " " <> (if res then "done" else "failed") + cmdOut "run-done" cmdRunAll :: Command cmdRunAll = do diff --git a/test/asset/run/tags.et b/test/asset/run/tags.et new file mode 100644 index 0000000..b1433fa --- /dev/null +++ b/test/asset/run/tags.et @@ -0,0 +1,38 @@ +export tag A +export tag B +export tag C + +test T1: + guard True + +test T2: + guard True + +test A1: + tag: A + guard True + +test A2: + tag: A + guard True + +test B1: + tag: B + guard True + +test B2: + tag: B + guard True + +test C1: + tag: C + guard True + +test C2: + tag: C + guard True + +test BC: + tag: B + tag: C + guard True diff --git a/test/script/definition.et b/test/script/definition.et index 3d84040..45951cd 100644 --- a/test/script/definition.et +++ b/test/script/definition.et @@ -15,5 +15,7 @@ test Definition: expect /match p 4/ expect /child-stdout p 11/ expect /match p 11/ + expect /run-test-result Test (.*)/ capture result + guard (result == "done") expect /(.*)/ capture done guard (done == "run-done") diff --git a/test/script/list.et b/test/script/list.et index cfd4803..4b493a5 100644 --- a/test/script/list.et +++ b/test/script/list.et @@ -37,5 +37,6 @@ test ListConcat: "c4 3" "c4-end" local: - expect /(run-.*)/ capture done - guard (done == "run-done") + expect /run-test-result Test (.*)/ capture result + guard (result == "done") + expect /run-done/ diff --git a/test/script/output.et b/test/script/output.et index d3f0eea..f210490 100644 --- a/test/script/output.et +++ b/test/script/output.et @@ -22,8 +22,9 @@ test FlushOutput: expect /match p a/ expect /match-fail expect.*/ - expect /(run-.*)/ capture done - guard (done == "run-failed") + expect /run-test-result Test (.*)/ capture result + guard (result == "failed") + expect /run-done/ test IgnoreOutput: spawn as p @@ -51,5 +52,6 @@ test IgnoreOutput: expect /match p F/ expect /match-fail expect.*/ - expect /(run-.*)/ capture done - guard (done == "run-failed") + expect /run-test-result Test (.*)/ capture result + guard (result == "failed") + expect /run-done/ diff --git a/test/script/run.et b/test/script/run.et index 2572f87..97f4dd8 100644 --- a/test/script/run.et +++ b/test/script/run.et @@ -18,14 +18,16 @@ test TrivialRun: send "run AlwaysSucceeds" local: - expect /(run-.*)/ capture done - guard (done == "run-done") + expect /run-test-result AlwaysSucceeds (.*)/ capture result + guard (result == "done") + expect /run-done/ send "run AlwaysFails" local: expect /match-fail .*/ - expect /(run-.*)/ capture done - guard (done == "run-failed") + expect /run-test-result AlwaysFails (.*)/ capture result + guard (result == "failed") + expect /run-done/ test SimpleRun: @@ -43,8 +45,9 @@ test SimpleRun: send "run Test" local: - expect /(run-.*)/ capture done - guard (done == "run-done") + expect /run-test-result Test (.*)/ capture result + guard (result == "done") + expect /run-done/ flush for file in should_fail: @@ -56,8 +59,9 @@ test SimpleRun: send "run Test" local: - expect /(run-.*)/ capture done - guard (done == "run-failed") + expect /run-test-result Test (.*)/ capture result + guard (result == "failed") + expect /run-done/ flush @@ -120,8 +124,9 @@ test CallStack: expect /(match-fail-.*)/ capture done guard (done == "match-fail-done") local: - expect /(run-.*)/ capture done - guard (done == "run-failed") + expect /run-test-result AG (.*)/ capture result + guard (result == "failed") + expect /run-done/ flush send "run AE" @@ -132,8 +137,9 @@ test CallStack: expect /(match-fail-.*)/ capture done guard (done == "match-fail-done") local: - expect /(run-.*)/ capture done - guard (done == "run-failed") + expect /run-test-result AE (.*)/ capture result + guard (result == "failed") + expect /run-done/ flush send "run BG" @@ -145,8 +151,9 @@ test CallStack: expect /(match-fail-.*)/ capture done guard (done == "match-fail-done") local: - expect /(run-.*)/ capture done - guard (done == "run-failed") + expect /run-test-result BG (.*)/ capture result + guard (result == "failed") + expect /run-done/ flush send "run CG" @@ -160,8 +167,9 @@ test CallStack: expect /(match-fail-.*)/ capture done guard (done == "match-fail-done") local: - expect /(run-.*)/ capture done - guard (done == "run-failed") + expect /run-test-result CG (.*)/ capture result + guard (result == "failed") + expect /run-done/ flush send "run BE" @@ -174,8 +182,9 @@ test CallStack: expect /(match-fail-.*)/ capture done guard (done == "match-fail-done") local: - expect /(run-.*)/ capture done - guard (done == "run-failed") + expect /run-test-result BE (.*)/ capture result + guard (result == "failed") + expect /run-done/ flush send "run CE" @@ -190,6 +199,86 @@ test CallStack: expect /(match-fail-.*)/ capture done guard (done == "match-fail-done") local: - expect /(run-.*)/ capture done - guard (done == "run-failed") + expect /run-test-result CE (.*)/ capture result + guard (result == "failed") + expect /run-done/ flush + + +test RunTag: + spawn as p + with p: + send "load ${scripts.path}/tags.et" + local: + expect /(load-.*)/ capture done + guard (done == "load-done") + flush + + send "run A" + local: + expect /run-test-result A1 (.*)/ capture result + guard (result == "done") + local: + expect /run-test-result A2 (.*)/ capture result + guard (result == "done") + local: + expect /run-(.*)/ capture done + guard (done == "done") + + send "run B C" + local: + expect /run-test-result B1 (.*)/ capture result + guard (result == "done") + local: + expect /run-test-result B2 (.*)/ capture result + guard (result == "done") + local: + expect /run-test-result C1 (.*)/ capture result + guard (result == "done") + local: + expect /run-test-result C2 (.*)/ capture result + guard (result == "done") + local: + expect /run-test-result BC (.*)/ capture result + guard (result == "done") + local: + expect /run-(.*)/ capture done + guard (done == "done") + + +test RunTagExclude: + spawn as p + with p: + send "load ${scripts.path}/tags.et" + local: + expect /(load-.*)/ capture done + guard (done == "load-done") + flush + + send "run * ^A ^C ^T2 ^B1" + local: + expect /run-test-result T1 (.*)/ capture result + guard (result == "done") + local: + expect /run-test-result B2 (.*)/ capture result + guard (result == "done") + local: + expect /run-(.*)/ capture done + guard (done == "done") + + send "run T1 B1 A C ^B ^A1" + local: + expect /run-test-result T1 (.*)/ capture result + guard (result == "done") + local: + expect /run-test-result A2 (.*)/ capture result + guard (result == "done") + local: + expect /run-test-result C1 (.*)/ capture result + guard (result == "done") + local: + expect /run-test-result C2 (.*)/ capture result + guard (result == "done") + local: + expect /run-(.*)/ capture done + guard (done == "done") -- cgit v1.2.3