{-# OPTIONS_GHC -cpp -pgmP "cpphs --layout --hashes --cpp" #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE BangPatterns #-}

--
-- Copyright (c) 2005, 2009, 2012  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 provides assert-like functions for writing unit tests.

/Hint:/ Do not use the @assertXXX_@ functions
directly. Instead, for each function @assertXXX_@,
there exist a preprocessor macro @assertXXX@, which provides
the "Location" parameter automatically. Use these macros, which
are available automatically if you add

@{-# OPTIONS_GHC -F -pgmF htfpp #-}@

at the top of your source file (see the 'Test.Framework.Tutorial').

-}

module Test.Framework.HUnitWrapper (

  -- * Assertions on Bool values
  assertBool_, assertBoolVerbose_,
  gassertBool_, gassertBoolVerbose_,

  -- * Equality assertions
  assertEqual_, assertEqualVerbose_,
  gassertEqual_, gassertEqualVerbose_,
  assertEqualPretty_, assertEqualPrettyVerbose_,
  gassertEqualPretty_, gassertEqualPrettyVerbose_,
  assertEqualNoShow_, assertEqualNoShowVerbose_,
  gassertEqualNoShow_, gassertEqualNoShowVerbose_,
  assertNotEqual_, assertNotEqualVerbose_,
  gassertNotEqual_, gassertNotEqualVerbose_,
  assertNotEqualPretty_, assertNotEqualPrettyVerbose_,
  gassertNotEqualPretty_, gassertNotEqualPrettyVerbose_,
  assertNotEqualNoShow_, assertNotEqualNoShowVerbose_,
  gassertNotEqualNoShow_, gassertNotEqualNoShowVerbose_,

  -- * Assertions on lists
  assertListsEqualAsSets_, assertListsEqualAsSetsVerbose_,
  gassertListsEqualAsSets_, gassertListsEqualAsSetsVerbose_,
  assertNotEmpty_, assertNotEmptyVerbose_,
  gassertNotEmpty_, gassertNotEmptyVerbose_,
  assertEmpty_, assertEmptyVerbose_,
  gassertEmpty_, gassertEmptyVerbose_,
  assertElem_, assertElemVerbose_,
  gassertElem_, gassertElemVerbose_,

  -- * Assertions for exceptions
  assertThrows_, assertThrowsVerbose_,
  assertThrowsSome_, assertThrowsSomeVerbose_,
  assertThrowsIO_, assertThrowsIOVerbose_,
  assertThrowsSomeIO_, assertThrowsSomeIOVerbose_,
  assertThrowsM_, assertThrowsMVerbose_,
  assertThrowsSomeM_, assertThrowsSomeMVerbose_,

  -- * Assertions on Either values
  assertLeft_, assertLeftVerbose_,
  gassertLeft_, gassertLeftVerbose_,
  assertLeftNoShow_, assertLeftNoShowVerbose_,
  gassertLeftNoShow_, gassertLeftNoShowVerbose_,
  assertRight_, assertRightVerbose_,
  gassertRight_, gassertRightVerbose_,
  assertRightNoShow_, assertRightNoShowVerbose_,
  gassertRightNoShow_, gassertRightNoShowVerbose_,

  -- * Assertions on Just values
  assertJust_, assertJustVerbose_,
  gassertJust_, gassertJustVerbose_,
  assertNothing_, assertNothingVerbose_,
  gassertNothing_, gassertNothingVerbose_,
  assertNothingNoShow_, assertNothingNoShowVerbose_,
  gassertNothingNoShow_, gassertNothingNoShowVerbose_,

  -- * General failure
  assertFailure_,
  gassertFailure_,

  -- * Pending unit tests
  unitTestPending, unitTestPending',

  -- * Sub assertions
  subAssert_, subAssertVerbose_,
  gsubAssert_, gsubAssertVerbose_,

  -- * HUnit re-exports
  HU.HUnitFailure,

  -- * Tests (for internal use)
  hunitWrapperTests

) where

import Control.Exception
import qualified Control.Exception.Lifted as ExL
import Control.Monad.Trans.Control
import Control.Monad.Trans
import qualified Test.HUnit.Lang as HU
#if !MIN_VERSION_HUnit(1,4,0)
import qualified Test.HUnit.Base as HU
#endif

import Data.List ( (\\) )
import System.IO.Unsafe (unsafePerformIO)

import Test.Framework.TestInterface
import Test.Framework.Location
import Test.Framework.Diff
import Test.Framework.Colors
import Test.Framework.Pretty
import Test.Framework.AssertM
import Test.Framework.PrettyHaskell

import qualified Data.Text as T
import qualified Data.List as List

-- WARNING: do not forget to add a preprocessor macro for new assertions!!

{- |
Fail with the given reason, supplying the error location and the error message.
-}
gassertFailure_ :: AssertM m => Location -> String -> m a
gassertFailure_ :: Location -> String -> m a
gassertFailure_ Location
loc String
s =
    Location -> ColorString -> m a
forall (m :: * -> *) a. AssertM m => Location -> ColorString -> m a
genericAssertFailure__ Location
loc (String -> String -> String -> ColorString
mkMsg String
"assertFailure" String
""
                                (String
"failed at " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Location -> String
showLoc Location
loc String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
": " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
s))

-- | Specialization of 'gassertFailure'.
assertFailure_ :: Location -> String -> IO a
assertFailure_ :: Location -> String -> IO a
assertFailure_ = Location -> String -> IO a
forall (m :: * -> *) a. AssertM m => Location -> String -> m a
gassertFailure_

{- |
Signals that the current unit test is pending.
-}
unitTestPending :: String -> IO a
unitTestPending :: String -> IO a
unitTestPending String
s =
    FullTestResult -> IO a
forall (m :: * -> *) a.
MonadBaseControl IO m =>
FullTestResult -> m a
failHTF (Maybe Location
-> [(Maybe String, Location)]
-> Maybe ColorString
-> Maybe TestResult
-> FullTestResult
FullTestResult Maybe Location
forall a. Maybe a
Nothing [] (ColorString -> Maybe ColorString
forall a. a -> Maybe a
Just (ColorString -> Maybe ColorString)
-> ColorString -> Maybe ColorString
forall a b. (a -> b) -> a -> b
$ String -> ColorString
noColor String
s) (TestResult -> Maybe TestResult
forall a. a -> Maybe a
Just TestResult
Pending))

{- |
Use @unitTestPending' msg test@ to mark the given test as pending
without removing it from the test suite and without deleting or commenting out the test code.
-}
unitTestPending' :: String -> IO a -> IO a
unitTestPending' :: String -> IO a -> IO a
unitTestPending' String
msg IO a
_ = String -> IO a
forall a. String -> IO a
unitTestPending String
msg

mkMsg :: String -> String -> String -> ColorString
mkMsg :: String -> String -> String -> ColorString
mkMsg String
s1 String
s2 String
s3 = String -> String -> ColorString -> ColorString
mkColorMsg String
s1 String
s2 (String -> ColorString
noColor String
s3)

mkColorMsg :: String -> String -> ColorString -> ColorString
mkColorMsg :: String -> String -> ColorString -> ColorString
mkColorMsg String
fun String
extraInfo ColorString
s =
    let pref :: String
pref = if String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
extraInfo
               then String
fun String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" "
               else String
fun String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" (" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
extraInfo String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
") "
    in String -> ColorString
noColor String
pref ColorString -> ColorString -> ColorString
+++ ColorString
s

--
-- Dirty macro hackery (I'm too lazy ...)
--
#define CreateAssertionsGenericNoGVariant(__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 CreateAssertionsGeneric(__name__, __ctx__, __ctx2__, __type__, __ret__) \
g##__name__##Verbose_ :: __ctx2__ Location -> String -> __type__ -> m __ret__; \
g##__name__##Verbose_ = _##__name__##_ (#__name__ ++ "Verbose"); \
g##__name__##_ :: __ctx2__ Location -> __type__ -> m __ret__; \
g##__name__##_ loc = _##__name__##_ #__name__ loc ""; \
CreateAssertionsGenericNoGVariant(__name__, __ctx__, __type__, IO __ret__)

#define CreateAssertionsCtx(__name__, __ctx__, __ctx2__, __type__) \
CreateAssertionsGeneric(__name__, __ctx__ =>, __ctx2__ =>, __type__, ())
#define CreateAssertionsCtxNoGVariant(__name__, __ctx__, __type__) \
CreateAssertionsGenericNoGVariant(__name__, __ctx__ =>, __type__, IO ())

#define CreateAssertions(__name__, __type__) \
CreateAssertionsGeneric(__name__, , AssertM m =>, __type__, ())
#define CreateAssertionsNoGVariant(__name__, __type__) \
CreateAssertionsGenericNoGVariant(__name__, , __type__, IO ())

#define CreateAssertionsCtxRet(__name__, __ctx__, __ctx2__, __type__, __ret__) \
CreateAssertionsGeneric(__name__, __ctx__ =>, __ctx2__ =>, __type__, __ret__)
#define CreateAssertionsCtxRetNoGVariant(__name__, __ctx__, __type__, __ret__) \
CreateAssertionsGenericNoGVariant(__name__, __ctx__ =>, __type__, IO __ret__)

#define CreateAssertionsRet(__name__, __type__, __ret__) \
CreateAssertionsGeneric(__name__, , AssertM m =>, __type__, __ret__)
#define CreateAssertionsRetNoGVariant(__name__, __type__, __ret__) \
CreateAssertionsGenericNoGVariant(__name__, , __type__, IO __ret__)

#define DocAssertion(__name__, __text__) \
  {- | __text__ The 'String' parameter in the @Verbose@ \
      variants can be used to provide extra information about the error. The \
      variants @g##__name__@ and @g##__name__##Verbose@ are generic assertions: \
      they run in the IO monad and can be evaluated to a 'Bool' value. \
      Do not use the \
      @__name__##_@, @__name__##Verbose_@, @g##__name__##_@, and @g##__name__##Verbose_@ \
      functions directly, use the macros @__name__@, @__name__##Verbose@, @g##__name__@, and \
      @g##__name__##Verbose@ instead. These macros, provided by the @htfpp@ preprocessor, \
      insert the 'Location' parameter automatically. -}
#define DocAssertionNoGVariant(__name__, __text__) \
  {- | __text__ The 'String' parameter in the @Verbose@ \
      variant can be used to provide extra information about the error. \
      Do not use the \
      @__name__##_@ and @__name__##Verbose_@ \
      functions directly, use the macros @__name__@ and @__name__##Verbose@ \
      instead. These macros, provided by the @htfpp@ preprocessor, \
      insert the 'Location' parameter automatically. -}
--
-- Boolean Assertions
--

_assertBool_ :: AssertM m => String -> Location -> String -> Bool -> m ()
_assertBool_ :: String -> Location -> String -> Bool -> m ()
_assertBool_ String
name Location
loc String
s Bool
False =
    Location -> ColorString -> m ()
forall (m :: * -> *) a. AssertM m => Location -> ColorString -> m a
genericAssertFailure__ Location
loc (String -> String -> String -> ColorString
mkMsg String
name String
s (String
"failed at " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Location -> String
showLoc Location
loc))
_assertBool_ String
_ Location
_ String
_   Bool
True = () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

DocAssertion(assertBool, Fail if the 'Bool' value is 'False'.)
CreateAssertions(assertBool, Bool)

--
-- Equality Assertions
--

equalityFailedMessage' :: String -> String -> ColorString
equalityFailedMessage' :: String -> String -> ColorString
equalityFailedMessage' String
exp String
act =
    let !diff :: ColorString
diff = IO ColorString -> ColorString
forall a. IO a -> a
unsafePerformIO (String -> String -> IO ColorString
diffWithSensibleConfig String
exp String
act)
        expected_ :: ColorString
expected_ = Color -> String -> ColorString
colorize Color
firstDiffColor String
"* expected:"
        but_got_ :: ColorString
but_got_ = Color -> String -> ColorString
colorize Color
secondDiffColor String
"* but got:"
        diff_ :: ColorString
diff_ = Color -> String -> ColorString
colorize Color
diffColor String
"* diff:"
    in (ColorString
"\n" ColorString -> ColorString -> ColorString
+++ ColorString
expected_ ColorString -> ColorString -> ColorString
+++ ColorString
" " ColorString -> ColorString -> ColorString
+++ String -> ColorString
noColor (String -> String
withNewline (String -> String
trim String
exp)) ColorString -> ColorString -> ColorString
+++
        ColorString
"\n" ColorString -> ColorString -> ColorString
+++ ColorString
but_got_ ColorString -> ColorString -> ColorString
+++ ColorString
"  " ColorString -> ColorString -> ColorString
+++ String -> ColorString
noColor (String -> String
withNewline (String -> String
trim String
act)) ColorString -> ColorString -> ColorString
+++
        ColorString
"\n" ColorString -> ColorString -> ColorString
+++ ColorString
diff_ ColorString -> ColorString -> ColorString
+++ ColorString
"     " ColorString -> ColorString -> ColorString
+++ ColorString -> ColorString
newlineBeforeDiff ColorString
diff ColorString -> ColorString -> ColorString
+++ ColorString
diff ColorString -> ColorString -> ColorString
+++
        (if (String
exp String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
act)
         then ColorString
"\nWARNING: strings are equal but actual values differ!"
         else ColorString
""))
    where
      withNewline :: String -> String
withNewline String
s =
          case String -> [String]
lines String
s of
            [] -> String
s
            [String
_] -> String
s
            [String]
_ -> Char
'\n'Char -> String -> String
forall a. a -> [a] -> [a]
:String
s
      newlineBeforeDiff :: ColorString -> ColorString
newlineBeforeDiff ColorString
d =
          let f :: Bool -> p
f Bool
b = case (Char -> Bool) -> ColorString -> Bool -> Maybe Char
colorStringFind (\Char
c -> Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'\n') ColorString
d Bool
b of
                      Just Char
_ -> p
"\n"
                      Maybe Char
Nothing -> p
""
          in String -> String -> ColorString
noColor' (Bool -> String
forall p. IsString p => Bool -> p
f Bool
True) (Bool -> String
forall p. IsString p => Bool -> p
f Bool
False)
      trim :: String -> String
trim String
s =
          case Int -> String -> (String, String)
forall a. Int -> [a] -> ([a], [a])
List.splitAt Int
maxLen String
s of
            (String
_, []) -> String
s
            (String
prefix, String
rest) ->
                String
prefix String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" (removed " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show (String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
rest) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" trailing chars)"
      maxLen :: Int
maxLen = Int
100000


equalityFailedMessage :: (Show a) => a -> a -> ColorString
equalityFailedMessage :: a -> a -> ColorString
equalityFailedMessage a
exp a
act =
    String -> String -> ColorString
equalityFailedMessage' String
expP String
actP
    where
      (String
expP, String
actP) =
          case (a -> Maybe String
forall a. Show a => a -> Maybe String
prettyHaskell' a
exp, a -> Maybe String
forall a. Show a => a -> Maybe String
prettyHaskell' a
act) of
            (Maybe String
Nothing, Maybe String
_) -> (a -> String
forall a. Show a => a -> String
show a
exp, a -> String
forall a. Show a => a -> String
show a
act)
            (Maybe String
_, Maybe String
Nothing) -> (a -> String
forall a. Show a => a -> String
show a
exp, a -> String
forall a. Show a => a -> String
show a
act)
            (Just String
expP, Just String
actP)
                | String
expP String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
actP ->
                    (a -> String
forall a. Show a => a -> String
show a
exp, a -> String
forall a. Show a => a -> String
show a
act)
                | Bool
otherwise -> (String
expP, String
actP)

notEqualityFailedMessage :: Show a => a -> String
notEqualityFailedMessage :: a -> String
notEqualityFailedMessage a
exp =
    String -> String
notEqualityFailedMessage' (a -> String
forall a. Show a => a -> String
prettyHaskell a
exp)

