{-# 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
import Test.QuickCheck.Random (QCGen, mkQCGen)
import System.Random (randomIO)

import Data.Typeable (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,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,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"

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
  seed <- IO Int
forall a (m :: * -> *). (Random a, MonadIO m) => m a
randomIO
  return (mkQCGen seed, seed)

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
    (gen, 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 = 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 = 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
stdArgs { replay = Just (gen, 0) -- NB: the 0 is the saved size. Defaults to 0 if you supply "Nothing" for "replay".
                       , maxSuccess = max_success
                       , maxDiscardRatio = (max_discard `div` max_success) + 1
                       , maxSize = unK $ topt_maximum_test_size topts
                       , chatty = False }
    -- FIXME: yield gradual improvement after each test
    runImprovingIO $ do
        tunnel <- tunnelImprovingIO
        mb_result <- maybeTimeoutImprovingIO (unK (topt_timeout topts)) $
          liftIO $ quickCheckWithResult args (callback (PostTest 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)) testable)
        return $ case 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,12,0)
    toPropertyStatus (InsufficientCoverage _ _ _)              = PropertyInsufficientCoverage
#endif