From c1b92215c3217b407cc009d0c54417a7de33dd51 Mon Sep 17 00:00:00 2001
From: "Julian K. Arni" <jkarni@gmail.com>
Date: Sat, 23 Apr 2016 11:50:04 +0200
Subject: [PATCH] Fix serversEqual and tests.

---
 src/Servant/QuickCheck/Internal/QuickCheck.hs | 25 +++++++++++++------
 test/Servant/QuickCheck/InternalSpec.hs       |  6 ++---
 test/Spec.hs                                  |  2 +-
 3 files changed, 21 insertions(+), 12 deletions(-)

diff --git a/src/Servant/QuickCheck/Internal/QuickCheck.hs b/src/Servant/QuickCheck/Internal/QuickCheck.hs
index 475e2ca..bc425ea 100644
--- a/src/Servant/QuickCheck/Internal/QuickCheck.hs
+++ b/src/Servant/QuickCheck/Internal/QuickCheck.hs
@@ -17,10 +17,12 @@ import           System.IO                (hPutStrLn, hFlush)
 import           System.IO.Temp           (withSystemTempFile)
 import           System.Mem               (performGC)
 import           System.Process           (callCommand)
-import           Test.Hspec               (Expectation, expectationFailure)
+import           Test.Hspec               (Expectation, expectationFailure, shouldBe)
 import           Test.QuickCheck          (Args (..), Property, forAll, Result (..),
                                            Testable, property, ioProperty,
                                            quickCheckWithResult, stdArgs)
+import System.IO.Unsafe (unsafePerformIO)
+import Test.QuickCheck.Monadic
 
 import Servant.QuickCheck.Internal.HasGenRequest
 import Servant.QuickCheck.Internal.Predicates
@@ -47,12 +49,21 @@ withServantServer api server t
 -- Evidently, if the behaviour of the server is expected to be
 -- non-deterministic,  this function may produce spurious failures
 serversEqual :: HasGenRequest a =>
-  Proxy a -> BaseUrl -> BaseUrl -> Manager -> Property
-serversEqual api burl1 burl2 mgr =
+  Proxy a -> BaseUrl -> BaseUrl -> Args -> Expectation
+serversEqual api burl1 burl2 args = do
   let reqs = (\f -> (f burl1, f burl2)) <$> genRequest api
-  in forAll reqs $ \(req1, req2) -> ioProperty $ do
-    resp1 <- httpLbs req1 mgr
-    resp2 <- httpLbs req2 mgr
-    return $ resp1 == resp2
+  r <- quickCheckWithResult args $ monadicIO $ forAllM reqs $ \(req1, req2) -> do
+    resp1 <- run $ httpLbs req1 defManager
+    resp2 <- run $ httpLbs req2 defManager
+    assert $ resp1 == resp2
+  case r of
+    Success {} -> return ()
+    GaveUp { numTests = n } -> expectationFailure $ "Gave up after " ++ show n ++ " tests"
+    Failure { output = m } -> expectationFailure $ "Failed:\n" ++ show m
+    NoExpectedFailure {} -> expectationFailure $ "No expected failure"
+    InsufficientCoverage {} -> expectationFailure $ "Insufficient coverage"
 
+defManager :: Manager
+defManager = unsafePerformIO $ newManager defaultManagerSettings
+{-# NOINLINE defManager #-}
 
diff --git a/test/Servant/QuickCheck/InternalSpec.hs b/test/Servant/QuickCheck/InternalSpec.hs
index ef28bb5..55c9559 100644
--- a/test/Servant/QuickCheck/InternalSpec.hs
+++ b/test/Servant/QuickCheck/InternalSpec.hs
@@ -23,11 +23,9 @@ serversEqualSpec :: Spec
 serversEqualSpec = describe "serversEqual" $ do
 
   it "considers equal servers equal" $ do
-    mgr <- newManager defaultManagerSettings
     withServantServer api server $ \burl1 ->
       withServantServer api server $ \burl2 -> do
-        return $ serversEqual api burl1 burl2 mgr
-
+        serversEqual api burl1 burl2 stdArgs { maxSuccess = 10000 }
 
 
 
@@ -44,7 +42,7 @@ api = Proxy
 server :: IO (Server API)
 server = do
     mvar <- newMVar ""
-    return $ (\x -> liftIO $ print 'a' >>  swapMVar mvar x)
+    return $ (\x -> liftIO $ swapMVar mvar x)
         :<|> (liftIO $ readMVar mvar >>= return . length)
 
 
diff --git a/test/Spec.hs b/test/Spec.hs
index 5416ef6..a824f8c 100644
--- a/test/Spec.hs
+++ b/test/Spec.hs
@@ -1 +1 @@
-{-# OPTIONS_GHC -F -pgmF hspec-discover -optF --module-name=Spec #-}
+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}