    {-# 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