{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE FlexibleContexts #-}

#if __GLASGOW_HASKELL__ >= 704
{-# LANGUAGE ConstraintKinds #-}
#define HasCallStack_ HasCallStack =>
#else
#define HasCallStack_
#endif

module Test.HUnit.Lang (
  Assertion,
  assertFailure,
  assertEqual,

  Result (..),
  performTestCase,
-- * Internals
-- |
-- /Note:/ This is not part of the public API!  It is exposed so that you can
-- tinker with the internals of HUnit, but do not expect it to be stable!
  HUnitFailure (..),
  FailureReason (..),
  formatFailureReason
) where

import           Control.DeepSeq
import           Control.Exception as E
import           Control.Monad
import           Data.List
import           Data.Typeable
import           Data.CallStack

-- | When an assertion is evaluated, it will output a message if and only if the
-- assertion fails.
--
-- Test cases are composed of a sequence of one or more assertions.
type Assertion = IO ()

data HUnitFailure = HUnitFailure (Maybe SrcLoc) FailureReason
    deriving (HUnitFailure -> HUnitFailure -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: HUnitFailure -> HUnitFailure -> Bool
$c/= :: HUnitFailure -> HUnitFailure -> Bool
== :: HUnitFailure -> HUnitFailure -> Bool
$c== :: HUnitFailure -> HUnitFailure -> Bool
Eq, Int -> HUnitFailure -> ShowS
[HUnitFailure] -> ShowS
HUnitFailure -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [HUnitFailure] -> ShowS
$cshowList :: [HUnitFailure] -> ShowS
show :: HUnitFailure -> String
$cshow :: HUnitFailure -> String
showsPrec :: Int -> HUnitFailure -> ShowS
$cshowsPrec :: Int -> HUnitFailure -> ShowS
Show, Typeable)

instance Exception HUnitFailure

data FailureReason = Reason String | ExpectedButGot (Maybe String) String String
    deriving (FailureReason -> FailureReason -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: FailureReason -> FailureReason -> Bool
$c/= :: FailureReason -> FailureReason -> Bool
== :: FailureReason -> FailureReason -> Bool
$c== :: FailureReason -> FailureReason -> Bool
Eq, Int -> FailureReason -> ShowS
[FailureReason] -> ShowS
FailureReason -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [FailureReason] -> ShowS
$cshowList :: [FailureReason] -> ShowS
show :: FailureReason -> String
$cshow :: FailureReason -> String
showsPrec :: Int -> FailureReason -> ShowS
$cshowsPrec :: Int -> FailureReason -> ShowS
Show, Typeable)

location :: HasCallStack_ Maybe SrcLoc
location :: HasCallStack => Maybe SrcLoc
location = case forall a. [a] -> [a]
reverse HasCallStack => CallStack
callStack of
  (String
_, SrcLoc
loc) : CallStack
_ -> forall a. a -> Maybe a
Just SrcLoc
loc
  [] -> forall a. Maybe a
Nothing

-- | Unconditionally signals that a failure has occurred.
assertFailure ::
     HasCallStack_
     String -- ^ A message that is displayed with the assertion failure
  -> IO a
assertFailure :: forall a. HasCallStack => String -> IO a
assertFailure String
msg = String
msg forall a b. NFData a => a -> b -> b
`deepseq` forall e a. Exception e => e -> IO a
E.throwIO (Maybe SrcLoc -> FailureReason -> HUnitFailure
HUnitFailure HasCallStack => Maybe SrcLoc
location forall a b. (a -> b) -> a -> b
$ String -> FailureReason
Reason String
msg)

-- | Asserts that the specified actual value is equal to the expected value.
-- The output message will contain the prefix, the expected value, and the
-- actual value.
--
-- If the prefix is the empty string (i.e., @\"\"@), then the prefix is omitted
-- and only the expected and actual values are output.
assertEqual :: HasCallStack_ (Eq a, Show a)
                              => String -- ^ The message prefix
                              -> a      -- ^ The expected value
                              -> a      -- ^ The actual value
                              -> Assertion
assertEqual :: forall a.
(HasCallStack, Eq a, Show a) =>
String -> a -> a -> Assertion
assertEqual String
preface a
expected a
actual =
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (a
actual forall a. Eq a => a -> a -> Bool
== a
expected) forall a b. (a -> b) -> a -> b
$ do
    (Maybe String
prefaceMsg forall a b. NFData a => a -> b -> b
`deepseq` String
expectedMsg forall a b. NFData a => a -> b -> b
`deepseq` String
actualMsg forall a b. NFData a => a -> b -> b
`deepseq` forall e a. Exception e => e -> IO a
E.throwIO (Maybe SrcLoc -> FailureReason -> HUnitFailure
HUnitFailure HasCallStack => Maybe SrcLoc
location forall a b. (a -> b) -> a -> b
$ Maybe String -> String -> String -> FailureReason
ExpectedButGot Maybe String
prefaceMsg String
expectedMsg String
actualMsg))
  where
    prefaceMsg :: Maybe String
prefaceMsg
      | forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
preface = forall a. Maybe a
Nothing
      | Bool
otherwise = forall a. a -> Maybe a
Just String
preface
    expectedMsg :: String
expectedMsg = forall a. Show a => a -> String
show a
expected
    actualMsg :: String
actualMsg = forall a. Show a => a -> String
show a
actual

formatFailureReason :: FailureReason -> String
formatFailureReason :: FailureReason -> String
formatFailureReason (Reason String
reason) = String
reason
formatFailureReason (ExpectedButGot Maybe String
preface String
expected String
actual) = forall a. [a] -> [[a]] -> [a]
intercalate String
"\n" forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. a -> a
id (:) Maybe String
preface forall a b. (a -> b) -> a -> b
$ [String
"expected: " forall a. [a] -> [a] -> [a]
++ String
expected, String
" but got: " forall a. [a] -> [a] -> [a]
++ String
actual]

data Result = Success | Failure (Maybe SrcLoc) String | Error (Maybe SrcLoc) String
  deriving (Result -> Result -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Result -> Result -> Bool
$c/= :: Result -> Result -> Bool
== :: Result -> Result -> Bool
$c== :: Result -> Result -> Bool
Eq, Int -> Result -> ShowS
[Result] -> ShowS
Result -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Result] -> ShowS
$cshowList :: [Result] -> ShowS
show :: Result -> String
$cshow :: Result -> String
showsPrec :: Int -> Result -> ShowS
$cshowsPrec :: Int -> Result -> ShowS
Show)

-- | Performs a single test case.
performTestCase :: Assertion -- ^ an assertion to be made during the test case run
                -> IO Result
performTestCase :: Assertion -> IO Result
performTestCase Assertion
action =
  (Assertion
action forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return Result
Success)
     forall a. IO a -> [Handler a] -> IO a
`E.catches`
      [forall a e. Exception e => (e -> IO a) -> Handler a
E.Handler (\(HUnitFailure Maybe SrcLoc
loc FailureReason
reason) -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Maybe SrcLoc -> String -> Result
Failure Maybe SrcLoc
loc (FailureReason -> String
formatFailureReason FailureReason
reason)),

       -- Re-throw AsyncException, otherwise execution will not terminate on
       -- SIGINT (ctrl-c).  Currently, all AsyncExceptions are being thrown
       -- because it's thought that none of them will be encountered during
       -- normal HUnit operation.  If you encounter an example where this
       -- is not the case, please email the maintainer.
       forall a e. Exception e => (e -> IO a) -> Handler a
E.Handler (\AsyncException
e -> forall a e. Exception e => e -> a
throw (AsyncException
e :: E.AsyncException)),

       forall a e. Exception e => (e -> IO a) -> Handler a
E.Handler (\SomeException
e -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Maybe SrcLoc -> String -> Result
Error forall a. Maybe a
Nothing forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show (SomeException
e :: E.SomeException))]