module Test.Framework.HUnitWrapper (
assertBool_, assertBoolVerbose_,
assertEqual_, assertEqualVerbose_,
assertEqualPretty_, assertEqualPrettyVerbose_,
assertEqualNoShow_, assertEqualNoShowVerbose_,
assertNotEqual_, assertNotEqualVerbose_,
assertNotEqualPretty_, assertNotEqualPrettyVerbose_,
assertNotEqualNoShow_, assertNotEqualNoShowVerbose_,
assertListsEqualAsSets_, assertListsEqualAsSetsVerbose_,
assertNotEmpty_, assertNotEmptyVerbose_,
assertEmpty_, assertEmptyVerbose_,
assertThrows_, assertThrowsVerbose_,
assertThrowsSome_, assertThrowsSomeVerbose_,
assertThrowsIO_, assertThrowsIOVerbose_,
assertThrowsSomeIO_, assertThrowsSomeIOVerbose_,
assertLeft_, assertLeftVerbose_,
assertLeftNoShow_, assertLeftNoShowVerbose_,
assertRight_, assertRightVerbose_,
assertRightNoShow_, assertRightNoShowVerbose_,
assertJust_, assertJustVerbose_,
assertNothing_, assertNothingVerbose_,
assertNothingNoShow_, assertNothingNoShowVerbose_,
assertFailure_,
unitTestPending, unitTestPending',
subAssert_, subAssertVerbose_
) where
import Control.Exception
import Control.Monad.Trans
import Control.Monad.Trans.Control
import qualified Test.HUnit as HU hiding ( assertFailure )
import qualified Language.Haskell.Exts.Pretty as HE
import qualified Language.Haskell.Exts.Parser as HE
import Data.List ( (\\) )
import Test.Framework.TestManagerInternal
import Test.Framework.Location
import Test.Framework.Diff
import Test.Framework.Colors
import Test.Framework.Pretty
assertFailure__ :: Location -> String -> IO a
assertFailure__ loc s = unitTestFail (Just loc) s
assertFailure_ :: Location -> String -> IO a
assertFailure_ loc s =
assertFailure__ loc (mkMsg "assertFailure" "" ("failed at " ++ showLoc loc) ++ ": " ++ s)
unitTestPending' :: String -> IO a -> IO a
unitTestPending' msg _ = unitTestPending msg
mkMsg :: String -> String -> String -> String
mkMsg fun extraInfo s =
if null extraInfo
then fun ++ (' ':s)
else fun ++ " (" ++ extraInfo ++ ") " ++ s
#define CreateAssertionsGeneric(__name__, __ctx__, __type__, __ret__) \
__name__##Verbose_ :: __ctx__ Location -> String -> __type__ -> __ret__; \
__name__##Verbose_ = _##__name__##_ (#__name__ ++ "Verbose"); \
__name__##_ :: __ctx__ Location -> __type__ -> __ret__; \
__name__##_ loc = _##__name__##_ #__name__ loc ""
#define CreateAssertionsCtx(__name__, __ctx__, __type__) \
CreateAssertionsGeneric(__name__, __ctx__ =>, __type__, HU.Assertion)
#define CreateAssertions(__name__, __type__) \
CreateAssertionsGeneric(__name__, , __type__, HU.Assertion)
#define CreateAssertionsCtxRet(__name__, __ctx__, __type__, __ret__) \
CreateAssertionsGeneric(__name__, __ctx__ =>, __type__, __ret__)
#define CreateAssertionsRet(__name__, __type__, __ret__) \
CreateAssertionsGeneric(__name__, , __type__, __ret__)
#define DocAssertion(__name__, __text__) \
_assertBool_ :: String -> Location -> String -> Bool -> HU.Assertion
_assertBool_ name loc s False =
assertFailure__ loc (mkMsg name s ("failed at " ++ showLoc loc))
_assertBool_ _ _ _ True = return ()
DocAssertion(assertBool, Fail if the 'Bool' value is 'False'.)
CreateAssertions(assertBool, Bool)
equalityFailedMessage :: String -> String -> IO String
equalityFailedMessage exp act =
do d <- diffWithSensibleConfig expP actP
expected_ <- colorize firstDiffColor "* expected:"
but_got_ <- colorize secondDiffColor "* but got:"
diff_ <- colorize diffColor "* diff:"
return ("\n" ++ expected_ ++ " " ++ withNewline expP ++
"\n" ++ but_got_ ++ " " ++ withNewline actP ++
"\n" ++ diff_ ++ " " ++ withNewline d ++
(if stringEq
then "\nWARNING: strings are equal but actual values differ!"
else ""))
where
withNewline s =
case lines s of
[] -> s
[_] -> s
_ -> '\n':s
(expP, actP, stringEq) =
case (pp exp, pp act) of
(Nothing, _) -> (exp, act, exp == act)
(_, Nothing) -> (exp, act, exp == act)
(Just expP, Just actP)
| expP == actP ->
if exp /= act
then (exp, act, exp == act)
else (expP, actP, True)
| otherwise -> (expP, actP, False)
pp s =
case HE.parseExp s of
HE.ParseOk x -> Just $ HE.prettyPrint x
HE.ParseFailed{} -> Nothing
notEqualityFailedMessage :: String -> IO String
notEqualityFailedMessage exp =
do return (": Objects are equal\n" ++ pp exp)
where
pp s =
case HE.parseExp s of
HE.ParseOk x -> HE.prettyPrint x
HE.ParseFailed{} -> s
_assertEqual_ :: (Eq a, Show a)
=> String -> Location -> String -> a -> a -> HU.Assertion
_assertEqual_ name loc s expected actual =
if expected /= actual
then do x <- equalityFailedMessage (show expected) (show actual)
assertFailure__ loc (mkMsg name s $ "failed at " ++ showLoc loc ++ x)
else return ()
DocAssertion(assertEqual, Fail if the two values of type @a@ are not equal.
The first parameter denotes the expected value. Use these two functions
of @a@ is an instance of 'Show' but not of 'Pretty'.)
CreateAssertionsCtx(assertEqual, (Eq a, Show a), a -> a)
_assertNotEqual_ :: (Eq a, Show a)
=> String -> Location -> String -> a -> a -> HU.Assertion
_assertNotEqual_ name loc s expected actual =
if expected == actual
then do x <- notEqualityFailedMessage (show expected)
assertFailure__ loc (mkMsg name s $ "failed at " ++ showLoc loc ++ x)
else return ()
DocAssertion(assertNotEqual, Fail if the two values of type @a@ are equal.
The first parameter denotes the expected value. Use these two functions
of @a@ is an instance of 'Show' but not of 'Pretty'.)
CreateAssertionsCtx(assertNotEqual, (Eq a, Show a), a -> a)
_assertEqualPretty_ :: (Eq a, Pretty a)
=> String -> Location -> String -> a -> a -> HU.Assertion
_assertEqualPretty_ name loc s expected actual =
if expected /= actual
then do x <- equalityFailedMessage (showPretty expected) (showPretty actual)
assertFailure__ loc (mkMsg name s $ "failed at " ++ showLoc loc ++ x)
else return ()
DocAssertion(assertEqualPretty, Fail if the two values of type @a@ are not equal.
The first parameter denotes the expected value. Use these two functions
of @a@ is an instance of 'Pretty'.)
CreateAssertionsCtx(assertEqualPretty, (Eq a, Pretty a), a -> a)
_assertNotEqualPretty_ :: (Eq a, Pretty a)
=> String -> Location -> String -> a -> a -> HU.Assertion
_assertNotEqualPretty_ name loc s expected actual =
if expected == actual
then do x <- notEqualityFailedMessage (showPretty expected)
assertFailure__ loc (mkMsg name s $ "failed at " ++ showLoc loc ++ x)
else return ()
DocAssertion(assertNotEqualPretty, Fail if the two values of type @a@ are equal.
The first parameter denotes the expected value. Use these two functions
of @a@ is an instance of 'Pretty'.)
CreateAssertionsCtx(assertNotEqualPretty, (Eq a, Pretty a), a -> a)
_assertEqualNoShow_ :: Eq a
=> String -> Location -> String -> a -> a -> HU.Assertion
_assertEqualNoShow_ name loc s expected actual =
if expected /= actual
then assertFailure__ loc (mkMsg name s ("failed at " ++ showLoc loc))
else return ()
DocAssertion(assertEqualNoShow, Fail if the two values of type @a@ are not equal.
The first parameter denotes the expected value. Use these two functions
of @a@ is neither an instance of 'Show' nor 'Pretty'. Be aware that in this
case the generated error message might not be very helpful.)
CreateAssertionsCtx(assertEqualNoShow, Eq a, a -> a)
_assertNotEqualNoShow_ :: Eq a
=> String -> Location -> String -> a -> a -> HU.Assertion
_assertNotEqualNoShow_ name loc s expected actual =
if expected == actual
then assertFailure__ loc (mkMsg name s ("failed at " ++ showLoc loc))
else return ()
DocAssertion(assertNotEqualNoShow, Fail if the two values of type @a@ are equal.
The first parameter denotes the expected value. Use these two functions
of @a@ is neither an instance of 'Show' nor 'Pretty'. Be aware that in this
case the generated error message might not be very helpful.)
CreateAssertionsCtx(assertNotEqualNoShow, Eq a, a -> a)
_assertListsEqualAsSets_ :: (Eq a, Show a)
=> String -> Location -> String -> [a] -> [a] -> HU.Assertion
_assertListsEqualAsSets_ name loc s expected actual =
let ne = length expected
na = length actual
in case () of
_| ne /= na ->
assertFailure__ loc (mkMsg name s
("failed at " ++ showLoc loc
++ "\n expected length: " ++ show ne
++ "\n actual length: " ++ show na))
| not (unorderedEq expected actual) ->
do x <- equalityFailedMessage (show expected) (show actual)
assertFailure__ loc (mkMsg "assertSetEqual" s
("failed at " ++ showLoc loc ++ x))
| otherwise -> return ()
where unorderedEq l1 l2 =
null (l1 \\ l2) && null (l2 \\ l1)
DocAssertion(assertListsEqualAsSets, Fail if the two given lists are not equal
when considered as sets. The first list parameter
denotes the expected value.)
CreateAssertionsCtx(assertListsEqualAsSets, (Eq a, Show a), [a] -> [a])
_assertNotEmpty_ :: String -> Location -> String -> [a] -> HU.Assertion
_assertNotEmpty_ name loc s [] =
assertFailure__ loc (mkMsg name s ("failed at " ++ showLoc loc))
_assertNotEmpty_ _ _ _ (_:_) = return ()
DocAssertion(assertNotEmpty, Fail if the given list is empty.)
CreateAssertions(assertNotEmpty, [a])
_assertEmpty_ :: String -> Location -> String -> [a] -> HU.Assertion
_assertEmpty_ name loc s (_:_) =
assertFailure__ loc (mkMsg name s ("failed at " ++ showLoc loc))
_assertEmpty_ _ _ _ [] = return ()
DocAssertion(assertEmpty, Fail if the given list is a nonempty list.)
CreateAssertions(assertEmpty, [a])
_assertThrowsIO_ :: Exception e
=> String -> Location -> String -> IO a -> (e -> Bool) -> HU.Assertion
_assertThrowsIO_ name loc s x f =
do res <- try x
case res of
Right _ -> assertFailure__ loc (mkMsg name s
("failed at " ++ showLoc loc ++
": no exception was thrown"))
Left e -> if f e then return ()
else assertFailure__ loc (mkMsg name s
("failed at " ++
showLoc loc ++
": wrong exception was thrown: " ++
show e))
DocAssertion(assertThrowsIO, Fail if executing the 'IO' action does not
throw an exception satisfying the given predicate @(e -> Bool)@.)
CreateAssertionsCtx(assertThrowsIO, Exception e, IO a -> (e -> Bool))
_assertThrowsSomeIO_ :: String -> Location -> String -> IO a -> HU.Assertion
_assertThrowsSomeIO_ name loc s x = _assertThrowsIO_ name loc s x (\ (e::SomeException) -> True)
DocAssertion(assertThrowsSomeIO, Fail if executing the 'IO' action does not
throw an exception.)
CreateAssertions(assertThrowsSomeIO, IO a)
_assertThrows_ :: Exception e
=> String -> Location -> String -> a -> (e -> Bool) -> HU.Assertion
_assertThrows_ name loc s x f = _assertThrowsIO_ name loc s (evaluate x) f
DocAssertion(assertThrows, Fail if evaluating the expression of type @a@ does not
throw an exception satisfying the given predicate @(e -> Bool)@.)
CreateAssertionsCtx(assertThrows, Exception e, a -> (e -> Bool))
_assertThrowsSome_ :: String -> Location -> String -> a -> HU.Assertion
_assertThrowsSome_ name loc s x =
_assertThrows_ name loc s x (\ (e::SomeException) -> True)
DocAssertion(assertThrowsSome, Fail if evaluating the expression of type @a@ does not
throw an exception.)
CreateAssertions(assertThrowsSome, a)
_assertLeft_ :: forall a b . Show b
=> String -> Location -> String -> Either a b -> IO a
_assertLeft_ _ _ _ (Left x) = return x
_assertLeft_ name loc s (Right x) =
assertFailure__ loc (mkMsg name s
("failed at " ++ showLoc loc ++
": expected a Left value, given " ++
show (Right x :: Either b b)))
DocAssertion(assertLeft, Fail if the given @Either a b@ value is a 'Right'.
Use this function if @b@ is an instance of 'Show')
CreateAssertionsCtxRet(assertLeft, Show b, Either a b, IO a)
_assertLeftNoShow_ :: String -> Location -> String -> Either a b -> IO a
_assertLeftNoShow_ _ _ _ (Left x) = return x
_assertLeftNoShow_ name loc s (Right _) =
assertFailure__ loc (mkMsg name s ("failed at " ++ showLoc loc ++
": expected a Left value, given a Right value"))
DocAssertion(assertLeftNoShow, Fail if the given @Either a b@ value is a 'Right'.)
CreateAssertionsRet(assertLeftNoShow, Either a b, IO a)
_assertRight_ :: forall a b . Show a
=> String -> Location -> String -> Either a b -> IO b
_assertRight_ _ _ _ (Right x) = return x
_assertRight_ name loc s (Left x) =
assertFailure__ loc (mkMsg name s ("failed at " ++ showLoc loc ++
": expected a Right value, given " ++
show (Left x :: Either a a)))
DocAssertion(assertRight, Fail if the given @Either a b@ value is a 'Left'.
Use this function if @a@ is an instance of 'Show')
CreateAssertionsCtxRet(assertRight, Show a, Either a b, IO b)
_assertRightNoShow_ :: String -> Location -> String -> Either a b -> IO b
_assertRightNoShow_ _ _ _ (Right x) = return x
_assertRightNoShow_ name loc s (Left _) =
assertFailure__ loc (mkMsg name s ("failed at " ++ showLoc loc ++
": expected a Right value, given a Left value"))
DocAssertion(assertRightNoShow, Fail if the given @Either a b@ value is a 'Left'.)
CreateAssertionsRet(assertRightNoShow, Either a b, IO b)
_assertJust_ :: String -> Location -> String -> Maybe a -> IO a
_assertJust_ _ _ _ (Just x) = return x
_assertJust_ name loc s Nothing =
assertFailure__ loc (mkMsg name s ("failed at " ++ showLoc loc ++
": expected a Just value, given Nothing"))
DocAssertion(assertJust, Fail is the given @Maybe a@ value is a 'Nothing'.)
CreateAssertionsRet(assertJust, Maybe a, IO a)
_assertNothing_ :: Show a
=> String -> Location -> String -> Maybe a -> HU.Assertion
_assertNothing_ _ _ _ Nothing = return ()
_assertNothing_ name loc s jx =
assertFailure__ loc (mkMsg name s ("failed at " ++ showLoc loc ++
": expected Nothing, given " ++ show jx))
DocAssertion(assertNothing, Fail is the given @Maybe a@ value is a 'Just'.
Use this function if @a@ is an instance of 'Show'.)
CreateAssertionsCtx(assertNothing, Show a, Maybe a)
_assertNothingNoShow_ :: String -> Location -> String -> Maybe a -> HU.Assertion
_assertNothingNoShow_ _ _ _ Nothing = return ()
_assertNothingNoShow_ name loc s _ =
assertFailure__ loc (mkMsg name s ("failed at " ++ showLoc loc ++
": expected Nothing, given a Just value"))
DocAssertion(assertNothingNoShow, Fail is the given @Maybe a@ value is a 'Just'.)
CreateAssertions(assertNothingNoShow, Maybe a)
subAssert_ :: MonadBaseControl IO m => Location -> m () -> m()
subAssert_ loc ass = unitTestSubAssert loc Nothing ass
subAssertVerbose_ :: MonadBaseControl IO m => Location -> String -> m () -> m ()
subAssertVerbose_ loc msg ass = unitTestSubAssert loc (Just msg) ass