1{-# LANGUAGE DeriveDataTypeable, FlexibleInstances, TypeSynonymInstances #-} 2 3-- required for HasCallStack by different versions of GHC 4{-# LANGUAGE ConstraintKinds, FlexibleContexts #-} 5 6-- | This is the code copied from the original hunit package (v. 1.2.5.2). 7-- with minor modifications 8module Test.Tasty.HUnit.Orig where 9 10import qualified Control.Exception as E 11import Control.Monad 12import Data.Typeable (Typeable) 13import Data.CallStack 14 15-- Interfaces 16-- ---------- 17 18-- | An assertion is simply an 'IO' action. Assertion failure is indicated 19-- by throwing an exception, typically 'HUnitFailure'. 20-- 21-- Instead of throwing the exception directly, you should use 22-- functions like 'assertFailure' and 'assertBool'. 23-- 24-- Test cases are composed of a sequence of one or more assertions. 25 26type Assertion = IO () 27 28-- | Unconditionally signals that a failure has occured. All 29-- other assertions can be expressed with the form: 30-- 31-- @ 32-- if conditionIsMet 33-- then return () 34-- else assertFailure msg 35-- @ 36 37assertFailure 38 :: HasCallStack 39 => String -- ^ A message that is displayed with the assertion failure 40 -> IO a 41assertFailure msg = E.throwIO (HUnitFailure location msg) 42 where 43 location :: Maybe SrcLoc 44 location = case reverse callStack of 45 (_, loc) : _ -> Just loc 46 [] -> Nothing 47 48-- Conditional Assertion Functions 49-- ------------------------------- 50 51-- | Asserts that the specified condition holds. 52assertBool 53 :: HasCallStack 54 => String -- ^ The message that is displayed if the assertion fails 55 -> Bool -- ^ The condition 56 -> Assertion 57assertBool msg b = unless b (assertFailure msg) 58 59-- | Asserts that the specified actual value is equal to the expected value. 60-- The output message will contain the prefix, the expected value, and the 61-- actual value. 62-- 63-- If the prefix is the empty string (i.e., @\"\"@), then the prefix is omitted 64-- and only the expected and actual values are output. 65assertEqual 66 :: (Eq a, Show a, HasCallStack) 67 => String -- ^ The message prefix 68 -> a -- ^ The expected value 69 -> a -- ^ The actual value 70 -> Assertion 71assertEqual preface expected actual = 72 unless (actual == expected) (assertFailure msg) 73 where msg = (if null preface then "" else preface ++ "\n") ++ 74 "expected: " ++ show expected ++ "\n but got: " ++ show actual 75 76infix 1 @?, @=?, @?= 77 78-- | Asserts that the specified actual value is equal to the expected value 79-- (with the expected value on the left-hand side). 80(@=?) 81 :: (Eq a, Show a, HasCallStack) 82 => a -- ^ The expected value 83 -> a -- ^ The actual value 84 -> Assertion 85expected @=? actual = assertEqual "" expected actual 86 87-- | Asserts that the specified actual value is equal to the expected value 88-- (with the actual value on the left-hand side). 89(@?=) 90 :: (Eq a, Show a, HasCallStack) 91 => a -- ^ The actual value 92 -> a -- ^ The expected value 93 -> Assertion 94actual @?= expected = assertEqual "" expected actual 95 96-- | An infix and flipped version of 'assertBool'. E.g. instead of 97-- 98-- >assertBool "Non-empty list" (null [1]) 99-- 100-- you can write 101-- 102-- >null [1] @? "Non-empty list" 103-- 104-- '@?' is also overloaded to accept @'IO' 'Bool'@ predicates, so instead 105-- of 106-- 107-- > do 108-- > e <- doesFileExist "test" 109-- > e @? "File does not exist" 110-- 111-- you can write 112-- 113-- > doesFileExist "test" @? "File does not exist" 114(@?) :: (AssertionPredicable t, HasCallStack) 115 => t -- ^ A value of which the asserted condition is predicated 116 -> String -- ^ A message that is displayed if the assertion fails 117 -> Assertion 118predi @? msg = assertionPredicate predi >>= assertBool msg 119 120-- | An ad-hoc class used to overload the '@?' operator. 121-- 122-- The only intended instances of this class are @'Bool'@ and @'IO' 'Bool'@. 123-- 124-- You shouldn't need to interact with this class directly. 125class AssertionPredicable t 126 where assertionPredicate :: t -> IO Bool 127 128instance AssertionPredicable Bool 129 where assertionPredicate = return 130 131instance (AssertionPredicable t) => AssertionPredicable (IO t) 132 where assertionPredicate = (>>= assertionPredicate) 133 134 135-- | Exception thrown by 'assertFailure' etc. 136data HUnitFailure = HUnitFailure (Maybe SrcLoc) String 137 deriving (Eq, Show, Typeable) 138instance E.Exception HUnitFailure 139 140prependLocation :: Maybe SrcLoc -> String -> String 141prependLocation mbloc s = 142 case mbloc of 143 Nothing -> s 144 Just loc -> srcLocFile loc ++ ":" ++ show (srcLocStartLine loc) ++ ":\n" ++ s 145 146---------------------------------------------------------------------- 147-- DEPRECATED CODE 148---------------------------------------------------------------------- 149 150{-# DEPRECATED assertString "Why not use assertBool instead?" #-} 151{-# DEPRECATED Assertable, AssertionPredicate 152 "This class or type seems dubious. If you have a good use case for it, please create an issue for tasty. Otherwise, it may be removed in a future version." #-} 153 154-- | Signals an assertion failure if a non-empty message (i.e., a message 155-- other than @\"\"@) is passed. 156assertString 157 :: HasCallStack 158 => String -- ^ The message that is displayed with the assertion failure 159 -> Assertion 160assertString s = unless (null s) (assertFailure s) 161 162-- Overloaded `assert` Function 163-- ---------------------------- 164 165-- | Allows the extension of the assertion mechanism. 166-- 167-- Since an 'Assertion' can be a sequence of @Assertion@s and @IO@ actions, 168-- there is a fair amount of flexibility of what can be achieved. As a rule, 169-- the resulting @Assertion@ should be the body of a 'TestCase' or part of 170-- a @TestCase@; it should not be used to assert multiple, independent 171-- conditions. 172-- 173-- If more complex arrangements of assertions are needed, 'Test's and 174-- 'Testable' should be used. 175class Assertable t 176 where assert :: t -> Assertion 177 178instance Assertable () 179 where assert = return 180 181instance Assertable Bool 182 where assert = assertBool "" 183 184instance (Assertable t) => Assertable (IO t) 185 where assert = (>>= assert) 186 187instance Assertable String 188 where assert = assertString 189 190 191-- Overloaded `assertionPredicate` Function 192-- ---------------------------------------- 193 194-- | The result of an assertion that hasn't been evaluated yet. 195-- 196-- Most test cases follow the following steps: 197-- 198-- 1. Do some processing or an action. 199-- 200-- 2. Assert certain conditions. 201-- 202-- However, this flow is not always suitable. @AssertionPredicate@ allows for 203-- additional steps to be inserted without the initial action to be affected 204-- by side effects. Additionally, clean-up can be done before the test case 205-- has a chance to end. A potential work flow is: 206-- 207-- 1. Write data to a file. 208-- 209-- 2. Read data from a file, evaluate conditions. 210-- 211-- 3. Clean up the file. 212-- 213-- 4. Assert that the side effects of the read operation meet certain conditions. 214-- 215-- 5. Assert that the conditions evaluated in step 2 are met. 216type AssertionPredicate = IO Bool 217 218