module Test.Framework.TestManager (
module Test.Framework.TestTypes,
htfMain, runTest, runTest', runTestWithArgs, runTestWithArgs',
runTestWithOptions, runTestWithOptions', runTestWithConfig, runTestWithConfig',
TestableHTF,
makeQuickCheckTest, makeUnitTest, makeBlackBoxTest, makeTestSuite,
makeAnonTestSuite,
addToTestSuite, testSuiteAsTest,
) where
import Control.Monad.RWS
import System.Exit (ExitCode(..), exitWith)
import System.Environment (getArgs)
import Control.Exception (finally)
import qualified Data.List as List
import System.IO
import qualified Test.HUnit.Lang as HU
import Test.Framework.Utils
import Test.Framework.TestManagerInternal
import Test.Framework.TestTypes
import Test.Framework.CmdlineOptions
import Test.Framework.TestReporter
import Test.Framework.Location
import Test.Framework.Colors
import Test.Framework.ThreadPool
makeQuickCheckTest :: TestID -> Location -> Assertion -> Test
makeQuickCheckTest id loc ass = BaseTest QuickCheckTest id (Just loc) defaultTestOptions ass
makeUnitTest :: AssertionWithTestOptions a => TestID -> Location -> a -> Test
makeUnitTest id loc ass =
BaseTest UnitTest id (Just loc) (testOptions ass) (assertion ass)
makeBlackBoxTest :: TestID -> Assertion -> Test
makeBlackBoxTest id ass = BaseTest BlackBoxTest id Nothing defaultTestOptions ass
makeTestSuite :: TestID -> [Test] -> TestSuite
makeTestSuite = TestSuite
makeAnonTestSuite :: [Test] -> TestSuite
makeAnonTestSuite = AnonTestSuite
testSuiteAsTest :: TestSuite -> Test
testSuiteAsTest = CompoundTest
addToTestSuite :: TestSuite -> [Test] -> TestSuite
addToTestSuite (TestSuite id ts) ts' = TestSuite id (ts ++ ts')
addToTestSuite (AnonTestSuite ts) ts' = AnonTestSuite (ts ++ ts')
class TestableHTF t where
flatten :: t -> [FlatTest]
instance TestableHTF Test where
flatten = flattenTest
instance TestableHTF TestSuite where
flatten = flattenTestSuite
instance TestableHTF t => TestableHTF [t] where
flatten = concatMap flatten
instance TestableHTF (IO a) where
flatten action = flatten (makeUnitTest "unnamed test" unknownLocation action)
flattenTest :: Test -> [FlatTest]
flattenTest (BaseTest sort id mloc opts x) =
[FlatTest sort (TestPathBase id) mloc (WithTestOptions opts x)]
flattenTest (CompoundTest ts) =
flattenTestSuite ts
flattenTestSuite :: TestSuite -> [FlatTest]
flattenTestSuite (TestSuite id ts) =
let fts = concatMap flattenTest ts
in map (\ft -> ft { ft_path = TestPathCompound (Just id) (ft_path ft) }) fts
flattenTestSuite (AnonTestSuite ts) =
let fts = concatMap flattenTest ts
in map (\ft -> ft { ft_path = TestPathCompound Nothing (ft_path ft) }) fts
mkFlatTestRunner :: FlatTest -> ThreadPoolEntry TR () (Maybe (Bool, String), Int)
mkFlatTestRunner ft = (pre, action, post)
where
pre = reportTestStart ft
action _ = measure $ HU.performTestCase (wto_payload (ft_payload ft))
post excOrResult =
let (testResult, (mLoc, callers, msg, time)) =
case excOrResult of
Left exc -> (Error, (Nothing,
[],
noColor ("Running test unexpectedly failed: " ++ show exc),
(1)))
Right (res, time) ->
case res of
Nothing -> (Pass, (Nothing, [], emptyColorString, time))
Just (isFailure, msg') ->
if ft_sort ft /= QuickCheckTest
then let utr = deserializeHUnitMsg msg'
r = case () of
_| utr_pending utr -> Pending
| isFailure -> Fail
| otherwise -> Error
in (r, (utr_location utr, utr_callingLocations utr, utr_message utr, time))
else let (r, s) = deserializeQuickCheckMsg msg'
in (r, (Nothing, [], noColor s, time))
rr = FlatTest
{ ft_sort = ft_sort ft
, ft_path = ft_path ft
, ft_location = ft_location ft
, ft_payload = RunResult testResult mLoc callers msg time }
in do modify (\s -> s { ts_results = rr : ts_results s })
reportTestResult rr
runAllFlatTests :: [FlatTest] -> TR ()
runAllFlatTests tests =
do reportGlobalStart tests
tc <- ask
case tc_threads tc of
Nothing ->
let entries = map mkFlatTestRunner tests
in tp_run sequentialThreadPool entries
Just i ->
let (ptests, stests) = List.partition (\t -> to_parallel (wto_options (ft_payload t))) tests
pentries' = map mkFlatTestRunner ptests
sentries = map mkFlatTestRunner stests
in do tp <- parallelThreadPool i
pentries <- if tc_shuffle tc
then liftIO (shuffleIO pentries')
else return pentries'
tp_run tp pentries
tp_run sequentialThreadPool sentries
runTest :: TestableHTF t => t
-> IO ExitCode
runTest = runTestWithOptions defaultCmdlineOptions
runTest' :: TestableHTF t => t
-> IO (IO (), ExitCode)
runTest' = runTestWithOptions' defaultCmdlineOptions
runTestWithArgs :: TestableHTF t => [String]
-> t
-> IO ExitCode
runTestWithArgs args t =
do (printSummary, ecode) <- runTestWithArgs' args t
printSummary
return ecode
runTestWithArgs' :: TestableHTF t => [String]
-> t
-> IO (IO (), ExitCode)
runTestWithArgs' args t =
case parseTestArgs args of
Left err ->
do hPutStrLn stderr err
return $ (return (), ExitFailure 1)
Right opts ->
runTestWithOptions' opts t
runTestWithOptions :: TestableHTF t => CmdlineOptions -> t -> IO ExitCode
runTestWithOptions opts t =
do (printSummary, ecode) <- runTestWithOptions' opts t
printSummary
return ecode
runTestWithOptions' :: TestableHTF t => CmdlineOptions -> t -> IO (IO (), ExitCode)
runTestWithOptions' opts t =
if opts_help opts
then do hPutStrLn stderr helpString
return $ (return (), ExitFailure 1)
else do tc <- testConfigFromCmdlineOptions opts
(printSummary, ecode) <-
(if opts_listTests opts
then let fts = filter (opts_filter opts) (flatten t)
in return (runRWST (reportAllTests fts) tc initTestState >> return (), ExitSuccess)
else runTestWithConfig' tc t)
return (printSummary `finally` cleanup tc, ecode)
where
cleanup tc =
case tc_output tc of
TestOutputHandle h True -> hClose h
_ -> return ()
runTestWithConfig :: TestableHTF t => TestConfig -> t -> IO ExitCode
runTestWithConfig tc t =
do (printSummary, ecode) <- runTestWithConfig' tc t
printSummary
return ecode
runTestWithConfig' :: TestableHTF t => TestConfig -> t -> IO (IO (), ExitCode)
runTestWithConfig' tc t =
do ((_, s, _), time) <-
measure $
runRWST (runAllFlatTests (filter (tc_filter tc) (flatten t))) tc initTestState
let results = reverse (ts_results s)
passed = filter (\ft -> (rr_result . ft_payload) ft == Pass) results
pending = filter (\ft -> (rr_result . ft_payload) ft == Pending) results
failed = filter (\ft -> (rr_result . ft_payload) ft == Fail) results
error = filter (\ft -> (rr_result . ft_payload) ft == Error) results
let printSummary =
runRWST (reportGlobalResults time passed pending failed error) tc (TestState [] (ts_index s))
return (printSummary >> return (),
case () of
_| length failed == 0 && length error == 0 -> ExitSuccess
| length error == 0 -> ExitFailure 1
| otherwise -> ExitFailure 2)
htfMain :: TestableHTF t => t -> IO ()
htfMain tests =
do args <- getArgs
ecode <- runTestWithArgs args tests
exitWith ecode