module Test.Framework.Providers.QuickCheck (
testProperty
) where
import Test.Framework.Providers.API
import Test.QuickCheck hiding (Property)
import qualified Control.Exception.Extensible as E
import Control.Parallel.Strategies (rnf)
import Data.List
import System.Random
testProperty :: Testable a => TestName -> a -> Test
testProperty name = Test name . Property
instance TestResultlike PropertyTestCount PropertyResult where
testSucceeded = propertySucceeded
type PropertyTestCount = Int
data PropertyResult = PropertyResult {
pr_status :: PropertyStatus,
pr_used_seed :: Int,
pr_tests_run :: Maybe PropertyTestCount
}
data PropertyStatus = PropertyOK
| PropertyArgumentsExhausted
| PropertyFalsifiable [String]
| PropertyTimedOut
| PropertyException String
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 test_args -> "Falsifiable with seed " ++ show used_seed ++ ", after " ++ tests_run_str ++ " tests:\n" ++ unlinesConcise test_args
PropertyTimedOut -> "Timed out after " ++ tests_run_str ++ " tests"
PropertyException text -> "Got an exception: " ++ text
where
tests_run_str = fmap show mb_tests_run `orElse` "an unknown number of"
propertySucceeded :: PropertyResult -> Bool
propertySucceeded result = propertyStatusIsSuccess (pr_status result)
propertyStatusIsSuccess :: PropertyStatus -> Bool
propertyStatusIsSuccess PropertyOK = True
propertyStatusIsSuccess PropertyArgumentsExhausted = True
propertyStatusIsSuccess _ = False
data Property = forall a. Testable a => Property a
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)
runImprovingIO $ do
mb_result <- maybeTimeoutImprovingIO (unK (topt_timeout topts)) $ myCheck topts gen testable
return $ toPropertyResult seed $ case mb_result of
Nothing -> (PropertyTimedOut, Nothing)
Just (status, tests_run) -> (status, Just tests_run)
where
toPropertyResult seed (status, mb_tests_run) = PropertyResult {
pr_status = status,
pr_used_seed = seed,
pr_tests_run = mb_tests_run
}
myCheck :: (Testable a) => CompleteTestOptions -> StdGen -> a -> ImprovingIO PropertyTestCount f (PropertyStatus, PropertyTestCount)
myCheck topts rnd a = myTests topts (evaluate a) rnd 0 0 []
myTests :: CompleteTestOptions -> Gen Result -> StdGen -> PropertyTestCount -> PropertyTestCount -> [[String]] -> ImprovingIO PropertyTestCount f (PropertyStatus, PropertyTestCount)
myTests topts gen rnd0 ntest nfail stamps
| ntest == unK (topt_maximum_generated_tests topts) = do return (PropertyOK, ntest)
| nfail == unK (topt_maximum_unsuitable_generated_tests topts) = do return (PropertyArgumentsExhausted, ntest)
| otherwise = do
yieldImprovement ntest
mb_exception <- liftIO $ E.catch (fmap (const Nothing) $ E.evaluate (rnfResult result))
(return . Just . show :: E.SomeException -> IO (Maybe String))
case mb_exception of
Just e -> return (PropertyException e, ntest)
Nothing -> case ok result of
Nothing ->
myTests topts gen rnd1 ntest (nfail + 1) stamps
Just True ->
myTests topts gen rnd1 (ntest + 1) nfail (stamp result:stamps)
Just False ->
return (PropertyFalsifiable (arguments result), ntest)
where
result = generate (configSize defaultConfig ntest) rnd2 gen
(rnd1, rnd2) = split rnd0
rnfResult r = rnf (ok r) `seq` rnf (stamp r) `seq` rnf (arguments r)