diff options
Diffstat (limited to 'src')
| -rw-r--r-- | src/Main.hs | 42 | ||||
| -rw-r--r-- | src/Parser/Core.hs | 22 | ||||
| -rw-r--r-- | src/Run.hs | 72 | ||||
| -rw-r--r-- | src/Test.hs | 1 | ||||
| -rw-r--r-- | src/TestMode.hs | 26 |
5 files changed, 106 insertions, 57 deletions
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 @@ -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 |