summaryrefslogtreecommitdiff
path: root/src/TestMode.hs
diff options
context:
space:
mode:
Diffstat (limited to 'src/TestMode.hs')
-rw-r--r--src/TestMode.hs70
1 files changed, 31 insertions, 39 deletions
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"