{-# LANGUAGE DeriveDataTypeable, FlexibleInstances, TypeSynonymInstances #-} -- required for HasCallStack by different versions of GHC {-# LANGUAGE ConstraintKinds, FlexibleContexts #-} -- | This is the code copied from the original hunit package (v. 1.2.5.2). -- with minor modifications module Test.Tasty.HUnit.Orig where import qualified Control.Exception as E import Control.Monad import Data.Typeable (Typeable) import Data.CallStack -- Interfaces -- ---------- -- | An assertion is simply an 'IO' action. Assertion failure is indicated -- by throwing an exception, typically 'HUnitFailure'. -- -- Instead of throwing the exception directly, you should use -- functions like 'assertFailure' and 'assertBool'. -- -- Test cases are composed of a sequence of one or more assertions. type Assertion = IO () -- | Unconditionally signals that a failure has occured. All -- other assertions can be expressed with the form: -- -- @ -- if conditionIsMet -- then return () -- else assertFailure msg -- @ assertFailure :: HasCallStack => String -- ^ A message that is displayed with the assertion failure -> IO a assertFailure msg = E.throwIO (HUnitFailure location msg) where location :: Maybe SrcLoc location = case reverse callStack of (_, loc) : _ -> Just loc [] -> Nothing -- Conditional Assertion Functions -- ------------------------------- -- | Asserts that the specified condition holds. assertBool :: HasCallStack => String -- ^ The message that is displayed if the assertion fails -> Bool -- ^ The condition -> Assertion assertBool msg b = unless b (assertFailure 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 :: (Eq a, Show a, HasCallStack) => String -- ^ The message prefix -> a -- ^ The expected value -> a -- ^ The actual value -> Assertion assertEqual preface expected actual = unless (actual == expected) (assertFailure msg) where msg = (if null preface then "" else preface ++ "\n") ++ "expected: " ++ show expected ++ "\n but got: " ++ show actual infix 1 @?, @=?, @?= -- | Asserts that the specified actual value is equal to the expected value -- (with the expected value on the left-hand side). (@=?) :: (Eq a, Show a, HasCallStack) => a -- ^ The expected value -> a -- ^ The actual value -> Assertion expected @=? actual = assertEqual "" expected actual -- | Asserts that the specified actual value is equal to the expected value -- (with the actual value on the left-hand side). (@?=) :: (Eq a, Show a, HasCallStack) => a -- ^ The actual value -> a -- ^ The expected value -> Assertion actual @?= expected = assertEqual "" expected actual -- | An infix and flipped version of 'assertBool'. E.g. instead of -- -- >assertBool "Non-empty list" (null [1]) -- -- you can write -- -- >null [1] @? "Non-empty list" -- -- '@?' is also overloaded to accept @'IO' 'Bool'@ predicates, so instead -- of -- -- > do -- > e <- doesFileExist "test" -- > e @? "File does not exist" -- -- you can write -- -- > doesFileExist "test" @? "File does not exist" (@?) :: (AssertionPredicable t, HasCallStack) => t -- ^ A value of which the asserted condition is predicated -> String -- ^ A message that is displayed if the assertion fails -> Assertion predi @? msg = assertionPredicate predi >>= assertBool msg -- | An ad-hoc class used to overload the '@?' operator. -- -- The only intended instances of this class are @'Bool'@ and @'IO' 'Bool'@. -- -- You shouldn't need to interact with this class directly. class AssertionPredicable t where assertionPredicate :: t -> IO Bool instance AssertionPredicable Bool where assertionPredicate = return instance (AssertionPredicable t) => AssertionPredicable (IO t) where assertionPredicate = (>>= assertionPredicate) -- | Exception thrown by 'assertFailure' etc. data HUnitFailure = HUnitFailure (Maybe SrcLoc) String deriving (Eq, Show, Typeable) instance E.Exception HUnitFailure prependLocation :: Maybe SrcLoc -> String -> String prependLocation mbloc s = case mbloc of Nothing -> s Just loc -> srcLocFile loc ++ ":" ++ show (srcLocStartLine loc) ++ ":\n" ++ s ---------------------------------------------------------------------- -- DEPRECATED CODE ---------------------------------------------------------------------- {-# DEPRECATED assertString "Why not use assertBool instead?" #-} {-# DEPRECATED Assertable, AssertionPredicate "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." #-} -- | Signals an assertion failure if a non-empty message (i.e., a message -- other than @\"\"@) is passed. assertString :: HasCallStack => String -- ^ The message that is displayed with the assertion failure -> Assertion assertString s = unless (null s) (assertFailure s) -- Overloaded `assert` Function -- ---------------------------- -- | Allows the extension of the assertion mechanism. -- -- Since an 'Assertion' can be a sequence of @Assertion@s and @IO@ actions, -- there is a fair amount of flexibility of what can be achieved. As a rule, -- the resulting @Assertion@ should be the body of a 'TestCase' or part of -- a @TestCase@; it should not be used to assert multiple, independent -- conditions. -- -- If more complex arrangements of assertions are needed, 'Test's and -- 'Testable' should be used. class Assertable t where assert :: t -> Assertion instance Assertable () where assert = return instance Assertable Bool where assert = assertBool "" instance (Assertable t) => Assertable (IO t) where assert = (>>= assert) instance Assertable String where assert = assertString -- Overloaded `assertionPredicate` Function -- ---------------------------------------- -- | The result of an assertion that hasn't been evaluated yet. -- -- Most test cases follow the following steps: -- -- 1. Do some processing or an action. -- -- 2. Assert certain conditions. -- -- However, this flow is not always suitable. @AssertionPredicate@ allows for -- additional steps to be inserted without the initial action to be affected -- by side effects. Additionally, clean-up can be done before the test case -- has a chance to end. A potential work flow is: -- -- 1. Write data to a file. -- -- 2. Read data from a file, evaluate conditions. -- -- 3. Clean up the file. -- -- 4. Assert that the side effects of the read operation meet certain conditions. -- -- 5. Assert that the conditions evaluated in step 2 are met. type AssertionPredicate = IO Bool