diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,98 @@ +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 +------------- + +Add `testCaseInfo` for tests that return some information upon success + +Version 0.9.1 +------------- + +Add `testCaseSteps` for multi-step tests + +Version 0.9.0.1 +--------------- + +Split the changelog out of the main tasty changelog + +Version 0.9 +----------- + +tasty-hunit now does not depend on the original HUnit package. The functions +that were previously re-exported from HUnit have been simply copied to +tasty-hunit. + +This is motivated by: + +* efficiency (one less package to compile/install) +* reliability (if something happens with HUnit, we won't be affected) + +The two packages are still compatible, except for the name clashes and +distinct exception types being thrown on assertion failures. + +Version 0.8.0.1 +--------------- + +Fix unbuildable haddock + +Version 0.8 +----------- + +* Exceptions are now handled by tasty rather than by HUnit +* Update to tasty-0.8 + +Version 0.4.1 +------------- + +Do not re-export HUnit's `Testable` class + +Version 0.2 +----------- + +Re-export useful bits of `Test.HUnit` from `Test.Tasty.HUnit` diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -17,3 +17,35 @@ LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. + +-------------------------------------------------------------------------------- + +HUnit is Copyright (c) Dean Herington, 2002, all rights reserved, +and is distributed as free software under the following license. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions +are met: + +- Redistributions of source code must retain the above copyright +notice, this list of conditions, and the following disclaimer. + +- Redistributions in binary form must reproduce the above copyright +notice, this list of conditions, and the following disclaimer in the +documentation and/or other materials provided with the distribution. + +- The names of the copyright holders may not be used to endorse or +promote products derived from this software without specific prior +written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS "AS IS" AND ANY +EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS BE +LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR +BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, +WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE +OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN +IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Test/Tasty/HUnit.hs b/Test/Tasty/HUnit.hs --- a/Test/Tasty/HUnit.hs +++ b/Test/Tasty/HUnit.hs @@ -1,57 +1,108 @@ --- | This module allows to use HUnit tests in tasty. +-- | 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 - -- | We only re-export parts of "Test.HUnit.Base" related to assertions - -- and not tests. - , module Test.HUnit.Base + ( + -- * Constructing test cases + testCase + , testCaseInfo + , testCaseSteps + -- * 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 -import qualified Test.HUnit.Base -import Test.HUnit.Lang -import Test.HUnit.Base hiding -- for re-export - ( Test(..) - , (~=?) - , (~?=) - , (~:) - , (~?) - , State(..) - , Counts(..) - , Path - , Node - , testCasePaths - , testCaseCount - , ReportStart - , ReportProblem - , performTest - ) +import Test.Tasty.HUnit.Orig +import Test.Tasty.HUnit.Steps import Data.Typeable -import Control.Monad.Trans +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 +testCase name = singleTest name . TestCase . (fmap (const "")) -newtype TestCase = TestCase Assertion +-- | Like 'testCase', except in case the test succeeds, the returned string +-- will be shown as the description. If the empty string is returned, it +-- will be ignored. +testCaseInfo :: TestName -> IO String -> TestTree +testCaseInfo name = singleTest name . TestCase + +-- IO String is a computation that throws an exception upon failure or +-- returns an informational string otherwise. This allows us to unify the +-- implementation of 'testCase' and 'testCaseInfo'. +-- +-- In case of testCase, we simply make the result string empty, which makes +-- tasty ignore it. +newtype TestCase = TestCase (IO String) deriving Typeable instance IsTest TestCase where run _ (TestCase assertion) _ = do - hunitResult <- performTestCase assertion + -- The standard HUnit's performTestCase catches (almost) all exceptions. + -- + -- This is bad for a few reasons: + -- - it interferes with timeout handling + -- - it makes exception reporting inconsistent across providers + -- - it doesn't provide enough information for ingredients such as + -- tasty-rerun + -- + -- So we do it ourselves. + hunitResult <- try assertion return $ case hunitResult of - Nothing -> - Result - { resultSuccessful = True - , resultDescription = "" - } - Just (_, message) -> - Result - { resultSuccessful = False - , resultDescription = message - } + Right info -> testPassed info + Left (HUnitFailure mbloc message) -> testFailed $ prependLocation mbloc message testOptions = return [] diff --git a/Test/Tasty/HUnit/Orig.hs b/Test/Tasty/HUnit/Orig.hs new file mode 100644 --- /dev/null +++ b/Test/Tasty/HUnit/Orig.hs @@ -0,0 +1,218 @@ +{-# 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 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, +-- 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@ 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 + diff --git a/Test/Tasty/HUnit/Steps.hs b/Test/Tasty/HUnit/Steps.hs new file mode 100644 --- /dev/null +++ b/Test/Tasty/HUnit/Steps.hs @@ -0,0 +1,111 @@ +{-# 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) yieldProgress = do + ref <- newIORef [] + + let + stepFn :: String -> IO () + 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 <- (Right <$> assertionFn stepFn) `catch` + \(SomeException ex) -> return $ Left (displayException ex) + + 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 errMsg -> testFailed $ + if null msgs + then + errMsg + else + -- Indent the error msg w.r.t. step messages + unlines $ + msgs ++ map (" " ++) (lines errMsg) + + testOptions = return [] + +-- | Create a multi-step unit test. +-- +-- Example: +-- +-- >main = defaultMain $ testCaseSteps "Multi-step test" $ \step -> do +-- > step "Preparing..." +-- > -- do something +-- > +-- > step "Running part 1" +-- > -- do something +-- > +-- > step "Running part 2" +-- > -- do something +-- > assertFailure "BAM!" +-- > +-- > step "Running part 3" +-- > -- do something +-- +-- The @step@ calls are mere annotations. They let you see which steps were +-- performed successfully, and which step failed. +-- +-- You can think of @step@ +-- as 'putStrLn', except 'putStrLn' would mess up the output with the +-- console reporter and get lost with the others. +-- +-- For the example above, the output will be +-- +-- >Multi-step test: FAIL +-- > Preparing... +-- > Running part 1 +-- > Running part 2 +-- > BAM! +-- > +-- >1 out of 1 tests failed (0.00s) +-- +-- Note that: +-- +-- * Tasty still treats this as a single test, even though it consists of +-- multiple steps. +-- +-- * The execution stops after the first failure. When we are looking at +-- a failed test, we know that all /displayed/ steps but the last one were +-- successful, and the last one failed. The steps /after/ the failed one +-- are /not displayed/, since they didn't run. +testCaseSteps :: TestName -> ((String -> IO ()) -> Assertion) -> TestTree +testCaseSteps name = singleTest name . TestCaseSteps diff --git a/tasty-hunit.cabal b/tasty-hunit.cabal --- a/tasty-hunit.cabal +++ b/tasty-hunit.cabal @@ -1,24 +1,37 @@ --- Initial tasty-hunit.cabal generated by cabal init. For further --- documentation, see http://haskell.org/cabal/users-guide/ - name: tasty-hunit -version: 0.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: roma@ro-che.info +author: Roman Cheplyaka +maintainer: Roman Cheplyaka +homepage: https://github.com/UnkindPartition/tasty +bug-reports: https://github.com/UnkindPartition/tasty/issues -- copyright: category: Testing build-type: Simple --- extra-source-files: +extra-source-files: CHANGELOG.md cabal-version: >=1.10 +Source-repository head + type: git + location: https://github.com/UnkindPartition/tasty.git + subdir: hunit + library exposed-modules: Test.Tasty.HUnit - -- other-modules: + other-modules: Test.Tasty.HUnit.Orig + Test.Tasty.HUnit.Steps other-extensions: TypeFamilies, DeriveDataTypeable - build-depends: base ==4.*, tasty, HUnit, mtl + 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