Bump HSpec to 2.4.4 and make tests use safeEvaluateExample to capture failure msg

servant-quickcheck.cabal

@@ -38,14 +38,15 @@ library
                      , case-insensitive == 1.2.*
                      , clock >= 0.7 && < 0.8
                      , data-default-class >= 0.0 && < 0.2
-                     , hspec >= 2.2 && < 2.4
+                     , hspec >= 2.4.4 && < 2.5
+                     , hspec-core >= 2.4.4 && < 2.5
                      , http-client >= 0.4.30 && < 0.6
                      , http-media == 0.6.*
                      , http-types > 0.8 && < 0.10
                      , mtl > 2.1 && < 2.3
                      , pretty == 1.1.*
                      , process >= 1.2 && < 1.5
-                     , QuickCheck > 2.7 && < 2.10
+                     , QuickCheck > 2.9 && < 2.11
                      , servant > 0.6 && < 0.10
                      , servant-client > 0.6 && < 0.10
                      , servant-server > 0.6 && < 0.10

src/Servant/QuickCheck/Internal/QuickCheck.hs

@@ -14,8 +14,7 @@ import           Servant                  (Context (EmptyContext), HasServer,
 import           Servant.Client           (BaseUrl (..), Scheme (..))
 import           System.IO.Unsafe         (unsafePerformIO)
 import           Test.Hspec               (Expectation, expectationFailure)
-import           Test.QuickCheck          (Args (..), Result (..),
-                                           quickCheckWithResult)
+import           Test.QuickCheck          (Args (..),  Result (..), quickCheckWithResult)
 import           Test.QuickCheck.Monadic  (assert, forAllM, monadicIO, monitor,
                                            run)
 import           Test.QuickCheck.Property (counterexample)
@@ -85,11 +84,10 @@ serversEqual api burl1 burl2 args req = do
       assert False
   case r of
     Success {} -> return ()
-    Failure{..} -> readMVar deetsMVar >>= \x -> expectationFailure $
-      "Failed:\n" ++ show x
+    Failure{..} -> readMVar deetsMVar >>= \x -> expectationFailure $ "Failed:\n" ++ show x
     GaveUp { numTests = n } -> expectationFailure $ "Gave up after " ++ show n ++ " tests"
-    NoExpectedFailure {} -> expectationFailure $ "No expected failure"
-    InsufficientCoverage {} -> expectationFailure $ "Insufficient coverage"
+    NoExpectedFailure {} -> expectationFailure "No expected failure"
+    InsufficientCoverage {} -> expectationFailure "Insufficient coverage"
 
 -- | Check that a server satisfies the set of properties specified.
 --

stack.yaml

@@ -2,8 +2,9 @@ resolver: lts-8.4
 packages:
 - '.'
 extra-deps:
-- hspec-2.3.2
-- hspec-core-2.3.2
-- hspec-discover-2.3.2
+- hspec-2.4.4
+- hspec-core-2.4.4
+- hspec-discover-2.4.4
+- quickcheck-io-0.2.0
 flags: {}
 extra-package-dbs: []

test/Servant/QuickCheck/InternalSpec.hs

@@ -2,6 +2,7 @@
 module Servant.QuickCheck.InternalSpec (spec) where
 
 import           Control.Concurrent.MVar (newMVar, readMVar, swapMVar)
+import           Control.Exception
 import           Control.Monad.IO.Class  (liftIO)
 import qualified Data.ByteString         as BS
 import qualified Data.ByteString.Char8   as C
@@ -9,8 +10,8 @@ import           Prelude.Compat
 import           Servant
 import           Test.Hspec              (Spec, context, describe, it, shouldBe,
                                           shouldContain)
-import           Test.Hspec.Core.Spec    (Arg, Example, Result (..),
-                                          defaultParams, evaluateExample)
+import           Test.Hspec.Core.Spec    (Arg, Example, Result (..), FailureReason (..),
+                                          defaultParams, evaluateExample, safeEvaluateExample)
 import           Test.QuickCheck.Gen     (unGen)
 import           Test.QuickCheck.Random  (mkQCGen)
 import           Network.HTTP.Client     (queryString, path)
@@ -46,11 +47,11 @@ serversEqualSpec = describe "serversEqual" $ do
 
   context "when servers are not equal" $ do
 
-
     it "provides the failing responses in the error message" $ do
-      Fail _ err <- withServantServer api2 server2 $ \burl1 ->
+      Right (Failure _ err) <- withServantServer api2 server2 $ \burl1 ->
         withServantServer api2 server3 $ \burl2 -> do
-          evalExample $ serversEqual api2 burl1 burl2 args bodyEquality
+          safeEvalExample $ serversEqual api2 burl1 burl2 args bodyEquality
+      show err `shouldContain` "Server equality failed"
       show err `shouldContain` "Body: 1"
       show err `shouldContain` "Body: 2"
       show err `shouldContain` "Path: /failplz"
@@ -75,20 +76,20 @@ serverSatisfiesSpec = describe "serverSatisfies" $ do
   context "when predicates are false" $ do
 
     it "fails with informative error messages" $ do
-      Fail _ err <- withServantServerAndContext api ctx server $ \burl -> do
-        evalExample $ serverSatisfies api burl args (getsHaveCacheControlHeader <%> mempty)
-      err `shouldContain` "getsHaveCacheControlHeader"
-      err `shouldContain` "Headers"
-      err `shouldContain` "Body"
+      Right (Failure _ err) <- withServantServerAndContext api ctx server $ \burl -> do
+        safeEvalExample $ serverSatisfies api burl args (getsHaveCacheControlHeader <%> mempty)
+      show err `shouldContain` "getsHaveCacheControlHeader"
+      show err `shouldContain` "Headers"
+      show err `shouldContain` "Body"
 
 onlyJsonObjectSpec :: Spec
 onlyJsonObjectSpec = describe "onlyJsonObjects" $ do
 
   it "fails correctly" $ do
-    Fail _ err <- withServantServerAndContext api ctx server $ \burl -> do
-      evalExample $ serverSatisfies (Proxy :: Proxy (Get '[JSON] Int)) burl args
+    Right (Failure _ err) <- withServantServerAndContext api ctx server $ \burl -> do
+      safeEvalExample $ serverSatisfies (Proxy :: Proxy (Get '[JSON] Int)) burl args
         (onlyJsonObjects <%> mempty)
-    err `shouldContain` "onlyJsonObjects"
+    show err `shouldContain` "onlyJsonObjects"
 
   it "accepts non-JSON endpoints" $ do
     withServantServerAndContext octetAPI ctx serverOctetAPI $ \burl ->
@@ -98,10 +99,10 @@ notLongerThanSpec :: Spec
 notLongerThanSpec = describe "notLongerThan" $ do
 
   it "fails correctly" $ do
-    Fail _ err <- withServantServerAndContext api ctx server $ \burl -> do
-      evalExample $ serverSatisfies (Proxy :: Proxy (Get '[JSON] Int)) burl args
+    Right (Failure _ err) <- withServantServerAndContext api ctx server $ \burl -> do
+      safeEvalExample $ serverSatisfies (Proxy :: Proxy (Get '[JSON] Int)) burl args
         (notLongerThan 1 <%> mempty)
-    err `shouldContain` "notLongerThan"
+    show err `shouldContain` "notLongerThan"
 
   it "succeeds correctly" $ do
     withServantServerAndContext api ctx server $ \burl ->
@@ -213,6 +214,12 @@ evalExample e = evaluateExample e defaultParams ($ ()) progCallback
   where
     progCallback _ = return ()
 
+safeEvalExample :: (Example e, Arg e ~ ()) => e -> IO (Either SomeException Result)
+safeEvalExample e = safeEvaluateExample e defaultParams ($ ()) progCallback
+  where
+    progCallback _ = return ()
+
+
 args :: Args
 args = defaultArgs { maxSuccess = noOfTestCases }