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