tasty-hunit 0.9.2 → 0.10.2
raw patch · 5 files changed
Files
- CHANGELOG.md +45/−0
- Test/Tasty/HUnit.hs +59/−5
- Test/Tasty/HUnit/Orig.hs +128/−71
- Test/Tasty/HUnit/Steps.hs +30/−6
- tasty-hunit.cabal +12/−8
CHANGELOG.md view
@@ -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 -------------
Test/Tasty/HUnit.hs view
@@ -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 []
Test/Tasty/HUnit/Orig.hs view
@@ -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
Test/Tasty/HUnit/Steps.hs view
@@ -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
tasty-hunit.cabal view
@@ -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 <roma@ro-che.info> maintainer: Roman Cheplyaka <roma@ro-che.info>-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