{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Test.Framework.TestInterface (
Assertion, TestResult(..), FullTestResult(..), HTFFailureException(..), failHTF, subAssertHTF
, mkFullTestResult
) where
import Test.Framework.Location
import Test.Framework.Colors
import Control.Monad.Trans.Control
import Data.Typeable
import qualified Control.Exception as Exc
import qualified Control.Exception.Lifted as ExcLifted
type Assertion = IO ()
data TestResult = Pass | Pending | Fail | Error
deriving (Int -> TestResult -> ShowS
[TestResult] -> ShowS
TestResult -> String
(Int -> TestResult -> ShowS)
-> (TestResult -> String)
-> ([TestResult] -> ShowS)
-> Show TestResult
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [TestResult] -> ShowS
$cshowList :: [TestResult] -> ShowS
show :: TestResult -> String
$cshow :: TestResult -> String
showsPrec :: Int -> TestResult -> ShowS
$cshowsPrec :: Int -> TestResult -> ShowS
Show, ReadPrec [TestResult]
ReadPrec TestResult
Int -> ReadS TestResult
ReadS [TestResult]
(Int -> ReadS TestResult)
-> ReadS [TestResult]
-> ReadPrec TestResult
-> ReadPrec [TestResult]
-> Read TestResult
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [TestResult]
$creadListPrec :: ReadPrec [TestResult]
readPrec :: ReadPrec TestResult
$creadPrec :: ReadPrec TestResult
readList :: ReadS [TestResult]
$creadList :: ReadS [TestResult]
readsPrec :: Int -> ReadS TestResult
$creadsPrec :: Int -> ReadS TestResult
Read, TestResult -> TestResult -> Bool
(TestResult -> TestResult -> Bool)
-> (TestResult -> TestResult -> Bool) -> Eq TestResult
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: TestResult -> TestResult -> Bool
$c/= :: TestResult -> TestResult -> Bool
== :: TestResult -> TestResult -> Bool
$c== :: TestResult -> TestResult -> Bool
Eq)
data FullTestResult
= FullTestResult
{ FullTestResult -> Maybe Location
ftr_location :: Maybe Location
, FullTestResult -> [(Maybe String, Location)]
ftr_callingLocations :: [(Maybe String, Location)]
, FullTestResult -> Maybe ColorString
ftr_message :: Maybe ColorString
, FullTestResult -> Maybe TestResult
ftr_result :: Maybe TestResult
} deriving (FullTestResult -> FullTestResult -> Bool
(FullTestResult -> FullTestResult -> Bool)
-> (FullTestResult -> FullTestResult -> Bool) -> Eq FullTestResult
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: FullTestResult -> FullTestResult -> Bool
$c/= :: FullTestResult -> FullTestResult -> Bool
== :: FullTestResult -> FullTestResult -> Bool
$c== :: FullTestResult -> FullTestResult -> Bool
Eq, Int -> FullTestResult -> ShowS
[FullTestResult] -> ShowS
FullTestResult -> String
(Int -> FullTestResult -> ShowS)
-> (FullTestResult -> String)
-> ([FullTestResult] -> ShowS)
-> Show FullTestResult
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [FullTestResult] -> ShowS
$cshowList :: [FullTestResult] -> ShowS
show :: FullTestResult -> String
$cshow :: FullTestResult -> String
showsPrec :: Int -> FullTestResult -> ShowS
$cshowsPrec :: Int -> FullTestResult -> ShowS
Show, ReadPrec [FullTestResult]
ReadPrec FullTestResult
Int -> ReadS FullTestResult
ReadS [FullTestResult]
(Int -> ReadS FullTestResult)
-> ReadS [FullTestResult]
-> ReadPrec FullTestResult
-> ReadPrec [FullTestResult]
-> Read FullTestResult
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [FullTestResult]
$creadListPrec :: ReadPrec [FullTestResult]
readPrec :: ReadPrec FullTestResult
$creadPrec :: ReadPrec FullTestResult
readList :: ReadS [FullTestResult]
$creadList :: ReadS [FullTestResult]
readsPrec :: Int -> ReadS FullTestResult
$creadsPrec :: Int -> ReadS FullTestResult
Read)
mkFullTestResult :: TestResult -> Maybe String -> FullTestResult
mkFullTestResult :: TestResult -> Maybe String -> FullTestResult
mkFullTestResult TestResult
r Maybe String
msg =
FullTestResult :: Maybe Location
-> [(Maybe String, Location)]
-> Maybe ColorString
-> Maybe TestResult
-> FullTestResult
FullTestResult
{ ftr_location :: Maybe Location
ftr_location = Maybe Location
forall a. Maybe a
Nothing
, ftr_callingLocations :: [(Maybe String, Location)]
ftr_callingLocations = []
, ftr_message :: Maybe ColorString
ftr_message = (String -> ColorString) -> Maybe String -> Maybe ColorString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap String -> ColorString
noColor Maybe String
msg
, ftr_result :: Maybe TestResult
ftr_result = TestResult -> Maybe TestResult
forall a. a -> Maybe a
Just TestResult
r
}
data HTFFailureException
= HTFFailure FullTestResult
deriving (Int -> HTFFailureException -> ShowS
[HTFFailureException] -> ShowS
HTFFailureException -> String
(Int -> HTFFailureException -> ShowS)
-> (HTFFailureException -> String)
-> ([HTFFailureException] -> ShowS)
-> Show HTFFailureException
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [HTFFailureException] -> ShowS
$cshowList :: [HTFFailureException] -> ShowS
show :: HTFFailureException -> String
$cshow :: HTFFailureException -> String
showsPrec :: Int -> HTFFailureException -> ShowS
$cshowsPrec :: Int -> HTFFailureException -> ShowS
Show, Typeable)
instance Exc.Exception HTFFailureException
failHTF :: MonadBaseControl IO m => FullTestResult -> m a
failHTF :: FullTestResult -> m a
failHTF FullTestResult
r = String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (FullTestResult -> String
forall a. Show a => a -> String
show FullTestResult
r) Int -> m a -> m a
`seq` HTFFailureException -> m a
forall (m :: * -> *) e a. (MonadBase IO m, Exception e) => e -> m a
ExcLifted.throwIO (FullTestResult -> HTFFailureException
HTFFailure FullTestResult
r)
subAssertHTF :: MonadBaseControl IO m => Location -> Maybe String -> m a -> m a
subAssertHTF :: Location -> Maybe String -> m a -> m a
subAssertHTF Location
loc Maybe String
mMsg m a
action =
m a
action m a -> (HTFFailureException -> m a) -> m a
forall (m :: * -> *) e a.
(MonadBaseControl IO m, Exception e) =>
m a -> (e -> m a) -> m a
`ExcLifted.catch`
(\(HTFFailure FullTestResult
res) ->
let newRes :: FullTestResult
newRes = FullTestResult
res { ftr_callingLocations :: [(Maybe String, Location)]
ftr_callingLocations = (Maybe String
mMsg, Location
loc) (Maybe String, Location)
-> [(Maybe String, Location)] -> [(Maybe String, Location)]
forall a. a -> [a] -> [a]
: FullTestResult -> [(Maybe String, Location)]
ftr_callingLocations FullTestResult
res }
in FullTestResult -> m a
forall (m :: * -> *) a.
MonadBaseControl IO m =>
FullTestResult -> m a
failHTF FullTestResult
newRes)