content: {-# LANGUAGE DeriveDataTypeable #-}
  -- | Allows QuickCheck2 properties to be used with the test-framework package.
  --
  -- For an example of how to use test-framework, please see <http://github.com/batterseapower/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 Data.Typeable
  
  
  -- | Create a 'Test' for a QuickCheck2 'Testable' property
  testProperty :: Testable a => TestName -> a -> Test
  testProperty name = Test name . Property
  
  
  instance TestResultlike PropertyTestCount PropertyResult where
      testSucceeded = 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 {
          pr_status :: PropertyStatus,
          pr_used_seed :: 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
  
  instance Show PropertyResult where
      show (PropertyResult { pr_status = status, pr_used_seed = used_seed, pr_tests_run = mb_tests_run })
        = case status of
              PropertyOK                    -> "OK, passed " ++ tests_run_str ++ " tests"
              PropertyArgumentsExhausted    -> "Arguments exhausted after " ++ tests_run_str ++ " tests"
              PropertyFalsifiable _rsn otpt -> otpt ++ "(used seed " ++ show used_seed ++ ")"
              PropertyNoExpectedFailure     -> "No expected failure with seed " ++ show used_seed ++ ", after " ++ tests_run_str ++ " tests"
              PropertyTimedOut              -> "Timed out after " ++ tests_run_str ++ " tests"
        where
          tests_run_str = fmap show mb_tests_run `orElse` "an unknown number of"
  
  propertySucceeded :: PropertyResult -> Bool
  propertySucceeded (PropertyResult { pr_status = status, pr_tests_run = mb_n }) = case status of
    PropertyOK                 -> True
    PropertyArgumentsExhausted -> maybe False (/= 0) mb_n
    _                          -> False
  
  
  data Property = forall a. Testable a => Property a
      deriving Typeable
  
  instance Testlike PropertyTestCount PropertyResult Property where
      runTest topts (Property testable) = runProperty topts testable
      testTypeName _ = "Properties"
  
  runProperty :: Testable a => CompleteTestOptions -> a -> IO (PropertyTestCount :~> PropertyResult, IO ())
  runProperty topts testable = do
      (gen, seed) <- newSeededStdGen (unK $ topt_seed topts)
      let max_success = unK $ topt_maximum_generated_tests topts
          max_discard = unK $ topt_maximum_unsuitable_generated_tests topts
          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
  #if MIN_VERSION_QuickCheck(2,5,0)
                         , maxDiscardRatio = max_discard `div` max_success
  #else
                         , maxDiscard = max_discard
  #endif
                         , 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 (\s _r -> tunnel $ yieldImprovement $ numSuccessTests s)) testable)
          return $ case mb_result of
              Nothing     -> PropertyResult { pr_status = PropertyTimedOut, pr_used_seed = seed, pr_tests_run = Nothing }
              Just result -> PropertyResult {
                     pr_status = toPropertyStatus result,
                     pr_used_seed = seed,
                     pr_tests_run = Just (numTests result)
                 }
    where
      toPropertyStatus (Success {})                              = PropertyOK
      toPropertyStatus (GaveUp {})                               = PropertyArgumentsExhausted
      toPropertyStatus (Failure { reason = rsn, output = otpt }) = PropertyFalsifiable rsn otpt
      toPropertyStatus (NoExpectedFailure {})                    = PropertyNoExpectedFailure
  