diff options
| -rw-r--r-- | src/Main.hs | 10 | ||||
| -rw-r--r-- | src/Run.hs | 28 | ||||
| -rw-r--r-- | src/TestMode.hs | 70 |
3 files changed, 57 insertions, 51 deletions
diff --git a/src/Main.hs b/src/Main.hs index a77e8cc..9969109 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -194,11 +194,11 @@ main = do | otherwise = OutputStyleQuiet out <- startOutput outputStyle useColor - ( modules, tags, globalDefs ) <- loadModules (map fst files) + LoadedModules {..} <- loadModules (map fst files) - let excludedTests = optExclude opts ++ map (snd . fst) (filter (\( ( _, _ ), ts ) -> any (\(Tag _ t) -> textVarName t `elem` optExclude opts) ts) tags) + 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 modules files) $ \( Module {..}, ( filePath, mbTestName )) -> do + then fmap concat $ forM (zip lmModules files) $ \( Module {..}, ( filePath, mbTestName )) -> do case mbTestName of Nothing -> return moduleTests Just name @@ -209,7 +209,7 @@ main = do hPutStrLn stderr $ "Test ‘" <> T.unpack name <> "’ not found in ‘" <> filePath <> "’" exitFailure else forM otests $ \name -> if - | Just test <- find ((name ==) . testName) $ concatMap moduleTests modules + | Just test <- find ((name ==) . testName) $ concatMap moduleTests lmModules -> return test | otherwise -> do @@ -224,7 +224,7 @@ main = do let topts = (optTest opts) { optTcpdump = tcpdump } - ok <- allM (runTest out topts globalDefs) $ + ok <- allM (runTest out topts lmGlobalDefs) $ concat $ replicate (optRepeat opts) tests when (not ok) exitFailure @@ -1,7 +1,8 @@ module Run ( module Run.Monad, runTest, - loadModules, + LoadedModules(..), + loadModules, loadModulesErr, evalGlobalDefs, ) where @@ -142,9 +143,15 @@ runTest out opts gdefs test = do return False -loadModules :: [ FilePath ] -> IO ( [ Module ], [ ( ( ModuleName, Text ), [ Tag ] ) ], GlobalDefs ) +data LoadedModules = LoadedModules + { lmModules :: [ Module ] + , lmTags :: [ ( ( ModuleName, Text ), [ Tag ] ) ] + , lmGlobalDefs :: GlobalDefs + } + +loadModules :: [ FilePath ] -> IO LoadedModules loadModules files = do - ( modules, allModules ) <- parseTestFiles files >>= \case + loadModulesErr files >>= \case Right res -> do return res Left err -> do @@ -154,10 +161,17 @@ loadModules files = do _ -> do putStrLn (showErrorComponent err) exitFailure - let globalDefs = evalGlobalDefs $ concatMap (\m -> map (first ( moduleName m, )) $ moduleDefinitions m) allModules - evalTags test = map (\e -> runSimpleEval (eval e) globalDefs []) $ testTags test - tags = concatMap (\Module {..} -> map (\test -> ( ( moduleName, testName test ), evalTags test )) moduleTests) modules - return ( modules, tags, globalDefs ) + +loadModulesErr :: [ FilePath ] -> IO (Either CustomTestError LoadedModules) +loadModulesErr files = do + parseTestFiles files >>= \case + Right ( lmModules, allModules ) -> do + 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 {..} + Left err -> do + return $ Left err evalGlobalDefs :: [ (( ModuleName, VarName ), SomeExpr ) ] -> GlobalDefs diff --git a/src/TestMode.hs b/src/TestMode.hs index d2cf00d..d4c7790 100644 --- a/src/TestMode.hs +++ b/src/TestMode.hs @@ -9,7 +9,6 @@ import Control.Monad.Except import Control.Monad.Reader import Control.Monad.State -import Data.Bifunctor import Data.List import Data.Maybe import Data.Text (Text) @@ -37,17 +36,13 @@ data TestModeInput = TestModeInput } data TestModeState = TestModeState - { tmsModules :: [ Module ] - , tmsTags :: [ ( ( ModuleName, Text ), [ Tag ] ) ] - , tmsGlobals :: GlobalDefs + { tmsModules :: Maybe LoadedModules , tmsNextTestNumber :: Int } initTestModeState :: TestModeState initTestModeState = TestModeState - { tmsModules = mempty - , tmsTags = mempty - , tmsGlobals = mempty + { tmsModules = Nothing , tmsNextTestNumber = 1 } @@ -88,14 +83,14 @@ runSingleTest :: Test -> CommandM Bool runSingleTest test = do out <- asks tmiOutput num <- getNextTestNumber - globals <- gets tmsGlobals + Just LoadedModules {..} <- gets tmsModules mbconfig <- asks tmiConfig let opts = defaultTestOptions { optDefaultTool = fromMaybe "/bin/true" $ configTool =<< mbconfig , optTestDir = ".test" <> show num , optKeep = True } - liftIO (runTest out opts globals test) + liftIO (runTest out opts lmGlobalDefs test) newtype CommandM a = CommandM (ReaderT TestModeInput (StateT TestModeState (ExceptT String IO)) a) @@ -117,27 +112,17 @@ commands = , ( "run-all", cmdRunAll ) ] -cmdLoad :: Command -cmdLoad = do - [ path ] <- asks tmiParams - liftIO (parseTestFiles [ T.unpack path ]) >>= \case - Right ( modules, allModules ) -> do - let globalDefs = evalGlobalDefs $ concatMap (\m -> map (first ( moduleName m, )) $ moduleDefinitions m) allModules - modify $ \s -> s - { tmsModules = modules - , tmsGlobals = globalDefs - } - cmdOut "load-done" - - Left (ModuleNotFound moduleName) -> do - cmdOut $ "load-failed module-not-found" <> textModuleName moduleName - Left (FileNotFound notFoundPath) -> do - cmdOut $ "load-failed file-not-found " <> T.pack notFoundPath - Left (ImportModuleError bundle) -> do +showError :: Text -> CustomTestError -> Command +showError prefix = \case + ModuleNotFound moduleName -> do + cmdOut $ prefix <> " module-not-found" <> textModuleName moduleName + FileNotFound notFoundPath -> do + cmdOut $ prefix <> " file-not-found " <> T.pack notFoundPath + ImportModuleError bundle -> do #if MIN_VERSION_megaparsec(9,7,0) - mapM_ (cmdOut . T.pack) $ lines $ errorBundlePrettyWith showParseError bundle + mapM_ (cmdOut . T.pack) $ lines $ errorBundlePrettyWith showParseError bundle #endif - cmdOut $ "load-failed parse-error" + cmdOut $ prefix <> " parse-error" where showParseError _ SourcePos {..} _ = concat [ "parse-error" @@ -146,22 +131,29 @@ cmdLoad = do , ":", show $ unPos sourceColumn ] +cmdLoad :: Command +cmdLoad = do + [ path ] <- asks tmiParams + liftIO (loadModulesErr [ T.unpack path ]) >>= \case + Right modules -> do + modify $ \s -> s { tmsModules = Just modules } + cmdOut "load-done" + Left err -> showError "load-failed" err + cmdLoadConfig :: Command cmdLoadConfig = do Just config <- asks tmiConfig - ( modules, tags, globalDefs ) <- liftIO $ loadModules =<< getConfigTestFiles config - modify $ \s -> s - { tmsModules = modules - , tmsTags = tags - , tmsGlobals = globalDefs - } - cmdOut "load-config-done" + liftIO (getConfigTestFiles config >>= loadModulesErr) >>= \case + Right modules -> do + modify $ \s -> s { tmsModules = Just modules } + cmdOut "load-config-done" + Left err -> showError "load-config-failed" err cmdRun :: Command cmdRun = do [ name ] <- asks tmiParams - TestModeState {..} <- get - case find ((name ==) . testName) $ concatMap moduleTests tmsModules of + Just LoadedModules {..} <- gets tmsModules + case find ((name ==) . testName) $ concatMap moduleTests lmModules of Nothing -> cmdOut "run-not-found" Just test -> do runSingleTest test >>= \case @@ -170,8 +162,8 @@ cmdRun = do cmdRunAll :: Command cmdRunAll = do - TestModeState {..} <- get - forM_ (concatMap moduleTests tmsModules) $ \test -> do + Just LoadedModules {..} <- gets tmsModules + forM_ (concatMap moduleTests lmModules) $ \test -> do res <- runSingleTest test cmdOut $ "run-test-result " <> testName test <> " " <> (if res then "done" else "failed") cmdOut "run-all-done" |