module Test.Framework.Providers.QuickCheck2 (
testProperty
) where
import Test.Framework.Providers.API
import Test.QuickCheck.Gen
import Test.QuickCheck.Property hiding ( Property )
import Test.QuickCheck.Test ( run, maxSize, stdArgs, callbackPostTest, callbackPostFinalFailure )
import Test.QuickCheck.Text
import Test.QuickCheck.State
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
| PropertyNoExpectedFailure
| PropertyTimedOut
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 fail_reason -> "Falsifiable with seed " ++ show used_seed ++ ", after " ++ tests_run_str ++ " tests. Reason: " ++ fail_reason
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 property_result = propertyStatusIsSuccess (pr_status property_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
(seed, state) <- initialState topts
runImprovingIO $ do
mb_result <- maybeTimeoutImprovingIO (unK (topt_timeout topts)) $ myTest state (unGen (property 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
}
initialState :: CompleteTestOptions -> IO (Int, State)
initialState topts = do
(gen, seed) <- newSeededStdGen (unK $ topt_seed topts)
tm <- newTerminal
let max_success = unK $ topt_maximum_generated_tests topts
max_size = maxSize stdArgs
return $ (seed, MkState {
terminal = tm
, maxSuccessTests = unK $ topt_maximum_generated_tests topts
, maxDiscardedTests = unK $ topt_maximum_unsuitable_generated_tests topts
, computeSize = \n d -> (n * max_size) `div` max_success + (d `div` 10)
, numSuccessTests = 0
, numDiscardedTests = 0
, collected = []
, expectedFailure = False
, randomSeed = gen
, isShrinking = False
, numSuccessShrinks = 0
, numTryShrinks = 0 })
myTest :: State -> (StdGen -> Int -> Prop) -> ImprovingIO PropertyTestCount f (PropertyStatus, PropertyTestCount)
myTest st f
| ntest >= maxSuccessTests st = return (if expectedFailure st then PropertyOK else PropertyNoExpectedFailure, ntest)
| numDiscardedTests st >= maxDiscardedTests st = return (PropertyArgumentsExhausted, ntest)
| otherwise = yieldImprovement ntest >> myRunATest st f
where ntest = numSuccessTests st
myRunATest :: State -> (StdGen -> Int -> Prop) -> ImprovingIO PropertyTestCount f (PropertyStatus, PropertyTestCount)
myRunATest st f = do
let size = computeSize st (numSuccessTests st) (numDiscardedTests st)
(rnd1, rnd2) = split (randomSeed st)
(res, ts) <- liftIO $ run (unProp (f rnd1 size))
liftIO $ callbackPostTest st res
case ok res of
Just True ->
do myTest st{ numSuccessTests = numSuccessTests st + 1
, randomSeed = rnd2
, collected = stamp res : collected st
, expectedFailure = expect res
} f
Nothing ->
do myTest st{ numDiscardedTests = numDiscardedTests st + 1
, randomSeed = rnd2
, expectedFailure = expect res
} f
Just False ->
do if expect res
then liftIO $ myFoundFailure st res ts
else return (PropertyOK, numSuccessTests st + 1)
myFoundFailure :: State -> Result -> [Rose (IO Result)] -> IO (PropertyStatus, PropertyTestCount)
myFoundFailure st res ts = myLocalMin st{ numTryShrinks = 0, isShrinking = True } res ts
myLocalMin :: State -> Result -> [Rose (IO Result)] -> IO (PropertyStatus, PropertyTestCount)
myLocalMin st res [] = do
callbackPostFinalFailure st res
return (PropertyFalsifiable (reason res), numSuccessTests st + 1)
myLocalMin st res (t : ts) =
do (res', ts') <- run t
callbackPostTest st res'
if ok res' == Just False
then myFoundFailure st{ numSuccessShrinks = numSuccessShrinks st + 1 } res' ts'
else myLocalMin st{ numTryShrinks = numTryShrinks st + 1 } res ts