Loaded modules data type to store related infoHEADmaster

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
 
diff --git a/src/Run.hs b/src/Run.hs
index d8251a2..e43265a 100644
--- a/src/Run.hs
+++ b/src/Run.hs
@@ -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"