notEqualityFailedMessage' :: String -> String
notEqualityFailedMessage' :: String -> String
notEqualityFailedMessage' String
exp =
    (String
": Objects are equal\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
exp)

_assertEqual_ :: (Eq a, Show a, AssertM m)
                 => String -> Location -> String -> a -> a -> m ()
_assertEqual_ :: String -> Location -> String -> a -> a -> m ()
_assertEqual_ String
name Location
loc String
s a
expected a
actual =
    if a
expected a -> a -> Bool
forall a. Eq a => a -> a -> Bool
/= a
actual
       then do let x :: ColorString
x = a -> a -> ColorString
forall a. Show a => a -> a -> ColorString
equalityFailedMessage a
expected a
actual
               Location -> ColorString -> m ()
forall (m :: * -> *) a. AssertM m => Location -> ColorString -> m a
genericAssertFailure__ Location
loc (String -> String -> ColorString -> ColorString
mkColorMsg String
name String
s (ColorString -> ColorString) -> ColorString -> ColorString
forall a b. (a -> b) -> a -> b
$
                                           String -> ColorString
noColor (String
"failed at " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Location -> String
showLoc Location
loc) ColorString -> ColorString -> ColorString
+++ ColorString
x)
       else () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
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), (Eq a, Show a, AssertM m), a -> a)

