diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,6 +1,13 @@ Changes ======= +Version 0.10 +------------ + +* Make `assertFailure`'s return type polymorphic +* When a test fails, print the source location of the failing assertion +* Deprecate `Assertable`, `AssertionPredicate`, `AssertionPredicable`, `(@?)` + Version 0.9.2 ------------- diff --git a/Test/Tasty/HUnit.hs b/Test/Tasty/HUnit.hs --- a/Test/Tasty/HUnit.hs +++ b/Test/Tasty/HUnit.hs @@ -1,10 +1,63 @@ --- | Unit testing support for tasty, inspired by the HUnit package +-- | Unit testing support for tasty, inspired by the HUnit package. +-- +-- Here's an example (a single tasty test case consisting of three +-- assertions): +-- +-- >import Test.Tasty +-- >import Test.Tasty.HUnit +-- > +-- >main = defaultMain $ +-- > testCase "Example test case" $ do +-- > -- assertion no. 1 (passes) +-- > 2 + 2 @?= 4 +-- > -- assertion no. 2 (fails) +-- > assertBool "the list is not empty" $ null [1] +-- > -- assertion no. 3 (would have failed, but won't be executed because +-- > -- the previous assertion has already failed) +-- > "foo" @?= "bar" {-# LANGUAGE TypeFamilies, DeriveDataTypeable #-} module Test.Tasty.HUnit - ( testCase + ( + -- * Constructing test cases + testCase , testCaseInfo , testCaseSteps - , module Test.Tasty.HUnit.Orig + -- * Constructing assertions + , assertFailure + , assertBool + , assertEqual + , (@=?) + , (@?=) + -- * Data types + , Assertion + , HUnitFailure(..) + -- * Accurate location for domain-specific assertion functions + -- | It is common to define domain-specific assertion functions based + -- on the standard ones, e.g. + -- + -- > assertNonEmpty = assertBool "List is empty" . not . null + -- + -- The problem is that if a test fails, tasty-hunit will point to the + -- definition site of @assertNonEmpty@ as the source of failure, not + -- its use site. + -- + -- To correct this, add a 'HasCallStack' constraint (re-exported from + -- this module) to your function: + -- + -- > assertNonEmpty :: HasCallStack => [a] -> Assertion + -- > assertNonEmpty = assertBool "List is empty" . not . null + -- + , HasCallStack + -- * Deprecated functions and types + -- | These definitions come from HUnit, but I don't see why one would + -- need them. If you have a valid use case for them, please contact me + -- or file an issue for tasty. Otherwise, they will eventually be + -- removed. + , assertString + , Assertable(..) + , AssertionPredicate + , AssertionPredicable(..) + , (@?) ) where import Test.Tasty.Providers @@ -13,9 +66,10 @@ import Test.Tasty.HUnit.Steps import Data.Typeable +import Data.CallStack (HasCallStack) import Control.Exception --- | Create a 'Test' for a HUnit 'Assertion' +-- | Turn an 'Assertion' into a tasty test case testCase :: TestName -> Assertion -> TestTree testCase name = singleTest name . TestCase . (fmap (const "")) @@ -49,6 +103,6 @@ return $ case hunitResult of Right info -> testPassed info - Left (HUnitFailure message) -> testFailed message + Left (HUnitFailure mbloc message) -> testFailed $ prependLocation mbloc message testOptions = return [] diff --git a/Test/Tasty/HUnit/Orig.hs b/Test/Tasty/HUnit/Orig.hs --- a/Test/Tasty/HUnit/Orig.hs +++ b/Test/Tasty/HUnit/Orig.hs @@ -1,4 +1,8 @@ {-# 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 @@ -6,13 +10,17 @@ import qualified Control.Exception as E import Control.Monad import Data.Typeable (Typeable) +import Data.CallStack -- Interfaces -- ---------- --- | When an assertion is evaluated, it will output a message if and only if the --- assertion fails. +-- | 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 () @@ -21,55 +29,104 @@ -- other assertions can be expressed with the form: -- -- @ --- if conditionIsMet --- then IO () +-- if conditionIsMet +-- then return () -- else assertFailure msg --- @ +-- @ -assertFailure :: String -- ^ A message that is displayed with the assertion failure - -> Assertion -assertFailure msg = E.throwIO (HUnitFailure 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 :: String -- ^ The message that is displayed if the assertion fails - -> Bool -- ^ The condition - -> Assertion +assertBool + :: HasCallStack + => String -- ^ The message that is displayed if the assertion fails + -> Bool -- ^ The condition + -> Assertion assertBool msg b = unless b (assertFailure msg) --- | Signals an assertion failure if a non-empty message (i.e., a message --- other than @\"\"@) is passed. -assertString :: String -- ^ The message that is displayed with the assertion failure - -> Assertion -assertString s = unless (null s) (assertFailure s) - -- | Asserts that the specified actual value is equal to the expected value. --- The output message will contain the prefix, the expected value, and the +-- 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) => String -- ^ The message prefix - -> a -- ^ The expected value - -> a -- ^ The actual value - -> Assertion +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 +-- | 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 + +-- | 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, AssertionPredicable, (@?) + "This class or function 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, +-- 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 +-- a @TestCase@; it should not be used to assert multiple, independent -- conditions. -- -- If more complex arrangements of assertions are needed, 'Test's and @@ -111,13 +168,13 @@ -- 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 --- | Used to signify that a data type can be converted to an assertion +-- | Used to signify that a data type can be converted to an assertion -- predicate. class AssertionPredicable t where assertionPredicate :: t -> AssertionPredicate @@ -141,21 +198,3 @@ -> Assertion predi @? msg = assertionPredicate predi >>= assertBool msg --- | 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) => 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) => a -- ^ The actual value - -> a -- ^ The expected value - -> Assertion -actual @?= expected = assertEqual "" expected actual - --- | Exception thrown by 'assertFailure' etc. -data HUnitFailure = HUnitFailure String - deriving (Show, Typeable) -instance E.Exception HUnitFailure diff --git a/Test/Tasty/HUnit/Steps.hs b/Test/Tasty/HUnit/Steps.hs --- a/Test/Tasty/HUnit/Steps.hs +++ b/Test/Tasty/HUnit/Steps.hs @@ -5,6 +5,7 @@ import Control.Exception import Data.IORef import Data.Typeable (Typeable) +import Prelude -- Silence AMP import warnings import Test.Tasty.HUnit.Orig import Test.Tasty.Providers @@ -28,14 +29,14 @@ Right {} -> testPassed (unlines msgs) - Left (HUnitFailure errMsg) -> testFailed $ + Left (HUnitFailure mbloc errMsg) -> testFailed $ if null msgs then errMsg else -- Indent the error msg w.r.t. step messages unlines $ - msgs ++ map (" " ++) (lines errMsg) + msgs ++ map (" " ++) (lines . prependLocation mbloc $ errMsg) testOptions = return [] diff --git a/tasty-hunit.cabal b/tasty-hunit.cabal --- a/tasty-hunit.cabal +++ b/tasty-hunit.cabal @@ -2,14 +2,14 @@ -- documentation, see http://haskell.org/cabal/users-guide/ name: tasty-hunit -version: 0.9.2 +version: 0.10 synopsis: HUnit support for the Tasty test framework. description: HUnit support for the Tasty test framework. license: MIT license-file: LICENSE author: Roman Cheplyaka maintainer: Roman Cheplyaka -homepage: http://documentup.com/feuerbach/tasty +homepage: https://github.com/feuerbach/tasty bug-reports: https://github.com/feuerbach/tasty/issues -- copyright: category: Testing @@ -27,7 +27,7 @@ other-modules: Test.Tasty.HUnit.Orig Test.Tasty.HUnit.Steps other-extensions: TypeFamilies, DeriveDataTypeable - build-depends: base ==4.*, tasty >= 0.8 + build-depends: base ==4.*, tasty >= 0.8, call-stack -- hs-source-dirs: default-language: Haskell2010 ghc-options: -Wall