module Test.Runner.Frontend ( testRunnerMain ) where
import System.IO ( hPutStrLn, stderr, hSetBuffering, stdout,
BufferMode ( NoBuffering ) )
import System.Console.GetOpt ( OptDescr(..), ArgDescr(..), getOpt, usageInfo,
ArgOrder(Permute) )
import System.Environment ( getArgs )
import System.Random ( StdGen )
import System.Exit ( exitWith, ExitCode(ExitSuccess) )
import Data.Maybe ( isJust )
import Text.Regex ( mkRegex, matchRegex )
import Test.QuickCheck ( Args(..), stdArgs )
import Test.Runner.Backends ( TestRunnerTest(..) )
import Test.Runner.Driver ( runTestsParallelWithArgs, Result(..) )
testRunnerMain :: [(String, TestRunnerTest)] -> IO ()
testRunnerMain tests = do
hSetBuffering stdout NoBuffering
maybeFlags <- parse_args `fmap` getArgs
case maybeFlags of
Nothing -> do hPutStrLn stderr "testrunner: Unrecognized arguments on command line"
printUsageAndDie
Just flags ->
let showHelp = not (null [x | x <- flags,
case x of
ShowHelp -> True
_ -> False])
in if showHelp
then printUsageAndDie
else runWithFlags flags tests
printUsageAndDie :: IO ()
printUsageAndDie = do
putStr (usageInfo "unit - run darcs unit tests" opts)
exitWith ExitSuccess
runWithFlags :: [UnitFlag] -> [(String, TestRunnerTest)] -> IO ()
runWithFlags flags tests = runAndShowTests numThreads qcArgs matchingTests
where matchingTests = filter (isJust . (matchRegex matchEx) . fst) tests
qcArgs = case replayValues of
Nothing -> stdArgs
Just (seed, size) -> stdArgs { replay = Just (seed, size) }
numThreads | null jobsArgs = 1
| otherwise = last jobsArgs
jobsArgs = [j | NumJobs j <- flags]
matchEx | null matchArgs = mkRegex ".*"
| otherwise = mkRegex (last matchArgs)
matchArgs = [ex | Matching ex <- flags]
replayValues | null replayArgs = Nothing
| otherwise = Just (last replayArgs)
replayArgs = [(seed, size) | QuickCheckReplay seed size <- flags]
runAndShowTests :: Int -> Args -> [(String, TestRunnerTest)] -> IO ()
runAndShowTests numThreads qcArgs tests = do
results <- runTestsParallelWithArgs numThreads qcArgs tests
putStr (show (numPassed results) ++ " tests passed.")
if not (null (failures results))
then do putStrLn " Failing tests:"
mapM_ (putStr . formatFailure) (failures results)
else putChar '\n'
where formatFailure (name, output) =
" " ++ name ++ ":\n" ++
((unlines . map (" "++) . lines) output)
data UnitFlag = ShowHelp
| NumJobs Int
| Matching String
| QuickCheckReplay StdGen Int
parse_numjobs :: String -> UnitFlag
parse_numjobs s = case reads s of
[(x,"")] -> NumJobs x
_ -> error "Invalid number of Haskell threads given"
parse_qc_replay :: String -> UnitFlag
parse_qc_replay s = QuickCheckReplay seed size
where (seedString, sizeString) = break (==',') s
seed = case reads seedString :: [(StdGen, String)] of
[(seed', "")] -> seed'
_ -> error "Invalid QuickCheck seed given"
size = case sizeString of
[] -> error "Empty QuickCheck size given"
sizeString' -> case reads (tail sizeString') of
[(size', "")] -> size'
_ -> error "Invalid QuickCheck size given"
opts :: [OptDescr UnitFlag]
opts = [Option ['j'] ["jobs"] (ReqArg parse_numjobs "NUM") "Number of Haskell threads to run unit tests (you need +RTS -N<NUM> too)"
,Option ['m'] ["matching"] (ReqArg Matching "REGEX") "Run only tests matching the given POSIX regular expression"
,Option ['r'] ["quickcheck-replay"] (ReqArg parse_qc_replay "SEED,SIZE") "Run QuickCheck tests once with given seed and size"
,Option ['h'] ["help"] (NoArg ShowHelp) "Show usage information and exit"
]
parse_args :: [String]
-> Maybe [UnitFlag]
parse_args args | not (null nonopts)
|| not (null errs) = Nothing
| otherwise = Just vals
where (vals, nonopts, errs) = getOpt Permute opts args