_assertNotEqual_ :: (Eq a, Show a, AssertM m)
                 => String -> Location -> String -> a -> a -> m ()
_assertNotEqual_ :: String -> Location -> String -> a -> a -> m ()
_assertNotEqual_ String
name Location
loc String
s a
expected a
actual =
    if a
expected a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
actual
       then do let x :: String
x = a -> String
forall a. Show a => a -> String
notEqualityFailedMessage a
expected
               Location -> ColorString -> m ()
forall (m :: * -> *) a. AssertM m => Location -> ColorString -> m a
genericAssertFailure__ Location
loc (String -> String -> String -> ColorString
mkMsg String
name String
s (String -> ColorString) -> String -> ColorString
forall a b. (a -> b) -> a -> b
$ String
"failed at " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Location -> String
showLoc Location
loc String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
x)
       else () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
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), (Eq a, Show a, AssertM m), a -> a)

_assertEqualPretty_ :: (Eq a, Pretty a, AssertM m)
                       => String -> Location -> String -> a -> a -> m ()
_assertEqualPretty_ :: String -> Location -> String -> a -> a -> m ()
_assertEqualPretty_ String
name Location
loc String
s a
expected a
actual =
    if a
expected a -> a -> Bool
forall a. Eq a => a -> a -> Bool
/= a
actual
       then do let x :: ColorString
