diff options
Diffstat (limited to 'src/Main.hs')
| -rw-r--r-- | src/Main.hs | 95 |
1 files changed, 72 insertions, 23 deletions
diff --git a/src/Main.hs b/src/Main.hs index 61afbd8..b3f7a2a 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -2,8 +2,10 @@ module Main (main) where import Control.Monad +import Data.List import Data.Maybe -import qualified Data.Text as T +import Data.Text (Text) +import Data.Text qualified as T import Text.Read (readMaybe) @@ -12,40 +14,44 @@ 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 import Test +import TestMode import Util import Version data CmdlineOptions = CmdlineOptions { optTest :: TestOptions , optRepeat :: Int + , optExclude :: [ Text ] , optVerbose :: Bool , optColor :: Maybe Bool , optShowHelp :: Bool , optShowVersion :: Bool + , optTestMode :: Bool } defaultCmdlineOptions :: CmdlineOptions defaultCmdlineOptions = CmdlineOptions { optTest = defaultTestOptions , optRepeat = 1 + , optExclude = [] , optVerbose = False , optColor = Nothing , optShowHelp = False , optShowVersion = False + , optTestMode = False } -options :: [OptDescr (CmdlineOptions -> CmdlineOptions)] +options :: [ OptDescr (CmdlineOptions -> CmdlineOptions) ] options = [ Option ['T'] ["tool"] (ReqArg (\str -> to $ \opts -> case break (==':') str of @@ -79,6 +85,9 @@ options = , Option ['r'] ["repeat"] (ReqArg (\str opts -> opts { optRepeat = read str }) "<count>") "number of times to repeat the test(s)" + , Option [ 'e' ] [ "exclude" ] + (ReqArg (\str opts -> opts { optExclude = T.pack str : optExclude opts }) "<test>") + "exclude given test from execution" , Option [] ["wait"] (NoArg $ to $ \opts -> opts { optWait = True }) "wait at the end of each test" @@ -92,11 +101,17 @@ options = where to f opts = opts { optTest = f (optTest opts) } +hiddenOptions :: [ OptDescr (CmdlineOptions -> CmdlineOptions) ] +hiddenOptions = + [ Option [] [ "test-mode" ] + (NoArg (\opts -> opts { optTestMode = True })) + "test mode" + ] + 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) @@ -105,19 +120,26 @@ main = do { optTest = defaultTestOptions { optDefaultTool = envtool , optTestDir = normalise $ baseDir </> optTestDir defaultTestOptions + , optTimeout = fromMaybe (optTimeout defaultTestOptions) $ configTimeout =<< config } } args <- getArgs - (opts, ofiles) <- case getOpt Permute options args of + (opts, oselection) <- case getOpt Permute (options ++ hiddenOptions) args of (o, files, []) -> return (foldl (flip id) initOpts o, files) (_, _, errs) -> do hPutStrLn stderr $ concat errs <> "Try `erebos-tester --help' for more information." exitFailure + let ( ofiles, otests ) + | any (any isPathSeparator) oselection = ( oselection, [] ) + | otherwise = ( [], map T.pack oselection ) + when (optShowHelp opts) $ do let header = unlines - [ "Usage: erebos-tester [<option>...] [<script>[:<test>]...]" + [ "Usage: erebos-tester [<option>...] [<test-name>...]" + , " or: erebos-tester [<option>...] <script>[:<test>]..." + , " <test-name> name of a test from project configuration" , " <script> path to test script file" , " <test> name of the test to run" , "" @@ -130,30 +152,57 @@ main = do putStrLn versionLine exitSuccess - getPermissions (head $ words $ optDefaultTool $ optTest opts) >>= \perms -> do - when (not $ executable perms) $ do - fail $ optDefaultTool (optTest opts) <> " is not executable" + when (optTestMode opts) $ do + testMode config + exitSuccess + + case words $ optDefaultTool $ optTest opts of + (path : _) -> getPermissions path >>= \perms -> do + when (not $ executable perms) $ do + fail $ "‘" <> path <> "’ is not executable" + _ -> fail $ "invalid tool argument: ‘" <> optDefaultTool (optTest opts) <> "’" files <- if not (null ofiles) then return $ flip map ofiles $ \ofile -> 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" useColor <- case optColor opts of Just use -> return use Nothing -> queryTerminal (Fd 1) - out <- startOutput (optVerbose opts) useColor - - tests <- forM files $ \(path, mbTestName) -> do - Module { .. } <- parseTestFile path - return $ case mbTestName of - Nothing -> moduleTests - Just name -> filter ((==name) . testName) moduleTests - - ok <- allM (runTest out $ optTest opts) $ - concat $ replicate (optRepeat opts) $ concat tests + let outputStyle + | optVerbose opts = OutputStyleVerbose + | otherwise = OutputStyleQuiet + out <- startOutput outputStyle useColor + + ( modules, globalDefs ) <- loadModules (map fst files) + tests <- filter ((`notElem` optExclude opts) . testName) <$> if null otests + then fmap concat $ forM (zip modules files) $ \( Module {..}, ( filePath, mbTestName )) -> do + case mbTestName of + Nothing -> return moduleTests + Just name + | Just test <- find ((name ==) . testName) moduleTests + -> return [ test ] + | otherwise + -> 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 + -> return test + | otherwise + -> do + hPutStrLn stderr $ "Test ‘" <> T.unpack name <> "’ not found" + exitFailure + + ok <- allM (runTest out (optTest opts) globalDefs) $ + concat $ replicate (optRepeat opts) tests when (not ok) exitFailure + +foreign export ccall testerMain :: IO () +testerMain :: IO () +testerMain = main |