diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,6 +1,51 @@ Changes ======= +Version 0.10.2 +-------------- + +* Teach `testCaseSteps` to log progress + ([#387](https://github.com/UnkindPartition/tasty/pull/387)). + +Version 0.10.1 +--------------- + +* Provide an explicit implementation of `displayException` + in `instance Exception HUnitFailure` + ([#330](https://github.com/UnkindPartition/tasty/issues/330)). + +Version 0.10.0.3 +---------------- + +The only point of this release is to introduce compatibility with GHCs back to 7.0 +(see https://github.com/UnkindPartition/tasty/pull/287). + +Note, however, that these changes are not merged to the master branch, and the +future releases will only support the GHC/base versions from the last 5 years, +as per our usual policy. To test with even older GHCs, you'll have to use this +particular version of tasty-hunit (or have the constraint solver pick it for you +when testing with older GHCs). + +The source of this release is in the `support-old-ghcs` branch of the tasty +repository. + +Version 0.10.0.2 +---------------- + +Catch all exceptions and time each step in testCaseSteps + +Version 0.10.0.1 +---------------- + +Un-deprecate `(@?)` and `AssertionPredicable` and improve their docs + +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 + , (@=?) + , (@?=) + , (@?) + , AssertionPredicable(..) + -- * 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 ) 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,59 +29,150 @@ -- 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 +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 where + displayException (HUnitFailure mbloc s) = prependLocation mbloc s + +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, +-- 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 +-- 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. +-- If more complex arrangements of assertions are needed, @Test@ and +-- @Testable@ should be used. class Assertable t where assert :: t -> Assertion @@ -111,51 +210,9 @@ -- 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 --- predicate. -class AssertionPredicable t - where assertionPredicate :: t -> AssertionPredicate - -instance AssertionPredicable Bool - where assertionPredicate = return - -instance (AssertionPredicable t) => AssertionPredicable (IO t) - where assertionPredicate = (>>= assertionPredicate) - - --- Assertion Construction Operators --- -------------------------------- - -infix 1 @?, @=?, @?= - --- | Asserts that the condition obtained from the specified --- 'AssertionPredicable' holds. -(@?) :: (AssertionPredicable t) => 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 - --- | 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 @@ -1,34 +1,58 @@ -{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveDataTypeable, BangPatterns #-} module Test.Tasty.HUnit.Steps (testCaseSteps) where import Control.Applicative import Control.Exception import Data.IORef +import Data.List (foldl') import Data.Typeable (Typeable) +import Prelude -- Silence AMP import warnings import Test.Tasty.HUnit.Orig import Test.Tasty.Providers +import Test.Tasty.Runners (getTime) +import Text.Printf (printf) newtype TestCaseSteps = TestCaseSteps ((String -> IO ()) -> Assertion) deriving Typeable instance IsTest TestCaseSteps where - run _ (TestCaseSteps assertionFn) _ = do + run _ (TestCaseSteps assertionFn) yieldProgress = do ref <- newIORef [] let stepFn :: String -> IO () - stepFn msg = atomicModifyIORef ref (\l -> (msg:l, ())) + stepFn msg = do + tme <- getTime + -- The number of steps is not fixed, so we can't + -- provide the progress percentage. + -- We also don't provide the timings here, only + -- at the end. + yieldProgress (Progress msg 0) + atomicModifyIORef ref (\l -> ((tme,msg):l, ())) - hunitResult <- try (assertionFn stepFn) + hunitResult <- (Right <$> assertionFn stepFn) `catch` + \(SomeException ex) -> return $ Left (displayException ex) - msgs <- reverse <$> readIORef ref + endTime <- getTime + maxMsgLength <- foldl' max 0 . map (length . snd) <$> readIORef ref + + let msgFormat = "%-" ++ show (min maxMsgLength 62) ++ "s (%.02fs)" + + msgs <- snd . foldl' + (\(lastTime, acc) (curTime, msg) -> + let !duration = lastTime - curTime + !msg' = if duration >= 0.01 then printf msgFormat msg duration else msg + in (curTime, msg':acc)) + (endTime, []) + <$> readIORef ref + return $ case hunitResult of Right {} -> testPassed (unlines msgs) - Left (HUnitFailure errMsg) -> testFailed $ + Left errMsg -> testFailed $ if null msgs then errMsg diff --git a/tasty-hunit.cabal b/tasty-hunit.cabal --- a/tasty-hunit.cabal +++ b/tasty-hunit.cabal @@ -1,16 +1,18 @@ --- Initial tasty-hunit.cabal generated by cabal init. For further --- documentation, see http://haskell.org/cabal/users-guide/ - name: tasty-hunit -version: 0.9.2 +version: 0.10.2 synopsis: HUnit support for the Tasty test framework. description: HUnit support for the Tasty test framework. + . + Note that this package does not depend on HUnit but + implements the relevant subset of its API. The name is a + legacy of the early versions of tasty-hunit and of + test-framework-hunit, which did depend on HUnit. license: MIT license-file: LICENSE author: Roman Cheplyaka maintainer: Roman Cheplyaka -homepage: http://documentup.com/feuerbach/tasty -bug-reports: https://github.com/feuerbach/tasty/issues +homepage: https://github.com/UnkindPartition/tasty +bug-reports: https://github.com/UnkindPartition/tasty/issues -- copyright: category: Testing build-type: Simple @@ -19,7 +21,7 @@ Source-repository head type: git - location: git://github.com/feuerbach/tasty.git + location: https://github.com/UnkindPartition/tasty.git subdir: hunit library @@ -27,7 +29,9 @@ 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.8 && < 5, + tasty >= 1.2.2 && < 1.6, + call-stack < 0.5 -- hs-source-dirs: default-language: Haskell2010 ghc-options: -Wall