x = String -> String -> ColorString
equalityFailedMessage' (a -> String
forall a. Pretty a => a -> String
showPretty a
expected) (a -> String
forall a. Pretty a => a -> String
showPretty a
actual)
               Location -> ColorString -> m ()
forall (m :: * -> *) a. AssertM m => Location -> ColorString -> m a
genericAssertFailure__ Location
loc (String -> String -> ColorString -> ColorString
mkColorMsg String
name String
s
                                           (String -> ColorString
noColor (String
"failed at " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Location -> String
showLoc Location
loc) ColorString -> ColorString -> ColorString
+++ ColorString
x))
       else () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
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), (Eq a, Pretty a, AssertM m), a -> a)

_assertNotEqualPretty_ :: (Eq a, Pretty a, AssertM m)
                       => String -> Location -> String -> a -> a -> m ()
_assertNotEqualPretty_ :: String -> Location -> String -> a -> a -> m ()
_assertNotEqualPretty_ String
name Location
loc String
s a
expected a
actual =
    if a
expected a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
actual
       then do let x :: String
x = String -> String
notEqualityFailedMessage' (a -> String
forall a. Pretty a => a -> String
showPretty a
expected)
               Location -> ColorString -> m ()
forall (m :: * -> *) a. AssertM m => Location -> ColorString -> m a
genericAssertFailure__ Location
loc (String -> String -> String -> ColorString
mkMsg String
name String
s (String -> ColorString) -> String -> ColorString
forall a b. (a -> b) -> a -> b
$ String
"failed at " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Location -> String
showLoc Location
loc String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
x)
       else () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
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), (Eq a, Pretty a, AssertM m), a -> a)

