1{-# LANGUAGE CPP #-}
2{-# LANGUAGE DeriveDataTypeable #-}
3{-# LANGUAGE FlexibleContexts #-}
4
5#if __GLASGOW_HASKELL__ >= 704
6{-# LANGUAGE ConstraintKinds #-}
7#define HasCallStack_ HasCallStack =>
8#else
9#define HasCallStack_
10#endif
11
12module Test.HUnit.Lang (
13  Assertion,
14  assertFailure,
15  assertEqual,
16
17  Result (..),
18  performTestCase,
19-- * Internals
20-- |
21-- /Note:/ This is not part of the public API!  It is exposed so that you can
22-- tinker with the internals of HUnit, but do not expect it to be stable!
23  HUnitFailure (..),
24  FailureReason (..),
25  formatFailureReason
26) where
27
28import           Control.DeepSeq
29import           Control.Exception as E
30import           Control.Monad
31import           Data.List
32import           Data.Typeable
33import           Data.CallStack
34
35-- | When an assertion is evaluated, it will output a message if and only if the
36-- assertion fails.
37--
38-- Test cases are composed of a sequence of one or more assertions.
39type Assertion = IO ()
40
41data HUnitFailure = HUnitFailure (Maybe SrcLoc) FailureReason
42    deriving (Eq, Show, Typeable)
43
44instance Exception HUnitFailure
45
46data FailureReason = Reason String | ExpectedButGot (Maybe String) String String
47    deriving (Eq, Show, Typeable)
48
49location :: HasCallStack_ Maybe SrcLoc
50location = case reverse callStack of
51  (_, loc) : _ -> Just loc
52  [] -> Nothing
53
54-- | Unconditionally signals that a failure has occurred.
55assertFailure ::
56     HasCallStack_
57     String -- ^ A message that is displayed with the assertion failure
58  -> IO a
59assertFailure msg = msg `deepseq` E.throwIO (HUnitFailure location $ Reason msg)
60
61-- | Asserts that the specified actual value is equal to the expected value.
62-- The output message will contain the prefix, the expected value, and the
63-- actual value.
64--
65-- If the prefix is the empty string (i.e., @\"\"@), then the prefix is omitted
66-- and only the expected and actual values are output.
67assertEqual :: HasCallStack_ (Eq a, Show a)
68                              => String -- ^ The message prefix
69                              -> a      -- ^ The expected value
70                              -> a      -- ^ The actual value
71                              -> Assertion
72assertEqual preface expected actual =
73  unless (actual == expected) $ do
74    (prefaceMsg `deepseq` expectedMsg `deepseq` actualMsg `deepseq` E.throwIO (HUnitFailure location $ ExpectedButGot prefaceMsg expectedMsg actualMsg))
75  where
76    prefaceMsg
77      | null preface = Nothing
78      | otherwise = Just preface
79    expectedMsg = show expected
80    actualMsg = show actual
81
82formatFailureReason :: FailureReason -> String
83formatFailureReason (Reason reason) = reason
84formatFailureReason (ExpectedButGot preface expected actual) = intercalate "\n" . maybe id (:) preface $ ["expected: " ++ expected, " but got: " ++ actual]
85
86data Result = Success | Failure (Maybe SrcLoc) String | Error (Maybe SrcLoc) String
87  deriving (Eq, Show)
88
89-- | Performs a single test case.
90performTestCase :: Assertion -- ^ an assertion to be made during the test case run
91                -> IO Result
92performTestCase action =
93  (action >> return Success)
94     `E.catches`
95      [E.Handler (\(HUnitFailure loc reason) -> return $ Failure loc (formatFailureReason reason)),
96
97       -- Re-throw AsyncException, otherwise execution will not terminate on
98       -- SIGINT (ctrl-c).  Currently, all AsyncExceptions are being thrown
99       -- because it's thought that none of them will be encountered during
100       -- normal HUnit operation.  If you encounter an example where this
101       -- is not the case, please email the maintainer.
102       E.Handler (\e -> throw (e :: E.AsyncException)),
103
104       E.Handler (\e -> return $ Error Nothing $ show (e :: E.SomeException))]
105