Test script execution based on config file

4 files changed, 93 insertions, 51 deletions

diff --git a/src/Config.hs b/src/Config.hs
index 7f5895c..e1dcebf 100644
--- a/src/Config.hs
+++ b/src/Config.hs
@@ -2,6 +2,7 @@ module Config (
     Config(..),
     findConfig,
     parseConfig,
+    getConfigTestFiles,
 ) where
 
 import Control.Monad.Combinators
@@ -16,31 +17,21 @@ import System.FilePath
 import System.FilePath.Glob
 
 data Config = Config
-    { configTool :: Maybe FilePath
+    { configDir :: FilePath
+    , configTool :: Maybe FilePath
     , configTests :: [Pattern]
     }
     deriving (Show)
 
-instance Semigroup Config where
-    a <> b = Config
-        { configTool = maybe (configTool b) Just (configTool a)
-        , configTests = configTests a ++ configTests b
-        }
-
-instance Monoid Config where
-    mempty = Config
-        { configTool = Nothing
-        , configTests = []
-        }
-
-instance FromYAML Config where
-    parseYAML = withMap "Config" $ \m -> Config
-        <$> (fmap T.unpack <$> m .:? "tool")
-        <*> (map (compile . T.unpack) <$> foldr1 (<|>)
+instance FromYAML (FilePath -> Config) where
+    parseYAML = withMap "Config" $ \m -> do
+        configTool <- (fmap T.unpack <$> m .:? "tool")
+        configTests <- (map (compile . T.unpack) <$> foldr1 (<|>)
                 [ fmap (:[]) (m .: "tests") -- single pattern
                 , m .:? "tests" .!= []      -- list of patterns
                 ]
             )
+        return $ \configDir -> Config {..}
 
 findConfig :: IO (Maybe FilePath)
 findConfig = go "."
@@ -63,4 +54,7 @@ parseConfig path = do
         Left (pos, err) -> do
             putStr $ prettyPosWithSource pos contents err
             exitFailure
-        Right conf -> return conf
+        Right conf -> return $ conf $ takeDirectory path
+
+getConfigTestFiles :: Config -> IO [ FilePath ]
+getConfigTestFiles config = concat <$> mapM (flip globDir1 $ configDir config) (configTests config)
diff --git a/src/Main.hs b/src/Main.hs
index 48f95df..36f88bd 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -2,27 +2,23 @@ module Main (main) where
 
 import Control.Monad
 
-import Data.Bifunctor
 import Data.List
 import Data.Maybe
 import Data.Text qualified as T
 
 import Text.Read (readMaybe)
-import Text.Megaparsec (errorBundlePretty, showErrorComponent)
 
 import System.Console.GetOpt
 import System.Directory
 import System.Environment
 import System.Exit
 import System.FilePath
-import System.FilePath.Glob
 import System.IO
 import System.Posix.Terminal
 import System.Posix.Types
 
 import Config
 import Output
-import Parser
 import Process
 import Run
 import Script.Module
@@ -108,9 +104,8 @@ hiddenOptions =
 
 main :: IO ()
 main = do
-    configPath <- findConfig
-    config <- mapM parseConfig configPath
-    let baseDir = maybe "." dropFileName configPath
+    config <- mapM parseConfig =<< findConfig
+    let baseDir = maybe "." configDir config
 
     envtool <- lookupEnv "EREBOS_TEST_TOOL" >>= \mbtool ->
         return $ fromMaybe (error "No test tool defined") $ mbtool `mplus` (return . (baseDir </>) =<< configTool =<< config)
@@ -151,7 +146,7 @@ main = do
         exitSuccess
 
     when (optTestMode opts) $ do
-        testMode
+        testMode config
         exitSuccess
 
     case words $ optDefaultTool $ optTest opts of
@@ -165,7 +160,7 @@ main = do
             case span (/= ':') ofile of
                 (path, ':':test) -> (path, Just $ T.pack test)
                 (path, _)        -> (path, Nothing)
-        else map (, Nothing) . concat <$> mapM (flip globDir1 baseDir) (maybe [] configTests config)
+        else map (, Nothing) <$> maybe (return []) (getConfigTestFiles) config
 
     when (null files) $ fail $ "No test files"
 
@@ -177,17 +172,7 @@ main = do
             | otherwise       = OutputStyleQuiet
     out <- startOutput outputStyle useColor
 
-    ( modules, allModules ) <- parseTestFiles (map fst files) >>= \case
-        Right res -> do
-            return res
-        Left err -> do
-            case err of
-                ImportModuleError bundle ->
-                    putStr (errorBundlePretty bundle)
-                _ -> do
-                    putStrLn (showErrorComponent err)
-            exitFailure
-
+    ( modules, globalDefs ) <- loadModules (map fst files)
     tests <- if null otests
         then fmap concat $ forM (zip modules files) $ \( Module {..}, ( filePath, mbTestName )) -> do
             case mbTestName of
@@ -207,9 +192,6 @@ main = do
                     hPutStrLn stderr $ "Test ‘" <> T.unpack name <> "’ not found"
                     exitFailure
 
-
-    let globalDefs = evalGlobalDefs $ concatMap (\m -> map (first ( moduleName m, )) $ moduleDefinitions m) allModules
-
     ok <- allM (runTest out (optTest opts) globalDefs) $
         concat $ replicate (optRepeat opts) tests
     when (not ok) exitFailure
diff --git a/src/Run.hs b/src/Run.hs
index 8088f23..200ae8e 100644
--- a/src/Run.hs
+++ b/src/Run.hs
@@ -1,6 +1,7 @@
 module Run (
     module Run.Monad,
     runTest,
+    loadModules,
     evalGlobalDefs,
 ) where
 
@@ -12,12 +13,14 @@ import Control.Monad.Except
 import Control.Monad.Fix
 import Control.Monad.Reader
 
+import Data.Bifunctor
 import Data.Map qualified as M
 import Data.Maybe
-import Data.Set qualified as S
 import Data.Scientific
+import Data.Set qualified as S
 import Data.Text (Text)
-import qualified Data.Text as T
+import Data.Text qualified as T
+import Text.Megaparsec (errorBundlePretty, showErrorComponent)
 
 import System.Directory
 import System.Exit
@@ -30,13 +33,16 @@ import GDB
 import Network
 import Network.Ip
 import Output
+import Parser
 import Process
 import Run.Monad
 import Script.Expr
+import Script.Module
 import Script.Shell
 import Test
 import Test.Builtins
 
+
 runTest :: Output -> TestOptions -> GlobalDefs -> Test -> IO Bool
 runTest out opts gdefs test = do
     let testDir = optTestDir opts
@@ -111,6 +117,22 @@ runTest out opts gdefs test = do
             return False
 
 
+loadModules :: [ FilePath ] -> IO ( [ Module ], GlobalDefs )
+loadModules files = do
+    ( modules, allModules ) <- parseTestFiles files >>= \case
+        Right res -> do
+            return res
+        Left err -> do
+            case err of
+                ImportModuleError bundle ->
+                    putStr (errorBundlePretty bundle)
+                _ -> do
+                    putStrLn (showErrorComponent err)
+            exitFailure
+    let globalDefs = evalGlobalDefs $ concatMap (\m -> map (first ( moduleName m, )) $ moduleDefinitions m) allModules
+    return ( modules, globalDefs )
+
+
 evalGlobalDefs :: [ (( ModuleName, VarName ), SomeExpr ) ] -> GlobalDefs
 evalGlobalDefs exprs = fix $ \gdefs ->
     builtins `M.union` M.fromList (map (fmap (evalSomeWith gdefs)) exprs)
diff --git a/src/TestMode.hs b/src/TestMode.hs
index ab938e6..c052fb9 100644
--- a/src/TestMode.hs
+++ b/src/TestMode.hs
@@ -4,12 +4,14 @@ module TestMode (
     testMode,
 ) where
 
+import Control.Monad
 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)
 import Data.Text qualified as T
 import Data.Text.IO qualified as T
@@ -19,6 +21,7 @@ import System.IO.Error
 import Text.Megaparsec.Error
 import Text.Megaparsec.Pos
 
+import Config
 import Output
 import Parser
 import Run
@@ -29,29 +32,32 @@ import Test
 
 data TestModeInput = TestModeInput
     { tmiOutput :: Output
+    , tmiConfig :: Maybe Config
     , tmiParams :: [ Text ]
     }
 
 data TestModeState = TestModeState
     { tmsModules :: [ Module ]
     , tmsGlobals :: GlobalDefs
+    , tmsNextTestNumber :: Int
     }
 
 initTestModeState :: TestModeState
 initTestModeState = TestModeState
     { tmsModules = mempty
     , tmsGlobals = mempty
+    , tmsNextTestNumber = 1
     }
 
-testMode :: IO ()
-testMode = do
-    out <- startOutput OutputStyleTest False
+testMode :: Maybe Config -> IO ()
+testMode tmiConfig = do
+    tmiOutput <- startOutput OutputStyleTest False
     let testLoop = getLineMb >>= \case
             Just line -> do
                 case T.words line of
-                    cname : params
+                    cname : tmiParams
                         | Just (CommandM cmd) <- lookup cname commands -> do
-                            runReaderT cmd $ TestModeInput out params
+                            runReaderT cmd $ TestModeInput {..}
                         | otherwise -> fail $ "Unknown command '" ++ T.unpack cname ++ "'"
                     [] -> return ()
                 testLoop
@@ -59,7 +65,7 @@ testMode = do
             Nothing -> return ()
 
     runExceptT (evalStateT testLoop initTestModeState) >>= \case
-        Left err -> flip runReaderT out $ outLine OutputError Nothing $ T.pack err
+        Left err -> flip runReaderT tmiOutput $ outLine OutputError Nothing $ T.pack err
         Right () -> return ()
 
 getLineMb :: MonadIO m => m (Maybe Text)
@@ -70,6 +76,25 @@ cmdOut line = do
     out <- asks tmiOutput
     flip runReaderT out $ outLine OutputTestRaw Nothing line
 
+getNextTestNumber :: CommandM Int
+getNextTestNumber = do
+    num <- gets tmsNextTestNumber
+    modify $ \s -> s { tmsNextTestNumber = num + 1 }
+    return num
+
+runSingleTest :: Test -> CommandM Bool
+runSingleTest test = do
+    out <- asks tmiOutput
+    num <- getNextTestNumber
+    globals <- gets tmsGlobals
+    mbconfig <- asks tmiConfig
+    let opts = defaultTestOptions
+            { optDefaultTool = fromMaybe "" $ configTool =<< mbconfig
+            , optTestDir = ".test" <> show num
+            , optKeep = True
+            }
+    liftIO (runTest out opts globals test)
+
 
 newtype CommandM a = CommandM (ReaderT TestModeInput (StateT TestModeState (ExceptT String IO)) a)
     deriving
@@ -85,7 +110,9 @@ type Command = CommandM ()
 commands :: [ ( Text, Command ) ]
 commands =
     [ ( "load", cmdLoad )
+    , ( "load-config", cmdLoadConfig )
     , ( "run", cmdRun )
+    , ( "run-all", cmdRunAll )
     ]
 
 cmdLoad :: Command
@@ -117,6 +144,16 @@ cmdLoad = do
         , ":", show $ unPos sourceColumn
         ]
 
+cmdLoadConfig :: Command
+cmdLoadConfig = do
+    Just config <- asks tmiConfig
+    ( modules, globalDefs ) <- liftIO $ loadModules =<< getConfigTestFiles config
+    modify $ \s -> s
+        { tmsModules = modules
+        , tmsGlobals = globalDefs
+        }
+    cmdOut "load-config-done"
+
 cmdRun :: Command
 cmdRun = do
     [ name ] <- asks tmiParams
@@ -124,7 +161,14 @@ cmdRun = do
     case find ((name ==) . testName) $ concatMap moduleTests tmsModules of
         Nothing -> cmdOut "run-not-found"
         Just test -> do
-            out <- asks tmiOutput
-            liftIO (runTest out defaultTestOptions tmsGlobals test) >>= \case
+            runSingleTest test >>= \case
                 True -> cmdOut "run-done"
                 False -> cmdOut "run-failed"
+
+cmdRunAll :: Command
+cmdRunAll = do
+    TestModeState {..} <- get
+    forM_ (concatMap moduleTests tmsModules) $ \test -> do
+        res <- runSingleTest test
+        cmdOut $ "run-test-result " <> testName test <> " " <> (if res then "done" else "failed")
+    cmdOut "run-all-done"