test-framework-quickcheck2 0.2.12.4 → 0.3.0.7
raw patch · 4 files changed
Files
- ChangeLog.md +25/−0
- Setup.lhs +0/−4
- Test/Framework/Providers/QuickCheck2.hs +58/−181
- test-framework-quickcheck2.cabal +42/−24
+ ChangeLog.md view
@@ -0,0 +1,25 @@+## 0.3.0.7++_2026-01-05, Andreas Abel_++- Remove obsolete `deriving Typeable`+- Tested building with GHC 8.0 - 9.14.1++## 0.3.0.6++_2025-02-26, Andreas Abel_++- Support `random-1.3` and other latest dependencies+- Drop support for GHC 7+- Drop support for dependency versions that predate Stackage LTS 9.21+- Tested building with GHC 8.0 - 9.12.1++## 0.3.0.5++- Add support for `QuickCheck-2.12`++## 0.3.0.4++- Add support for `Quickcheck >= 2.8 && < 2.11`'s `InsufficientCoverage` status result+- Drop support for GHC < 7.0 (require `Haskell2010` support)+- Prevent `maxDiscardRatio` from becoming zero
− Setup.lhs
@@ -1,4 +0,0 @@-#! /usr/bin/env runhaskell--> import Distribution.Simple-> main = defaultMain
Test/Framework/Providers/QuickCheck2.hs view
@@ -1,25 +1,23 @@+{-# LANGUAGE CPP #-}+{-# 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 <http://github.com/batterseapower/test-framework/raw/master/example/Test/Framework/Example.lhs>+-- 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.Gen-import Test.QuickCheck.Property hiding ( Property, Result( reason, interrupted ) )-import qualified Test.QuickCheck.Property as P+import Test.QuickCheck.Property (Testable, Callback(PostTest), CallbackKind(NotCounterexample), callback)+import Test.QuickCheck.State (numSuccessTests) import Test.QuickCheck.Test-import Test.QuickCheck.Text-import Test.QuickCheck.State--import Control.Concurrent.MVar-import qualified Control.Exception.Extensible as E--import Data.IORef-import System.Random-import Unsafe.Coerce+import Test.QuickCheck.Random (QCGen, mkQCGen)+import System.Random (randomIO) -- | Create a 'Test' for a QuickCheck2 'Testable' property@@ -41,22 +39,26 @@ -- 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 -- ^ The property was not true. The string is the reason.- | PropertyNoExpectedFailure -- ^ We expected that a property would fail but it didn't- | PropertyTimedOut -- ^ The property timed out during execution- | PropertyException String -- ^ The property raised an exception during execution+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 { 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"- PropertyException text -> "Got an exception: " ++ text+ 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"+#if !MIN_VERSION_QuickCheck(2,12,0)+ PropertyInsufficientCoverage -> "Insufficient coverage after " ++ tests_run_str ++ " tests"+#endif where tests_run_str = fmap show mb_tests_run `orElse` "an unknown number of" @@ -73,164 +75,39 @@ runTest topts (Property testable) = runProperty topts testable testTypeName _ = "Properties" +newSeededQCGen :: Seed -> IO (QCGen, Int)+newSeededQCGen (FixedSeed seed) = return $ (mkQCGen seed, seed)+newSeededQCGen RandomSeed = do+ seed <- randomIO+ return (mkQCGen seed, seed)+ runProperty :: Testable a => CompleteTestOptions -> a -> IO (PropertyTestCount :~> PropertyResult, IO ()) runProperty topts testable = do- (seed, mk_state) <- initialState topts+ (gen, seed) <- newSeededQCGen (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+ , 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- mb_result <- maybeTimeoutImprovingIO (unK (topt_timeout topts)) $ do- (state, get_out) <- liftIO mk_state- myTest state get_out (unGen (property testable))- return $ toPropertyResult seed $ case mb_result of- Nothing -> (PropertyTimedOut, Nothing)- Just (status, tests_run) -> (status, Just tests_run)+ 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- toPropertyResult seed (status, mb_tests_run) = PropertyResult {- pr_status = status,- pr_used_seed = seed,- pr_tests_run = mb_tests_run- }----- I've copied these parts out of QuickCheck 2 source code and modified them to fit my purpose. My--- central problem with using the code as-is is that it insists on writing to stdout!--initialState :: CompleteTestOptions -> IO (Int, IO (State, IO String))-initialState topts = do- (gen, seed) <- newSeededStdGen (unK $ topt_seed topts)- - let max_success = unK $ topt_maximum_generated_tests topts- max_size = unK $ topt_maximum_test_size topts-- -- Copied from the unexported function Test.QuickCheck.Text.output- -- Very horrible hack here since the Output data constructor is also not exported!- output f = do- r <- newIORef ""- return (unsafeCoerce (TestQuickCheckTextOutput f r))-- mk_state = do- -- My code is very careful not to write to the terminal since it will screw up my own- -- output code, but I need to fill in the terminal field anyway. This is useful for- -- catching the failing examples that get written to the output.- out_var <- newMVar ""- out <- output $ \extra -> modifyMVar_ out_var $ \str -> return (str ++ extra)- tm <- newTerminal out out-- return (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- , numSuccessShrinks = 0- , numTryShrinks = 0-#if MIN_VERSION_QuickCheck(2,5,0)- , numTotTryShrinks = 0+ toPropertyStatus (Success {}) = PropertyOK+ toPropertyStatus (GaveUp {}) = PropertyArgumentsExhausted+ toPropertyStatus (Failure { reason = rsn, output = otpt }) = PropertyFalsifiable rsn otpt+ toPropertyStatus (NoExpectedFailure {}) = PropertyNoExpectedFailure+#if !MIN_VERSION_QuickCheck(2,12,0)+ toPropertyStatus (InsufficientCoverage _ _ _) = PropertyInsufficientCoverage #endif- },- modifyMVar out_var $ \str -> return ("", str))- return (seed, mk_state)---- If this doesn't exactly match the definition of Test.QuickCheck.Text.Out you can get segfaults-data TestQuickCheckTextOutput = TestQuickCheckTextOutput (String -> IO ()) (IORef String)----- NB: could use (summary st) in the messages produced by myTest-myTest :: State -> IO String -> (StdGen -> Int -> Prop) -> ImprovingIO PropertyTestCount f (PropertyStatus, PropertyTestCount)-myTest st get_out 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 get_out f- where ntest = numSuccessTests st--myRunATest :: State -> IO String -> (StdGen -> Int -> Prop) -> ImprovingIO PropertyTestCount f (PropertyStatus, PropertyTestCount)-myRunATest st get_out f = do- let size = computeSize st (numSuccessTests st) (numDiscardedTests st)- -- Careful to catch exceptions, or else they might bring down the whole test framework- ei_st_res <- liftIO $ flip E.catch (\e -> return $ Left $ show (e :: E.SomeException)) $ do- MkRose res ts <- protectRose (reduceRose (unProp (f rnd1 size)))- return (Right (res, ts))- - case ei_st_res of- Left text -> liftIO get_out >>= \extra_text -> return (PropertyException (text ++ extra_text), numSuccessTests st + 1)- Right (res, ts) -> do- liftIO $ callbackPostTest st res- - case res of- MkResult{ok = Just True, stamp = stamp, expect = expect} -> -- successful test- do myTest st{ numSuccessTests = numSuccessTests st + 1- , randomSeed = rnd2- , collected = stamp : collected st- , expectedFailure = expect- } get_out f- - MkResult{ok = Nothing, expect = expect} -> -- discarded test- do myTest st{ numDiscardedTests = numDiscardedTests st + 1- , randomSeed = rnd2- , expectedFailure = expect- } get_out f- - MkResult{ok = Just False} -> -- failed test- do if expect res- then liftIO $ myFoundFailure st get_out res ts- -- Could terminate immediately without any shrinking by doing this instead:- -- return (PropertyFalsifiable (reason res), numSuccessTests st + 1)- else return (PropertyOK, numSuccessTests st + 1)- where- (rnd1,rnd2) = split (randomSeed st)----- | This function eventually reports a failure but attempts to shrink the counterexample before it does so-myFoundFailure :: State -> IO String -> P.Result -> [Rose P.Result] -> IO (PropertyStatus, PropertyTestCount)-myFoundFailure st get_out res ts =- do myLocalMin st{ numTryShrinks = 0 } get_out res ts--myLocalMin :: State -> IO String -> P.Result -> [Rose P.Result] -> IO (PropertyStatus, PropertyTestCount)-myLocalMin st get_out res _ | P.interrupted res = myLocalMinFound st get_out res-myLocalMin st get_out res ts = do- r <- tryEvaluate ts- case r of- Left err ->- myLocalMinFound st get_out- (exception "Exception while generating shrink-list" err) { callbacks = callbacks res }- Right ts' -> myLocalMin' st get_out res ts'---myLocalMin' :: State -> IO String -> P.Result -> [Rose P.Result] -> IO (PropertyStatus, PropertyTestCount)-myLocalMin' st get_out res [] = myLocalMinFound st get_out res-myLocalMin' st get_out res (t:ts) =- do -- CALLBACK before_test- MkRose res' ts' <- protectRose (reduceRose t)- callbackPostTest st res'- -- NB: both (numSuccessShrinks st) (numTryShrinks st) contain interesting information here.- -- I'm not going to output any message at all here (unlike QuickCheck2) because I want a- -- single error message I can give to the user.- if ok res' == Just False- then myFoundFailure st{ numSuccessShrinks = numSuccessShrinks st + 1 } get_out res' ts'- else myLocalMin st{ numTryShrinks = numTryShrinks st + 1 } get_out res ts--myLocalMinFound :: State -> IO String -> P.Result -> IO (PropertyStatus, PropertyTestCount)-myLocalMinFound st get_out res =- do callbackPostFinalFailure st res- -- NB: could use (numSuccessShrinks st) in the message somehow- extra_text <- get_out- let reason = dropWhileRev (`elem` "\r\n") extra_text ++- if P.reason res /= "Falsifiable" then P.reason res else ""- return (PropertyFalsifiable reason, numSuccessTests st + 1)--dropWhileRev :: (a -> Bool) -> [a] -> [a]-dropWhileRev p = reverse . dropWhile p . reverse-------- Hidden module Test.QuickCheck.Exception-----tryEvaluate :: a -> IO (Either E.SomeException a)-tryEvaluate x = tryEvaluateIO (return x)--tryEvaluateIO :: IO a -> IO (Either E.SomeException a)-tryEvaluateIO m = E.try (m >>= E.evaluate)---tryEvaluateIO m = Right `fmap` m
test-framework-quickcheck2.cabal view
@@ -1,38 +1,56 @@+Cabal-Version: 1.18 Name: test-framework-quickcheck2-Version: 0.2.12.4-Cabal-Version: >= 1.2.3+Version: 0.3.0.7+ Category: Testing-Synopsis: QuickCheck2 support for the test-framework package.+Synopsis: QuickCheck-2 support for the test-framework package. License: BSD3 License-File: LICENSE Author: Max Bolingbroke <batterseapower@hotmail.com>-Maintainer: Max Bolingbroke <batterseapower@hotmail.com>-Homepage: http://batterseapower.github.com/test-framework/+Maintainer: Andreas Abel+Homepage: https://github.com/haskell/test-framework#readme+Bug-Reports: https://github.com/haskell/test-framework/issues Build-Type: Simple--Flag Base4- Description: Choose base version 4- Default: True+Description: Allows @QuickCheck-2@ properties to be used with the </package/test-framework test-framework package>. -Flag Base3- Description: Choose base version 3- Default: False+Tested-With:+ GHC == 9.14.1+ GHC == 9.12.2+ GHC == 9.10.3+ GHC == 9.8.4+ GHC == 9.6.7+ GHC == 9.4.8+ GHC == 9.2.8+ GHC == 9.0.2+ GHC == 8.10.7+ GHC == 8.8.4+ GHC == 8.6.5+ GHC == 8.4.4+ GHC == 8.2.2+ GHC == 8.0.2 +extra-doc-files: ChangeLog.md Library+ Default-Language: Haskell2010+ Other-Extensions: CPP+ DeriveDataTypeable+ ExistentialQuantification+ MultiParamTypeClasses+ TypeOperators+ TypeSynonymInstances+ Exposed-Modules: Test.Framework.Providers.QuickCheck2 - Build-Depends: test-framework >= 0.6, QuickCheck >= 2.4 && < 2.6, extensible-exceptions >= 0.1.1 && < 0.2.0- if flag(base3)- Build-Depends: base >= 3 && < 4, random >= 1- else- if flag(base4)- Build-Depends: base >= 4 && < 5, random >= 1+ Build-Depends: test-framework == 0.8.*+ , QuickCheck >= 2.9.2 && < 3+ , base >= 4.9 && < 5+ , random >= 1 && < 1.4 - Extensions: TypeSynonymInstances- TypeOperators- MultiParamTypeClasses- ExistentialQuantification- CPP+ Ghc-Options: -Wno-deprecations+ -- This package is legacy and won't address deprecation warnings. - Ghc-Options: -Wall+Source-Repository head+ Type: git+ Location: https://github.com/haskell/test-framework.git+ subdir: quickcheck2