diff options
Diffstat (limited to 'src')
| -rw-r--r-- | src/Config.hs | 30 | ||||
| -rw-r--r-- | src/Main.hs | 28 | ||||
| -rw-r--r-- | src/Run.hs | 26 | ||||
| -rw-r--r-- | src/TestMode.hs | 60 |
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 @@ -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" |