Add shouldBeNear expectation

.travis.yml

@@ -3,7 +3,7 @@ sudo: false
 env:
   - CABALVER=1.18 GHCVER=7.6.3
   - CABALVER=1.18 GHCVER=7.8.4
-  - CABALVER=1.22 GHCVER=7.10.2
+  - CABALVER=1.22 GHCVER=7.10.3
   - CABALVER=1.24 GHCVER=8.0.1
 
 addons:
@@ -13,7 +13,7 @@ addons:
     packages:
       - ghc-7.6.3
       - ghc-7.8.4
-      - ghc-7.10.2
+      - ghc-7.10.3
       - ghc-8.0.1
       - cabal-install-1.18
       - cabal-install-1.22

src/Test/Hspec/Expectations.hs

@@ -11,6 +11,7 @@ module Test.Hspec.Expectations (
   Expectation
 , expectationFailure
 , shouldBe
+, shouldBeNear
 , shouldSatisfy
 , shouldStartWith
 , shouldEndWith
@@ -78,7 +79,7 @@ expectationFailure = Test.HUnit.assertFailure
 with_loc(expectTrue, String -> Bool -> Expectation)
 expectTrue msg b = unless b (expectationFailure msg)
 
-infix 1 `shouldBe`, `shouldSatisfy`, `shouldStartWith`, `shouldEndWith`, `shouldContain`, `shouldMatchList`, `shouldReturn`, `shouldThrow`
+infix 1 `shouldBe`, `shouldBeNear`, `shouldSatisfy`, `shouldStartWith`, `shouldEndWith`, `shouldContain`, `shouldMatchList`, `shouldReturn`, `shouldThrow`
 infix 1 `shouldNotBe`, `shouldNotSatisfy`, `shouldNotContain`, `shouldNotReturn`
 
 -- |
@@ -87,6 +88,24 @@ infix 1 `shouldNotBe`, `shouldNotSatisfy`, `shouldNotContain`, `shouldNotReturn`
 with_loc(shouldBe, (Show a, Eq a) => a -> a -> Expectation)
 actual `shouldBe` expected = expectTrue ("expected: " ++ show expected ++ "\n but got: " ++ show actual) (actual == expected)
 
+-- |
+-- @actual \`shouldBeNear\` expected@ sets the expectation that @actual@ be a
+-- floating point value near @expected@. If either value is zero we check that
+-- the absolute difference is less than epsilon (1e-15) otherwise we check if
+-- the relative difference is less than epsilon.
+with_loc(shouldBeNear, (Show a, Ord a, Floating a) => a -> a -> Expectation)
+actual `shouldBeNear` expected
+  -- Short circuit if they are actually equal.
+  | actual == expected = reportFail (actual == expected)
+  | actual == 0 || expected == 0 = reportFail (absoluteDifference < epsilon)
+  | otherwise =  reportFail (relativeDifference < epsilon)
+  where
+    epsilon = 1e-15
+    absoluteDifference = abs (expected - actual)
+    relativeDifference = absoluteDifference / (abs actual + abs expected)
+    reportFail =
+      expectTrue ("expected: " ++ show expected ++ "\n but got: " ++ show actual)
+
 -- |
 -- @v \`shouldSatisfy\` p@ sets the expectation that @p v@ is @True@.
 with_loc(shouldSatisfy, (Show a) => a -> (a -> Bool) -> Expectation)

test/Test/Hspec/ExpectationsSpec.hs

@@ -1,4 +1,5 @@
 {-# LANGUAGE CPP #-}
+
 #if MIN_VERSION_base(4,8,1)
 #define HAS_SOURCE_LOCATIONS
 {-# LANGUAGE ImplicitParams #-}
@@ -43,6 +44,31 @@ spec = do
     it "fails if arguments are not equal" $ do
       ("foo" `shouldBe` "bar") `shouldThrow` expectationFailed "expected: \"bar\"\n but got: \"foo\""
 
+  describe "shouldBeNear" $ do
+    it "succeeds if arguments are equal" $ do
+      1.23456789 `shouldBeNear` (1.23456789 :: Float)
+
+    it "fails if arguments are not equal" $ do
+      (1.0 `shouldBe` (2.0 :: Float)) `shouldThrow` expectationFailed "expected: 2.0\n but got: 1.0"
+
+    it "succeeds if one argument is zero and the other less than epsilon" $ do
+      0.0 `shouldBeNear` (-1e-16 :: Float)
+
+    it "succeeds for large values near one another" $ do
+      1e20 `shouldBeNear` (1e20 + 1 :: Float)
+
+    it "succeeds for a small number near zero" $ do
+      1e-300 `shouldBeNear` (0.0 :: Double)
+
+#if __GLASGOW_HASKELL__ != 710
+    -- For some reason this fails with ghc-7.10.2 and 7.10.3.
+    it "fails for large values not near each other" $ do
+      (1.1e20 `shouldBeNear` (2.1e20 :: Double)) `shouldThrow` expectationFailed "expected: 2.1e20\n but got: 1.1e20"
+
+    it "fails for two small numbers that are not near each other" $ do
+      (1.1e-300 `shouldBeNear` (1e-300 :: Double)) `shouldThrow` expectationFailed "expected: 1.0e-300\n but got: 1.1e-300"
+#endif
+
   describe "shouldSatisfy" $ do
     it "succeeds if value satisfies predicate" $ do
       "" `shouldSatisfy` null