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 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
makeQuickCheckTest :: TestID -> Location -> Assertion -> Test
makeQuickCheckTest id loc ass = BaseTest QuickCheckTest id (Just loc) ass
makeUnitTest :: TestID -> Location -> IO a -> Test
makeUnitTest id loc ass = BaseTest UnitTest id (Just loc) (ass >> return ())
makeBlackBoxTest :: TestID -> Assertion -> Test
makeBlackBoxTest id ass = BaseTest BlackBoxTest id Nothing 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 x) =
[FlatTest sort (TestPathBase id) mloc 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
runFlatTest :: FlatTest -> TR FlatTestResult
runFlatTest ft =
do reportTestStart ft
(res, time) <- liftIO $ measure $ HU.performTestCase (ft_payload ft)
let (testResult, (mLoc, callers, msg)) =
case res of
Nothing -> (Pass, (Nothing, [], ""))
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))
else let (r, s) = deserializeQuickCheckMsg msg'
in (r, (Nothing, [], s))
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 }
return rr
handleRunResult :: FlatTestResult -> TR ()
handleRunResult r =
do modify (\s -> s { ts_results = r : ts_results s })
reportTestResult r
runAllFlatTests :: [FlatTest] -> TR ()
runAllFlatTests tests =
do reportGlobalStart tests
mapM_ (\ft -> runFlatTest ft >>= handleRunResult) tests
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