diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,4 +1,4 @@ -Copyright (c) 2011-2015 Simon Hengel +Copyright (c) 2011-2023 Simon Hengel Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal diff --git a/hspec-expectations.cabal b/hspec-expectations.cabal --- a/hspec-expectations.cabal +++ b/hspec-expectations.cabal @@ -1,20 +1,21 @@ --- This file has been generated from package.yaml by hpack version 0.15.0. +cabal-version: 1.12 + +-- This file has been generated from package.yaml by hpack version 0.35.2. -- -- see: https://github.com/sol/hpack name: hspec-expectations -version: 0.8.2 +version: 0.8.3 synopsis: Catchy combinators for HUnit description: Catchy combinators for HUnit: bug-reports: https://github.com/hspec/hspec-expectations/issues license: MIT license-file: LICENSE -copyright: (c) 2011-2015 Simon Hengel +copyright: (c) 2011-2023 Simon Hengel author: Simon Hengel maintainer: Simon Hengel build-type: Simple category: Testing -cabal-version: >= 1.10 homepage: https://github.com/hspec/hspec-expectations#readme source-repository head @@ -26,9 +27,9 @@ src ghc-options: -Wall build-depends: - base == 4.* + HUnit + , base ==4.* , call-stack - , HUnit exposed-modules: Test.Hspec.Expectations Test.Hspec.Expectations.Contrib @@ -45,14 +46,17 @@ src ghc-options: -Wall build-depends: - base == 4.* + HUnit >=1.5.0.0 + , base ==4.* , call-stack , nanospec - , HUnit >= 1.5.0.0 other-modules: + Helper + Test.Hspec.Expectations.ContribSpec Test.Hspec.Expectations.MatcherSpec Test.Hspec.ExpectationsSpec Test.Hspec.Expectations Test.Hspec.Expectations.Contrib Test.Hspec.Expectations.Matcher + Paths_hspec_expectations default-language: Haskell2010 diff --git a/src/Test/Hspec/Expectations.hs b/src/Test/Hspec/Expectations.hs --- a/src/Test/Hspec/Expectations.hs +++ b/src/Test/Hspec/Expectations.hs @@ -3,7 +3,7 @@ {-# LANGUAGE KindSignatures #-} {-# LANGUAGE ImplicitParams #-} -- | --- Introductory documentation: +-- Introductory documentation: module Test.Hspec.Expectations ( -- * Setting expectations diff --git a/src/Test/Hspec/Expectations/Contrib.hs b/src/Test/Hspec/Expectations/Contrib.hs --- a/src/Test/Hspec/Expectations/Contrib.hs +++ b/src/Test/Hspec/Expectations/Contrib.hs @@ -7,8 +7,13 @@ -- | (useful in combination with `shouldSatisfy`) isLeft , isRight + +-- * Annotating expectations +, annotate ) where +import Control.Exception +import Test.HUnit.Lang (HUnitFailure(..), FailureReason(..)) #if MIN_VERSION_base(4,7,0) import Data.Either @@ -24,3 +29,32 @@ isRight (Left _) = False isRight (Right _) = True #endif + +-- | +-- If you have a test case that has multiple assertions, you can use the +-- 'annotate' function to provide a string message that will be attached to +-- the 'Expectation'. +-- +-- @ +-- describe "annotate" $ do +-- it "adds the message" $ do +-- annotate "obvious falsehood" $ do +-- True `shouldBe` False +-- +-- ========> +-- +-- 1) annotate, adds the message +-- obvious falsehood +-- expected: False +-- but got: True +-- @ +-- +-- @since 0.8.3 +annotate :: String -> IO a -> IO a +annotate message = handle $ \ (HUnitFailure loc reason) -> throwIO . HUnitFailure loc $ case reason of + Reason err -> Reason $ addMessage err + ExpectedButGot err expected got -> ExpectedButGot (Just $ maybe message addMessage err) expected got + where + addMessage err + | null err = message + | otherwise = message ++ "\n" ++ err diff --git a/src/Test/Hspec/Expectations/Matcher.hs b/src/Test/Hspec/Expectations/Matcher.hs --- a/src/Test/Hspec/Expectations/Matcher.hs +++ b/src/Test/Hspec/Expectations/Matcher.hs @@ -17,10 +17,10 @@ err :: ShowS err = showString "Actual list is not a permutation of expected list!\n" - . msgAndList " expected list contains: " ys - . msgAndList " actual list contains: " xs - . optMsgList " the missing elements are: " missing - . optMsgList " the extra elements are: " extra + . msgAndList " expected elements: " ys + . msgAndList " actual elements: " xs + . optMsgList " missing elements: " missing + . optMsgList " extra elements: " extra showList :: Show a => [a] -> ShowS showList xs = showChar '[' . foldr (.) (showChar ']') (intersperse (showString ", ") $ map shows xs) diff --git a/test/Helper.hs b/test/Helper.hs new file mode 100644 --- /dev/null +++ b/test/Helper.hs @@ -0,0 +1,19 @@ +{-# LANGUAGE FlexibleContexts #-} + +module Helper where + +import Test.HUnit.Lang +import Data.CallStack + +-- note: this function expects the callstacks to have identical line +-- numbers, so you need to be careful to call expectationFailed on the same +-- line that you throw any exceptions +expectationFailed :: HasCallStack => FailureReason -> HUnitFailure -> Bool +expectationFailed msg (HUnitFailure l m) = m == msg && (fmap setColumn l) == (fmap setColumn location) + where + location = case reverse callStack of + [] -> Nothing + (_, loc) : _ -> Just loc + location :: Maybe SrcLoc + + setColumn loc_ = loc_{srcLocStartCol = 0, srcLocEndCol = 0} diff --git a/test/Test/Hspec/Expectations/ContribSpec.hs b/test/Test/Hspec/Expectations/ContribSpec.hs new file mode 100644 --- /dev/null +++ b/test/Test/Hspec/Expectations/ContribSpec.hs @@ -0,0 +1,30 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE FlexibleContexts #-} +module Test.Hspec.Expectations.ContribSpec (spec) where + +import Helper + +import Test.HUnit.Lang +import Test.Hspec (Spec, describe, it) + +import Test.Hspec.Expectations +import Test.Hspec.Expectations.Contrib + +spec :: Spec +spec = do + describe "annotate" $ do + it "does not affect the running of a successful test" $ do + annotate "obviously correct" $ + True `shouldBe` True + + it "provides a message on expectation failure" $ do + (annotate "obvious falsehood" $ True `shouldBe` False) `shouldThrow` expectationFailed (ExpectedButGot (Just "obvious falsehood") (show False) (show True)) + + it "nests messages using newlines" $ do + let msg0 = "obvious falsehood" + msg1 = "welp" + msgs = msg0 ++ "\n" ++ msg1 + (annotate msg0 $ annotate msg1 $ True `shouldBe` False) `shouldThrow` expectationFailed (ExpectedButGot (Just msgs) (show False) (show True)) + + it "appends messages to Reason" $ do + (annotate "welp" $ True `shouldSatisfy` (== False)) `shouldThrow` expectationFailed (Reason "welp\npredicate failed on: True") diff --git a/test/Test/Hspec/Expectations/MatcherSpec.hs b/test/Test/Hspec/Expectations/MatcherSpec.hs --- a/test/Test/Hspec/Expectations/MatcherSpec.hs +++ b/test/Test/Hspec/Expectations/MatcherSpec.hs @@ -20,15 +20,15 @@ it "shows extra elements" $ do [1, 2, 2, 3] `matchList` [1, 2, 3 :: Int] `shouldBe` (Just . unlines) [ "Actual list is not a permutation of expected list!" - , " expected list contains: [1, 2, 3]" - , " actual list contains: [1, 2, 2, 3]" - , " the extra elements are: [2]" + , " expected elements: [1, 2, 3]" + , " actual elements: [1, 2, 2, 3]" + , " extra elements: [2]" ] it "shows missing elements" $ do [1, 2, 3] `matchList` [1, 2, 2, 3 :: Int] `shouldBe` (Just . unlines) [ "Actual list is not a permutation of expected list!" - , " expected list contains: [1, 2, 2, 3]" - , " actual list contains: [1, 2, 3]" - , " the missing elements are: [2]" + , " expected elements: [1, 2, 2, 3]" + , " actual elements: [1, 2, 3]" + , " missing elements: [2]" ] diff --git a/test/Test/Hspec/ExpectationsSpec.hs b/test/Test/Hspec/ExpectationsSpec.hs --- a/test/Test/Hspec/ExpectationsSpec.hs +++ b/test/Test/Hspec/ExpectationsSpec.hs @@ -2,22 +2,13 @@ {-# LANGUAGE FlexibleContexts #-} module Test.Hspec.ExpectationsSpec (spec) where +import Helper + import Control.Exception import Test.HUnit.Lang import Test.Hspec (Spec, describe, it) -import Test.Hspec.Expectations hiding (HasCallStack) -import Data.CallStack - -expectationFailed :: HasCallStack => FailureReason -> HUnitFailure -> Bool -expectationFailed msg (HUnitFailure l m) = m == msg && (fmap setColumn l) == (fmap setColumn location) - where - location = case reverse callStack of - [] -> Nothing - (_, loc) : _ -> Just loc - location :: Maybe SrcLoc - - setColumn loc_ = loc_{srcLocStartCol = 0, srcLocEndCol = 0} +import Test.Hspec.Expectations spec :: Spec spec = do