module Test.Framework.Runners.Console (
        defaultMain, defaultMainWithArgs, defaultMainWithOpts,
        SuppliedRunnerOptions, optionsDescription,
        interpretArgs, interpretArgsOrExit
    ) where

import Test.Framework.Core
import Test.Framework.Options
import Test.Framework.Runners.Console.Run
import Test.Framework.Runners.Core
import Test.Framework.Runners.Options
import Test.Framework.Runners.Processors
import Test.Framework.Runners.Statistics
import qualified Test.Framework.Runners.XML as XML
import Test.Framework.Seed
import Test.Framework.Utilities

import Control.Monad (when)
import System.Console.GetOpt
    ( getOpt,
      usageInfo,
      ArgDescr(NoArg, ReqArg),
      ArgOrder(Permute),
      OptDescr(..) )
import System.Environment ( getArgs, getProgName )
import System.Exit
    ( exitSuccess, exitWith, ExitCode(ExitFailure, ExitSuccess) )
import System.IO ( hIsTerminalDevice, hPutStrLn, stderr, stdout )

-- | @Nothing@ signifies that usage information should be displayed.
-- @Just@ simply gives us the contribution to overall options by the command line option.
type SuppliedRunnerOptions = Maybe RunnerOptions

-- | Options understood by test-framework. This can be used to add more
-- options to the tester executable.
optionsDescription :: [OptDescr SuppliedRunnerOptions]
optionsDescription :: [OptDescr SuppliedRunnerOptions]
optionsDescription = [
        [Char]
-> [[Char]]
-> ArgDescr SuppliedRunnerOptions
-> [Char]
-> OptDescr SuppliedRunnerOptions
forall a. [Char] -> [[Char]] -> ArgDescr a -> [Char] -> OptDescr a
Option [] [[Char]
"help"]
            (SuppliedRunnerOptions -> ArgDescr SuppliedRunnerOptions
forall a. a -> ArgDescr a
NoArg SuppliedRunnerOptions
forall a. Maybe a
Nothing)
            [Char]
"show this help message"
    ] [OptDescr SuppliedRunnerOptions]
