haskell/servant-quickcheck
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

merge mvars

Browse Source
This commit is contained in:
parsonsmatt 2018-05-09 14:32:30 -06:00
commit 89c361d1ee
2 changed files with 20 additions and 10 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
servant-quickcheck.cabal
View File

@ -93,7 +93,7 @@ test-suite spec
other-modules: Servant.QuickCheck.InternalSpec other-modules: Servant.QuickCheck.InternalSpec
build-tool-depends: hspec-discover:hspec-discover build-tool-depends: hspec-discover:hspec-discover
build-depends: base build-depends: base
, base-compat , base-compat-batteries
, aeson , aeson
, servant-quickcheck , servant-quickcheck
, bytestring , bytestring

28
src/Servant/QuickCheck/Internal/QuickCheck.hs
View File

@ -2,7 +2,7 @@
{-# LANGUAGE CPP #-} {-# LANGUAGE CPP #-}
module Servant.QuickCheck.Internal.QuickCheck where module Servant.QuickCheck.Internal.QuickCheck where
import Control.Concurrent (modifyMVar_, newMVar, readMVar) import Control.Concurrent (tryReadMVar, newEmptyMVar, tryPutMVar)
import Control.Monad (unless) import Control.Monad (unless)
import qualified Data.ByteString.Lazy as LBS import qualified Data.ByteString.Lazy as LBS
import Data.Proxy (Proxy) import Data.Proxy (Proxy)
@ -73,18 +73,23 @@ serversEqual api burl1 burl2 args req = do
let reqs = (\f -> (f burl1, f burl2)) <$> runGenRequest api let reqs = (\f -> (f burl1, f burl2)) <$> runGenRequest api
-- This MVar stuff is clunky! But there doesn't seem to be an easy way to -- This MVar stuff is clunky! But there doesn't seem to be an easy way to
-- return results when a test fails, since an exception is throw. -- return results when a test fails, since an exception is throw.
deetsMVar <- newMVar $ error "should not be called" deetsMVar <- newEmptyMVar
r <- quickCheckWithResult args { chatty = False } $ monadicIO $ forAllM reqs $ \(req1, req2) -> do r <- quickCheckWithResult args { chatty = False } $ monadicIO $ forAllM reqs $ \(req1, req2) -> do
resp1 <- run $ C.httpLbs (noCheckStatus req1) defManager resp1 <- run $ C.httpLbs (noCheckStatus req1) defManager
resp2 <- run $ C.httpLbs (noCheckStatus req2) defManager resp2 <- run $ C.httpLbs (noCheckStatus req2) defManager
unless (getResponseEquality req resp1 resp2) $ do unless (getResponseEquality req resp1 resp2) $ do
monitor (counterexample "hi" ) monitor (counterexample "hi" )
run $ modifyMVar_ deetsMVar $ const $ return $ _ <- run $ tryPutMVar deetsMVar $ ServerEqualityFailure req1 resp1 resp2
ServerEqualityFailure req1 resp1 resp2
assert False assert False
case r of case r of
Success {} -> return () Success {} -> return ()
Failure{..} -> readMVar deetsMVar >>= \x -> expectationFailure $ "Failed:\n" ++ show x Failure{..} -> do
mx <- tryReadMVar deetsMVar
case mx of
Just x ->
expectationFailure $ "Failed:\n" ++ show x
Nothing ->
expectationFailure $ "We failed to record a reason for failure: " <> show r
GaveUp { numTests = n } -> expectationFailure $ "Gave up after " ++ show n ++ " tests" GaveUp { numTests = n } -> expectationFailure $ "Gave up after " ++ show n ++ " tests"
NoExpectedFailure {} -> expectationFailure "No expected failure" NoExpectedFailure {} -> expectationFailure "No expected failure"
InsufficientCoverage {} -> expectationFailure "Insufficient coverage" InsufficientCoverage {} -> expectationFailure "Insufficient coverage"
@ -112,17 +117,22 @@ serverSatisfies :: (HasGenRequest a) =>
Proxy a -> BaseUrl -> Args -> Predicates -> Expectation Proxy a -> BaseUrl -> Args -> Predicates -> Expectation
serverSatisfies api burl args preds = do serverSatisfies api burl args preds = do
let reqs = ($ burl) <$> runGenRequest api let reqs = ($ burl) <$> runGenRequest api
deetsMVar <- newMVar $ error "should not be called" deetsMVar <- newEmptyMVar
r <- quickCheckWithResult args { chatty = False } $ monadicIO $ forAllM reqs $ \req -> do r <- quickCheckWithResult args { chatty = False } $ monadicIO $ forAllM reqs $ \req -> do
v <- run $ finishPredicates preds (noCheckStatus req) defManager v <- run $ finishPredicates preds (noCheckStatus req) defManager
run $ modifyMVar_ deetsMVar $ const $ return v _ <- run $ tryPutMVar deetsMVar v
case v of case v of
Just _ -> assert False Just _ -> assert False
_ -> return () _ -> return ()
case r of case r of
Success {} -> return () Success {} -> return ()
Failure{..} -> readMVar deetsMVar >>= \x -> expectationFailure $ Failure {..} -> do
"Failed:\n" ++ show x mx <- tryReadMVar deetsMVar
case mx of
Just x ->
expectationFailure $ "Failed:\n" ++ show x
Nothing ->
expectationFailure $ "We failed to record a reason for failure: " <> show r
GaveUp { numTests = n } -> expectationFailure $ "Gave up after " ++ show n ++ " tests" GaveUp { numTests = n } -> expectationFailure $ "Gave up after " ++ show n ++ " tests"
NoExpectedFailure {} -> expectationFailure $ "No expected failure" NoExpectedFailure {} -> expectationFailure $ "No expected failure"
InsufficientCoverage {} -> expectationFailure $ "Insufficient coverage" InsufficientCoverage {} -> expectationFailure $ "Insufficient coverage"