{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE TypeSynonymInstances #-}
module Test.Framework.Providers.QuickCheck2 (
testProperty
) where
import Test.Framework.Providers.API
import Test.QuickCheck.Property (Testable, Callback(PostTest), CallbackKind(NotCounterexample), callback)
import Test.QuickCheck.State (numSuccessTests)
import Test.QuickCheck.Test
#if MIN_VERSION_QuickCheck(2,7,0)
import Test.QuickCheck.Random (QCGen, mkQCGen)
#endif
import System.Random
import Data.Typeable
testProperty :: Testable a => TestName -> a -> Test
testProperty :: TestName -> a -> Test
testProperty name :: TestName
name = TestName -> Property -> Test
forall i r t. (Testlike i r t, Typeable t) => TestName -> t -> Test
Test TestName
name (Property -> Test) -> (a -> Property) -> a -> Test
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Property
forall a. Testable a => a -> Property
Property
instance TestResultlike PropertyTestCount PropertyResult where
testSucceeded :: PropertyResult -> Bool
testSucceeded = PropertyResult -> Bool
propertySucceeded
type PropertyTestCount = Int
data PropertyResult = PropertyResult {
PropertyResult -> PropertyStatus
pr_status :: PropertyStatus,
PropertyResult -> PropertyTestCount
pr_used_seed :: Int,
PropertyResult -> Maybe PropertyTestCount
pr_tests_run :: Maybe PropertyTestCount
}
data PropertyStatus = PropertyOK
| PropertyArgumentsExhausted
| PropertyFalsifiable String String
| PropertyNoExpectedFailure
| PropertyTimedOut
#if MIN_VERSION_QuickCheck(2,8,0) && !MIN_VERSION_QuickCheck(2,12,0)
| PropertyInsufficientCoverage
#endif
instance Show PropertyResult where
show :: PropertyResult -> TestName
show (PropertyResult { pr_status :: PropertyResult -> PropertyStatus
pr_status = PropertyStatus
status, pr_used_seed :: PropertyResult -> PropertyTestCount
pr_used_seed = PropertyTestCount
used_seed, pr_tests_run :: PropertyResult -> Maybe PropertyTestCount
pr_tests_run = Maybe PropertyTestCount
mb_tests_run })
= case PropertyStatus
status of
PropertyOK -> "OK, passed " TestName -> ShowS
forall a. [a] -> [a] -> [a]
++ TestName
tests_run_str TestName -> ShowS
forall a. [a] -> [a] -> [a]
++ " tests"
PropertyArgumentsExhausted -> "Arguments exhausted after " TestName -> ShowS
forall a. [a] -> [a] -> [a]
++ TestName
tests_run_str TestName -> ShowS
forall a. [a] -> [a] -> [a]
++ " tests"
PropertyFalsifiable _rsn :: TestName
_rsn otpt :: TestName
otpt -> TestName
otpt TestName -> ShowS
forall a. [a] -> [a] -> [a]
++ "(used seed " TestName -> ShowS
forall a. [a] -> [a] -> [a]
++ PropertyTestCount -> TestName
forall a. Show a => a -> TestName
show PropertyTestCount
used_seed TestName -> ShowS
forall a. [a] -> [a] -> [a]
++ ")"
PropertyNoExpectedFailure -> "No expected failure with seed " TestName -> ShowS
forall a. [a] -> [a] -> [a]
++ PropertyTestCount -> TestName
forall a. Show a => a -> TestName
show PropertyTestCount
used_seed TestName -> ShowS
forall a. [a] -> [a] -> [a]
++ ", after " TestName -> ShowS
forall a. [a] -> [a] -> [a]
++ TestName
tests_run_str TestName -> ShowS
forall a. [a] -> [a] -> [a]
++ " tests"
PropertyTimedOut -> "Timed out after " TestName -> ShowS
forall a. [a] -> [a] -> [a]
++ TestName
tests_run_str TestName -> ShowS
forall a. [a] -> [a] -> [a]
++ " tests"
#if MIN_VERSION_QuickCheck(2,8,0) && !MIN_VERSION_QuickCheck(2,12,0)
PropertyInsufficientCoverage -> "Insufficient coverage after " ++ tests_run_str ++ " tests"
#endif
where
tests_run_str :: TestName
tests_run_str = (PropertyTestCount -> TestName)
-> Maybe PropertyTestCount -> Maybe TestName
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap PropertyTestCount -> TestName
forall a. Show a => a -> TestName
show Maybe PropertyTestCount
mb_tests_run Maybe TestName -> ShowS
forall a. Maybe a -> a -> a
`orElse` "an unknown number of"
propertySucceeded :: PropertyResult -> Bool
propertySucceeded :: PropertyResult -> Bool
propertySucceeded (PropertyResult { pr_status :: PropertyResult -> PropertyStatus
pr_status = PropertyStatus
status, pr_tests_run :: PropertyResult -> Maybe PropertyTestCount
pr_tests_run = Maybe PropertyTestCount
mb_n }) = case PropertyStatus
status of
PropertyOK -> Bool
True
PropertyArgumentsExhausted -> Bool
-> (PropertyTestCount -> Bool) -> Maybe PropertyTestCount -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False (PropertyTestCount -> PropertyTestCount -> Bool
forall a. Eq a => a -> a -> Bool
/= 0) Maybe PropertyTestCount
mb_n
_ -> Bool
False
data Property = forall a. Testable a => Property a
deriving Typeable
instance Testlike PropertyTestCount PropertyResult Property where
runTest :: CompleteTestOptions
-> Property -> IO (PropertyTestCount :~> PropertyResult, IO ())
runTest topts :: CompleteTestOptions
topts (Property testable :: a
testable) = CompleteTestOptions
-> a -> IO (PropertyTestCount :~> PropertyResult, IO ())
forall a.
Testable a =>
CompleteTestOptions
-> a -> IO (PropertyTestCount :~> PropertyResult, IO ())
runProperty CompleteTestOptions
topts a
testable
testTypeName :: Property -> TestName
testTypeName _ = "Properties"
#if MIN_VERSION_QuickCheck(2,7,0)
newSeededQCGen :: Seed -> IO (QCGen, Int)
newSeededQCGen :: Seed -> IO (QCGen, PropertyTestCount)
newSeededQCGen (FixedSeed seed :: PropertyTestCount
seed) = (QCGen, PropertyTestCount) -> IO (QCGen, PropertyTestCount)
forall (m :: * -> *) a. Monad m => a -> m a
return ((QCGen, PropertyTestCount) -> IO (QCGen, PropertyTestCount))
-> (QCGen, PropertyTestCount) -> IO (QCGen, PropertyTestCount)
forall a b. (a -> b) -> a -> b
$ (PropertyTestCount -> QCGen
mkQCGen PropertyTestCount
seed, PropertyTestCount
seed)
newSeededQCGen RandomSeed = do
PropertyTestCount
seed <- IO PropertyTestCount
forall a. Random a => IO a
randomIO
(QCGen, PropertyTestCount) -> IO (QCGen, PropertyTestCount)
forall (m :: * -> *) a. Monad m => a -> m a
return (PropertyTestCount -> QCGen
mkQCGen PropertyTestCount
seed, PropertyTestCount
seed)
#else
newSeededQCGen :: Seed -> IO (StdGen, Int)
newSeededQCGen = newSeededStdGen
#endif
runProperty :: Testable a => CompleteTestOptions -> a -> IO (PropertyTestCount :~> PropertyResult, IO ())
runProperty :: CompleteTestOptions
-> a -> IO (PropertyTestCount :~> PropertyResult, IO ())
runProperty topts :: CompleteTestOptions
topts testable :: a
testable = do
(gen :: QCGen
gen, seed :: PropertyTestCount
seed) <- Seed -> IO (QCGen, PropertyTestCount)
newSeededQCGen (K Seed -> Seed
forall a. K a -> a
unK (K Seed -> Seed) -> K Seed -> Seed
forall a b. (a -> b) -> a -> b
$ CompleteTestOptions -> K Seed
forall (f :: * -> *). TestOptions' f -> f Seed
topt_seed CompleteTestOptions
topts)
let max_success :: PropertyTestCount
max_success = K PropertyTestCount -> PropertyTestCount
forall a. K a -> a
unK (K PropertyTestCount -> PropertyTestCount)
-> K PropertyTestCount -> PropertyTestCount
forall a b. (a -> b) -> a -> b
$ CompleteTestOptions -> K PropertyTestCount
forall (f :: * -> *). TestOptions' f -> f PropertyTestCount
topt_maximum_generated_tests CompleteTestOptions
topts
max_discard :: PropertyTestCount
max_discard = K PropertyTestCount -> PropertyTestCount
forall a. K a -> a
unK (K PropertyTestCount -> PropertyTestCount)
-> K PropertyTestCount -> PropertyTestCount
forall a b. (a -> b) -> a -> b
$ CompleteTestOptions -> K PropertyTestCount
forall (f :: * -> *). TestOptions' f -> f PropertyTestCount
topt_maximum_unsuitable_generated_tests CompleteTestOptions
topts
args :: Args
args = Args
stdArgs { replay :: Maybe (QCGen, PropertyTestCount)
replay = (QCGen, PropertyTestCount) -> Maybe (QCGen, PropertyTestCount)
forall a. a -> Maybe a
Just (QCGen
gen, 0)
, maxSuccess :: PropertyTestCount
maxSuccess = PropertyTestCount
max_success
#if MIN_VERSION_QuickCheck(2,5,0)
, maxDiscardRatio :: PropertyTestCount
maxDiscardRatio = (PropertyTestCount
max_discard PropertyTestCount -> PropertyTestCount -> PropertyTestCount
forall a. Integral a => a -> a -> a
`div` PropertyTestCount
max_success) PropertyTestCount -> PropertyTestCount -> PropertyTestCount
forall a. Num a => a -> a -> a
+ 1
#else
, maxDiscard = max_discard
#endif
, maxSize :: PropertyTestCount
maxSize = K PropertyTestCount -> PropertyTestCount
forall a. K a -> a
unK (K PropertyTestCount -> PropertyTestCount)
-> K PropertyTestCount -> PropertyTestCount
forall a b. (a -> b) -> a -> b
$ CompleteTestOptions -> K PropertyTestCount
forall (f :: * -> *). TestOptions' f -> f PropertyTestCount
topt_maximum_test_size CompleteTestOptions
topts
, chatty :: Bool
chatty = Bool
False }
ImprovingIO PropertyTestCount PropertyResult PropertyResult
-> IO (PropertyTestCount :~> PropertyResult, IO ())
forall i f. ImprovingIO i f f -> IO (i :~> f, IO ())
runImprovingIO (ImprovingIO PropertyTestCount PropertyResult PropertyResult
-> IO (PropertyTestCount :~> PropertyResult, IO ()))
-> ImprovingIO PropertyTestCount PropertyResult PropertyResult
-> IO (PropertyTestCount :~> PropertyResult, IO ())
forall a b. (a -> b) -> a -> b
$ do
ImprovingIO PropertyTestCount PropertyResult () -> IO ()
tunnel <- ImprovingIO
PropertyTestCount
PropertyResult
(ImprovingIO PropertyTestCount PropertyResult () -> IO ())
forall i f a. ImprovingIO i f (ImprovingIO i f a -> IO a)
tunnelImprovingIO
Maybe Result
mb_result <- Maybe PropertyTestCount
-> ImprovingIO PropertyTestCount PropertyResult Result
-> ImprovingIO PropertyTestCount PropertyResult (Maybe Result)
forall i f a.
Maybe PropertyTestCount
-> ImprovingIO i f a -> ImprovingIO i f (Maybe a)
maybeTimeoutImprovingIO (K (Maybe PropertyTestCount) -> Maybe PropertyTestCount
forall a. K a -> a
unK (CompleteTestOptions -> K (Maybe PropertyTestCount)
forall (f :: * -> *). TestOptions' f -> f (Maybe PropertyTestCount)
topt_timeout CompleteTestOptions
topts)) (ImprovingIO PropertyTestCount PropertyResult Result
-> ImprovingIO PropertyTestCount PropertyResult (Maybe Result))
-> ImprovingIO PropertyTestCount PropertyResult Result
-> ImprovingIO PropertyTestCount PropertyResult (Maybe Result)
forall a b. (a -> b) -> a -> b
$
IO Result -> ImprovingIO PropertyTestCount PropertyResult Result
forall a i f. IO a -> ImprovingIO i f a
liftIO (IO Result -> ImprovingIO PropertyTestCount PropertyResult Result)
-> IO Result -> ImprovingIO PropertyTestCount PropertyResult Result
forall a b. (a -> b) -> a -> b
$ Args -> Property -> IO Result
forall prop. Testable prop => Args -> prop -> IO Result
quickCheckWithResult Args
args (Callback -> a -> Property
forall prop. Testable prop => Callback -> prop -> Property
callback (CallbackKind -> (State -> Result -> IO ()) -> Callback
PostTest CallbackKind
NotCounterexample (\s :: State
s _r :: Result
_r -> ImprovingIO PropertyTestCount PropertyResult () -> IO ()
tunnel (ImprovingIO PropertyTestCount PropertyResult () -> IO ())
-> ImprovingIO PropertyTestCount PropertyResult () -> IO ()
forall a b. (a -> b) -> a -> b
$ PropertyTestCount
-> ImprovingIO PropertyTestCount PropertyResult ()
forall i f. i -> ImprovingIO i f ()
yieldImprovement (PropertyTestCount
-> ImprovingIO PropertyTestCount PropertyResult ())
-> PropertyTestCount
-> ImprovingIO PropertyTestCount PropertyResult ()
forall a b. (a -> b) -> a -> b
$ State -> PropertyTestCount
numSuccessTests State
s)) a
testable)
PropertyResult
-> ImprovingIO PropertyTestCount PropertyResult PropertyResult
forall (m :: * -> *) a. Monad m => a -> m a
return (PropertyResult
-> ImprovingIO PropertyTestCount PropertyResult PropertyResult)
-> PropertyResult
-> ImprovingIO PropertyTestCount PropertyResult PropertyResult
forall a b. (a -> b) -> a -> b
$ case Maybe Result
mb_result of
Nothing -> PropertyResult :: PropertyStatus
-> PropertyTestCount -> Maybe PropertyTestCount -> PropertyResult
PropertyResult { pr_status :: PropertyStatus
pr_status = PropertyStatus
PropertyTimedOut, pr_used_seed :: PropertyTestCount
pr_used_seed = PropertyTestCount
seed, pr_tests_run :: Maybe PropertyTestCount
pr_tests_run = Maybe PropertyTestCount
forall a. Maybe a
Nothing }
Just result :: Result
result -> PropertyResult :: PropertyStatus
-> PropertyTestCount -> Maybe PropertyTestCount -> PropertyResult
PropertyResult {
pr_status :: PropertyStatus
pr_status = Result -> PropertyStatus
toPropertyStatus Result
result,
pr_used_seed :: PropertyTestCount
pr_used_seed = PropertyTestCount
seed,
pr_tests_run :: Maybe PropertyTestCount
pr_tests_run = PropertyTestCount -> Maybe PropertyTestCount
forall a. a -> Maybe a
Just (Result -> PropertyTestCount
numTests Result
result)
}
where
toPropertyStatus :: Result -> PropertyStatus
toPropertyStatus (Success {}) = PropertyStatus
PropertyOK
toPropertyStatus (GaveUp {}) = PropertyStatus
PropertyArgumentsExhausted
toPropertyStatus (Failure { reason :: Result -> TestName
reason = TestName
rsn, output :: Result -> TestName
output = TestName
otpt }) = TestName -> TestName -> PropertyStatus
PropertyFalsifiable TestName
rsn TestName
otpt
toPropertyStatus (NoExpectedFailure {}) = PropertyStatus
PropertyNoExpectedFailure
#if MIN_VERSION_QuickCheck(2,8,0) && !MIN_VERSION_QuickCheck(2,12,0)
toPropertyStatus (InsufficientCoverage _ _ _) = PropertyInsufficientCoverage
#endif