_assertEqualNoShow_ :: (Eq a, AssertM m)
                    => String -> Location -> String -> a -> a -> m ()
_assertEqualNoShow_ :: String -> Location -> String -> a -> a -> m ()
_assertEqualNoShow_ String
name Location
loc String
s a
expected a
actual =
    if a
expected a -> a -> Bool
forall a. Eq a => a -> a -> Bool
/= a
actual
    then Location -> ColorString -> m ()
forall (m :: * -> *) a. AssertM m => Location -> ColorString -> m a
genericAssertFailure__ Location
loc (String -> String -> String -> ColorString
mkMsg String
name String
s (String
"failed at " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Location -> String
showLoc Location
loc))
    else () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
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, (Eq a, AssertM m), a -> a)

_assertNotEqualNoShow_ :: (Eq a, AssertM m)
                    => String -> Location -> String -> a -> a -> m ()
_assertNotEqualNoShow_ :: String -> Location -> String -> a -> a -> m ()
_assertNotEqualNoShow_ String
name Location
loc String
s a
expected a
actual =
    if a
expected a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
actual
       then Location -> ColorString -> m ()
forall (m :: * -> *) a. AssertM m => Location -> ColorString -> m a
genericAssertFailure__ Location
loc (String -> String -> String -> ColorString
mkMsg String
name String
s (String
"failed at " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Location -> String
showLoc Location
loc))
       else () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
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, (Eq a, AssertM m), a -> a)

--
-- Assertions on Lists
--

_assertListsEqualAsSets_ :: (Eq a, Show a, AssertM m)
                   => String -> Location -> String -> [a] -> [a] -> m ()
_assertListsEqualAsSets_ :: String -> Location -> String -> [a] -> [a] -> m ()
_assertListsEqualAsSets_ String
name Location
loc String
s [a]
expected [a]
actual =
    let ne :: Int
