{-# 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
(HUnitFailure -> HUnitFailure -> Bool)
-> (HUnitFailure -> HUnitFailure -> Bool) -> Eq HUnitFailure
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: HUnitFailure -> HUnitFailure -> Bool
== :: HUnitFailure -> HUnitFailure -> Bool
$c/= :: HUnitFailure -> HUnitFailure -> Bool
/= :: HUnitFailure -> HUnitFailure -> Bool
Eq, Int -> HUnitFailure -> ShowS
[HUnitFailure] -> ShowS
HUnitFailure -> String
(Int -> HUnitFailure -> ShowS)
-> (HUnitFailure -> String)
-> ([HUnitFailure] -> ShowS)
-> Show HUnitFailure
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> HUnitFailure -> ShowS
showsPrec :: Int -> HUnitFailure -> ShowS
$cshow :: HUnitFailure -> String
show :: HUnitFailure -> String
$cshowList :: [HUnitFailure] -> ShowS
showList :: [HUnitFailure] -> ShowS
Show, Typeable)

instance Exception HUnitFailure

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

location :: HasCallStack_ Maybe SrcLoc
location :: HasCallStack => Maybe SrcLoc
location = case [(String, SrcLoc)] -> [(String, SrcLoc)]
forall a. [a] -> [a]
reverse [(String, SrcLoc)]
HasCallStack => [(String, SrcLoc)]
callStack of
  (String
_, SrcLoc
loc) : [(String, SrcLoc)]
_ -> SrcLoc -> Maybe SrcLoc
forall a. a -> Maybe a
Just SrcLoc
loc
  [] -> Maybe SrcLoc
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 String -> IO a -> IO a
forall a b. NFData a => a -> b -> b
`deepseq` HUnitFailure -> IO a
forall e a. Exception e => e -> IO a
E.throwIO (Maybe SrcLoc -> FailureReason -> HUnitFailure
HUnitFailure Maybe SrcLoc
HasCallStack => Maybe SrcLoc
location (FailureReason -> HUnitFailure) -> FailureReason -> HUnitFailure
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 =
  Bool -> Assertion -> Assertion
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (a
actual a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
expected) (Assertion -> Assertion) -> Assertion -> Assertion
forall a b. (a -> b) -> a -> b
$ do
    (Maybe String
prefaceMsg Maybe String -> Assertion -> Assertion
forall a b. NFData a => a -> b -> b
`deepseq` String
expectedMsg String -> Assertion -> Assertion
forall a b. NFData a => a -> b -> b
`deepseq` String
actualMsg String -> Assertion -> Assertion
forall a b. NFData a => a -> b -> b
`deepseq` HUnitFailure -> Assertion
forall e a. Exception e => e -> IO a
E.throwIO (Maybe SrcLoc -> FailureReason -> HUnitFailure
HUnitFailure Maybe SrcLoc
HasCallStack => Maybe SrcLoc
location (FailureReason -> HUnitFailure) -> FailureReason -> HUnitFailure
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
      | String -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
preface = Maybe String
forall a. Maybe a
Nothing
      | Bool
otherwise = String -> Maybe String
forall a. a -> Maybe a
Just String
preface
    expectedMsg :: String
expectedMsg = a -> String
forall a. Show a => a -> String
show a
expected
    actualMsg :: String
actualMsg = a -> String
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) = String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"\n" ([String] -> String)
-> ([String] -> [String]) -> [String] -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([String] -> [String])
-> (String -> [String] -> [String])
-> Maybe String
-> [String]
-> [String]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [String] -> [String]
forall a. a -> a
id (:) Maybe String
preface ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ [String
"expected: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
expected, String
" but got: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
actual]

data Result = Success | Failure (Maybe SrcLoc) String | Error (Maybe SrcLoc) String
  deriving (Result -> Result -> Bool
(Result -> Result -> Bool)
-> (Result -> Result -> Bool) -> Eq Result
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Result -> Result -> Bool
== :: Result -> Result -> Bool
$c/= :: Result -> Result -> Bool
/= :: Result -> Result -> Bool
Eq, Int -> Result -> ShowS
[Result] -> ShowS
Result -> String
(Int -> Result -> ShowS)
-> (Result -> String) -> ([Result] -> ShowS) -> Show Result
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Result -> ShowS
showsPrec :: Int -> Result -> ShowS
$cshow :: Result -> String
show :: Result -> String
$cshowList :: [Result] -> ShowS
showList :: [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 Assertion -> IO Result -> IO Result
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Result -> IO Result
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Result
Success)
     IO Result -> [Handler Result] -> IO Result
forall a. IO a -> [Handler a] -> IO a
`E.catches`
      [(HUnitFailure -> IO Result) -> Handler Result
forall a e. Exception e => (e -> IO a) -> Handler a
E.Handler (\(HUnitFailure Maybe SrcLoc
loc FailureReason
reason) -> Result -> IO Result
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Result -> IO Result) -> Result -> IO Result
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.
       (AsyncException -> IO Result) -> Handler Result
forall a e. Exception e => (e -> IO a) -> Handler a
E.Handler (\AsyncException
e -> AsyncException -> IO Result
forall a e. Exception e => e -> a
throw (AsyncException
e :: E.AsyncException)),

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