{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE TypeSynonymInstances #-}

-- | Allows QuickCheck2 properties to be used with the test-framework package.
--
-- For an example of how to use @test-framework@, please see <https://github.com/haskell/test-framework/raw/master/example/Test/Framework/Example.lhs>.
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


-- | Create a 'Test' for a QuickCheck2 'Testable' property
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

-- | Used to document numbers which we expect to be intermediate test counts from running properties
type PropertyTestCount = Int

-- | The failure information from the run of a property
data PropertyResult = PropertyResult {
        PropertyResult -> PropertyStatus
pr_status :: PropertyStatus,
        PropertyResult -> Int
pr_used_seed :: Int,
        PropertyResult -> Maybe Int
pr_tests_run :: Maybe PropertyTestCount -- Due to technical limitations, it's currently not possible to find out the number of
                                                -- tests previously run if the test times out, hence we need a Maybe here for that case.
    }

data PropertyStatus = PropertyOK                        -- ^ The property is true as far as we could check it
                    | PropertyArgumentsExhausted        -- ^ The property may be true, but we ran out of arguments to try it out on
                    | PropertyFalsifiable String String -- ^ The property was not true. The strings are the reason and the output.
                    | PropertyNoExpectedFailure         -- ^ We expected that a property would fail but it didn't
                    | PropertyTimedOut                  -- ^ The property timed out during execution
#if MIN_VERSION_QuickCheck(2,8,0) && !MIN_VERSION_QuickCheck(2,12,0)
                    | PropertyInsufficientCoverage      -- ^ The tests passed but a use of 'cover' had insufficient coverage.
#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 a b. (a -> b) -> Maybe a -> Maybe b
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 a. a -> IO a
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 a. a -> IO a
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) -- NB: the 0 is the saved size. Defaults to 0 if you supply "Nothing" for "replay".
                       , 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 }
    -- FIXME: yield gradual improvement after each test
    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 a. a -> ImprovingIO Int PropertyResult a
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 { 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 {
                   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