ne = [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
expected
        na :: Int
na = [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
actual
        in case () of
            ()
_| Int
ne Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
na ->
                 do let x :: ColorString
x = [a] -> [a] -> ColorString
forall a. Show a => a -> a -> ColorString
equalityFailedMessage [a]
expected [a]
actual
                    Location -> ColorString -> m ()
forall (m :: * -> *) a. AssertM m => Location -> ColorString -> m a
genericAssertFailure__ Location
loc (String -> String -> ColorString -> ColorString
mkColorMsg String
name String
s
                                                (String -> ColorString
noColor
                                                 (String
"failed at " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Location -> String
showLoc Location
loc
                                                  String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\n expected length: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
ne
                                                  String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\n actual length: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
na) ColorString -> ColorString -> ColorString
+++
                                                  (if ColorString -> Int
maxLength ColorString
x Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
5000
                                                   then ColorString
x else ColorString
emptyColorString)))
             | Bool -> Bool
not ([a] -> [a] -> Bool
forall a. Eq a => [a] -> [a] -> Bool
unorderedEq [a]
expected [a]
actual) ->
                 do let x :: ColorString
x = [a] -> [a] -> ColorString
forall a. Show a => a -> a -> ColorString
equalityFailedMessage [a]
expected [a]
actual
                    Location -> ColorString -> m ()
forall (m :: * -> *) a. AssertM m => Location -> ColorString -> m a
genericAssertFailure__ Location
loc (String -> String -> ColorString -> ColorString
mkColorMsg String
"assertSetEqual" String
s
                                                (String -> ColorString
noColor (String
"failed at " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Location -> String
showLoc Location
loc) ColorString -> ColorString -> ColorString
+++ ColorString
x))
             | Bool
otherwise -> () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    where unorderedEq :: [a] -> [a] -> Bool
unorderedEq [a]
l1 [a]
l2 =
              [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([a]
l1 [a] -> [a] -> [a]
forall a. Eq a => [a] -> [a] -> [a]
\\ [a]
l2) Bool -> Bool -> Bool
&& [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([a]
l2 [a] -> [a] -> [a]
forall a. Eq a => [a] -> [a] -> [a]
\\ [a]
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), (Eq a, Show a, AssertM m), [a] -> [a])

_assertNotEmpty_ :: AssertM m => String -> Location -> String -> [a] -> m ()
_assertNotEmpty_ :: String -> Location -> String -> [a] -> m ()
_assertNotEmpty_ String
name Location
loc String
s [] =
    Location -> ColorString -> m ()
forall (m :: * -> *) a. AssertM m => Location -> ColorString -> m a
genericAssertFailure__ Location
loc (String -> String -> String -> ColorString
mkMsg String
name String
s (String
"failed at " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Location -> String
showLoc Location
loc))
_assertNotEmpty_ String
_ Location
_ String
_ (a
_:[a]
_) = () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
DocAssertion(assertNotEmpty, Fail if the given list is empty.)
CreateAssertions(assertNotEmpty, [a])

_assertEmpty_ :: AssertM m => String -> Location -> String -> [a] -> m ()
_assertEmpty_ :: String -> Location -> String -> [a] -> m ()
_assertEmpty_ String
name Location
loc String
s (a
_:[a]
_) =
    Location -> ColorString -> m ()
forall (m :: * -> *) a. AssertM m => Location -> ColorString -> m a
genericAssertFailure__ Location
loc (String -> String -> String -> ColorString
mkMsg String
name String
s (String
"failed at " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Location -> String
showLoc Location
loc))
_assertEmpty_ String
_ Location
_ String
_ [] = () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
DocAssertion(assertEmpty, Fail if the given list is a non-empty list.)
CreateAssertions(assertEmpty, [a])

_assertElem_ :: (Eq a, Show a, AssertM m) => String -> Location -> String -> a -> [a] -> m ()
_assertElem_ :: String -> Location -> String -> a -> [a] -> m ()
_assertElem_ String
name Location
loc String
s a
x [a]
l =
    if a
x a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [a]
l
    then () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    else Location -> ColorString -> m ()
forall (m :: * -> *) a. AssertM m => Location -> ColorString -> m a
genericAssertFailure__ Location
loc (String -> String -> String -> ColorString
mkMsg String
name String
s
                                     (String
"failed at " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Location -> String
showLoc Location
loc String -> String -> String
forall a. [a] -> [a] -> [a]
++
                                      String
"\n element: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
x String -> String -> String
forall a. [a] -> [a] -> [a]
++
                                      String
"\n list:   " String -> String -> String
forall a. [a] -> [a] -> [a]
++ [a] -> String
forall a. Show a => a -> String
show [a]
l))
DocAssertion(assertElem, Fail if the given element is not in the list.)
CreateAssertionsCtx(assertElem, (Eq a, Show a), (Eq a, Show a, AssertM m), a -> [a])

--
-- Assertions for Exceptions
--

_assertThrowsIO_ :: Exception e
                 => String -> Location -> String -> IO a -> (e -> Bool) -> IO ()
_assertThrowsIO_ :: String -> Location -> String -> IO a -> (e -> Bool) -> IO ()
_assertThrowsIO_ String
name Location
loc String
s IO a
x e -> Bool
f =
    String -> Location -> String -> IO a -> (e -> Bool) -> IO ()
forall (m :: * -> *) e a.
(MonadBaseControl IO m, MonadIO m, Exception e) =>
String -> Location -> String -> m a -> (e -> Bool) -> m ()
_assertThrowsM_ String
name Location
loc String
s IO a
x e -> Bool
f
DocAssertionNoGVariant(assertThrowsIO, Fail if executing the 'IO' action does not
                       throw an exception satisfying the given predicate @(e -> Bool)@.)
CreateAssertionsCtxNoGVariant(assertThrowsIO, Exception e, IO a -> (e -> Bool))

_assertThrowsSomeIO_ :: String -> Location -> String -> IO a -> IO ()
_assertThrowsSomeIO_ :: String -> Location -> String -> IO a -> IO ()
_assertThrowsSomeIO_ String
name Location
loc String
s IO a
x = String
-> Location -> String -> IO a -> (SomeException -> Bool) -> IO ()
forall e a.
Exception e =>
String -> Location -> String -> IO a -> (e -> Bool) -> IO ()
_assertThrowsIO_ String
name Location
loc String
s IO a
x (\ (SomeException
_e::SomeException) -> Bool
True)
DocAssertionNoGVariant(assertThrowsSomeIO, Fail if executing the 'IO' action does not
                       throw an exception.)
CreateAssertionsNoGVariant(assertThrowsSomeIO, IO a)

_assertThrowsM_ :: (MonadBaseControl IO m, MonadIO m, Exception e)
                => String -> Location -> String -> m a -> (e -> Bool) -> m ()
_assertThrowsM_ :: String -> Location -> String -> m a -> (e -> Bool) -> m ()
_assertThrowsM_ String
name Location
loc String
s m a
x e -> Bool
f =
    do Either e a
res <- m a -> m (Either e a)
forall (m :: * -> *) e a.
(MonadBaseControl IO m, Exception e) =>
m a -> m (Either e a)
ExL.try m a
x
       case Either e a
res of
         Right a
_ -> IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$
                    Location -> ColorString -> IO ()
forall (m :: * -> *) a. AssertM m => Location -> ColorString -> m a
genericAssertFailure__ Location
loc (String -> String -> String -> ColorString
mkMsg String
name String
s
                                                (String
"failed at " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Location -> String
showLoc Location
loc String -> String -> String
forall a. [a] -> [a] -> [a]
++
                                                 String
": no exception was thrown"))
         Left e
e -> if e -> Bool
f e
e then () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
                   else IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$
                        Location -> ColorString -> IO ()
forall (m :: * -> *) a. AssertM m => Location -> ColorString -> m a
genericAssertFailure__ Location
loc (String -> String -> String -> ColorString
mkMsg String
name String
s
                                                    (String
"failed at " String -> String -> String
forall a. [a] -> [a] -> [a]
++
                                                     Location -> String
showLoc Location
loc String -> String -> String
forall a. [a] -> [a] -> [a]
++
                                                     String
": wrong exception was thrown: " String -> String -> String
forall a. [a] -> [a] -> [a]
++
                                                     e -> String
forall a. Show a => a -> String
show e
e))
DocAssertionNoGVariant(assertThrowsM, Fail if executing the 'm' action does not
                       throw an exception satisfying the given predicate @(e -> Bool)@.)
CreateAssertionsGenericNoGVariant(assertThrowsM, (MonadBaseControl IO m, MonadIO m, Exception e) =>,
                                  m a -> (e -> Bool), m ())

_assertThrowsSomeM_ :: (MonadBaseControl IO m, MonadIO m)
                    => String -> Location -> String -> m a -> m ()
_assertThrowsSomeM_ name loc s x = _assertThrowsM_ name loc s x (\ (_e::SomeException) -> True)
DocAssertionNoGVariant(assertThrowsSomeM, Fail if executing the 'm' action does not
                       throw an exception.)
CreateAssertionsGenericNoGVariant(assertThrowsSomeM, (MonadBaseControl IO m, MonadIO m) =>, m a, m ())

_assertThrows_ :: Exception e
               => String -> Location -> String -> a -> (e -> Bool) -> IO ()
_assertThrows_ name loc s x f = _assertThrowsIO_ name loc s (evaluate x) f
DocAssertionNoGVariant(assertThrows, Fail if evaluating the expression of type @a@ does not
                       throw an exception satisfying the given predicate @(e -> Bool)@.)
CreateAssertionsCtxNoGVariant(assertThrows, Exception e, a -> (e -> Bool))

_assertThrowsSome_ :: String -> Location -> String -> a -> IO ()
_assertThrowsSome_ :: String -> Location -> String -> a -> IO ()
_assertThrowsSome_ name loc s x =
    _assertThrows_ name loc s x (\ (_e::SomeException) -> True)
DocAssertionNoGVariant(assertThrowsSome, Fail if evaluating the expression of type @a@ does not
                       throw an exception.)
CreateAssertionsNoGVariant(assertThrowsSome, a)

--
-- Assertions on Either
--

_assertLeft_ :: forall a b m . (AssertM m, Show b)
             => String -> Location -> String -> Either a b -> m a
_assertLeft_ _ _ _ (Left x) = return x
_assertLeft_ name loc s (Right x) =
    genericAssertFailure__ 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, (Show b, AssertM m), Either a b, a)

_assertLeftNoShow_ :: String -> Location -> String -> Either a b -> m a
_assertLeftNoShow_ :: AssertM m => String -> Location -> String -> Either a b -> m a
_assertLeftNoShow_ _ _ _ (Left x) = return x
_assertLeftNoShow_ name loc s (Right _) =
    genericAssertFailure__ 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, a)

_assertRight_ :: forall a b m . (Show a, AssertM m)
              => String -> Location -> String -> Either a b -> m b
_assertRight_ _ _ _ (Right x) = return x
_assertRight_ name loc s (Left x) =
    genericAssertFailure__ 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, (Show a, AssertM m), Either a b, b)