-> [OptDescr SuppliedRunnerOptions]
-> [OptDescr SuppliedRunnerOptions]
forall a. [a] -> [a] -> [a]
++ (OptDescr (RunnerOptions' Maybe) -> OptDescr SuppliedRunnerOptions)
-> [OptDescr (RunnerOptions' Maybe)]
-> [OptDescr SuppliedRunnerOptions]
forall a b. (a -> b) -> [a] -> [b]
map ((RunnerOptions' Maybe -> SuppliedRunnerOptions)
-> OptDescr (RunnerOptions' Maybe)
-> OptDescr SuppliedRunnerOptions
forall a b. (a -> b) -> OptDescr a -> OptDescr b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap RunnerOptions' Maybe -> SuppliedRunnerOptions
forall a. a -> Maybe a
Just) [
        [Char]
-> [[Char]]
-> ArgDescr (RunnerOptions' Maybe)
-> [Char]
-> OptDescr (RunnerOptions' Maybe)
forall a. [Char] -> [[Char]] -> ArgDescr a -> [Char] -> OptDescr a
Option [Char
'j'] [[Char]
"threads"]
            (([Char] -> RunnerOptions' Maybe)
-> [Char] -> ArgDescr (RunnerOptions' Maybe)
forall a. ([Char] -> a) -> [Char] -> ArgDescr a
ReqArg (\[Char]
t -> RunnerOptions' Maybe
forall a. Monoid a => a
mempty { ropt_threads :: Maybe Int
ropt_threads = Int -> Maybe Int
forall a. a -> Maybe a
Just ([Char] -> Int
forall a. Read a => [Char] -> a
read [Char]
t) }) [Char]
"NUMBER")
            [Char]
"number of threads to use to run tests",
        [Char]
-> [[Char]]
-> ArgDescr (RunnerOptions' Maybe)
-> [Char]
-> OptDescr (RunnerOptions' Maybe)
forall a. [Char] -> [[Char]] -> ArgDescr a -> [Char] -> OptDescr a
Option [] [[Char]
"test-seed"]
            (([Char] -> RunnerOptions' Maybe)
-> [Char] -> ArgDescr (RunnerOptions' Maybe)
forall a. ([Char] -> a) -> [Char] -> ArgDescr a
ReqArg (\[Char]
t -> RunnerOptions' Maybe
forall a. Monoid a => a
mempty { ropt_test_options :: Maybe TestOptions
ropt_test_options = TestOptions -> Maybe TestOptions
forall a. a -> Maybe a
Just (TestOptions
forall a. Monoid a => a
mempty { topt_seed :: Maybe Seed
topt_seed = Seed -> Maybe Seed
forall a. a -> Maybe a
Just ([Char] -> Seed
forall a. Read a => [Char] -> a
read [Char]
t) }) }) ([Char]
"NUMBER|" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Seed -> [Char]
forall a. Show a => a -> [Char]
show Seed
RandomSeed))
            [Char]
"default seed for test random number generator",
        [Char]
-> [[Char]]
-> ArgDescr (RunnerOptions' Maybe)
-> [Char]
-> OptDescr (RunnerOptions' Maybe)
forall a. [Char] -> [[Char]] -> ArgDescr a -> [Char] -> OptDescr a
Option [Char
'a'] [[Char]
"maximum-generated-tests"]
            (([Char] -> RunnerOptions' Maybe)
-> [Char] -> ArgDescr (RunnerOptions' Maybe)
forall a. ([Char] -> a) -> [Char] -> ArgDescr a
ReqArg (\[Char]
t -> RunnerOptions' Maybe
forall a. Monoid a => a
mempty { ropt_test_options :: Maybe TestOptions
ropt_test_options = TestOptions -> Maybe TestOptions
forall a. a -> Maybe a
Just (TestOptions
forall a. Monoid a => a
mempty { topt_maximum_generated_tests :: Maybe Int
topt_maximum_generated_tests = Int -> Maybe Int
forall a. a -> Maybe a
Just ([Char] -> Int
forall a. Read a => [Char] -> a
read [Char]
t) }) }) [Char]
"NUMBER")
            [Char]
"how many automated tests something like QuickCheck should try, by default",
        [Char]
-> [[Char]]
-> ArgDescr (RunnerOptions' Maybe)
-> [Char]
-> OptDescr (RunnerOptions' Maybe)
forall a. [Char] -> [[Char]] -> ArgDescr a -> [Char] -> OptDescr a
Option [] [[Char]
"maximum-unsuitable-generated-tests"]
            (([Char] -> RunnerOptions' Maybe)
-> [Char] -> ArgDescr (RunnerOptions' Maybe)
forall a. ([Char] -> a) -> [Char] -> ArgDescr a
ReqArg (\[Char]
t -> RunnerOptions' Maybe
forall a. Monoid a => a
mempty { ropt_test_options :: Maybe TestOptions
ropt_test_options = TestOptions -> Maybe TestOptions
forall a. a -> Maybe a
Just (TestOptions
forall a. Monoid a => a
mempty { topt_maximum_unsuitable_generated_tests :: Maybe Int
topt_maximum_unsuitable_generated_tests = Int -> Maybe Int
forall a. a -> Maybe a
Just ([Char] -> Int
forall a. Read a => [Char] -> a
read [Char]
t) }) }) [Char]
"NUMBER")
            [Char]
"how many unsuitable candidate tests something like QuickCheck should endure before giving up, by default",
        [Char]
-> [[Char]]
-> ArgDescr (RunnerOptions' Maybe)
-> [Char]
-> OptDescr (RunnerOptions' Maybe)
forall a. [Char] -> [[Char]] -> ArgDescr a -> [Char] -> OptDescr a
Option [Char
's'] [[Char]
"maximum-test-size"]
            (([Char] -> RunnerOptions' Maybe)
-> [Char] -> ArgDescr (RunnerOptions' Maybe)
forall a. ([Char] -> a) -> [Char] -> ArgDescr a
ReqArg (\[Char]
t -> RunnerOptions' Maybe
forall a. Monoid a => a
mempty {ropt_test_options :: Maybe TestOptions
ropt_test_options = TestOptions -> Maybe TestOptions
forall a. a -> Maybe a
Just (TestOptions
forall a. Monoid a => a
mempty { topt_maximum_test_size :: Maybe Int
topt_maximum_test_size = Int -> Maybe Int
forall a. a -> Maybe a
Just ([Char] -> Int
forall a. Read a => [Char] -> a
read [Char]
t) }) }) [Char]
"NUMBER")
            [Char]
"to what size something like QuickCheck should test the properties, by default",
        [Char]
-> [[Char]]
-> ArgDescr (RunnerOptions' Maybe)
-> [Char]
-> OptDescr (RunnerOptions' Maybe)
forall a. [Char] -> [[Char]] -> ArgDescr a -> [Char] -> OptDescr a
Option [Char
'd'] [[Char]
"maximum-test-depth"]
            (([Char] -> RunnerOptions' Maybe)
-> [Char] -> ArgDescr (RunnerOptions' Maybe)
forall a. ([Char] -> a) -> [Char] -> ArgDescr a
ReqArg (\[Char]
t -> RunnerOptions' Maybe
forall a. Monoid a => a
mempty { ropt_test_options :: Maybe TestOptions
ropt_test_options = TestOptions -> Maybe TestOptions
forall a. a -> Maybe a
Just (TestOptions
forall a. Monoid a => a
mempty { topt_maximum_test_depth :: Maybe Int
topt_maximum_test_depth = Int -> Maybe Int
forall a. a -> Maybe a
Just ([Char] -> Int
forall a. Read a => [Char] -> a
read [Char]
t) }) }) [Char]
"NUMBER")
            [Char]
"to what depth something like SmallCheck should test the properties, by default",
        [Char]
-> [[Char]]
-> ArgDescr (RunnerOptions' Maybe)
-> [Char]
-> OptDescr (RunnerOptions' Maybe)
forall a. [Char] -> [[Char]] -> ArgDescr a -> [Char] -> OptDescr a
Option [Char
'o'] [[Char]
"timeout"]
            (([Char] -> RunnerOptions' Maybe)
-> [Char] -> ArgDescr (RunnerOptions' Maybe)
forall a. ([Char] -> a) -> [Char] -> ArgDescr a
ReqArg (\[Char]
t -> RunnerOptions' Maybe
forall a. Monoid a => a
mempty { ropt_test_options :: Maybe TestOptions
ropt_test_options = TestOptions -> Maybe TestOptions
forall a. a -> Maybe a
Just (TestOptions
forall a. Monoid a => a
mempty { topt_timeout :: Maybe (Maybe Int)
topt_timeout = Maybe Int -> Maybe (Maybe Int)
forall a. a -> Maybe a
Just (Int -> Maybe Int
forall a. a -> Maybe a
Just (Int -> Int
forall a. Num a => a -> a
secondsToMicroseconds ([Char] -> Int
forall a. Read a => [Char] -> a
read [Char]
t))) }) }) [Char]
"NUMBER")
            [Char]
"how many seconds a test should be run for before giving up, by default",
        [Char]
-> [[Char]]
-> ArgDescr (RunnerOptions' Maybe)
-> [Char]
-> OptDescr (RunnerOptions' Maybe)
forall a. [Char] -> [[Char]] -> ArgDescr a -> [Char] -> OptDescr a
Option [] [[Char]
"no-timeout"]
            (RunnerOptions' Maybe -> ArgDescr (RunnerOptions' Maybe)
forall a. a -> ArgDescr a
NoArg (RunnerOptions' Maybe
forall a. Monoid a => a
mempty { ropt_test_options :: Maybe TestOptions
ropt_test_options = TestOptions -> Maybe TestOptions
forall a. a -> Maybe a
Just (TestOptions
forall a. Monoid a => a
mempty { topt_timeout :: Maybe (Maybe Int)
topt_timeout = Maybe Int -> Maybe (Maybe Int)
forall a. a -> Maybe a
Just Maybe Int
forall a. Maybe a
Nothing }) }))
            [Char]
"specifies that tests should be run without a timeout, by default",
        [Char]
-> [[Char]]
-> ArgDescr (RunnerOptions' Maybe)
-> [Char]
-> OptDescr (RunnerOptions' Maybe)
forall a. [Char] -> [[Char]] -> ArgDescr a -> [Char] -> OptDescr a
Option [Char
'l'] [[Char]
"list-tests"]
            (RunnerOptions' Maybe -> ArgDescr (RunnerOptions' Maybe)
forall a. a -> ArgDescr a
NoArg (RunnerOptions' Maybe
forall a. Monoid a => a
mempty { ropt_list_only :: Maybe Bool
ropt_list_only = Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
True }))
            [Char]
"list available tests but don't run any; useful to guide subsequent --select-tests",
        [Char]
-> [[Char]]
-> ArgDescr (RunnerOptions' Maybe)
-> [Char]
-> OptDescr (RunnerOptions' Maybe)
forall a. [Char] -> [[Char]] -> ArgDescr a -> [Char] -> OptDescr a
Option [Char
't'] [[Char]
"select-tests"]
            (([Char] -> RunnerOptions' Maybe)
-> [Char] -> ArgDescr (RunnerOptions' Maybe)
forall a. ([Char] -> a) -> [Char] -> ArgDescr a
ReqArg (\[Char]
t -> RunnerOptions' Maybe
forall a. Monoid a => a
mempty { ropt_test_patterns :: Maybe [TestPattern]
ropt_test_patterns = [TestPattern] -> Maybe [TestPattern]
forall a. a -> Maybe a
Just [[Char] -> TestPattern
forall a. Read a => [Char] -> a
read [Char]
t] }) [Char]
"TEST-PATTERN")
            [Char]
"only tests that match at least one glob pattern given by an instance of this argument will be run",
        [Char]
-> [[Char]]
-> ArgDescr (RunnerOptions' Maybe)
-> [Char]
-> OptDescr (RunnerOptions' Maybe)
forall a. [Char] -> [[Char]] -> ArgDescr a -> [Char] -> OptDescr a
Option [] [[Char]
"jxml"]
            (([Char] -> RunnerOptions' Maybe)
-> [Char] -> ArgDescr (RunnerOptions' Maybe)
forall a. ([Char] -> a) -> [Char] -> ArgDescr a
ReqArg (\[Char]
t -> RunnerOptions' Maybe
forall a. Monoid a => a
mempty { ropt_xml_output :: Maybe (Maybe [Char])
ropt_xml_output = Maybe [Char] -> Maybe (Maybe [Char])
forall a. a -> Maybe a
Just ([Char] -> Maybe [Char]
forall a. a -> Maybe a
Just [Char]
t) }) [Char]
"FILE")
            [Char]
"write a JUnit XML summary of the output to FILE",
        [Char]
-> [[Char]]
-> ArgDescr (RunnerOptions' Maybe)
-> [Char]
-> OptDescr (RunnerOptions' Maybe)
forall a. [Char] -> [[Char]] -> ArgDescr a -> [Char] -> OptDescr a
Option [] [[Char]
"jxml-nested"]
            (RunnerOptions' Maybe -> ArgDescr (RunnerOptions' Maybe)
forall a. a -> ArgDescr a
NoArg (RunnerOptions' Maybe
forall a. Monoid a => a
mempty { ropt_xml_nested :: Maybe Bool
ropt_xml_nested = Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
True }))
            [Char]
"use nested testsuites to represent groups in JUnit XML (not standards compliant)",
        [Char]
-> [[Char]]
-> ArgDescr (RunnerOptions' Maybe)
-> [Char]
-> OptDescr (RunnerOptions' Maybe)
forall a. [Char] -> [[Char]] -> ArgDescr a -> [Char] -> OptDescr a
Option [] [[Char]
"plain"]
            (RunnerOptions' Maybe -> ArgDescr (RunnerOptions' Maybe)
forall a. a -> ArgDescr a
NoArg (RunnerOptions' Maybe
forall a. Monoid a => a
mempty { ropt_color_mode :: Maybe ColorMode
ropt_color_mode = ColorMode -> Maybe ColorMode
forall a. a -> Maybe a
Just ColorMode
ColorNever }))
            [Char]
"do not use any ANSI terminal features to display the test run",
        [Char]
-> [[Char]]
-> ArgDescr (RunnerOptions' Maybe)
-> [Char]
-> OptDescr (RunnerOptions' Maybe)
forall a. [Char] -> [[Char]] -> ArgDescr a -> [Char] -> OptDescr a
Option [] [[Char]
"color"]
            (RunnerOptions' Maybe -> ArgDescr (RunnerOptions' Maybe)
forall a. a -> ArgDescr a
NoArg (RunnerOptions' Maybe
forall a. Monoid a => a
mempty { ropt_color_mode :: Maybe ColorMode
ropt_color_mode = ColorMode -> Maybe ColorMode
forall a. a -> Maybe a
Just ColorMode
ColorAlways }))
            [Char]
"use ANSI terminal features to display the test run",
        [Char]
-> [[Char]]
-> ArgDescr (RunnerOptions' Maybe)
-> [Char]
-> OptDescr (RunnerOptions' Maybe)
forall a. [Char] -> [[Char]] -> ArgDescr a -> [Char] -> OptDescr a
Option [] [[Char]
"hide-successes"]
            (RunnerOptions' Maybe -> ArgDescr (RunnerOptions' Maybe)
forall a. a -> ArgDescr a
NoArg (RunnerOptions' Maybe
forall a. Monoid a => a
mempty { ropt_hide_successes :: Maybe Bool
ropt_hide_successes = Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
True }))
            [Char]
"hide sucessful tests, and only show failures"
    ]

-- | Parse the specified command line arguments into a 'RunnerOptions' and some remaining arguments,
-- or return a reason as to why we can't.
interpretArgs :: [String] -> IO (Either String (RunnerOptions, [String]))
interpretArgs :: [[Char]] -> IO (Either [Char] (RunnerOptions' Maybe, [[Char]]))
interpretArgs [[Char]]
args = do
    [Char]
prog_name <- IO [Char]
getProgName
    let usage_header :: [Char]
usage_header = [Char]
"Usage: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
prog_name [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" [OPTIONS]"

    case ArgOrder SuppliedRunnerOptions
-> [OptDescr SuppliedRunnerOptions]
-> [[Char]]
-> ([SuppliedRunnerOptions], [[Char]], [[Char]])
forall a.
ArgOrder a -> [OptDescr a] -> [[Char]] -> ([a], [[Char]], [[Char]])
getOpt ArgOrder SuppliedRunnerOptions
forall a. ArgOrder a
Permute [OptDescr SuppliedRunnerOptions]
optionsDescription [[Char]]
args of
        ([SuppliedRunnerOptions]
oas, [[Char]]
n, []) | Just [RunnerOptions' Maybe]
os <- [SuppliedRunnerOptions] -> Maybe [RunnerOptions' Maybe]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence [SuppliedRunnerOptions]
oas -> Either [Char] (RunnerOptions' Maybe, [[Char]])
-> IO (Either [Char] (RunnerOptions' Maybe, [[Char]]))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either [Char] (RunnerOptions' Maybe, [[Char]])
 -> IO (Either [Char] (RunnerOptions' Maybe, [[Char]])))
-> Either [Char] (RunnerOptions' Maybe, [[Char]])
-> IO (Either [Char] (RunnerOptions' Maybe, [[Char]]))
forall a b. (a -> b) -> a -> b
$ (RunnerOptions' Maybe, [[Char]])
-> Either [Char] (RunnerOptions' Maybe, [[Char]])
forall a b. b -> Either a b
Right ([RunnerOptions' Maybe] -> RunnerOptions' Maybe
forall a. Monoid a => [a] -> a
mconcat [RunnerOptions' Maybe]
os, [[Char]]
n)
        ([SuppliedRunnerOptions]
_, [[Char]]
_, [[Char]]
errs)                           -> Either [Char] (RunnerOptions' Maybe, [[Char]])
-> IO (Either [Char] (RunnerOptions' Maybe, [[Char]]))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either [Char] (RunnerOptions' Maybe, [[Char]])
 -> IO (Either [Char] (RunnerOptions' Maybe, [[Char]])))
-> Either [Char] (RunnerOptions' Maybe, [[Char]])
-> IO (Either [Char] (RunnerOptions' Maybe, [[Char]]))
forall a b. (a -> b) -> a -> b
$ [Char] -> Either [Char] (RunnerOptions' Maybe, [[Char]])
forall a b. a -> Either a b
Left ([[Char]] -> [Char]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Char]]
errs [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char] -> [OptDescr SuppliedRunnerOptions] -> [Char]
forall a. [Char] -> [OptDescr a] -> [Char]
usageInfo [Char]
usage_header [OptDescr SuppliedRunnerOptions]
optionsDescription)

-- | A version of 'interpretArgs' that ends the process if it fails.
interpretArgsOrExit :: [String] -> IO RunnerOptions
interpretArgsOrExit :: [[Char]] -> IO (RunnerOptions' Maybe)
interpretArgsOrExit [[Char]]
args = do
    Either [Char] (RunnerOptions' Maybe, [[Char]])
interpreted_args <- [[Char]] -> IO (Either [Char] (RunnerOptions' Maybe, [[Char]]))
interpretArgs [[Char]]
args
    case Either [Char] (RunnerOptions' Maybe, [[Char]])
interpreted_args of
        Right (RunnerOptions' Maybe
ropts, [])    -> RunnerOptions' Maybe -> IO (RunnerOptions' Maybe)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return RunnerOptions' Maybe
ropts
        Right (RunnerOptions' Maybe
_, [[Char]]
leftovers) -> do
            Handle -> [Char] -> IO ()
hPutStrLn Handle
stderr ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
"Could not understand these extra arguments: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [[Char]] -> [Char]
unwords [[Char]]
leftovers
            ExitCode -> IO (RunnerOptions' Maybe)
forall a. ExitCode -> IO a
exitWith (Int -> ExitCode
ExitFailure Int
1)
        Left [Char]
error_message   -> do
            Handle -> [Char] -> IO ()
hPutStrLn Handle
stderr [Char]
error_message
            ExitCode -> IO (RunnerOptions' Maybe)
forall a. ExitCode -> IO a
exitWith (Int -> ExitCode
ExitFailure Int
1)


defaultMain :: [Test] -> IO ()
defaultMain :: [Test] -> IO ()
defaultMain [Test]
tests = do
    [[Char]]
args <- IO [[Char]]
getArgs
    [Test] -> [[Char]] -> IO ()
defaultMainWithArgs [Test]
tests [[Char]]
args

-- | A version of 'defaultMain' that lets you ignore the command line arguments
-- in favour of another list of 'String's.
defaultMainWithArgs :: [Test] -> [String] -> IO ()
defaultMainWithArgs :: [Test] -> [[Char]] -> IO ()
defaultMainWithArgs [Test]
tests [[Char]]
args = do
    RunnerOptions' Maybe
ropts <- [[Char]] -> IO (RunnerOptions' Maybe)
interpretArgsOrExit [[Char]]
args
    [Test] -> RunnerOptions' Maybe -> IO ()
defaultMainWithOpts [Test]
tests RunnerOptions' Maybe
ropts

-- | A version of 'defaultMain' that lets you ignore the command line arguments
-- in favour of an explicit set of 'RunnerOptions'.
defaultMainWithOpts :: [Test] -> RunnerOptions -> IO ()
defaultMainWithOpts :: [Test] -> RunnerOptions' Maybe -> IO ()
defaultMainWithOpts [Test]
tests RunnerOptions' Maybe
ropts = do
    let ropts' :: CompleteRunnerOptions
ropts' = RunnerOptions' Maybe -> CompleteRunnerOptions
completeRunnerOptions RunnerOptions' Maybe
ropts

    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (K Bool -> Bool
forall a. K a -> a
unK(K Bool -> Bool) -> K Bool -> Bool
forall a b. (a -> b) -> a -> b
$ CompleteRunnerOptions -> K Bool
forall (f :: * -> *). RunnerOptions' f -> f Bool
ropt_list_only CompleteRunnerOptions
ropts') (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
      [Char] -> IO ()
putStr ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ [Test] -> [Char]
listTests [Test]
tests
      IO ()
forall a. IO a
exitSuccess

    -- Get a lazy list of the test results, as executed in parallel
    [RunningTest]
running_tests <- CompleteRunnerOptions -> [Test] -> IO [RunningTest]
runTests CompleteRunnerOptions
ropts' [Test]
tests

    Bool
isplain <- case K ColorMode -> ColorMode
forall a. K a -> a
unK (K ColorMode -> ColorMode) -> K ColorMode -> ColorMode
forall a b. (a -> b) -> a -> b
$ CompleteRunnerOptions -> K ColorMode
forall (f :: * -> *). RunnerOptions' f -> f ColorMode
ropt_color_mode CompleteRunnerOptions
ropts' of
        ColorMode
ColorAuto   -> Bool -> Bool
not (Bool -> Bool) -> IO Bool -> IO Bool
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` Handle -> IO Bool
hIsTerminalDevice Handle
stdout
        ColorMode
ColorNever  -> Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
        ColorMode
ColorAlways -> Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False

    -- Show those test results to the user as we get them
    [FinishedTest]
fin_tests <- Bool -> Bool -> [RunningTest] -> IO [FinishedTest]
showRunTestsTop Bool
isplain (K Bool -> Bool
forall a. K a -> a
unK (K Bool -> Bool) -> K Bool -> Bool
forall a b. (a -> b) -> a -> b
$ CompleteRunnerOptions -> K Bool
forall (f :: * -> *). RunnerOptions' f -> f Bool
ropt_hide_successes CompleteRunnerOptions
ropts') [RunningTest]
running_tests
    let test_statistics' :: TestStatistics
test_statistics' = [FinishedTest] -> TestStatistics
gatherStatistics [FinishedTest]
fin_tests

    -- Output XML report (if requested)
    case CompleteRunnerOptions -> K (Maybe [Char])
forall (f :: * -> *). RunnerOptions' f -> f (Maybe [Char])
ropt_xml_output CompleteRunnerOptions
ropts' of
        K (Just [Char]
file) -> Bool -> TestStatistics -> [FinishedTest] -> IO [Char]
XML.produceReport (K Bool -> Bool
forall a. K a -> a
unK (CompleteRunnerOptions -> K Bool
forall (f :: * -> *). RunnerOptions' f -> f Bool
ropt_xml_nested CompleteRunnerOptions
ropts')) TestStatistics
test_statistics' [FinishedTest]
fin_tests IO [Char] -> ([Char] -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= [Char] -> [Char] -> IO ()
writeFile [Char]
file
        K (Maybe [Char])
_ -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

    -- Set the error code depending on whether the tests succeeded or not
    ExitCode -> IO ()
forall a. ExitCode -> IO a
exitWith (ExitCode -> IO ()) -> ExitCode -> IO ()
forall a b. (a -> b) -> a -> b
$ if TestStatistics -> Bool
ts_no_failures TestStatistics
test_statistics'
               then ExitCode
ExitSuccess
               else Int -> ExitCode
ExitFailure Int
1

-- | Print out a list of available tests.
listTests :: [Test] -> String
listTests :: [Test] -> [Char]
listTests [Test]
tests = [Char]
"\ntest-framework: All available tests:\n"[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++
                  [Char]
"====================================\n"[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++
                  [[Char]] -> [Char]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (([Char] -> [Char]) -> [[Char]] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map ([Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++[Char]
"\n") ((Test -> [[Char]]) -> [Test] -> [[Char]]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ([Char] -> Test -> [[Char]]
showTest [Char]
"") [Test]
tests))
  where
    showTest :: String -> Test -> [String]
    showTest :: [Char] -> Test -> [[Char]]
showTest [Char]
path (Test [Char]
name t
_testlike)    = [[Char]
"  "[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++[Char]
path [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
name]
    showTest [Char]
path (TestGroup [Char]
name [Test]
gtests)   = (Test -> [[Char]]) -> [Test] -> [[Char]]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ([Char] -> Test -> [[Char]]
showTest ([Char]
path[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++[Char]
":"[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++[Char]
name)) [Test]
gtests
    showTest [Char]
path (PlusTestOptions TestOptions
_ Test
test) = [Char] -> Test -> [[Char]]
showTest [Char]
path Test
test
    showTest [Char]
path (BuildTestBracketed IO (Test, IO ())
_)   = [[Char]
"  "[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++[Char]
path [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"<created at runtime>"]


completeRunnerOptions :: RunnerOptions -> CompleteRunnerOptions
completeRunnerOptions :: RunnerOptions' Maybe -> CompleteRunnerOptions
completeRunnerOptions RunnerOptions' Maybe
ro = RunnerOptions {
            ropt_threads :: K Int
ropt_threads = Int -> K Int
forall a. a -> K a
K (Int -> K Int) -> Int -> K Int
forall a b. (a -> b) -> a -> b
$ RunnerOptions' Maybe -> Maybe Int
forall (f :: * -> *). RunnerOptions' f -> f Int
ropt_threads RunnerOptions' Maybe
ro Maybe Int -> Int -> Int
forall a. Maybe a -> a -> a
`orElse` Int
processorCount,
            ropt_test_options :: K TestOptions
ropt_test_options = TestOptions -> K TestOptions
forall a. a -> K a
K (TestOptions -> K TestOptions) -> TestOptions -> K TestOptions
forall a b. (a -> b) -> a -> b
$ RunnerOptions' Maybe -> Maybe TestOptions
forall (f :: * -> *). RunnerOptions' f -> f TestOptions
ropt_test_options RunnerOptions' Maybe
ro Maybe TestOptions -> TestOptions -> TestOptions
forall a. Maybe a -> a -> a
`orElse` TestOptions
forall a. Monoid a => a
mempty,
            ropt_test_patterns :: K [TestPattern]
ropt_test_patterns = [TestPattern] -> K [TestPattern]
forall a. a -> K a
K ([TestPattern] -> K [TestPattern])
-> [TestPattern] -> K [TestPattern]
forall a b. (a -> b) -> a -> b
$ RunnerOptions' Maybe -> Maybe [TestPattern]
forall (f :: * -> *). RunnerOptions' f -> f [TestPattern]
ropt_test_patterns RunnerOptions' Maybe
ro Maybe [TestPattern] -> [TestPattern] -> [TestPattern]
forall a. Maybe a -> a -> a
`orElse` [TestPattern]
forall a. Monoid a => a
mempty,
            ropt_xml_output :: K (Maybe [Char])
ropt_xml_output = Maybe [Char] -> K (Maybe [Char])
forall a. a -> K a
K (Maybe [Char] -> K (Maybe [Char]))
-> Maybe [Char] -> K (Maybe [Char])
forall a b. (a -> b) -> a -> b
$ RunnerOptions' Maybe -> Maybe (Maybe [Char])
forall (f :: * -> *). RunnerOptions' f -> f (Maybe [Char])
ropt_xml_output RunnerOptions' Maybe
ro Maybe (Maybe [Char]) -> Maybe [Char] -> Maybe [Char]
forall a. Maybe a -> a -> a
`orElse` Maybe [Char]
forall a. Maybe a
Nothing,
            ropt_xml_nested :: K Bool
ropt_xml_nested = Bool -> K Bool
forall a. a -> K a
K (Bool -> K Bool) -> Bool -> K Bool
forall a b. (a -> b) -> a -> b
$ RunnerOptions' Maybe -> Maybe Bool
forall (f :: * -> *). RunnerOptions' f -> f Bool
ropt_xml_nested RunnerOptions' Maybe
ro Maybe Bool -> Bool -> Bool
forall a. Maybe a -> a -> a
`orElse` Bool
False,
            ropt_color_mode :: K ColorMode
ropt_color_mode = ColorMode -> K ColorMode
forall a. a -> K a
K (ColorMode -> K ColorMode) -> ColorMode -> K ColorMode
forall a b. (a -> b) -> a -> b
$ RunnerOptions' Maybe -> Maybe ColorMode
forall (f :: * -> *). RunnerOptions' f -> f ColorMode
ropt_color_mode RunnerOptions' Maybe
ro Maybe ColorMode -> ColorMode -> ColorMode
forall a. Maybe a -> a -> a
`orElse` ColorMode
ColorAuto,
            ropt_hide_successes :: K Bool
ropt_hide_successes = Bool -> K Bool
forall a. a -> K a
K (Bool -> K Bool) -> Bool -> K Bool
forall a b. (a -> b) -> a -> b
$ RunnerOptions' Maybe -> Maybe Bool
forall (f :: * -> *). RunnerOptions' f -> f Bool
ropt_hide_successes RunnerOptions' Maybe
ro Maybe Bool -> Bool -> Bool
forall a. Maybe a -> a -> a
`orElse` Bool
False,
            ropt_list_only :: K Bool
ropt_list_only      = Bool -> K Bool
forall a. a -> K a
K (Bool -> K Bool) -> Bool -> K Bool
forall a b. (a -> b) -> a -> b
$ RunnerOptions' Maybe -> Maybe Bool
forall (f :: * -> *). RunnerOptions' f -> f Bool
ropt_list_only      RunnerOptions' Maybe
ro Maybe Bool -> Bool -> Bool
forall a. Maybe a -> a -> a
`orElse` Bool
False
        }