{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE ScopedTypeVariables #-}
--
-- Copyright (c) 2009-2022   Stefan Wehr - http://www.stefanwehr.de
--
-- This library is free software; you can redistribute it and/or
-- modify it under the terms of the GNU Lesser General Public
-- License as published by the Free Software Foundation; either
-- version 2.1 of the License, or (at your option) any later version.
--
-- This library is distributed in the hope that it will be useful,
-- but WITHOUT ANY WARRANTY; without even the implied warranty of
-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-- Lesser General Public License for more details.
--
-- You should have received a copy of the GNU Lesser General Public
-- License along with this library; if not, write to the Free Software
-- Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307, USA
--

{- |

This module defines function for running a set of tests. Furthermore,
it provides functionality for organzing tests into a hierarchical
structure.

This functionality is mainly used internally in the code
generated by the @hftpp@ pre-processor.
-}

module Test.Framework.TestManager (

  -- * Re-exports
  module Test.Framework.TestTypes,

  -- * Running tests
  htfMain, htfMainWithArgs, runTest, runTest', runTestWithArgs, runTestWithArgs',
  runTestWithOptions, runTestWithOptions', runTestWithConfig, runTestWithConfig',

  -- * Organzing tests
  TestableHTF,
  WrappableHTF(..),

  makeQuickCheckTest, makeUnitTest, makeBlackBoxTest, makeTestSuite,
  makeAnonTestSuite,
  addToTestSuite, testSuiteAsTest,

  flattenTest,

  -- * Tests (for internal use)
  wrappableTests
) where

import Control.Monad.RWS
import System.Exit (ExitCode(..), exitWith)
import System.Environment (getArgs)
import qualified Control.Exception as Exc
import Data.Maybe
import Data.Time
import qualified Data.List as List
import qualified Data.ByteString as BS
import Data.IORef
import Control.Concurrent

import System.IO

import Test.Framework.Utils
import Test.Framework.TestInterface
import Test.Framework.TestTypes
import Test.Framework.CmdlineOptions
import Test.Framework.TestReporter
import Test.Framework.Location
import Test.Framework.Colors
import Test.Framework.ThreadPool
import Test.Framework.History

import qualified Test.HUnit as HU
-- | Construct a test where the given 'Assertion' checks a quick check property.
-- Mainly used internally by the htfpp preprocessor.
makeQuickCheckTest :: TestID -> Location -> Assertion -> Test
makeQuickCheckTest :: TestID -> Location -> Assertion -> Test
makeQuickCheckTest TestID
id Location
loc Assertion
ass = TestSort
-> TestID -> Maybe Location -> TestOptions -> Assertion -> Test
BaseTest TestSort
QuickCheckTest TestID
id (Location -> Maybe Location
forall a. a -> Maybe a
Just Location
loc) TestOptions
defaultTestOptions Assertion
ass

-- | Construct a unit test from the given 'IO' action.
-- Mainly used internally by the htfpp preprocessor.
makeUnitTest :: AssertionWithTestOptions a => TestID -> Location -> a -> Test
makeUnitTest :: TestID -> Location -> a -> Test
makeUnitTest TestID
id Location
loc a
ass =
    TestSort
-> TestID -> Maybe Location -> TestOptions -> Assertion -> Test
BaseTest TestSort
UnitTest TestID
id (Location -> Maybe Location
forall a. a -> Maybe a
Just Location
loc) (a -> TestOptions
forall a. AssertionWithTestOptions a => a -> TestOptions
testOptions a
ass) (a -> Assertion
forall a. AssertionWithTestOptions a => a -> Assertion
assertion a
ass)

-- | Construct a black box test from the given 'Assertion'.
-- Mainly used internally.
makeBlackBoxTest :: TestID -> Assertion -> Test
makeBlackBoxTest :: TestID -> Assertion -> Test
makeBlackBoxTest TestID
id Assertion
ass = TestSort
-> TestID -> Maybe Location -> TestOptions -> Assertion -> Test
BaseTest TestSort
BlackBoxTest TestID
id Maybe Location
forall a. Maybe a
Nothing TestOptions
defaultTestOptions Assertion
ass

-- | Create a named 'TestSuite' from a list of 'Test' values.
makeTestSuite :: TestID -> [Test] -> TestSuite
makeTestSuite :: TestID -> [Test] -> TestSuite
makeTestSuite = TestID -> [Test] -> TestSuite
TestSuite

-- | Create an unnamed 'TestSuite' from a list of 'Test' values.
makeAnonTestSuite :: [Test] -> TestSuite
makeAnonTestSuite :: [Test] -> TestSuite
makeAnonTestSuite = [Test] -> TestSuite
AnonTestSuite

-- | Turn a 'TestSuite' into a proper 'Test'.
testSuiteAsTest :: TestSuite -> Test
testSuiteAsTest :: TestSuite -> Test
testSuiteAsTest = TestSuite -> Test
CompoundTest

-- | Extend a 'TestSuite' with a list of 'Test' values
addToTestSuite :: TestSuite -> [Test] -> TestSuite
addToTestSuite :: TestSuite -> [Test] -> TestSuite
addToTestSuite (TestSuite TestID
id [Test]
ts) [Test]
ts' = TestID -> [Test] -> TestSuite
TestSuite TestID
id ([Test]
ts [Test] -> [Test] -> [Test]
forall a. [a] -> [a] -> [a]
++ [Test]
ts')
addToTestSuite (AnonTestSuite [Test]
ts) [Test]
ts' = [Test] -> TestSuite
AnonTestSuite ([Test]
ts [Test] -> [Test] -> [Test]
forall a. [a] -> [a] -> [a]
++ [Test]
ts')

-- | Kind of specialised 'Functor' type class for tests, which allows you to
-- modify the 'Assertion's of the 'WrappableHTF'-thing without changing any
-- test code.
--
-- E.g. if you want to add timeouts to all tests of a module, you could write:
--
-- > addTimeout test = timeout 100 test >>= assertJustVerbose "Timeout exceeded"
-- > testsWithTimeouts = wrap addTimeout htf_thisModulesTests
class WrappableHTF t where
    wrap :: (Assertion -> Assertion) -> t -> t

instance WrappableHTF TestSuite where
    wrap :: (Assertion -> Assertion) -> TestSuite -> TestSuite
wrap Assertion -> Assertion
wrapper (TestSuite TestID
tid [Test]
tests) = TestID -> [Test] -> TestSuite
TestSuite TestID
tid ([Test] -> TestSuite) -> [Test] -> TestSuite
forall a b. (a -> b) -> a -> b
$ (Test -> Test) -> [Test] -> [Test]
forall a b. (a -> b) -> [a] -> [b]
map ((Assertion -> Assertion) -> Test -> Test
forall t. WrappableHTF t => (Assertion -> Assertion) -> t -> t
wrap Assertion -> Assertion
wrapper) [Test]
tests
    wrap Assertion -> Assertion
wrapper (AnonTestSuite [Test]
tests) = [Test] -> TestSuite
AnonTestSuite ([Test] -> TestSuite) -> [Test] -> TestSuite
forall a b. (a -> b) -> a -> b
$ (Test -> Test) -> [Test] -> [Test]
forall a b. (a -> b) -> [a] -> [b]
map ((Assertion -> Assertion) -> Test -> Test
forall t. WrappableHTF t => (Assertion -> Assertion) -> t -> t
wrap Assertion -> Assertion
wrapper) [Test]
tests

instance WrappableHTF Test where
    wrap :: (Assertion -> Assertion) -> Test -> Test
wrap Assertion -> Assertion
wrapper (BaseTest TestSort
ts TestID
tid Maybe Location
loc TestOptions
topt Assertion
assertion) =
        TestSort
-> TestID -> Maybe Location -> TestOptions -> Assertion -> Test
BaseTest TestSort
ts TestID
tid Maybe Location
loc TestOptions
topt (Assertion -> Assertion
wrapper Assertion
assertion)
    wrap Assertion -> Assertion
wrapper (CompoundTest TestSuite
suite) = TestSuite -> Test
CompoundTest (TestSuite -> Test) -> TestSuite -> Test
forall a b. (a -> b) -> a -> b
$ (Assertion -> Assertion) -> TestSuite -> TestSuite
forall t. WrappableHTF t => (Assertion -> Assertion) -> t -> t
wrap Assertion -> Assertion
wrapper TestSuite
suite

-- | A type class for things that can be run as tests.
-- Mainly used internally.
class TestableHTF t where
    flatten :: t -> [FlatTest]

instance TestableHTF Test where
    flatten :: Test -> [FlatTest]
flatten = Test -> [FlatTest]
flattenTest

instance TestableHTF TestSuite where
    flatten :: TestSuite -> [FlatTest]
flatten = TestSuite -> [FlatTest]
flattenTestSuite

instance TestableHTF t => TestableHTF [t] where
    flatten :: [t] -> [FlatTest]
flatten = (t -> [FlatTest]) -> [t] -> [FlatTest]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap t -> [FlatTest]
forall t. TestableHTF t => t -> [FlatTest]
flatten

instance TestableHTF (IO a) where
    flatten :: IO a -> [FlatTest]
flatten IO a
action = Test -> [FlatTest]
forall t. TestableHTF t => t -> [FlatTest]
flatten (TestID -> Location -> IO a -> Test
forall a.
AssertionWithTestOptions a =>
TestID -> Location -> a -> Test
makeUnitTest TestID
"unnamed test" Location
unknownLocation IO a
action)

flattenTest :: Test -> [FlatTest]
flattenTest :: Test -> [FlatTest]
flattenTest (BaseTest TestSort
sort TestID
id Maybe Location
mloc TestOptions
opts Assertion
x) =
    [TestSort
-> TestPath
-> Maybe Location
-> WithTestOptions Assertion
-> FlatTest
forall a.
TestSort -> TestPath -> Maybe Location -> a -> GenFlatTest a
FlatTest TestSort
sort (TestID -> TestPath
TestPathBase TestID
id) Maybe Location
mloc (TestOptions -> Assertion -> WithTestOptions Assertion
forall a. TestOptions -> a -> WithTestOptions a
WithTestOptions TestOptions
opts Assertion
x)]
flattenTest (CompoundTest TestSuite
ts) =
    TestSuite -> [FlatTest]
flattenTestSuite TestSuite
ts

flattenTestSuite :: TestSuite -> [FlatTest]
flattenTestSuite :: TestSuite -> [FlatTest]
flattenTestSuite (TestSuite TestID
id [Test]
ts) =
    let fts :: [FlatTest]
fts = (Test -> [FlatTest]) -> [Test] -> [FlatTest]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Test -> [FlatTest]
flattenTest [Test]
ts
    in (FlatTest -> FlatTest) -> [FlatTest] -> [FlatTest]
forall a b. (a -> b) -> [a] -> [b]
map (\FlatTest
ft -> FlatTest
ft { ft_path :: TestPath
ft_path = Maybe TestID -> TestPath -> TestPath
TestPathCompound (TestID -> Maybe TestID
forall a. a -> Maybe a
Just TestID
id) (FlatTest -> TestPath
forall a. GenFlatTest a -> TestPath
ft_path FlatTest
ft) }) [FlatTest]
fts
flattenTestSuite (AnonTestSuite [Test]
ts) =
    let fts :: [FlatTest]
fts = (Test -> [FlatTest]) -> [Test] -> [FlatTest]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Test -> [FlatTest]
flattenTest [Test]
ts
    in (FlatTest -> FlatTest) -> [FlatTest] -> [FlatTest]
forall a b. (a -> b) -> [a] -> [b]
map (\FlatTest
ft -> FlatTest
ft { ft_path :: TestPath
ft_path = Maybe TestID -> TestPath -> TestPath
TestPathCompound Maybe TestID
forall a. Maybe a
Nothing (FlatTest -> TestPath
forall a. GenFlatTest a -> TestPath
ft_path FlatTest
ft) }) [FlatTest]
fts

maxRunTime :: TestConfig -> FlatTest -> Maybe Milliseconds
maxRunTime :: TestConfig -> FlatTest -> Maybe Milliseconds
maxRunTime TestConfig
tc FlatTest
ft =
    let mt1 :: Maybe Milliseconds
mt1 = TestConfig -> Maybe Milliseconds
tc_maxSingleTestTime TestConfig
tc
        mt2 :: Maybe Milliseconds
mt2 =
            case TestConfig -> Maybe Double
tc_prevFactor TestConfig
tc of
              Maybe Double
Nothing -> Maybe Milliseconds
forall a. Maybe a
Nothing
              Just Double
d ->
                  case Maybe Milliseconds -> Maybe Milliseconds -> Maybe Milliseconds
forall a. Ord a => a -> a -> a
max ((HistoricTestResult -> Milliseconds)
-> Maybe HistoricTestResult -> Maybe Milliseconds
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap HistoricTestResult -> Milliseconds
htr_timeMs (Text -> TestHistory -> Maybe HistoricTestResult
findHistoricSuccessfulTestResult (FlatTest -> Text
forall a. GenFlatTest a -> Text
historyKey FlatTest
ft) (TestConfig -> TestHistory
tc_history TestConfig
tc)))
                           ((HistoricTestResult -> Milliseconds)
-> Maybe HistoricTestResult -> Maybe Milliseconds
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap HistoricTestResult -> Milliseconds
htr_timeMs (Text -> TestHistory -> Maybe HistoricTestResult
findHistoricTestResult (FlatTest -> Text
forall a. GenFlatTest a -> Text
historyKey FlatTest
ft) (TestConfig -> TestHistory
tc_history TestConfig
tc)))
                  of
                    Maybe Milliseconds
Nothing -> Maybe Milliseconds
forall a. Maybe a
Nothing
                    Just Milliseconds
t -> Milliseconds -> Maybe Milliseconds
forall a. a -> Maybe a
Just (Milliseconds -> Maybe Milliseconds)
-> Milliseconds -> Maybe Milliseconds
forall a b. (a -> b) -> a -> b
$ Double -> Milliseconds
forall a b. (RealFrac a, Integral b) => a -> b
ceiling (Integer -> Double
forall a. Num a => Integer -> a
fromInteger (Milliseconds -> Integer
forall a. Integral a => a -> Integer
toInteger Milliseconds
t) Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
d)
    in case (Maybe Milliseconds
mt1, Maybe Milliseconds
mt2) of
         (Just Milliseconds
t1, Just Milliseconds
t2) -> Milliseconds -> Maybe Milliseconds
forall a. a -> Maybe a
Just (Milliseconds -> Milliseconds -> Milliseconds
forall a. Ord a => a -> a -> a
min Milliseconds
t1 Milliseconds
t2)
         (Maybe Milliseconds
_, Maybe Milliseconds
Nothing) -> Maybe Milliseconds
mt1
         (Maybe Milliseconds
Nothing, Maybe Milliseconds
_) -> Maybe Milliseconds
mt2

-- | HTF uses this function to execute the given assertion as a HTF test.
performTestHTF :: Assertion -> IO FullTestResult
performTestHTF :: Assertion -> IO FullTestResult
performTestHTF Assertion
action =
    do Assertion
action
       FullTestResult -> IO FullTestResult
forall (m :: * -> *) a. Monad m => a -> m a
return (TestResult -> Maybe TestID -> FullTestResult
mkFullTestResult TestResult
Pass Maybe TestID
forall a. Maybe a
Nothing)
     IO FullTestResult -> [Handler FullTestResult] -> IO FullTestResult
forall a. IO a -> [Handler a] -> IO a
`Exc.catches`
      [(HTFFailureException -> IO FullTestResult)
-> Handler FullTestResult
forall a e. Exception e => (e -> IO a) -> Handler a
Exc.Handler (\(HTFFailure FullTestResult
res) -> FullTestResult -> IO FullTestResult
forall (m :: * -> *) a. Monad m => a -> m a
return FullTestResult
res)
      ,(SomeException -> IO FullTestResult) -> Handler FullTestResult
forall a e. Exception e => (e -> IO a) -> Handler a
Exc.Handler SomeException -> IO FullTestResult
handleUnexpectedException]
    where
      handleUnexpectedException :: SomeException -> IO FullTestResult
handleUnexpectedException SomeException
exc =
          case SomeException -> Maybe AsyncException
forall e. Exception e => SomeException -> Maybe e
Exc.fromException SomeException
exc of
            Just (AsyncException
async :: Exc.AsyncException) ->
                case AsyncException
async of
                  AsyncException
Exc.StackOverflow -> SomeException -> IO FullTestResult
forall (m :: * -> *). Monad m => SomeException -> m FullTestResult
exceptionAsError SomeException
exc
                  AsyncException
_ -> SomeException -> IO FullTestResult
forall e a. Exception e => e -> IO a
Exc.throwIO SomeException
exc
            Maybe AsyncException
_ -> SomeException -> IO FullTestResult
forall (m :: * -> *). Monad m => SomeException -> m FullTestResult
exceptionAsError SomeException
exc
      exceptionAsError :: SomeException -> m FullTestResult
exceptionAsError SomeException
exc =
          FullTestResult -> m FullTestResult
forall (m :: * -> *) a. Monad m => a -> m a
return (TestResult -> Maybe TestID -> FullTestResult
mkFullTestResult TestResult
Error (TestID -> Maybe TestID
forall a. a -> Maybe a
Just (TestID -> Maybe TestID) -> TestID -> Maybe TestID
forall a b. (a -> b) -> a -> b
$ SomeException -> TestID
forall a. Show a => a -> TestID
show (SomeException
exc :: Exc.SomeException)))

data TimeoutResult a
    = TimeoutResultOk a
    | TimeoutResultException Exc.SomeException
    | TimeoutResultTimeout

timeout :: Int -> IO a -> IO (Maybe a)
timeout :: Milliseconds -> IO a -> IO (Maybe a)
timeout Milliseconds
microSecs IO a
action
    | Milliseconds
microSecs Milliseconds -> Milliseconds -> Bool
forall a. Ord a => a -> a -> Bool
< Milliseconds
0 = (a -> Maybe a) -> IO a -> IO (Maybe a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> Maybe a
forall a. a -> Maybe a
Just IO a
action
    | Milliseconds
microSecs Milliseconds -> Milliseconds -> Bool
forall a. Eq a => a -> a -> Bool
== Milliseconds
0 = Maybe a -> IO (Maybe a)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe a
forall a. Maybe a
Nothing
    | Bool
otherwise =
        do Chan (TimeoutResult a)
resultChan <- IO (Chan (TimeoutResult a))
forall a. IO (Chan a)
newChan
           IORef Bool
finishedVar <- Bool -> IO (IORef Bool)
forall a. a -> IO (IORef a)
newIORef Bool
False
           ThreadId
workerTid <- Assertion -> IO ThreadId
forkIO (Chan (TimeoutResult a) -> IORef Bool -> Assertion
wrappedAction Chan (TimeoutResult a)
resultChan IORef Bool
finishedVar)
           ThreadId
_ <- Assertion -> IO ThreadId
forkIO (Milliseconds -> Assertion
threadDelay Milliseconds
microSecs Assertion -> Assertion -> Assertion
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Chan (TimeoutResult a) -> TimeoutResult a -> Assertion
forall a. Chan a -> a -> Assertion
writeChan Chan (TimeoutResult a)
resultChan TimeoutResult a
forall a. TimeoutResult a
TimeoutResultTimeout)
           TimeoutResult a
res <- Chan (TimeoutResult a) -> IO (TimeoutResult a)
forall a. Chan a -> IO a
readChan Chan (TimeoutResult a)
resultChan
           case TimeoutResult a
res of
             TimeoutResult a
TimeoutResultTimeout ->
                 do IORef Bool -> (Bool -> (Bool, ())) -> Assertion
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef IORef Bool
finishedVar (\Bool
_ -> (Bool
True, ()))
                    ThreadId -> Assertion
killThread ThreadId
workerTid
                    Maybe a -> IO (Maybe a)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe a
forall a. Maybe a
Nothing
             TimeoutResultOk a
x ->
                 Maybe a -> IO (Maybe a)
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> Maybe a
forall a. a -> Maybe a
Just a
x)
             TimeoutResultException SomeException
exc ->
                 SomeException -> IO (Maybe a)
forall e a. Exception e => e -> IO a
Exc.throwIO SomeException
exc
    where
      wrappedAction :: Chan (TimeoutResult a) -> IORef Bool -> Assertion
wrappedAction Chan (TimeoutResult a)
resultChan IORef Bool
finishedVar =
          ((forall a. IO a -> IO a) -> Assertion) -> Assertion
forall b. ((forall a. IO a -> IO a) -> IO b) -> IO b
Exc.mask (((forall a. IO a -> IO a) -> Assertion) -> Assertion)
-> ((forall a. IO a -> IO a) -> Assertion) -> Assertion
forall a b. (a -> b) -> a -> b
$ \forall a. IO a -> IO a
restore ->
                   (do a
x <- IO a -> IO a
forall a. IO a -> IO a
restore IO a
action
                       Chan (TimeoutResult a) -> TimeoutResult a -> Assertion
forall a. Chan a -> a -> Assertion
writeChan Chan (TimeoutResult a)
resultChan (a -> TimeoutResult a
forall a. a -> TimeoutResult a
TimeoutResultOk a
x))
                   Assertion -> (SomeException -> Assertion) -> Assertion
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`Exc.catch`
                   (\(SomeException
exc::Exc.SomeException) ->
                        do Bool
b <- SomeException -> IORef Bool -> IO Bool
shouldReraiseException SomeException
exc IORef Bool
finishedVar
                           if Bool
b then SomeException -> Assertion
forall e a. Exception e => e -> IO a
Exc.throwIO SomeException
exc else Chan (TimeoutResult a) -> TimeoutResult a -> Assertion
forall a. Chan a -> a -> Assertion
writeChan Chan (TimeoutResult a)
resultChan (SomeException -> TimeoutResult a
forall a. SomeException -> TimeoutResult a
TimeoutResultException SomeException
exc))
      shouldReraiseException :: SomeException -> IORef Bool -> IO Bool
shouldReraiseException SomeException
exc IORef Bool
finishedVar =
          case SomeException -> Maybe AsyncException
forall e. Exception e => SomeException -> Maybe e
Exc.fromException SomeException
exc of
            Just (AsyncException
async :: Exc.AsyncException) ->
                case AsyncException
async of
                  AsyncException
Exc.ThreadKilled -> IORef Bool -> (Bool -> (Bool, Bool)) -> IO Bool
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef IORef Bool
finishedVar (\Bool
old -> (Bool
old, Bool
old))
                  AsyncException
_ -> Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
            Maybe AsyncException
_ -> Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False

data PrimTestResult
    = PrimTestResultNoTimeout FullTestResult
    | PrimTestResultTimeout

mkFlatTestRunner :: TestConfig -> FlatTest -> ThreadPoolEntry TR () (PrimTestResult, Milliseconds)
mkFlatTestRunner :: TestConfig
-> FlatTest -> ThreadPoolEntry TR () (PrimTestResult, Milliseconds)
mkFlatTestRunner TestConfig
tc FlatTest
ft = (TR ()
pre, () -> IO (PrimTestResult, Milliseconds)
forall p. p -> IO (PrimTestResult, Milliseconds)
action, Either SomeException (PrimTestResult, Milliseconds)
-> RWST TestConfig () TestState IO StopFlag
forall a.
Show a =>
Either a (PrimTestResult, Milliseconds)
-> RWST TestConfig () TestState IO StopFlag
post)
    where
      pre :: TR ()
pre = ReportTestStart
reportTestStart FlatTest
ft
      action :: p -> IO (PrimTestResult, Milliseconds)
action p
_ =
          let run :: IO FullTestResult
run = Assertion -> IO FullTestResult
performTestHTF (WithTestOptions Assertion -> Assertion
forall a. WithTestOptions a -> a
wto_payload (FlatTest -> WithTestOptions Assertion
forall a. GenFlatTest a -> a
ft_payload FlatTest
ft))
              runWithTimeout :: IO (PrimTestResult, Milliseconds)
runWithTimeout =
                  case TestConfig -> FlatTest -> Maybe Milliseconds
maxRunTime TestConfig
tc FlatTest
ft of
                    Maybe Milliseconds
Nothing ->
                        do (FullTestResult
res, Milliseconds
time) <- IO FullTestResult -> IO (FullTestResult, Milliseconds)
forall a. IO a -> IO (a, Milliseconds)
measure IO FullTestResult
run
                           (PrimTestResult, Milliseconds) -> IO (PrimTestResult, Milliseconds)
forall (m :: * -> *) a. Monad m => a -> m a
return (FullTestResult -> PrimTestResult
PrimTestResultNoTimeout FullTestResult
res, Milliseconds
time)
                    Just Milliseconds
maxMs ->
                         do Maybe (FullTestResult, Milliseconds)
mx <- Milliseconds
-> IO (FullTestResult, Milliseconds)
-> IO (Maybe (FullTestResult, Milliseconds))
forall a. Milliseconds -> IO a -> IO (Maybe a)
timeout (Milliseconds
1000 Milliseconds -> Milliseconds -> Milliseconds
forall a. Num a => a -> a -> a
* Milliseconds
maxMs) (IO (FullTestResult, Milliseconds)
 -> IO (Maybe (FullTestResult, Milliseconds)))
-> IO (FullTestResult, Milliseconds)
-> IO (Maybe (FullTestResult, Milliseconds))
forall a b. (a -> b) -> a -> b
$ IO FullTestResult -> IO (FullTestResult, Milliseconds)
forall a. IO a -> IO (a, Milliseconds)
measure IO FullTestResult
run
                            case Maybe (FullTestResult, Milliseconds)
mx of
                              Maybe (FullTestResult, Milliseconds)
Nothing -> (PrimTestResult, Milliseconds) -> IO (PrimTestResult, Milliseconds)
forall (m :: * -> *) a. Monad m => a -> m a
return (PrimTestResult
PrimTestResultTimeout, Milliseconds
maxMs)
                              Just (FullTestResult
res, Milliseconds
time) ->
                                  (PrimTestResult, Milliseconds) -> IO (PrimTestResult, Milliseconds)
forall (m :: * -> *) a. Monad m => a -> m a
return (FullTestResult -> PrimTestResult
PrimTestResultNoTimeout FullTestResult
res, Milliseconds
time)
              isPass :: PrimTestResult -> Bool
isPass PrimTestResult
primTestRes =
                  case PrimTestResult
primTestRes of
                    PrimTestResultNoTimeout FullTestResult
fullTestRes ->
                        FullTestResult -> Maybe TestResult
ftr_result FullTestResult
fullTestRes Maybe TestResult -> Maybe TestResult -> Bool
forall a. Eq a => a -> a -> Bool
== TestResult -> Maybe TestResult
forall a. a -> Maybe a
Just TestResult
Pass
                    PrimTestResult
PrimTestResultTimeout -> Bool
False
              iterRunWithTimeout :: t -> IO (PrimTestResult, Milliseconds)
iterRunWithTimeout t
i =
                  do (PrimTestResult
primTestRes, Milliseconds
time) <- IO (PrimTestResult, Milliseconds)
runWithTimeout
                     if PrimTestResult -> Bool
isPass PrimTestResult
primTestRes Bool -> Bool -> Bool
&& t
i t -> t -> Bool
forall a. Ord a => a -> a -> Bool
>= t
2
                       then t -> IO (PrimTestResult, Milliseconds)
iterRunWithTimeout (t
it -> t -> t
forall a. Num a => a -> a -> a
-t
1)
                       else (PrimTestResult, Milliseconds) -> IO (PrimTestResult, Milliseconds)
forall (m :: * -> *) a. Monad m => a -> m a
return (PrimTestResult
primTestRes, Milliseconds
time)
          in Milliseconds -> IO (PrimTestResult, Milliseconds)
forall t. (Ord t, Num t) => t -> IO (PrimTestResult, Milliseconds)
iterRunWithTimeout (TestConfig -> Milliseconds
tc_repeat TestConfig
tc)
      post :: Either a (PrimTestResult, Milliseconds)
-> RWST TestConfig () TestState IO StopFlag
post Either a (PrimTestResult, Milliseconds)
excOrResult =
          let (FullTestResult
testResult, Milliseconds
time) =
                 case Either a (PrimTestResult, Milliseconds)
excOrResult of
                   Left exc ->
                       (FullTestResult :: HtfStack -> Maybe ColorString -> Maybe TestResult -> FullTestResult
FullTestResult
                        { ftr_stack :: HtfStack
ftr_stack = HtfStack
emptyHtfStack
                        , ftr_message :: Maybe ColorString
ftr_message = ColorString -> Maybe ColorString
forall a. a -> Maybe a
Just (ColorString -> Maybe ColorString)
-> ColorString -> Maybe ColorString
forall a b. (a -> b) -> a -> b
$ TestID -> ColorString
noColor (TestID
"Running test unexpectedly failed: " TestID -> TestID -> TestID
forall a. [a] -> [a] -> [a]
++ a -> TestID
forall a. Show a => a -> TestID
show a
exc)
                        , ftr_result :: Maybe TestResult
ftr_result = TestResult -> Maybe TestResult
forall a. a -> Maybe a
Just TestResult
Error
                        }
                       ,(-Milliseconds
1))
                   Right (res, time) ->
                       case PrimTestResult
res of
                         PrimTestResult
PrimTestResultTimeout ->
                             (FullTestResult :: HtfStack -> Maybe ColorString -> Maybe TestResult -> FullTestResult
FullTestResult
                              { ftr_stack :: HtfStack
ftr_stack = HtfStack
emptyHtfStack
                              , ftr_message :: Maybe ColorString
ftr_message = ColorString -> Maybe ColorString
forall a. a -> Maybe a
Just (ColorString -> Maybe ColorString)
-> ColorString -> Maybe ColorString
forall a b. (a -> b) -> a -> b
$ Color -> TestID -> ColorString
colorize Color
warningColor TestID
"timeout"
                              , ftr_result :: Maybe TestResult
ftr_result = Maybe TestResult
forall a. Maybe a
Nothing
                              }
                             ,Milliseconds
time)
                         PrimTestResultNoTimeout FullTestResult
res ->
                             let res' :: FullTestResult
res' =
                                     if Maybe ColorString -> Bool
forall a. Maybe a -> Bool
isNothing (FullTestResult -> Maybe ColorString
ftr_message FullTestResult
res) Bool -> Bool -> Bool
&& Maybe TestResult -> Bool
forall a. Maybe a -> Bool
isNothing (FullTestResult -> Maybe TestResult
ftr_result FullTestResult
res)
                                     then FullTestResult
res { ftr_message :: Maybe ColorString
ftr_message = ColorString -> Maybe ColorString
forall a. a -> Maybe a
Just (Color -> TestID -> ColorString
colorize Color
warningColor TestID
"timeout") }
                                     else FullTestResult
res
                             in (FullTestResult
res', Milliseconds
time)
              (TestResult
sumRes, Bool
isTimeout) =
                  case FullTestResult -> Maybe TestResult
ftr_result FullTestResult
testResult of
                    Just TestResult
x -> (TestResult
x, Bool
False)
                    Maybe TestResult
Nothing -> (if TestConfig -> Bool
tc_timeoutIsSuccess TestConfig
tc then TestResult
Pass else TestResult
Error, Bool
True)
              rr :: GenFlatTest RunResult
rr = FlatTest :: forall a.
TestSort -> TestPath -> Maybe Location -> a -> GenFlatTest a
FlatTest
                     { ft_sort :: TestSort
ft_sort = FlatTest -> TestSort
forall a. GenFlatTest a -> TestSort
ft_sort FlatTest
ft
                     , ft_path :: TestPath
ft_path = FlatTest -> TestPath
forall a. GenFlatTest a -> TestPath
ft_path FlatTest
ft
                     , ft_location :: Maybe Location
ft_location = FlatTest -> Maybe Location
forall a. GenFlatTest a -> Maybe Location
ft_location FlatTest
ft
                     , ft_payload :: RunResult
ft_payload = TestResult
-> HtfStack -> ColorString -> Milliseconds -> Bool -> RunResult
RunResult TestResult
sumRes (FullTestResult -> HtfStack
ftr_stack FullTestResult
testResult)
                                              (ColorString -> Maybe ColorString -> ColorString
forall a. a -> Maybe a -> a
fromMaybe ColorString
emptyColorString (FullTestResult -> Maybe ColorString
ftr_message FullTestResult
testResult))
                                              Milliseconds
time Bool
isTimeout
                     }
          in do (TestState -> TestState) -> TR ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (\TestState
s -> TestState
s { ts_results :: [GenFlatTest RunResult]
ts_results = GenFlatTest RunResult
rr GenFlatTest RunResult
-> [GenFlatTest RunResult] -> [GenFlatTest RunResult]
forall a. a -> [a] -> [a]
: TestState -> [GenFlatTest RunResult]
ts_results TestState
s })
                ReportTestResult
reportTestResult GenFlatTest RunResult
rr
                StopFlag -> RWST TestConfig () TestState IO StopFlag
forall (m :: * -> *) a. Monad m => a -> m a
return (TestResult -> StopFlag
stopFlag TestResult
sumRes)
      stopFlag :: TestResult -> StopFlag
stopFlag TestResult
result =
          if Bool -> Bool
not (TestConfig -> Bool
tc_failFast TestConfig
tc)
          then StopFlag
DoNotStop
          else case TestResult
result of
                 TestResult
Pass -> StopFlag
DoNotStop
                 TestResult
Pending -> StopFlag
DoNotStop
                 TestResult
Fail -> StopFlag
DoStop
                 TestResult
Error -> StopFlag
DoStop

runAllFlatTests :: [FlatTest] -> TR ()
runAllFlatTests :: [FlatTest] -> TR ()
runAllFlatTests [FlatTest]
tests' =
    do TestConfig
tc <- RWST TestConfig () TestState IO TestConfig
forall r (m :: * -> *). MonadReader r m => m r
ask
       [FlatTest]
tests <- TestConfig
-> [FlatTest] -> RWST TestConfig () TestState IO [FlatTest]
forall a.
TestConfig
-> [GenFlatTest a]
-> RWST TestConfig () TestState IO [GenFlatTest a]
orderTests TestConfig
tc [FlatTest]
tests'
       [FlatTest] -> TR ()
reportGlobalStart [FlatTest]
tests
       case TestConfig -> Maybe Milliseconds
tc_threads TestConfig
tc of
         Maybe Milliseconds
Nothing ->
             let entries :: [ThreadPoolEntry TR () (PrimTestResult, Milliseconds)]
entries = (FlatTest -> ThreadPoolEntry TR () (PrimTestResult, Milliseconds))
-> [FlatTest]
-> [ThreadPoolEntry TR () (PrimTestResult, Milliseconds)]
forall a b. (a -> b) -> [a] -> [b]
map (TestConfig
-> FlatTest -> ThreadPoolEntry TR () (PrimTestResult, Milliseconds)
mkFlatTestRunner TestConfig
tc) [FlatTest]
tests
             in ThreadPool TR () (PrimTestResult, Milliseconds)
-> [ThreadPoolEntry TR () (PrimTestResult, Milliseconds)] -> TR ()
forall (m :: * -> *) a b.
ThreadPool m a b -> [ThreadPoolEntry m a b] -> m ()
tp_run ThreadPool TR () (PrimTestResult, Milliseconds)
forall (m :: * -> *) a b. MonadIO m => ThreadPool m a b
sequentialThreadPool [ThreadPoolEntry TR () (PrimTestResult, Milliseconds)]
entries
         Just Milliseconds
i ->
             let ([FlatTest]
ptests, [FlatTest]
stests) = (FlatTest -> Bool) -> [FlatTest] -> ([FlatTest], [FlatTest])
forall a. (a -> Bool) -> [a] -> ([a], [a])
List.partition (\FlatTest
t -> TestOptions -> Bool
to_parallel (WithTestOptions Assertion -> TestOptions
forall a. WithTestOptions a -> TestOptions
wto_options (FlatTest -> WithTestOptions Assertion
forall a. GenFlatTest a -> a
ft_payload FlatTest
t))) [FlatTest]
tests
                 pentries :: [ThreadPoolEntry TR () (PrimTestResult, Milliseconds)]
pentries = (FlatTest -> ThreadPoolEntry TR () (PrimTestResult, Milliseconds))
-> [FlatTest]
-> [ThreadPoolEntry TR () (PrimTestResult, Milliseconds)]
forall a b. (a -> b) -> [a] -> [b]
map (TestConfig
-> FlatTest -> ThreadPoolEntry TR () (PrimTestResult, Milliseconds)
mkFlatTestRunner TestConfig
tc) [FlatTest]
ptests
                 sentries :: [ThreadPoolEntry TR () (PrimTestResult, Milliseconds)]
sentries = (FlatTest -> ThreadPoolEntry TR () (PrimTestResult, Milliseconds))
-> [FlatTest]
-> [ThreadPoolEntry TR () (PrimTestResult, Milliseconds)]
forall a b. (a -> b) -> [a] -> [b]
map (TestConfig
-> FlatTest -> ThreadPoolEntry TR () (PrimTestResult, Milliseconds)
mkFlatTestRunner TestConfig
tc) [FlatTest]
stests
             in do ThreadPool TR () (PrimTestResult, Milliseconds)
tp <- Milliseconds
-> RWST
     TestConfig
     ()
     TestState
     IO
     (ThreadPool TR () (PrimTestResult, Milliseconds))
forall (m :: * -> *) a b.
MonadIO m =>
Milliseconds -> m (ThreadPool m a b)
parallelThreadPool Milliseconds
i
                   ThreadPool TR () (PrimTestResult, Milliseconds)
-> [ThreadPoolEntry TR () (PrimTestResult, Milliseconds)] -> TR ()
forall (m :: * -> *) a b.
ThreadPool m a b -> [ThreadPoolEntry m a b] -> m ()
tp_run ThreadPool TR () (PrimTestResult, Milliseconds)
tp [ThreadPoolEntry TR () (PrimTestResult, Milliseconds)]
pentries
                   ThreadPool TR () (PrimTestResult, Milliseconds)
-> [ThreadPoolEntry TR () (PrimTestResult, Milliseconds)] -> TR ()
forall (m :: * -> *) a b.
ThreadPool m a b -> [ThreadPoolEntry m a b] -> m ()
tp_run ThreadPool TR () (PrimTestResult, Milliseconds)
forall (m :: * -> *) a b. MonadIO m => ThreadPool m a b
sequentialThreadPool [ThreadPoolEntry TR () (PrimTestResult, Milliseconds)]
sentries
    where
      orderTests :: TestConfig
-> [GenFlatTest a]
-> RWST TestConfig () TestState IO [GenFlatTest a]
orderTests TestConfig
tc [GenFlatTest a]
ts
          | TestConfig -> Bool
tc_sortByPrevTime TestConfig
tc = [GenFlatTest a] -> RWST TestConfig () TestState IO [GenFlatTest a]
forall (m :: * -> *) a. Monad m => a -> m a
return ([GenFlatTest a]
 -> RWST TestConfig () TestState IO [GenFlatTest a])
-> [GenFlatTest a]
-> RWST TestConfig () TestState IO [GenFlatTest a]
forall a b. (a -> b) -> a -> b
$ TestConfig -> [GenFlatTest a] -> [GenFlatTest a]
forall a. TestConfig -> [GenFlatTest a] -> [GenFlatTest a]
sortByPrevTime TestConfig
tc [GenFlatTest a]
ts
          | TestConfig -> Bool
tc_shuffle TestConfig
tc = [GenFlatTest a] -> RWST TestConfig () TestState IO [GenFlatTest a]
forall a. [a] -> RWST TestConfig () TestState IO [a]
shuffleTests [GenFlatTest a]
ts
          | Bool
otherwise = [GenFlatTest a] -> RWST TestConfig () TestState IO [GenFlatTest a]
forall (m :: * -> *) a. Monad m => a -> m a
return [GenFlatTest a]
ts
      shuffleTests :: [a] -> RWST TestConfig () TestState IO [a]
shuffleTests = IO [a] -> RWST TestConfig () TestState IO [a]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [a] -> RWST TestConfig () TestState IO [a])
-> ([a] -> IO [a]) -> [a] -> RWST TestConfig () TestState IO [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [a] -> IO [a]
forall a. [a] -> IO [a]
shuffleIO
      sortByPrevTime :: TestConfig -> [GenFlatTest a] -> [GenFlatTest a]
sortByPrevTime TestConfig
tc [GenFlatTest a]
ts =
              ((Text, GenFlatTest a) -> GenFlatTest a)
-> [(Text, GenFlatTest a)] -> [GenFlatTest a]
forall a b. (a -> b) -> [a] -> [b]
map (Text, GenFlatTest a) -> GenFlatTest a
forall a b. (a, b) -> b
snd ([(Text, GenFlatTest a)] -> [GenFlatTest a])
-> [(Text, GenFlatTest a)] -> [GenFlatTest a]
forall a b. (a -> b) -> a -> b
$ ((Text, GenFlatTest a) -> (Text, GenFlatTest a) -> Ordering)
-> [(Text, GenFlatTest a)] -> [(Text, GenFlatTest a)]
forall a. (a -> a -> Ordering) -> [a] -> [a]
List.sortBy (TestConfig
-> (Text, GenFlatTest a) -> (Text, GenFlatTest a) -> Ordering
forall b b. TestConfig -> (Text, b) -> (Text, b) -> Ordering
compareTests TestConfig
tc) ((GenFlatTest a -> (Text, GenFlatTest a))
-> [GenFlatTest a] -> [(Text, GenFlatTest a)]
forall a b. (a -> b) -> [a] -> [b]
map (\GenFlatTest a
t -> (GenFlatTest a -> Text
forall a. GenFlatTest a -> Text
historyKey GenFlatTest a
t, GenFlatTest a
t)) [GenFlatTest a]
ts)
      compareTests :: TestConfig -> (Text, b) -> (Text, b) -> Ordering
compareTests TestConfig
tc (Text
t1, b
_) (Text
t2, b
_) =
          case (Maybe Milliseconds -> Maybe Milliseconds -> Maybe Milliseconds
forall a. Ord a => a -> a -> a
max ((HistoricTestResult -> Milliseconds)
-> Maybe HistoricTestResult -> Maybe Milliseconds
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap HistoricTestResult -> Milliseconds
htr_timeMs (Text -> TestHistory -> Maybe HistoricTestResult
findHistoricSuccessfulTestResult Text
t1 (TestConfig -> TestHistory
tc_history TestConfig
tc)))
                    ((HistoricTestResult -> Milliseconds)
-> Maybe HistoricTestResult -> Maybe Milliseconds
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap HistoricTestResult -> Milliseconds
htr_timeMs (Text -> TestHistory -> Maybe HistoricTestResult
findHistoricTestResult Text
t1 (TestConfig -> TestHistory
tc_history TestConfig
tc)))
               ,Maybe Milliseconds -> Maybe Milliseconds -> Maybe Milliseconds
forall a. Ord a => a -> a -> a
max ((HistoricTestResult -> Milliseconds)
-> Maybe HistoricTestResult -> Maybe Milliseconds
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap HistoricTestResult -> Milliseconds
htr_timeMs (Text -> TestHistory -> Maybe HistoricTestResult
findHistoricSuccessfulTestResult Text
t2 (TestConfig -> TestHistory
tc_history TestConfig
tc)))
                    ((HistoricTestResult -> Milliseconds)
-> Maybe HistoricTestResult -> Maybe Milliseconds
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap HistoricTestResult -> Milliseconds
htr_timeMs (Text -> TestHistory -> Maybe HistoricTestResult
findHistoricTestResult Text
t2 (TestConfig -> TestHistory
tc_history TestConfig
tc))))
          of
            (Just Milliseconds
t1, Just Milliseconds
t2) -> Milliseconds -> Milliseconds -> Ordering
forall a. Ord a => a -> a -> Ordering
compare Milliseconds
t1 Milliseconds
t2
            (Just Milliseconds
_, Maybe Milliseconds
Nothing) -> Ordering
GT
            (Maybe Milliseconds
Nothing, Just Milliseconds
_) -> Ordering
LT
            (Maybe Milliseconds
Nothing, Maybe Milliseconds
Nothing) -> Ordering
EQ

-- | Run something testable using the 'Test.Framework.TestConfig.defaultCmdlineOptions'.
runTest :: TestableHTF t => t              -- ^ Testable thing
                         -> IO ExitCode    -- ^ See 'runTestWithOptions' for a specification of the 'ExitCode' result
runTest :: t -> IO ExitCode
runTest = CmdlineOptions -> t -> IO ExitCode
forall t. TestableHTF t => CmdlineOptions -> t -> IO ExitCode
runTestWithOptions CmdlineOptions
defaultCmdlineOptions

-- | Run something testable using the 'Test.Framework.TestConfig.defaultCmdlineOptions'.
runTest' :: TestableHTF t => t              -- ^ Testable thing
                         -> IO (IO (), ExitCode)    -- ^ 'IO' action for printing the overall test results, and exit code for the test run. See 'runTestWithOptions' for a specification of the 'ExitCode' result
runTest' :: t -> IO (Assertion, ExitCode)
runTest' = CmdlineOptions -> t -> IO (Assertion, ExitCode)
forall t.
TestableHTF t =>
CmdlineOptions -> t -> IO (Assertion, ExitCode)
runTestWithOptions' CmdlineOptions
defaultCmdlineOptions

-- | Run something testable, parse the 'CmdlineOptions' from the given commandline arguments.
-- Does not print the overall test results but returns an 'IO' action for doing so.
runTestWithArgs :: TestableHTF t => [String]        -- ^ Commandline arguments
                                 -> t               -- ^ Testable thing
                                 -> IO ExitCode     -- ^ See 'runTestWithConfig' for a specification of the 'ExitCode' result.
runTestWithArgs :: [TestID] -> t -> IO ExitCode
runTestWithArgs [TestID]
args t
t =
    do (Assertion
printSummary, ExitCode
ecode) <- [TestID] -> t -> IO (Assertion, ExitCode)
forall t.
TestableHTF t =>
[TestID] -> t -> IO (Assertion, ExitCode)
runTestWithArgs' [TestID]
args t
t
       Assertion
printSummary
       ExitCode -> IO ExitCode
forall (m :: * -> *) a. Monad m => a -> m a
return ExitCode
ecode


-- | Run something testable, parse the 'CmdlineOptions' from the given commandline arguments.
runTestWithArgs' :: TestableHTF t => [String]        -- ^ Commandline arguments
                                 -> t               -- ^ Testable thing
                                 -> IO (IO (), ExitCode)  -- ^ 'IO' action for printing the overall test results, and exit code for the test run. See 'runTestWithConfig' for a specification of the 'ExitCode' result.
runTestWithArgs' :: [TestID] -> t -> IO (Assertion, ExitCode)
runTestWithArgs' [TestID]
args t
t =
    case [TestID] -> Either TestID CmdlineOptions
parseTestArgs [TestID]
args of
      Left TestID
err ->
          do Handle -> TestID -> Assertion
hPutStrLn Handle
stderr TestID
err
             (Assertion, ExitCode) -> IO (Assertion, ExitCode)
forall (m :: * -> *) a. Monad m => a -> m a
return ((Assertion, ExitCode) -> IO (Assertion, ExitCode))
-> (Assertion, ExitCode) -> IO (Assertion, ExitCode)
forall a b. (a -> b) -> a -> b
$ (() -> Assertion
forall (m :: * -> *) a. Monad m => a -> m a
return (), Milliseconds -> ExitCode
ExitFailure Milliseconds
1)
      Right CmdlineOptions
opts ->
          CmdlineOptions -> t -> IO (Assertion, ExitCode)
forall t.
TestableHTF t =>
CmdlineOptions -> t -> IO (Assertion, ExitCode)
runTestWithOptions' CmdlineOptions
opts t
t

-- | Runs something testable with the given 'CmdlineOptions'.
-- See 'runTestWithConfig' for a specification of the 'ExitCode' result.
runTestWithOptions :: TestableHTF t => CmdlineOptions -> t -> IO ExitCode
runTestWithOptions :: CmdlineOptions -> t -> IO ExitCode
runTestWithOptions CmdlineOptions
opts t
t =
    do (Assertion
printSummary, ExitCode
ecode) <- CmdlineOptions -> t -> IO (Assertion, ExitCode)
forall t.
TestableHTF t =>
CmdlineOptions -> t -> IO (Assertion, ExitCode)
runTestWithOptions' CmdlineOptions
opts t
t
       Assertion
printSummary
       ExitCode -> IO ExitCode
forall (m :: * -> *) a. Monad m => a -> m a
return ExitCode
ecode

-- | Runs something testable with the given 'CmdlineOptions'. Does not
-- print the overall test results but returns an 'IO' action for doing so.
-- See 'runTestWithConfig' for a specification of the 'ExitCode' result.
runTestWithOptions' :: TestableHTF t => CmdlineOptions -> t -> IO (IO (), ExitCode)
runTestWithOptions' :: CmdlineOptions -> t -> IO (Assertion, ExitCode)
runTestWithOptions' CmdlineOptions
opts t
t =
    if CmdlineOptions -> Bool
opts_help CmdlineOptions
opts
       then do Handle -> TestID -> Assertion
hPutStrLn Handle
stderr TestID
helpString
               (Assertion, ExitCode) -> IO (Assertion, ExitCode)
forall (m :: * -> *) a. Monad m => a -> m a
return ((Assertion, ExitCode) -> IO (Assertion, ExitCode))
-> (Assertion, ExitCode) -> IO (Assertion, ExitCode)
forall a b. (a -> b) -> a -> b
$ (() -> Assertion
forall (m :: * -> *) a. Monad m => a -> m a
return (), Milliseconds -> ExitCode
ExitFailure Milliseconds
1)
       else do TestConfig
tc <- CmdlineOptions -> IO TestConfig
testConfigFromCmdlineOptions CmdlineOptions
opts
               (Assertion
printSummary, ExitCode
ecode) <-
                   (if CmdlineOptions -> Bool
opts_listTests CmdlineOptions
opts
                      then let fts :: [FlatTest]
fts = (FlatTest -> Bool) -> [FlatTest] -> [FlatTest]
forall a. (a -> Bool) -> [a] -> [a]
filter (CmdlineOptions -> FlatTest -> Bool
opts_filter CmdlineOptions
opts) (t -> [FlatTest]
forall t. TestableHTF t => t -> [FlatTest]
flatten t
t)
                           in (Assertion, ExitCode) -> IO (Assertion, ExitCode)
forall (m :: * -> *) a. Monad m => a -> m a
return (TR () -> TestConfig -> TestState -> IO ((), TestState, ())
forall r w s (m :: * -> *) a.
RWST r w s m a -> r -> s -> m (a, s, w)
runRWST ([FlatTest] -> TR ()
reportAllTests [FlatTest]
fts) TestConfig
tc TestState
initTestState IO ((), TestState, ()) -> Assertion -> Assertion
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> () -> Assertion
forall (m :: * -> *) a. Monad m => a -> m a
return (), ExitCode
ExitSuccess)
                      else do (Assertion
printSummary, ExitCode
ecode, TestHistory
history) <- TestConfig -> t -> IO (Assertion, ExitCode, TestHistory)
forall t.
TestableHTF t =>
TestConfig -> t -> IO (Assertion, ExitCode, TestHistory)
runTestWithConfig' TestConfig
tc t
t
                              TestID -> TestHistory -> Assertion
storeHistory (TestConfig -> TestID
tc_historyFile TestConfig
tc) TestHistory
history
                              (Assertion, ExitCode) -> IO (Assertion, ExitCode)
forall (m :: * -> *) a. Monad m => a -> m a
return (Assertion
printSummary, ExitCode
ecode))
               (Assertion, ExitCode) -> IO (Assertion, ExitCode)
forall (m :: * -> *) a. Monad m => a -> m a
return (Assertion
printSummary Assertion -> Assertion -> Assertion
forall a b. IO a -> IO b -> IO a
`Exc.finally` TestConfig -> Assertion
cleanup TestConfig
tc, ExitCode
ecode)
    where
      cleanup :: TestConfig -> Assertion
cleanup TestConfig
tc =
          case TestConfig -> TestOutput
tc_output TestConfig
tc of
            TestOutputHandle Handle
h Bool
True -> Handle -> Assertion
hClose Handle
h
            TestOutput
_ -> () -> Assertion
forall (m :: * -> *) a. Monad m => a -> m a
return ()
      storeHistory :: TestID -> TestHistory -> Assertion
storeHistory TestID
file TestHistory
history =
          TestID -> ByteString -> Assertion
BS.writeFile TestID
file (TestHistory -> ByteString
serializeTestHistory TestHistory
history)
          Assertion -> (IOException -> Assertion) -> Assertion
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`Exc.catch` (\(IOException
e::Exc.IOException) ->
                          Handle -> TestID -> Assertion
hPutStrLn Handle
stderr (TestID
"Error storing HTF history into file " TestID -> TestID -> TestID
forall a. [a] -> [a] -> [a]
++ TestID
file TestID -> TestID -> TestID
forall a. [a] -> [a] -> [a]
++ TestID
": " TestID -> TestID -> TestID
forall a. [a] -> [a] -> [a]
++ IOException -> TestID
forall a. Show a => a -> TestID
show IOException
e))

-- | Runs something testable with the given 'TestConfig'.
-- The result is 'ExitSuccess' if all tests were executed successfully,
-- 'ExitFailure' otherwise. In the latter case, an error code of @1@ indicates
-- that failures but no errors occurred, otherwise the error code @2@ is used.
--
-- A test is /successful/ if the test terminates and no assertion fails.
-- A test is said to /fail/ if an assertion fails but no other error occur.
runTestWithConfig :: TestableHTF t => TestConfig -> t -> IO (ExitCode, TestHistory)
runTestWithConfig :: TestConfig -> t -> IO (ExitCode, TestHistory)
runTestWithConfig TestConfig
tc t
t =
    do (Assertion
printSummary, ExitCode
ecode, TestHistory
history) <- TestConfig -> t -> IO (Assertion, ExitCode, TestHistory)
forall t.
TestableHTF t =>
TestConfig -> t -> IO (Assertion, ExitCode, TestHistory)
runTestWithConfig' TestConfig
tc t
t
       Assertion
printSummary
       (ExitCode, TestHistory) -> IO (ExitCode, TestHistory)
forall (m :: * -> *) a. Monad m => a -> m a
return (ExitCode
ecode, TestHistory
history)

-- | Runs something testable with the given 'TestConfig'. Does not
-- print the overall test results but returns an 'IO' action for doing so.
-- See 'runTestWithConfig' for a specification of the 'ExitCode' result.
runTestWithConfig' :: TestableHTF t => TestConfig -> t -> IO (IO (), ExitCode, TestHistory)
runTestWithConfig' :: TestConfig -> t -> IO (Assertion, ExitCode, TestHistory)
runTestWithConfig' TestConfig
tc t
t =
     do let allTests :: [FlatTest]
allTests = t -> [FlatTest]
forall t. TestableHTF t => t -> [FlatTest]
flatten t
t
            activeTests :: [FlatTest]
activeTests = (FlatTest -> Bool) -> [FlatTest] -> [FlatTest]
forall a. (a -> Bool) -> [a] -> [a]
filter (TestConfig -> FlatTest -> Bool
tc_filter TestConfig
tc) [FlatTest]
allTests
            filteredTests :: [FlatTest]
filteredTests = (FlatTest -> Bool) -> [FlatTest] -> [FlatTest]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (FlatTest -> Bool) -> FlatTest -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TestConfig -> FlatTest -> Bool
tc_filter TestConfig
tc) [FlatTest]
allTests
        UTCTime
startTime <- IO UTCTime
getCurrentTime
        ((()
_, TestState
s, ()
_), Milliseconds
time) <-
            IO ((), TestState, ()) -> IO (((), TestState, ()), Milliseconds)
forall a. IO a -> IO (a, Milliseconds)
measure (IO ((), TestState, ()) -> IO (((), TestState, ()), Milliseconds))
-> IO ((), TestState, ()) -> IO (((), TestState, ()), Milliseconds)
forall a b. (a -> b) -> a -> b
$
            TR () -> TestConfig -> TestState -> IO ((), TestState, ())
forall r w s (m :: * -> *) a.
RWST r w s m a -> r -> s -> m (a, s, w)
runRWST ([FlatTest] -> TR ()
runAllFlatTests [FlatTest]
activeTests) TestConfig
tc TestState
initTestState
        let results :: [GenFlatTest RunResult]
results = [GenFlatTest RunResult] -> [GenFlatTest RunResult]
forall a. [a] -> [a]
reverse (TestState -> [GenFlatTest RunResult]
ts_results TestState
s)
            passed :: [GenFlatTest RunResult]
passed = (GenFlatTest RunResult -> Bool)
-> [GenFlatTest RunResult] -> [GenFlatTest RunResult]
forall a. (a -> Bool) -> [a] -> [a]
filter (\GenFlatTest RunResult
ft -> (RunResult -> TestResult
rr_result (RunResult -> TestResult)
-> (GenFlatTest RunResult -> RunResult)
-> GenFlatTest RunResult
-> TestResult
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenFlatTest RunResult -> RunResult
forall a. GenFlatTest a -> a
ft_payload) GenFlatTest RunResult
ft TestResult -> TestResult -> Bool
forall a. Eq a => a -> a -> Bool
== TestResult
Pass) [GenFlatTest RunResult]
results
            pending :: [GenFlatTest RunResult]
pending = (GenFlatTest RunResult -> Bool)
-> [GenFlatTest RunResult] -> [GenFlatTest RunResult]
forall a. (a -> Bool) -> [a] -> [a]
filter (\GenFlatTest RunResult
ft -> (RunResult -> TestResult
rr_result (RunResult -> TestResult)
-> (GenFlatTest RunResult -> RunResult)
-> GenFlatTest RunResult
-> TestResult
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenFlatTest RunResult -> RunResult
forall a. GenFlatTest a -> a
ft_payload) GenFlatTest RunResult
ft TestResult -> TestResult -> Bool
forall a. Eq a => a -> a -> Bool
== TestResult
Pending) [GenFlatTest RunResult]
results
            failed :: [GenFlatTest RunResult]
failed = (GenFlatTest RunResult -> Bool)
-> [GenFlatTest RunResult] -> [GenFlatTest RunResult]
forall a. (a -> Bool) -> [a] -> [a]
filter (\GenFlatTest RunResult
ft -> (RunResult -> TestResult
rr_result (RunResult -> TestResult)
-> (GenFlatTest RunResult -> RunResult)
-> GenFlatTest RunResult
-> TestResult
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenFlatTest RunResult -> RunResult
forall a. GenFlatTest a -> a
ft_payload) GenFlatTest RunResult
ft TestResult -> TestResult -> Bool
forall a. Eq a => a -> a -> Bool
== TestResult
Fail) [GenFlatTest RunResult]
results
            error :: [GenFlatTest RunResult]
error = (GenFlatTest RunResult -> Bool)
-> [GenFlatTest RunResult] -> [GenFlatTest RunResult]
forall a. (a -> Bool) -> [a] -> [a]
filter (\GenFlatTest RunResult
ft -> (RunResult -> TestResult
rr_result (RunResult -> TestResult)
-> (GenFlatTest RunResult -> RunResult)
-> GenFlatTest RunResult
-> TestResult
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenFlatTest RunResult -> RunResult
forall a. GenFlatTest a -> a
ft_payload) GenFlatTest RunResult
ft TestResult -> TestResult -> Bool
forall a. Eq a => a -> a -> Bool
== TestResult
Error) [GenFlatTest RunResult]
results
            timedOut :: [GenFlatTest RunResult]
timedOut = (GenFlatTest RunResult -> Bool)
-> [GenFlatTest RunResult] -> [GenFlatTest RunResult]
forall a. (a -> Bool) -> [a] -> [a]
filter (\GenFlatTest RunResult
ft -> (RunResult -> Bool
rr_timeout (RunResult -> Bool)
-> (GenFlatTest RunResult -> RunResult)
-> GenFlatTest RunResult
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenFlatTest RunResult -> RunResult
forall a. GenFlatTest a -> a
ft_payload) GenFlatTest RunResult
ft) [GenFlatTest RunResult]
results
            arg :: ReportGlobalResultsArg
arg = ReportGlobalResultsArg :: Milliseconds
-> [GenFlatTest RunResult]
-> [GenFlatTest RunResult]
-> [GenFlatTest RunResult]
-> [GenFlatTest RunResult]
-> [GenFlatTest RunResult]
-> [FlatTest]
-> ReportGlobalResultsArg
ReportGlobalResultsArg
                  { rgra_timeMs :: Milliseconds
rgra_timeMs = Milliseconds
time
                  , rgra_passed :: [GenFlatTest RunResult]
rgra_passed = [GenFlatTest RunResult]
passed
                  , rgra_pending :: [GenFlatTest RunResult]
rgra_pending = [GenFlatTest RunResult]
pending
                  , rgra_failed :: [GenFlatTest RunResult]
rgra_failed = [GenFlatTest RunResult]
failed
                  , rgra_errors :: [GenFlatTest RunResult]
rgra_errors = [GenFlatTest RunResult]
error
                  , rgra_timedOut :: [GenFlatTest RunResult]
rgra_timedOut = [GenFlatTest RunResult]
timedOut
                  , rgra_filtered :: [FlatTest]
rgra_filtered = [FlatTest]
filteredTests
    }
        let printSummary :: IO ((), TestState, ())
printSummary =
                TR () -> TestConfig -> TestState -> IO ((), TestState, ())
forall r w s (m :: * -> *) a.
RWST r w s m a -> r -> s -> m (a, s, w)
runRWST (ReportGlobalResults
reportGlobalResults ReportGlobalResultsArg
arg) TestConfig
tc ([GenFlatTest RunResult] -> Milliseconds -> TestState
TestState [] (TestState -> Milliseconds
ts_index TestState
s)) -- keep index from run
            !newHistory :: TestHistory
newHistory = UTCTime -> [GenFlatTest RunResult] -> TestHistory -> TestHistory
updateHistory UTCTime
startTime [GenFlatTest RunResult]
results (TestConfig -> TestHistory
tc_history TestConfig
tc)
        (Assertion, ExitCode, TestHistory)
-> IO (Assertion, ExitCode, TestHistory)
forall (m :: * -> *) a. Monad m => a -> m a
return (IO ((), TestState, ())
printSummary IO ((), TestState, ()) -> Assertion -> Assertion
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> () -> Assertion
forall (m :: * -> *) a. Monad m => a -> m a
return (),
                case () of
                   ()
_| [GenFlatTest RunResult] -> Milliseconds
forall (t :: * -> *) a. Foldable t => t a -> Milliseconds
length [GenFlatTest RunResult]
failed Milliseconds -> Milliseconds -> Bool
forall a. Eq a => a -> a -> Bool
== Milliseconds
0 Bool -> Bool -> Bool
&& [GenFlatTest RunResult] -> Milliseconds
forall (t :: * -> *) a. Foldable t => t a -> Milliseconds
length [GenFlatTest RunResult]
error Milliseconds -> Milliseconds -> Bool
forall a. Eq a => a -> a -> Bool
== Milliseconds
0 -> ExitCode
ExitSuccess
                    | [GenFlatTest RunResult] -> Milliseconds
forall (t :: * -> *) a. Foldable t => t a -> Milliseconds
length [GenFlatTest RunResult]
error Milliseconds -> Milliseconds -> Bool
forall a. Eq a => a -> a -> Bool
== Milliseconds
0 -> Milliseconds -> ExitCode
ExitFailure Milliseconds
1
                    | Bool
otherwise -> Milliseconds -> ExitCode
ExitFailure Milliseconds
2
               ,TestHistory
newHistory)
    where
      updateHistory :: UTCTime -> [FlatTestResult] -> TestHistory -> TestHistory
      updateHistory :: UTCTime -> [GenFlatTest RunResult] -> TestHistory -> TestHistory
updateHistory UTCTime
time [GenFlatTest RunResult]
results TestHistory
history =
          let runHistory :: TestRunHistory
runHistory = UTCTime -> [HistoricTestResult] -> TestRunHistory
mkTestRunHistory UTCTime
time ((GenFlatTest RunResult -> HistoricTestResult)
-> [GenFlatTest RunResult] -> [HistoricTestResult]
forall a b. (a -> b) -> [a] -> [b]
map (\GenFlatTest RunResult
res -> HistoricTestResult :: Text -> TestResult -> Bool -> Milliseconds -> HistoricTestResult
HistoricTestResult {
                                                                 htr_testId :: Text
htr_testId = GenFlatTest RunResult -> Text
forall a. GenFlatTest a -> Text
historyKey GenFlatTest RunResult
res
                                                               , htr_result :: TestResult
htr_result = RunResult -> TestResult
rr_result (GenFlatTest RunResult -> RunResult
forall a. GenFlatTest a -> a
ft_payload GenFlatTest RunResult
res)
                                                               , htr_timedOut :: Bool
htr_timedOut = RunResult -> Bool
rr_timeout (GenFlatTest RunResult -> RunResult
forall a. GenFlatTest a -> a
ft_payload GenFlatTest RunResult
res)
                                                               , htr_timeMs :: Milliseconds
htr_timeMs = RunResult -> Milliseconds
rr_wallTimeMs (GenFlatTest RunResult -> RunResult
forall a. GenFlatTest a -> a
ft_payload GenFlatTest RunResult
res)
                                                               })
                                                      [GenFlatTest RunResult]
results)
          in TestRunHistory -> TestHistory -> TestHistory
updateTestHistory TestRunHistory
runHistory TestHistory
history

-- | Runs something testable by parsing the commandline arguments as test options
-- (using 'parseTestArgs'). Exits with the exit code returned by 'runTestWithArgs'.
-- This function is the main entry point for running tests.
htfMain :: TestableHTF t => t -> IO ()
htfMain :: t -> Assertion
htfMain t
tests =
    do [TestID]
args <- IO [TestID]
getArgs
       [TestID] -> t -> Assertion
forall t. TestableHTF t => [TestID] -> t -> Assertion
htfMainWithArgs [TestID]
args t
tests

-- | Runs something testable by parsing the commandline arguments as test options
-- (using 'parseTestArgs'). Exits with the exit code returned by 'runTestWithArgs'.
htfMainWithArgs :: TestableHTF t => [String] -> t -> IO ()
htfMainWithArgs :: [TestID] -> t -> Assertion
htfMainWithArgs [TestID]
args t
tests =
    do ExitCode
ecode <- [TestID] -> t -> IO ExitCode
forall t. TestableHTF t => [TestID] -> t -> IO ExitCode
runTestWithArgs [TestID]
args t
tests
       ExitCode -> Assertion
forall a. ExitCode -> IO a
exitWith ExitCode
ecode

testWrapCanCauseFailure :: IO ()
testWrapCanCauseFailure :: Assertion
testWrapCanCauseFailure =
    do TestID -> ExitCode -> ExitCode -> Assertion
forall a.
(HasCallStack, Eq a, Show a) =>
TestID -> a -> a -> Assertion
HU.assertEqual TestID
"plain unit test passes" ExitCode
ExitSuccess (ExitCode -> Assertion) -> IO ExitCode -> Assertion
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Test -> IO ExitCode
forall t. TestableHTF t => t -> IO ExitCode
runTest Test
unitTest
       TestID -> ExitCode -> ExitCode -> Assertion
forall a.
(HasCallStack, Eq a, Show a) =>
TestID -> a -> a -> Assertion
HU.assertEqual TestID
"wrapped unit test fails" (Milliseconds -> ExitCode
ExitFailure Milliseconds
2) (ExitCode -> Assertion) -> IO ExitCode -> Assertion
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Test -> IO ExitCode
forall t. TestableHTF t => t -> IO ExitCode
runTest Test
wrappedUnitTest
    where
      unitTest :: Test
unitTest = TestSort
-> TestID -> Maybe Location -> TestOptions -> Assertion -> Test
BaseTest TestSort
UnitTest TestID
"unitTest" Maybe Location
forall a. Maybe a
Nothing TestOptions
defaultTestOptions (() -> Assertion
forall (m :: * -> *) a. Monad m => a -> m a
return ())
      wrappedUnitTest :: Test
wrappedUnitTest = (Assertion -> Assertion) -> Test -> Test
forall t. WrappableHTF t => (Assertion -> Assertion) -> t -> t
wrap Assertion -> Assertion
forall a. IO a -> IO a
wrapper Test
unitTest
      wrapper :: IO b -> IO b
wrapper IO b
test = TestID -> IO Any
forall a. HasCallStack => TestID -> IO a
HU.assertFailure TestID
"Fail" IO Any -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO b
test

wrappableTests :: [(TestID, Assertion)]
wrappableTests = [(TestID
"testWrapCanCauseFailure", Assertion
testWrapCanCauseFailure)]