{-# 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 :: forall a. Testable a => TestName -> a -> Test
testProperty 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 -> Int
pr_used_seed :: Int,
PropertyResult -> Maybe Int
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 -> Int
pr_used_seed = Int
used_seed, pr_tests_run :: PropertyResult -> Maybe Int
pr_tests_run = Maybe Int
mb_tests_run })
= case PropertyStatus
status of
PropertyStatus
PropertyOK -> TestName
"OK, passed " TestName -> ShowS
forall a. [a] -> [a] -> [a]
++ TestName
tests_run_str TestName -> ShowS
forall a. [a] -> [a] -> [a]
++ TestName
" tests"
PropertyStatus
PropertyArgumentsExhausted -> TestName
"Arguments exhausted after " TestName -> ShowS
forall a. [a] -> [a] -> [a]
++ TestName
tests_run_str TestName -> ShowS
forall a. [a] -> [a] -> [a]
++ TestName
" tests"
PropertyFalsifiable TestName
_rsn TestName
otpt -> TestName
otpt TestName -> ShowS
forall a. [a] -> [a] -> [a]
++ TestName
"(used seed " TestName -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> TestName
forall a. Show a => a -> TestName
show Int
used_seed TestName -> ShowS
forall a. [a] -> [a] -> [a]
++ TestName
")"
PropertyStatus
PropertyNoExpectedFailure -> TestName
"No expected failure with seed " TestName -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> TestName
forall a. Show a => a -> TestName
show Int
used_seed TestName -> ShowS
forall a. [a] -> [a] -> [a]
++ TestName
", after " TestName -> ShowS
forall a. [a] -> [a] -> [a]
++ TestName
tests_run_str TestName -> ShowS
forall a. [a] -> [a] -> [a]
++ TestName
" tests"
PropertyStatus
PropertyTimedOut -> TestName
"Timed out after " TestName -> ShowS
forall a. [a] -> [a] -> [a]
++ TestName
tests_run_str TestName -> ShowS
forall a. [a] -> [a] -> [a]
++ TestName
" 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 = (Int -> TestName) -> Maybe Int -> Maybe TestName
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Int -> TestName
forall a. Show a => a -> TestName
show Maybe Int
mb_tests_run Maybe TestName -> ShowS
forall a. Maybe a -> a -> a
`orElse` TestName
"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 Int
pr_tests_run = Maybe Int
mb_n }) = case PropertyStatus
status of
PropertyStatus
PropertyOK -> Bool
True
PropertyStatus
PropertyArgumentsExhausted -> Bool -> (Int -> Bool) -> Maybe Int -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False (Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
0) Maybe Int
mb_n
PropertyStatus
_ -> Bool
False
data Property = forall a. Testable a => Property a
deriving Typeable
instance Testlike PropertyTestCount PropertyResult Property where
runTest :: CompleteTestOptions
-> Property -> IO (Int :~> PropertyResult, IO ())
runTest CompleteTestOptions
topts (Property a
testable) = CompleteTestOptions -> a -> IO (Int :~> PropertyResult, IO ())
forall a.
Testable a =>
CompleteTestOptions -> a -> IO (Int :~> PropertyResult, IO ())
runProperty CompleteTestOptions
topts a
testable
testTypeName :: Property -> TestName
testTypeName Property
_ = TestName
"Properties"
#if MIN_VERSION_QuickCheck(2,7,0)
newSeededQCGen :: Seed -> IO (QCGen, Int)
newSeededQCGen :: Seed -> IO (QCGen, Int)
newSeededQCGen (FixedSeed Int
seed) = (QCGen, Int) -> IO (QCGen, Int)
forall (m :: * -> *) a. Monad m => a -> m a
return ((QCGen, Int) -> IO (QCGen, Int))
-> (QCGen, Int) -> IO (QCGen, Int)
forall a b. (a -> b) -> a -> b
$ (Int -> QCGen
mkQCGen Int
seed, Int
seed)
newSeededQCGen Seed
RandomSeed = do
Int
seed <- IO Int
forall a (m :: * -> *). (Random a, MonadIO m) => m a
randomIO
(QCGen, Int) -> IO (QCGen, Int)
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> QCGen
mkQCGen Int
seed, Int
seed)
#else
newSeededQCGen :: Seed -> IO (StdGen, Int)
newSeededQCGen = newSeededStdGen
#endif
runProperty :: Testable a => CompleteTestOptions -> a -> IO (PropertyTestCount :~> PropertyResult, IO ())
runProperty :: forall a.
Testable a =>
CompleteTestOptions -> a -> IO (Int :~> PropertyResult, IO ())
runProperty CompleteTestOptions
topts a
testable = do
(QCGen
gen, Int
seed) <- Seed -> IO (QCGen, Int)
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 :: Int
max_success = K Int -> Int
forall a. K a -> a
unK (K Int -> Int) -> K Int -> Int
forall a b. (a -> b) -> a -> b
$ CompleteTestOptions -> K Int
forall (f :: * -> *). TestOptions' f -> f Int
topt_maximum_generated_tests CompleteTestOptions
topts
max_discard :: Int
max_discard = K Int -> Int
forall a. K a -> a
unK (K Int -> Int) -> K Int -> Int
forall a b. (a -> b) -> a -> b
$ CompleteTestOptions -> K Int
forall (f :: * -> *). TestOptions' f -> f Int
topt_maximum_unsuitable_generated_tests CompleteTestOptions
topts
args :: Args
args = Args
stdArgs { replay :: Maybe (QCGen, Int)
replay = (QCGen, Int) -> Maybe (QCGen, Int)
forall a. a -> Maybe a
Just (QCGen
gen, Int
0)
, maxSuccess :: Int
maxSuccess = Int
max_success
#if MIN_VERSION_QuickCheck(2,5,0)
, maxDiscardRatio :: Int
maxDiscardRatio = (Int
max_discard Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
max_success) Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1
#else
, maxDiscard = max_discard
#endif
, maxSize :: Int
maxSize = K Int -> Int
forall a. K a -> a
unK (K Int -> Int) -> K Int -> Int
forall a b. (a -> b) -> a -> b
$ CompleteTestOptions -> K Int
forall (f :: * -> *). TestOptions' f -> f Int
topt_maximum_test_size CompleteTestOptions
topts
, chatty :: Bool
chatty = Bool
False }
ImprovingIO Int PropertyResult PropertyResult
-> IO (Int :~> PropertyResult, IO ())
forall i f. ImprovingIO i f f -> IO (i :~> f, IO ())
runImprovingIO (ImprovingIO Int PropertyResult PropertyResult
-> IO (Int :~> PropertyResult, IO ()))
-> ImprovingIO Int PropertyResult PropertyResult
-> IO (Int :~> PropertyResult, IO ())
forall a b. (a -> b) -> a -> b
$ do
ImprovingIO Int PropertyResult () -> IO ()
tunnel <- ImprovingIO
Int PropertyResult (ImprovingIO Int PropertyResult () -> IO ())
forall i f a. ImprovingIO i f (ImprovingIO i f a -> IO a)
tunnelImprovingIO
Maybe Result
mb_result <- Maybe Int
-> ImprovingIO Int PropertyResult Result
-> ImprovingIO Int PropertyResult (Maybe Result)
forall i f a.
Maybe Int -> ImprovingIO i f a -> ImprovingIO i f (Maybe a)
maybeTimeoutImprovingIO (K (Maybe Int) -> Maybe Int
forall a. K a -> a
unK (CompleteTestOptions -> K (Maybe Int)
forall (f :: * -> *). TestOptions' f -> f (Maybe Int)
topt_timeout CompleteTestOptions
topts)) (ImprovingIO Int PropertyResult Result
-> ImprovingIO Int PropertyResult (Maybe Result))
-> ImprovingIO Int PropertyResult Result
-> ImprovingIO Int PropertyResult (Maybe Result)
forall a b. (a -> b) -> a -> b
$
IO Result -> ImprovingIO Int PropertyResult Result
forall a i f. IO a -> ImprovingIO i f a
liftIO (IO Result -> ImprovingIO Int PropertyResult Result)
-> IO Result -> ImprovingIO Int 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 (\State
s Result
_r -> ImprovingIO Int PropertyResult () -> IO ()
tunnel (ImprovingIO Int PropertyResult () -> IO ())
-> ImprovingIO Int PropertyResult () -> IO ()
forall a b. (a -> b) -> a -> b
$ Int -> ImprovingIO Int PropertyResult ()
forall i f. i -> ImprovingIO i f ()
yieldImprovement (Int -> ImprovingIO Int PropertyResult ())
-> Int -> ImprovingIO Int PropertyResult ()
forall a b. (a -> b) -> a -> b
$ State -> Int
numSuccessTests State
s)) a
testable)
PropertyResult -> ImprovingIO Int PropertyResult PropertyResult
forall (m :: * -> *) a. Monad m => a -> m a
return (PropertyResult -> ImprovingIO Int PropertyResult PropertyResult)
-> PropertyResult -> ImprovingIO Int PropertyResult PropertyResult
forall a b. (a -> b) -> a -> b
$ case Maybe Result
mb_result of
Maybe Result
Nothing -> PropertyResult :: PropertyStatus -> Int -> Maybe Int -> PropertyResult
PropertyResult { pr_status :: PropertyStatus
pr_status = PropertyStatus
PropertyTimedOut, pr_used_seed :: Int
pr_used_seed = Int
seed, pr_tests_run :: Maybe Int
pr_tests_run = Maybe Int
forall a. Maybe a
Nothing }
Just Result
result -> PropertyResult :: PropertyStatus -> Int -> Maybe Int -> PropertyResult
PropertyResult {
pr_status :: PropertyStatus
pr_status = Result -> PropertyStatus
toPropertyStatus Result
result,
pr_used_seed :: Int
pr_used_seed = Int
seed,
pr_tests_run :: Maybe Int
pr_tests_run = Int -> Maybe Int
forall a. a -> Maybe a
Just (Result -> Int
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