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