diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 --- /dev/null +++ b/ChangeLog.md @@ -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 diff --git a/Setup.lhs b/Setup.lhs deleted file mode 100644 --- a/Setup.lhs +++ /dev/null @@ -1,4 +0,0 @@ -#! /usr/bin/env runhaskell - -> import Distribution.Simple -> main = defaultMain diff --git a/Test/Framework/Providers/QuickCheck2.hs b/Test/Framework/Providers/QuickCheck2.hs --- a/Test/Framework/Providers/QuickCheck2.hs +++ b/Test/Framework/Providers/QuickCheck2.hs @@ -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 +-- For an example of how to use @test-framework@, please see . 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 diff --git a/test-framework-quickcheck2.cabal b/test-framework-quickcheck2.cabal --- a/test-framework-quickcheck2.cabal +++ b/test-framework-quickcheck2.cabal @@ -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 -Maintainer: Max Bolingbroke -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 . -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