_assertRightNoShow_ :: String -> Location -> String -> Either a b -> m b
_assertRightNoShow_ :: AssertM m => String -> Location -> String -> Either a b -> m b
_assertRightNoShow_ _ _ _ (Right x) = return x
_assertRightNoShow_ name loc s (Left _) =
    genericAssertFailure__ 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, b)

--
-- Assertions on Maybe
--

_assertJust_ :: String -> Location -> String -> Maybe a -> m a
_assertJust_ :: AssertM m => String -> Location -> String -> Maybe a -> m a
_assertJust_ _ _ _ (Just x) = return x
_assertJust_ name loc s Nothing =
    genericAssertFailure__ 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, a)

_assertNothing_ :: (Show a, AssertM m)
                => String -> Location -> String -> Maybe a -> m ()
_assertNothing_ _ _ _ Nothing = return ()
_assertNothing_ name loc s jx =
    genericAssertFailure__ 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, (Show a, AssertM m), Maybe a)

_assertNothingNoShow_ :: String -> Location -> String -> Maybe a -> m ()
_assertNothingNoShow_ :: AssertM m => String -> Location -> String -> Maybe a -> m ()
_assertNothingNoShow_ _ _ _ Nothing = return ()
_assertNothingNoShow_ name loc s _ =
    genericAssertFailure__ 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)

--
-- Sub assertions
--

-- | Sub assertions are a poor man's way of abstracting over assertions while still propagating location
-- information. Say you want to abstract over the assertion that an 'Int' is positive. You would write
--
-- > assertIsPositive :: Int -> Assertion
-- > assertIsPositive n = assertBool (n > 0)
--
-- You can now use @assertIsPositive i@ for some integer @i@ from your unit tests, but if you call it directly
-- you will lose location information: if @assertIsPositive i@ fails you will only get the location where
-- @assertIsPositive@ is defined but not from where it has been called.
--
-- To recover the location information you simply use @subAssert (assertIsPositive i)@.
-- In this case, if @i@ is not positive, you will get the location of the caller.
--
-- /Note:/ Don't use subAssert_ directly but use the preprocessor macro @subAssert@.
subAssert_ :: Location -> m a -> m a
subAssert_ :: MonadBaseControl IO m => Location -> m a -> m a
subAssert_ loc ass = subAssertHTF loc Nothing ass

-- | Generic variant of 'subAssert_'.
gsubAssert_ :: Location -> m a -> m a
gsubAssert_ :: AssertM m => Location -> m a -> m a
gsubAssert_ loc ass = genericSubAssert loc Nothing ass

-- | Same as 'subAssert_' but with an additional error message.
subAssertVerbose_ :: Location -> String -> m a -> m a
subAssertVerbose_ :: MonadBaseControl IO m => Location -> String -> m a -> m a
subAssertVerbose_ loc msg ass = subAssertHTF loc (Just msg) ass

-- | Generic variant of 'subAssertVerbose_'.
gsubAssertVerbose_ :: Location -> String -> m a -> m a
gsubAssertVerbose_ :: AssertM m => Location -> String -> m a -> m a
gsubAssertVerbose_ loc msg ass = genericSubAssert loc (Just msg) ass

testEqualityFailedMessage1 :: IO ()
testEqualityFailedMessage1 :: IO ()
testEqualityFailedMessage1 =
    let msg = T.unpack $ renderColorString (equalityFailedMessage [1,2,3] [1,2,3,4]) False
    in HU.assertEqual "error" msg exp
    where
      exp = "\n* expected: [1, 2, 3]\n* but got:  [1, 2, 3, 4]\n* " ++
            "diff:     \nC <...[1, 2, 3...>C \nS , 4\nC ]<......>C "

testEqualityFailedMessage2 :: IO ()
testEqualityFailedMessage2 :: IO ()
testEqualityFailedMessage2 =
    let msg = T.unpack $ renderColorString (equalityFailedMessage [1,2,3] [1,2,3]) False
    in HU.assertEqual "error" msg exp
    where
      exp = "\n* expected: [1,2,3]\n* but got:  [1,2,3]\n* " ++
            "diff:     \nWARNING: strings are equal but actual values differ!"

hunitWrapperTests =
    [("testEqualityFailedMessage1", testEqualityFailedMessage1)
    ,("testEqualityFailedMessage2", testEqualityFailedMessage2)]