diff --git a/QuickCheck.cabal b/QuickCheck.cabal --- a/QuickCheck.cabal +++ b/QuickCheck.cabal @@ -1,5 +1,5 @@ Name: QuickCheck -Version: 2.14.3 +Version: 2.18.0.0 Cabal-Version: >= 1.10 Build-type: Simple License: BSD3 @@ -8,7 +8,7 @@ Author: Koen Claessen Maintainer: Nick Smallbone Bug-reports: https://github.com/nick8325/quickcheck/issues -Tested-with: GHC ==7.0.4 || ==7.2.2 || >= 7.4 +Tested-with: GHC >= 8.10 && < 9.15, hugs Homepage: https://github.com/nick8325/quickcheck Category: Testing Synopsis: Automatic testing of Haskell programs @@ -39,7 +39,7 @@ extra-source-files: README - changelog + changelog.md examples/Heap.hs examples/Heap_Program.hs examples/Heap_ProgramAlgebraic.hs @@ -49,6 +49,7 @@ examples/Simple.hs make-hugs test-hugs + test-mhs source-repository head type: git @@ -57,7 +58,7 @@ source-repository this type: git location: https://github.com/nick8325/quickcheck - tag: 2.14.3 + tag: 2.18 flag templateHaskell Description: Build Test.QuickCheck.All, which uses Template Haskell. @@ -71,7 +72,7 @@ library Hs-source-dirs: src - Build-depends: base >=4.3 && <5, containers + Build-depends: base >=4.14 && <5, containers Default-language: Haskell2010 -- New vs old random. @@ -79,7 +80,7 @@ Build-depends: random >= 1.0.0.3 && < 1.2.0 cpp-options: -DOLD_RANDOM else - Build-depends: random >= 1.2.0 && < 1.3 + Build-depends: random >= 1.2.0 && < 1.4 -- We always use splitmix directly rather than going through StdGen -- (it's somewhat more efficient). @@ -88,15 +89,20 @@ if impl(hugs) cpp-options: -DNO_SPLITMIX else - Build-depends: splitmix >= 0.1 && <0.2 + Build-depends: splitmix >= 0.1.0.2 && <0.2 + if impl(hugs) + cpp-options: -DNO_SEMIGROUP -DNO_EXISTENTIAL_FIELD_SELECTORS + -- Modules that are always built. Exposed-Modules: Test.QuickCheck, + Test.QuickCheck.Compat, Test.QuickCheck.Arbitrary, Test.QuickCheck.Gen, Test.QuickCheck.Gen.Unsafe, Test.QuickCheck.Monadic, + Test.QuickCheck.Monoids, Test.QuickCheck.Modifiers, Test.QuickCheck.Property, Test.QuickCheck.Test, @@ -108,70 +114,57 @@ Test.QuickCheck.Features -- GHC-specific modules. - if impl(ghc) + if impl(ghc) || impl(mhs) Exposed-Modules: Test.QuickCheck.Function Build-depends: transformers >= 0.3, deepseq >= 1.1.0.0 - else - cpp-options: -DNO_TRANSFORMERS -DNO_DEEPSEQ if impl(ghc) && flag(templateHaskell) Build-depends: template-haskell >= 2.4 - if impl(ghc >=8.0) - Other-Extensions: TemplateHaskellQuotes - else - Other-Extensions: TemplateHaskell + Other-Extensions: TemplateHaskellQuotes Exposed-Modules: Test.QuickCheck.All else cpp-options: -DNO_TEMPLATE_HASKELL - if !impl(ghc >= 7.4) - cpp-options: -DNO_CTYPES_CONSTRUCTORS -DNO_FOREIGN_C_USECONDS - - -- The new generics appeared in GHC 7.2... - if impl(ghc < 7.2) - cpp-options: -DNO_GENERICS - -- ...but in 7.2-7.4 it lives in the ghc-prim package. - if impl(ghc >= 7.2) && impl(ghc < 7.6) - Build-depends: ghc-prim - - -- Safe Haskell appeared in GHC 7.2, but GHC.Generics isn't safe until 7.4. - if impl (ghc < 7.4) - cpp-options: -DNO_SAFE_HASKELL + if !impl(ghc) && !impl(mhs) + cpp-options: -DNO_CALLSTACK + -DNO_SEMIGROUP + -DNO_CTYPES_CONSTRUCTORS + -DNO_FOREIGN_C_USECONDS + -DNO_POLYKINDS + -DNO_MONADFAIL + -DNO_TRANSFORMERS + -DNO_DEEPSEQ -- random is explicitly Trustworthy since 1.0.1.0 -- similar constraint for containers - if impl(ghc >= 7.2) + if impl(ghc) Build-depends: random >=1.0.1.0 - if impl(ghc >= 7.4) - Build-depends: containers >=0.4.2.1 + , containers >=0.4.2.1 - if !impl(ghc >= 7.6) - cpp-options: -DNO_POLYKINDS + if impl(ghc >= 9.8) + ghc-options: -Wno-x-partial - if !impl(ghc >= 8.0) - cpp-options: -DNO_MONADFAIL + if impl(ghc < 9.4) + Build-depends: data-array-byte -- Switch off most optional features on non-GHC systems. - if !impl(ghc) + if !impl(ghc) && !impl(mhs) -- If your Haskell compiler can cope without some of these, please -- send a message to the QuickCheck mailing list! cpp-options: -DNO_TIMEOUT -DNO_NEWTYPE_DERIVING -DNO_GENERICS -DNO_TEMPLATE_HASKELL -DNO_SAFE_HASKELL -DNO_TYPEABLE -DNO_GADTS - -DNO_EXTRA_METHODS_IN_APPLICATIVE -DOLD_RANDOM + -DNO_EXTRA_METHODS_IN_APPLICATIVE -DOLD_RANDOM -DNO_CALLSTACK if !impl(hugs) && !impl(uhc) cpp-options: -DNO_ST_MONAD -DNO_MULTI_PARAM_TYPE_CLASSES + if impl(mhs) + cpp-options: -DNO_GENERICS -DNO_TEMPLATE_HASKELL -DNO_CTYPES_CONSTRUCTORS + -DNO_EXISTENTIAL_FIELD_SELECTORS + -- LANGUAGE pragmas don't have any effect in Hugs. if impl(hugs) Default-Extensions: CPP - if impl(uhc) - -- Cabal under UHC needs pointing out all the dependencies of the - -- random package. - Build-depends: old-time, old-locale - -- Plus some bits of the standard library are missing. - cpp-options: -DNO_FIXED -DNO_EXCEPTIONS - Test-Suite test-quickcheck type: exitcode-stdio-1.0 Default-language: Haskell2010 @@ -188,10 +181,8 @@ hs-source-dirs: tests main-is: GCoArbitraryExample.hs build-depends: base, QuickCheck - if !flag(templateHaskell) || !impl(ghc >= 7.2) + if !flag(templateHaskell) buildable: False - if impl(ghc >= 7.2) && impl(ghc < 7.6) - build-depends: ghc-prim Test-Suite test-quickcheck-generators type: exitcode-stdio-1.0 @@ -208,10 +199,8 @@ hs-source-dirs: tests main-is: GShrinkExample.hs build-depends: base, QuickCheck - if !flag(templateHaskell) || !impl(ghc >= 7.2) + if !flag(templateHaskell) buildable: False - if impl(ghc >= 7.2) && impl(ghc < 7.6) - build-depends: ghc-prim Test-Suite test-quickcheck-terminal type: exitcode-stdio-1.0 @@ -219,7 +208,7 @@ hs-source-dirs: tests main-is: Terminal.hs build-depends: base, process, deepseq >= 1.1.0.0, QuickCheck - if !flag(templateHaskell) || !impl(ghc >= 7.10) + if !flag(templateHaskell) buildable: False Test-Suite test-quickcheck-monadfix @@ -228,7 +217,7 @@ hs-source-dirs: tests main-is: MonadFix.hs build-depends: base, QuickCheck - if !flag(templateHaskell) || !impl(ghc >= 7.10) + if !flag(templateHaskell) buildable: False Test-Suite test-quickcheck-split @@ -237,12 +226,61 @@ hs-source-dirs: tests main-is: Split.hs build-depends: base, QuickCheck + if impl(ghc >= 9.8) + ghc-options: -Wno-x-partial +Test-Suite test-quickcheck-strictness + type: exitcode-stdio-1.0 + Default-language: Haskell2010 + hs-source-dirs: tests + main-is: Strictness.hs + build-depends: base, QuickCheck, containers + if !flag(templateHaskell) + buildable: False + Test-Suite test-quickcheck-misc type: exitcode-stdio-1.0 Default-language: Haskell2010 hs-source-dirs: tests main-is: Misc.hs + build-depends: base, QuickCheck, containers + if !flag(templateHaskell) + buildable: False + +Test-Suite test-quickcheck-discard + type: exitcode-stdio-1.0 + Default-language: Haskell2010 + hs-source-dirs: tests + main-is: DiscardRatio.hs build-depends: base, QuickCheck - if !flag(templateHaskell) || !impl(ghc >= 7.10) + +Test-Suite test-quickcheck-monoids + type: exitcode-stdio-1.0 + Default-language: Haskell2010 + hs-source-dirs: tests + main-is: Monoids.hs + build-depends: base, QuickCheck + +Test-Suite test-quickcheck-withprogress + type: exitcode-stdio-1.0 + Default-language: Haskell2010 + hs-source-dirs: tests + main-is: WithProgress.hs + build-depends: base, QuickCheck + +Test-Suite test-quickcheck-instances + type: exitcode-stdio-1.0 + Default-language: Haskell2010 + hs-source-dirs: tests + other-modules: CollectDataTypes + main-is: RunCollectDataTypes.hs + build-depends: + base, + QuickCheck, + transformers, + split, + process, + template-haskell, + hint + if !flag(templateHaskell) || impl(ghc <= 8.10) buildable: False diff --git a/changelog b/changelog deleted file mode 100644 --- a/changelog +++ /dev/null @@ -1,394 +0,0 @@ -QuickCheck 2.14.3 (released 2023-05-31) - * Add shrinkBoundedEnum (thanks to Jonathan Knowles) - * Add discardAfter for discarding tests on timeout (thanks to Justus Sagemüller) - * Add assertWith for monadic testing (thanks to KtorZ) - * Add functionElements to Test.QuickCheck.Function (thanks to Oleg Grenrus) - * Add Arbitrary instance for Newline (thanks to Daniel Bramucci) - * Improve Arbitrary instances for Float and Double (thanks to Oleg Grenrus) - * Improve arbitrarySizedFractional (thanks to Bodigrim) - * Fix shrinkRealFrac and shrinkDecimal, which were broken - * Speed up printing of progress messages (thanks to Bodigrim) - * Add COMPLETE pragmas for Fn and family (thanks to ilkecan) - * Make templateHaskell flag manual (thanks to Oleg Grenrus) - -QuickCheck 2.14.2 (released 2020-11-14) - * Add Arbitrary instances for Tree (thanks to Oleg Grenrus) - * GHC 9.0 compatibility (thanks to Vilem-Benjamin Liepelt) - -QuickCheck 2.14.1 (released 2020-07-05) - * Compatibility with random >= 1.2. - -QuickCheck 2.14 (released 2020-03-28) - * QuickCheck is now much faster at generating test data! - As a result, many properties can now be tested a lot faster; - the examples distributed with QuickCheck run about twice as - fast as before, for example. Of course, your mileage may vary. - - The reason for this is that there are now specialised versions - of the 'choose' combinator for various types. These are: - chooseInt, chooseInteger, chooseBoundedIntegral, and chooseEnum. - These combinators are identical to 'choose' but much faster. - All QuickCheck combinators, with the exception of 'choose' - itself, use the new combinators behind the scenes. - - You should see a speedup without doing anything, but to get a - further speedup, consider replacing any uses of 'choose' in your - own generators with the new combinators. - - We are hoping that future releases of the 'random' library may - speed up 'choose', in which case these combinators may no longer - be needed. - - Thanks to Oleg Grenrus for suggesting to bypass 'choose' for - random number generation, and providing the appropriate - primitive in his 'splitmix' random number library. - - * Smaller changes and bugfixes: - - RecursivelyShrink and GSubterms are exported from - Test.QuickCheck.Test (thanks to Tom Mortiboy). - - Don't generate invalid unicode characters - (thanks to Boris Stepanov). - - When a call to 'within' fails, include the duration of the - timeout in the failure report (thanks to William Rusnack). - - In Gen, avoid splitting the seed in the implementation of - >>, *> and <* (thanks to David Feuer). - - Fix a couple of bugs with shrinking of floating-point - numbers. - - Export functionMapWith, functionEitherWith and - functionPairWith from Test.QuickCheck.Function - (thanks to Oleg Grenrus). - - Remove redundant RealFloat constraint from - Arbitrary/CoArbitrary instances for Complex - (thanks to Bodigrim). - -QuickCheck 2.13.2 (released 2019-06-30) - * Compatibility with GHC 8.8 (thanks to Bodigrim) - * Improve error message when 'frequency' is used with only zero weights - * Add 'functionVoid' combinator (thanks to Oleg Grenrus) - * Tighten bounds for random package (thanks to Oleg Grenrus) - -QuickCheck 2.13.1 (released 2019-03-29) - * A couple of bug fixes - -QuickCheck 2.13 (released 2019-03-26) - * Properties with multiple arguments now shrink better. - Previously, the first argument was shrunk, then the second, and - so on. Now, the arguments are shrunk as a whole, so shrink steps - for different arguments can be interleaved. - - * New features: - - New modifiers Negative and NonPositive - - A Testable instance for Maybe prop (where Nothing means 'discard - the test case') - * Dependencies on C code removed: - - Use splitmix instead of tf-random for random number generation - - Remove dependency on 'erf' package - * Small changes: - - Say 'Falsified' instead of 'Falsifiable' when a property fails - * Compatibility improvements: - - Explicitly derive instance Typeable Args - - Lower bound on deepseq - - A script for building Hugs packages - -QuickCheck 2.12.6 (released 2018-10-02) - * Make arbitrarySizedBoundedIntegral handle huge sizes correctly. - * Add changelog for QuickCheck 2.12.5 :) - -QuickCheck 2.12.5 (released 2018-09-30) - * Export isSuccess from Test.QuickCheck. - * Export CoArbitrary even when generics are disabled (bugfix). - * Fix bug in shrinkDecimal. - * Include Test.QuickCheck.Gen in exposed modules for Haddock. - -QuickCheck 2.12.3, 2.12.4 (released 2018-09-12) - * Shrinking for Float and Decimal now works by reducing the number - of digits in the number. The new function shrinkDecimal - implements this shrinking behaviour. - * Shrinking for Rational now tries to make the numerator and - denominator of the number smaller. Previously it tried to reduce - the magnitude of the number. - -QuickCheck 2.12.2 (released 2018-09-10) - * Fix infinite shrinking loop for fractional types. - * Add SortedList modifier. - -QuickCheck 2.12.1 (released 2018-09-06) - * Fix bug in 'classify'. - -QuickCheck 2.12 (released 2018-09-03) - * Silently breaking changes! - - The Arbitrary instance for Word now generates only small - values, the same as Int - - cover no longer causes a property failure if coverage is - insufficient. It just prints a warning. (But see next item!) - - * Overhaul of label/cover family of combinators: - - New property combinator checkCoverage, which checks coverage - requirements in a statistically sound way, and *does* fail if - they are not met. - - Order of arguments to cover swapped, to make it easier to - switch between classify and cover - - New combinators tabulate and coverTable, for reporting test - case distribution more flexibly than label. - - When label is called multiple times in a property, each call - produces a separate table of frequencies. - - * New functions: - - (=/=): like (/=), but prints a counterexample - (thanks to tom-bop) - - forAllShow/forAllShrinkShow: quantification using an - explicit show function (thanks to Stevan Andjelkovic) - - forAllBlind/forAllShrinkBlind: quantification without - printing anything - - verboseShrinking: see how a counterexample is shrunk - - labelledExamples: given a property which uses label, - generate an example test case for each label - - idempotentIOProperty: a variant of ioProperty which shrinks - better but only works for idempotent I/O actions - - * Other improvements: - - MonadFix Gen instance (thanks to Jon Fowler) - - Rational numbers shrink using continued fractions - (thanks to Justus Sagemüller) - - Function instances for Const, Identity, and the types in - Data.Monoid; instance Functor Fun (thanks to Erik Schnetter - and Xia Li-yao) - - More of Test.QuickCheck.Function is exported from - Test.QuickCheck - - Semantics of .||. changed to improve short-circuiting: - if the left argument's precondition is false, the right - argument is not evaluated and the whole disjunction is - considered to have a false precondition - - Bug fix: suchThatMaybe always increased size to at least 1 - - * Miscellaneous API changes: - - Result type has changed a bit: - - InsufficientCovered constructor is gone - - Type of labels has changed - - New fields classes, tables - -QuickCheck 2.11.1 - 2.11.3 (released 2018-01-12) - * Cosmetic fixes. - -QuickCheck 2.11 (released 2018-01-12) - * New features: - - InfiniteList modifier generates infinite lists and shows - only the relevant part. - - applyArbitrary2/3/4 for applying a function to random - arguments. - - Template Haskell function allProperties returns all - properties in a module. - - * Applicative Gen instances do less splitting. - * Property now has a Typeable instance. - * (===) now prints correct output when the property is true. - * Test.QuickCheck now exports Fun constructor. - * verboseCheck output is now slightly less confusing. - -QuickCheck 2.10.1 (released 2017-10-06) - * Arbitrary instances for Foreign.C.Types are available in more - GHC versions. - * Fixed a bug where withMaxSuccess didn't adjust the allowed - number of discarded tests. - * Remove quadratic behaviour in terminal output. - -QuickCheck 2.10 (released 2017-06-15) - * New combinators: - - withMaxSuccess sets the maximum number of test cases for a property. - - shrinkMap/shrinkMapBy are helpers for defining shrink functions. - - total checks that a value is non-crashing. - - suchThatMap is similar to 'suchThat' - but takes a Maybe-returning function instead of a predicate. - - getSize returns the current test case size. - - * Random strings and characters now include Unicode characters by - default. To generate only ASCII characters, use the new - ASCIIString modifier or arbitraryASCIIChar generator. - The following modifiers and generators also control the - kind of strings generated: UnicodeString, PrintableString, - arbitraryUnicodeChar, arbitraryPrintableChar. - - * QuickCheck no longer catches asynchronous exceptions, which - means that pressing ctrl-C will now cancel testing without - printing a counterexample. If you are debugging an infinite loop, - please use the 'within' combinator or 'verboseCheck' instead. - ('within' is better as it allows the counterexample to be - shrunk.) - - * Much of Test.QuickCheck.Function (showable random functions) - is now exported from Test.QuickCheck. - - Test.QuickCheck.Function now defines functions and - pattern synonyms which simplify testing functions of - more than one argument: apply2, apply3, Fn2, Fn3. - - * New typeclasses Arbitrary1 and Arbitrary2 which lift Arbitrary - to unary/binary type constructors, like in Data.Functor.Classes. - - * Some Arbitrary instances have been removed: NonEmpty, Natural. - This is because they resulted in a lot of extra dependencies. - You can now find them in the quickcheck-instances package. - Alternatively, use the NonEmptyList and NonNegative modifiers. - - * New Arbitrary instances for the following types: Proxy, ExitCode, - WrappedMonad, WrappedArrow, QCGen, and the types in - Foreign.C.Types and Data.Functor.{Product,Compose}. - Also a Function instance for Word. - - * The functions in Test.QuickCheck.Monadic which take an argument - of type PropertyM m a now expect that 'a' to be Testable, and test it. - To reduce breakage from this, () is now an instance of Testable which - always succeeds. - - PropertyM now has a MonadFail instance on recent GHCs. - Furthermore, the constraints on some instances were loosened. - - * Miscellaneous API changes: - - Result now returns the counterexample as a list of strings. - See the "failingTestCase" field. - - Args now has a `maxShrinks` argument, the maximum number of - shrinks to try before giving up shrinking. - - The 'labels' field of Result now encodes frequencies as Doubles - rather than Ints. - - * Bugfixes: - - 'Test.QuickCheck.Function', 'Test.QuickCheck.Poly', and - 'Test.QuickCheck.Monadic' are now Safe modules. - - Result.theException and Result.reason were taken from - the pre-shrunk counterexample, not the shrunk one. - - The Testable Property instance improperly used 'again'. - - Gen.>>= is strict in the result of split, fixing a space leak. - - within now gives a better error message on timeout - - * Some more examples and links have been added to the documentation. - -QuickCheck 2.9.2 (released 2016-09-15) - * Fix a bug where some properties were only being tested once - * Make shrinking of floating-point values less aggressive - * Add function chooseAny :: Random a => Gen a - -QuickCheck 2.9.1 (released 2016-07-11) - * 'again' was only used in forAllShrink, not forAll - -QuickCheck 2.9 (released 2016-07-10) - * Arbitrary, CoArbitrary and Function instances for more types - * Generics for automatic Function instances - * A new combinator "again" which undoes the effect of "once" - * Remove "exhaustive" from Testable typeclass; - instead, combinators which are nonexhaustive (such as forAll) - call "again", which should be more robust - - * Drop support for GHC 6.x - - * Fixed bugs: - * arbitrarySizedBoundedIntegral wasn't generating huge integers - * verboseCheck failed with Test.QuickCheck.Function - * label had a space leak - -QuickCheck 2.8.2 (released 2016-01-15) - * GHC 8 support - * Add Arbitrary and CoArbitrary instances for types in - containers package - * Improve speed of shuffle combinator - * Only print to stderr if it's a terminal. - * Small changes: slightly improve documentation, - remove redundant constraints from some functions' types, - small improvements to Test.QuickCheck.All. - -QuickCheck 2.8.1 (released 2015-04-03) - * Fix bug where exceptions thrown printing counterexamples weren't - being caught when terminal output was disabled - * Don't export Test.QuickCheck.Property.result - -QuickCheck 2.8 (released 2015-03-18) - * New features: - * Support for GHC 7.10 - * Arbitrary instance for Natural - * New generators shuffle and sublistOf - * Support for generic coarbitrary - * When using the cover combinator, insufficient coverage now - causes the property to fail - - * API changes: - * Test.QuickCheck.Function: new pattern synonym Fn - * genericShrink no longer requires Typeable - * Result has a new constructor InsufficientCoverage - * resize throws an error if the size is negative - - * Bug fixes: - * Fix memory leaks - * Exceptions thrown by callbacks now cause the test to fail - * Fixed a bug where the cover combinator wouldn't give a - warning if coverage was 0% - -QuickCheck 2.7.3 (released 2014-03-24) - * Add annotations for Safe Haskell. - -QuickCheck 2.7.2 (released 2014-03-22) - * Fix bug in cabal file which broke cabal test - -QuickCheck 2.7.1 (released 2014-03-20) - * Fixed bug - the Small modifier didn't work on unsigned types - * Changed arbitrarySizedIntegral to have an Integral constraint - instead of just Num - -QuickCheck 2.7 (released 2014-03-19) - - * New features: - * New genericShrink function provides generic shrinking with GHC. - * New combinator x === y: fails if x /= y, but also prints their values - * New function generate :: Gen a -> IO a for running a generator. - * New combinators infiniteList and infiniteListOf for generating infinite lists. - * Several combinators added to the main Test.QuickCheck module which - were previously languishing in other modules. Of particular interest: - quickCheckAll, ioProperty. - * New combinators delay and capture which can be used (unsafely!) - to reuse the random number seed. Useful for generating - polymorphic (rank-2) values. - * A new Discard data type and a Testable instance for discarding test cases. - * All modifiers now have Functor instances and accessor functions. - * Pressing ctrl-C during shrinking now shows the last failed - test case, rather than the current shrinking candidate. - * Experimental support for UHC. You will need the latest version of Cabal from git. - - * Better distribution of test data: - * The Int generator now only generates fairly small numbers. - * The new Small and Large modifiers control the distribution of integers - (Small generates small numbers, Large from the whole range). - * Floating-point numbers shrink better. - - * Improved random number generation: - * QuickCheck now uses TFGen rather than StdGen on newer versions - of GHC, because StdGen's random numbers aren't always random. - * 'variant' now uses a prefix code. This should prevent some - potential bananaskins with coarbitrary. - - * API changes: - * The Gen monad now uses an abstract type QCGen rather than StdGen. - * The Result type now returns the thrown exception and number - of failed shrink attempts. - * Property is now a newtype rather than Gen Prop as it was before. - * promote is moved into the new module Test.QuickCheck.Gen.Unsafe. - * 'printTestCase' is deprecated - its new name is 'counterexample' - * 'morallyDubiousIOProperty' is deprecated - its new name is - 'ioProperty', no moral judgement involved :) - -QuickCheck 2.6, released 2013-03-07 - - * Add convenience Function instances for up to 7-tuples - * Make stderr line buffered to reduce console I/O. - * Return a flag to say whether the test case was interrupted. - -QuickCheck 2.5, released 2012-06-18 - - * Replace maxDiscard with maxDiscardRatio - * Remove Testable () instance. - * Added a 'discard' exception that discards the current test case - * Add accessors for modifiers (where it makes sense) - * Rename 'stop' to 'abort' to avoid a name clash - * Added a 'once' combinator - * If a property is of type Bool, only run it once - * Add coarbitraryEnum to Test.QuickCheck module. - * Add 'coarbitrary' helper for Enums. - * Rejiggled the formatting code to support multi-line error messages - * Add instances for Ordering and Fixed. - * Added arbitraryBoundedEnum generator (thanks to Antoine Latter). - * Add verboseCheckAll and polyverboseCheck function for usability. diff --git a/changelog.md b/changelog.md new file mode 100644 --- /dev/null +++ b/changelog.md @@ -0,0 +1,457 @@ +## UNRELEASED + +## QuickCheck 2.18.0.0 (released 2026-02-26) +* BREAKING: Added a number of `CoArbitrary` and `Function` instances for types in `base` +* Improve implementation of `shrinkIntegral` (thanks tom93) +* Improve implementation of `Arbitrary NonEmptyList` (thanks konsumlamm) +* Convert changelog to markdown (thanks Artem) +* Deprecate `withMaxSuccess` in favour of the renamed `withNumTests` +* `Test.QuickCheck.Function` marked as `Trustworthy` not `Safe` +* Fix bug in heap example + +## QuickCheck 2.17.1.0 (released 2025-10-13) +* Fix random-1.2 support (thanks bodigrim) +* Update docs (thanks effectfully) + +## QuickCheck 2.17.0.0 (released 2025-10-07) +* Lower the memory use of `arbitrary` for `Double` and `Float` (thanks +ChickenProp) +* BREAKING: Remove `Gen.Class` +* BREAKING: Add `Arbitrary` instances for most of the types in `base` +* Add microHS support (thanks Lennart) + +## QuickCheck 2.16.0.0 (released 2025-06-17) +* Add a `Safe` declaration to `Test.QuickCheck.Monoids` +* Fix `Test.QuickCheck.Features` to not depend on the internal testing loop +* Add `withProgress` to install common callbacks for downstream tools +* Relax bounds on `random` dependency (thanks to LaurentRDC and +Andreas Abel) +* Fix some haddock issues (thanks to pgujjula) +* Use `displayException` instead of `show` (thanks Edsko) +* Added helper monoids `Every` and `Some` for predicates (thanks +Marcin) + +## QuickCheck 2.15 (released 2024-04-22) +* BREAKING: properties without quantification are no longer implicitly + wrapped in once +* Add witness property modifier and witnesses field in result on +compilers that support Typeable to allow conveniently exposing +counterexamples +* Add assertException, assertExceptionIO, assertDeepException, and +assertDeepExceptionIO (thanks to Alexey Kuleshevich) +* Add withMaxSize, withMaxShrinks, and withMaxDiscardRatio combinators +* Add recheck +* Add HasCallStack to partial top-level functions +* Updated some documentation +* Fix overflow bug when calculating discard ratio +* Fix error printing bug when shrinks are discarded +* Fix withMaxSuccess not working when checkCoverage is turned on +* Fix a bug whereby an unfortunately timed discard could unduly fail a +property running with checkCoverage +* Fix Arbitrary intance for Map breaking invariants from +Data.Map.Strict (thanks to Neil Mayhew) +* Fix non-covered classes not showing up in output as 0% covered +* Fix Negative's Arbitrary instance discarding an unnecessary number +of generated values. +* Fix promote doing an unnecessary seed split +* Fix a bug whereby maxSuccess and discardRatio would interact poorly +to produce too few size increases. +* Fix a couple of underflow bugs in generators for Small Natural and +Ratio Natural +* Fix a bug whereby the internal DISCARDED exception would show up +user-side in sample + +## QuickCheck 2.14.3 (released 2023-05-31) +* Add shrinkBoundedEnum (thanks to Jonathan Knowles) +* Add discardAfter for discarding tests on timeout (thanks to Justus Sagemüller) +* Add assertWith for monadic testing (thanks to KtorZ) +* Add functionElements to Test.QuickCheck.Function (thanks to Oleg Grenrus) +* Add Arbitrary instance for Newline (thanks to Daniel Bramucci) +* Improve Arbitrary instances for Float and Double (thanks to Oleg Grenrus) +* Improve arbitrarySizedFractional (thanks to Bodigrim) +* Fix shrinkRealFrac and shrinkDecimal, which were broken +* Speed up printing of progress messages (thanks to Bodigrim) +* Add COMPLETE pragmas for Fn and family (thanks to ilkecan) +* Make templateHaskell flag manual (thanks to Oleg Grenrus) + +## QuickCheck 2.14.2 (released 2020-11-14) +* Add Arbitrary instances for Tree (thanks to Oleg Grenrus) +* GHC 9.0 compatibility (thanks to Vilem-Benjamin Liepelt) + +## QuickCheck 2.14.1 (released 2020-07-05) +* Compatibility with random >= 1.2. + +## QuickCheck 2.14 (released 2020-03-28) +* QuickCheck is now much faster at generating test data! + As a result, many properties can now be tested a lot faster; + the examples distributed with QuickCheck run about twice as + fast as before, for example. Of course, your mileage may vary. + + The reason for this is that there are now specialised versions + of the 'choose' combinator for various types. These are: + chooseInt, chooseInteger, chooseBoundedIntegral, and chooseEnum. + These combinators are identical to 'choose' but much faster. + All QuickCheck combinators, with the exception of 'choose' + itself, use the new combinators behind the scenes. + + You should see a speedup without doing anything, but to get a + further speedup, consider replacing any uses of 'choose' in your + own generators with the new combinators. + + We are hoping that future releases of the 'random' library may + speed up 'choose', in which case these combinators may no longer + be needed. + + Thanks to Oleg Grenrus for suggesting to bypass 'choose' for + random number generation, and providing the appropriate + primitive in his 'splitmix' random number library. + +* Smaller changes and bugfixes: +- RecursivelyShrink and GSubterms are exported from + Test.QuickCheck.Test (thanks to Tom Mortiboy). +- Don't generate invalid unicode characters + (thanks to Boris Stepanov). +- When a call to 'within' fails, include the duration of the + timeout in the failure report (thanks to William Rusnack). +- In Gen, avoid splitting the seed in the implementation of + >>, *> and <* (thanks to David Feuer). +- Fix a couple of bugs with shrinking of floating-point + numbers. +- Export functionMapWith, functionEitherWith and + functionPairWith from Test.QuickCheck.Function + (thanks to Oleg Grenrus). +- Remove redundant RealFloat constraint from + Arbitrary/CoArbitrary instances for Complex + (thanks to Bodigrim). + +## QuickCheck 2.13.2 (released 2019-06-30) +* Compatibility with GHC 8.8 (thanks to Bodigrim) +* Improve error message when 'frequency' is used with only zero weights +* Add 'functionVoid' combinator (thanks to Oleg Grenrus) +* Tighten bounds for random package (thanks to Oleg Grenrus) + +## QuickCheck 2.13.1 (released 2019-03-29) +* A couple of bug fixes + +## QuickCheck 2.13 (released 2019-03-26) +* Properties with multiple arguments now shrink better. + Previously, the first argument was shrunk, then the second, and + so on. Now, the arguments are shrunk as a whole, so shrink steps + for different arguments can be interleaved. + +* New features: + - New modifiers Negative and NonPositive + - A Testable instance for Maybe prop (where Nothing means 'discard + the test case') +* Dependencies on C code removed: + - Use splitmix instead of tf-random for random number generation + - Remove dependency on 'erf' package +* Small changes: + - Say 'Falsified' instead of 'Falsifiable' when a property fails +* Compatibility improvements: + - Explicitly derive instance Typeable Args + - Lower bound on deepseq + - A script for building Hugs packages + +## QuickCheck 2.12.6 (released 2018-10-02) +* Make arbitrarySizedBoundedIntegral handle huge sizes correctly. +* Add changelog for QuickCheck 2.12.5 :) + +## QuickCheck 2.12.5 (released 2018-09-30) +* Export isSuccess from Test.QuickCheck. +* Export CoArbitrary even when generics are disabled (bugfix). +* Fix bug in shrinkDecimal. +* Include Test.QuickCheck.Gen in exposed modules for Haddock. + +## QuickCheck 2.12.3, 2.12.4 (released 2018-09-12) +* Shrinking for Float and Decimal now works by reducing the number + of digits in the number. The new function shrinkDecimal + implements this shrinking behaviour. +* Shrinking for Rational now tries to make the numerator and + denominator of the number smaller. Previously it tried to reduce + the magnitude of the number. + +## QuickCheck 2.12.2 (released 2018-09-10) +* Fix infinite shrinking loop for fractional types. +* Add SortedList modifier. + +## QuickCheck 2.12.1 (released 2018-09-06) +* Fix bug in 'classify'. + +## QuickCheck 2.12 (released 2018-09-03) +* Silently breaking changes! + - The Arbitrary instance for Word now generates only small + values, the same as Int + - cover no longer causes a property failure if coverage is + insufficient. It just prints a warning. (But see next item!) + +* Overhaul of label/cover family of combinators: + - New property combinator checkCoverage, which checks coverage + requirements in a statistically sound way, and *does* fail if + they are not met. + - Order of arguments to cover swapped, to make it easier to + switch between classify and cover + - New combinators tabulate and coverTable, for reporting test + case distribution more flexibly than label. + - When label is called multiple times in a property, each call + produces a separate table of frequencies. + +* New functions: + - (=/=): like (/=), but prints a counterexample + (thanks to tom-bop) + - forAllShow/forAllShrinkShow: quantification using an + explicit show function (thanks to Stevan Andjelkovic) + - forAllBlind/forAllShrinkBlind: quantification without + printing anything + - verboseShrinking: see how a counterexample is shrunk + - labelledExamples: given a property which uses label, + generate an example test case for each label + - idempotentIOProperty: a variant of ioProperty which shrinks + better but only works for idempotent I/O actions + +* Other improvements: + - MonadFix Gen instance (thanks to Jon Fowler) + - Rational numbers shrink using continued fractions + (thanks to Justus Sagemüller) + - Function instances for Const, Identity, and the types in + Data.Monoid; instance Functor Fun (thanks to Erik Schnetter + and Xia Li-yao) + - More of Test.QuickCheck.Function is exported from + Test.QuickCheck + - Semantics of .||. changed to improve short-circuiting: + if the left argument's precondition is false, the right + argument is not evaluated and the whole disjunction is + considered to have a false precondition + - Bug fix: suchThatMaybe always increased size to at least 1 + +* Miscellaneous API changes: + - Result type has changed a bit: + - InsufficientCovered constructor is gone + - Type of labels has changed + - New fields classes, tables + +## QuickCheck 2.11.1 - 2.11.3 (released 2018-01-12) +* Cosmetic fixes. + +## QuickCheck 2.11 (released 2018-01-12) +* New features: + - InfiniteList modifier generates infinite lists and shows + only the relevant part. + - applyArbitrary2/3/4 for applying a function to random + arguments. + - Template Haskell function allProperties returns all + properties in a module. + +* Applicative Gen instances do less splitting. +* Property now has a Typeable instance. +* (===) now prints correct output when the property is true. +* Test.QuickCheck now exports Fun constructor. +* verboseCheck output is now slightly less confusing. + +## QuickCheck 2.10.1 (released 2017-10-06) +* Arbitrary instances for Foreign.C.Types are available in more + GHC versions. +* Fixed a bug where withMaxSuccess didn't adjust the allowed + number of discarded tests. +* Remove quadratic behaviour in terminal output. + +## QuickCheck 2.10 (released 2017-06-15) +* New combinators: + - withMaxSuccess sets the maximum number of test cases for a property. + - shrinkMap/shrinkMapBy are helpers for defining shrink functions. + - total checks that a value is non-crashing. + - suchThatMap is similar to 'suchThat' + but takes a Maybe-returning function instead of a predicate. + - getSize returns the current test case size. + +* Random strings and characters now include Unicode characters by + default. To generate only ASCII characters, use the new + ASCIIString modifier or arbitraryASCIIChar generator. + The following modifiers and generators also control the + kind of strings generated: UnicodeString, PrintableString, + arbitraryUnicodeChar, arbitraryPrintableChar. + +* QuickCheck no longer catches asynchronous exceptions, which + means that pressing ctrl-C will now cancel testing without + printing a counterexample. If you are debugging an infinite loop, + please use the 'within' combinator or 'verboseCheck' instead. + ('within' is better as it allows the counterexample to be + shrunk.) + +* Much of Test.QuickCheck.Function (showable random functions) + is now exported from Test.QuickCheck. + - Test.QuickCheck.Function now defines functions and + pattern synonyms which simplify testing functions of + more than one argument: apply2, apply3, Fn2, Fn3. + +* New typeclasses Arbitrary1 and Arbitrary2 which lift Arbitrary + to unary/binary type constructors, like in Data.Functor.Classes. + +* Some Arbitrary instances have been removed: NonEmpty, Natural. + This is because they resulted in a lot of extra dependencies. + You can now find them in the quickcheck-instances package. + Alternatively, use the NonEmptyList and NonNegative modifiers. + +* New Arbitrary instances for the following types: Proxy, ExitCode, + WrappedMonad, WrappedArrow, QCGen, and the types in + Foreign.C.Types and Data.Functor.{Product,Compose}. + Also a Function instance for Word. + +* The functions in Test.QuickCheck.Monadic which take an argument + of type PropertyM m a now expect that 'a' to be Testable, and test it. + To reduce breakage from this, () is now an instance of Testable which + always succeeds. + - PropertyM now has a MonadFail instance on recent GHCs. + Furthermore, the constraints on some instances were loosened. + +* Miscellaneous API changes: + - Result now returns the counterexample as a list of strings. + See the "failingTestCase" field. + - Args now has a `maxShrinks` argument, the maximum number of + shrinks to try before giving up shrinking. + - The 'labels' field of Result now encodes frequencies as Doubles + rather than Ints. + +* Bugfixes: + - 'Test.QuickCheck.Function', 'Test.QuickCheck.Poly', and + 'Test.QuickCheck.Monadic' are now Safe modules. + - Result.theException and Result.reason were taken from + the pre-shrunk counterexample, not the shrunk one. + - The Testable Property instance improperly used 'again'. + - Gen.>>= is strict in the result of split, fixing a space leak. + - within now gives a better error message on timeout + +* Some more examples and links have been added to the documentation. + +## QuickCheck 2.9.2 (released 2016-09-15) +* Fix a bug where some properties were only being tested once +* Make shrinking of floating-point values less aggressive +* Add function chooseAny :: Random a => Gen a + +## QuickCheck 2.9.1 (released 2016-07-11) +* 'again' was only used in forAllShrink, not forAll + +## QuickCheck 2.9 (released 2016-07-10) +* Arbitrary, CoArbitrary and Function instances for more types +* Generics for automatic Function instances +* A new combinator "again" which undoes the effect of "once" +* Remove "exhaustive" from Testable typeclass; + instead, combinators which are nonexhaustive (such as forAll) + call "again", which should be more robust + +* Drop support for GHC 6.x + +* Fixed bugs: + * arbitrarySizedBoundedIntegral wasn't generating huge integers + * verboseCheck failed with Test.QuickCheck.Function + * label had a space leak + +## QuickCheck 2.8.2 (released 2016-01-15) +* GHC 8 support +* Add Arbitrary and CoArbitrary instances for types in + containers package +* Improve speed of shuffle combinator +* Only print to stderr if it's a terminal. +* Small changes: slightly improve documentation, + remove redundant constraints from some functions' types, + small improvements to Test.QuickCheck.All. + +## QuickCheck 2.8.1 (released 2015-04-03) +* Fix bug where exceptions thrown printing counterexamples weren't + being caught when terminal output was disabled +* Don't export Test.QuickCheck.Property.result + +## QuickCheck 2.8 (released 2015-03-18) +* New features: + * Support for GHC 7.10 + * Arbitrary instance for Natural + * New generators shuffle and sublistOf + * Support for generic coarbitrary + * When using the cover combinator, insufficient coverage now + causes the property to fail + +* API changes: + * Test.QuickCheck.Function: new pattern synonym Fn + * genericShrink no longer requires Typeable + * Result has a new constructor InsufficientCoverage + * resize throws an error if the size is negative + +* Bug fixes: + * Fix memory leaks + * Exceptions thrown by callbacks now cause the test to fail + * Fixed a bug where the cover combinator wouldn't give a + warning if coverage was 0% + +## QuickCheck 2.7.3 (released 2014-03-24) +* Add annotations for Safe Haskell. + +## QuickCheck 2.7.2 (released 2014-03-22) +* Fix bug in cabal file which broke cabal test + +## QuickCheck 2.7.1 (released 2014-03-20) +* Fixed bug - the Small modifier didn't work on unsigned types +* Changed arbitrarySizedIntegral to have an Integral constraint + instead of just Num + +## QuickCheck 2.7 (released 2014-03-19) + +* New features: + * New genericShrink function provides generic shrinking with GHC. + * New combinator x === y: fails if x /= y, but also prints their values + * New function generate :: Gen a -> IO a for running a generator. + * New combinators infiniteList and infiniteListOf for generating infinite lists. + * Several combinators added to the main Test.QuickCheck module which + were previously languishing in other modules. Of particular interest: + quickCheckAll, ioProperty. + * New combinators delay and capture which can be used (unsafely!) + to reuse the random number seed. Useful for generating + polymorphic (rank-2) values. + * A new Discard data type and a Testable instance for discarding test cases. + * All modifiers now have Functor instances and accessor functions. + * Pressing ctrl-C during shrinking now shows the last failed + test case, rather than the current shrinking candidate. + * Experimental support for UHC. You will need the latest version of Cabal from git. + +* Better distribution of test data: + * The Int generator now only generates fairly small numbers. + * The new Small and Large modifiers control the distribution of integers + (Small generates small numbers, Large from the whole range). + * Floating-point numbers shrink better. + +* Improved random number generation: + * QuickCheck now uses TFGen rather than StdGen on newer versions + of GHC, because StdGen's random numbers aren't always random. + * 'variant' now uses a prefix code. This should prevent some + potential bananaskins with coarbitrary. + +* API changes: + * The Gen monad now uses an abstract type QCGen rather than StdGen. + * The Result type now returns the thrown exception and number + of failed shrink attempts. + * Property is now a newtype rather than Gen Prop as it was before. + * promote is moved into the new module Test.QuickCheck.Gen.Unsafe. + * 'printTestCase' is deprecated - its new name is 'counterexample' + * 'morallyDubiousIOProperty' is deprecated - its new name is + 'ioProperty', no moral judgement involved :) + +## QuickCheck 2.6 (released 2013-03-07) + +* Add convenience Function instances for up to 7-tuples +* Make stderr line buffered to reduce console I/O. +* Return a flag to say whether the test case was interrupted. + +## QuickCheck 2.5 (released 2012-06-18) + +* Replace maxDiscard with maxDiscardRatio +* Remove Testable () instance. +* Added a 'discard' exception that discards the current test case +* Add accessors for modifiers (where it makes sense) +* Rename 'stop' to 'abort' to avoid a name clash +* Added a 'once' combinator +* If a property is of type Bool, only run it once +* Add coarbitraryEnum to Test.QuickCheck module. +* Add 'coarbitrary' helper for Enums. +* Rejiggled the formatting code to support multi-line error messages +* Add instances for Ordering and Fixed. +* Added arbitraryBoundedEnum generator (thanks to Antoine Latter). +* Add verboseCheckAll and polyverboseCheck function for usability. diff --git a/examples/Heap.hs b/examples/Heap.hs --- a/examples/Heap.hs +++ b/examples/Heap.hs @@ -72,7 +72,7 @@ toSortedList :: Ord a => Heap a -> [a] toSortedList Empty = [] -toSortedList (Node x h1 h2) = x : toList (h1 `merge` h2) +toSortedList (Node x h1 h2) = x : toSortedList (h1 `merge` h2) -------------------------------------------------------------------------- -- specification @@ -144,24 +144,21 @@ -- main return [] -main = $quickCheckAll +main = do True <- $quickCheckAll; return () -------------------------------------------------------------------------- -- the end. -{- - shrink Empty = [] - shrink (Node x h1 h2) = - [ h1, h2 ] - ++ [ Node x h1' h2 | h1' <- shrink h1, x <=? h1' ] - ++ [ Node x h1 h2' | h2' <- shrink h2, x <=? h2' ] - ++ [ Node x' h1 h2 | x' <- shrink x, x' <=? h1, x' <=? h2 ] --} +-- shrink Empty = [] +-- shrink (Node x h1 h2) = +-- [ h1, h2 ] +-- ++ [ Node x h1' h2 | h1' <- shrink h1, x <=? h1' ] +-- ++ [ Node x h1 h2' | h2' <- shrink h2, x <=? h2' ] +-- ++ [ Node x' h1 h2 | x' <- shrink x, x' <=? h1, x' <=? h2 ] + -- toSortedList (Node x h1 h2) = x : toSortedList (h1 `merge` h2) -{- -prop_HeapIsNotSorted (h :: Heap Int) = - expectFailure $ - toList h == toSortedList h --} +-- prop_HeapIsNotSorted (h :: Heap Int) = +-- expectFailure $ +-- toList h == toSortedList h diff --git a/examples/Heap_Program.hs b/examples/Heap_Program.hs --- a/examples/Heap_Program.hs +++ b/examples/Heap_Program.hs @@ -187,7 +187,7 @@ -- main return [] -main = $(quickCheckAll) +main = do True <- $quickCheckAll; return () -------------------------------------------------------------------------- -- the end. diff --git a/examples/Heap_ProgramAlgebraic.hs b/examples/Heap_ProgramAlgebraic.hs --- a/examples/Heap_ProgramAlgebraic.hs +++ b/examples/Heap_ProgramAlgebraic.hs @@ -245,7 +245,7 @@ -- main return [] -main = $(quickCheckAll) +main = do True <- $quickCheckAll; return () -------------------------------------------------------------------------- -- the end. diff --git a/examples/Merge.hs b/examples/Merge.hs --- a/examples/Merge.hs +++ b/examples/Merge.hs @@ -110,7 +110,7 @@ -- mapSize (`div` 2) $ \(xss :: [OrderedList Int]) -> return [] -main = $quickCheckAll +main = do True <- $quickCheckAll; return () -------------------------------------------------------------------------- -- the end. diff --git a/examples/Set.hs b/examples/Set.hs --- a/examples/Set.hs +++ b/examples/Set.hs @@ -21,8 +21,6 @@ import Data.Maybe ---import Text.Show.Functions - -------------------------------------------------------------------------- -- binary search trees @@ -142,8 +140,6 @@ shrink t@(Node x s1 s2) = [ s1, s2 ] ++ [ t' | x' <- shrink x, let t' = Node x' s1 s2, invariant t' ] --- instance (Ord a, ShrinkSub a) => ShrinkSub (Set a) - -------------------------------------------------------------------------- -- properties @@ -197,8 +193,6 @@ where xs = toSortedList s --- whenFail (putStrLn ("Result: " ++ show (fromList xs))) $ - prop_FromList' (xs :: [Int]) = shrinking shrink xs $ \xs' -> fromList xs ==? xs @@ -207,7 +201,7 @@ -- main return [] -main = $quickCheckAll +main = do True <- $quickCheckAll; return () -------------------------------------------------------------------------- -- the end. diff --git a/examples/Simple.hs b/examples/Simple.hs --- a/examples/Simple.hs +++ b/examples/Simple.hs @@ -40,7 +40,7 @@ prop_disj = counterexample "reverse" $(monomorphic 'prop_Reverse) .||. counterexample "Simon Thompson" $(monomorphic 'prop_SimonThompson) return [] -main = $quickCheckAll +main = do True <- $quickCheckAll; return () -------------------------------------------------------------------------- -- the end. diff --git a/make-hugs b/make-hugs --- a/make-hugs +++ b/make-hugs @@ -18,7 +18,8 @@ -DNO_CTYPES_CONSTRUCTORS -DNO_FOREIGN_C_USECONDS -DNO_GENERICS \ -DNO_SAFE_HASKELL -DNO_POLYKINDS -DNO_MONADFAIL -DNO_TIMEOUT \ -DNO_NEWTYPE_DERIVING -DNO_TYPEABLE -DNO_GADTS -DNO_TRANSFORMERS \ - -DNO_DEEPSEQ -DNO_EXTRA_METHODS_IN_APPLICATIVE \ + -DNO_DEEPSEQ -DNO_EXTRA_METHODS_IN_APPLICATIVE -DNO_CALLSTACK \ + -DNO_SEMIGROUP -DNO_EXISTENTIAL_FIELD_SELECTORS \ "$src" > "$tgt" done diff --git a/src/Test/QuickCheck.hs b/src/Test/QuickCheck.hs --- a/src/Test/QuickCheck.hs +++ b/src/Test/QuickCheck.hs @@ -19,15 +19,48 @@ >>> quickCheck prop_reverse +++ OK, passed 100 tests. -To run more tests you can use the 'withMaxSuccess' combinator: +To run more tests you can use the 'withNumTests' combinator: ->>> quickCheck (withMaxSuccess 10000 prop_reverse) +>>> quickCheck (withNumTests 10000 prop_reverse) +++ OK, passed 10000 tests. To use QuickCheck on your own data types you will need to write 'Arbitrary' instances for those types. See the for details about how to do that. + +When testing fails @quickCheck@ will try to give you a minimal counterexample to +your property: +@ +import Test.QuickCheck + +prop_reverse_bad :: [Int] -> Bool +prop_reverse_bad xs = reverse xs == xs + +>>> quickCheck prop_reverse_bad +*** Failed! Falsified (after 3 tests and 3 shrinks): +[0,1] +@ + +However, beware because not all properties that ought to fail will fail when you expect +them to: + +@ +>>> quickCheck $ \ x y -> x == y ++++ Ok, passed 100 tests. +@ + +That's because GHCi will default any type variables in your property to @()@, so in the example +above @quickCheck@ was really testing that @()@ is equal to itself. To avoid this behaviour it +is best practise to monomorphise your polymorphic properties when testing: + +@ +>>> quickCheck $ \ x y -> (x :: Int) == y +*** Failed! Falsified (after 4 tests and 3 shrinks): +0 +1 +@ + -} {-# LANGUAGE CPP #-} #ifndef NO_SAFE_HASKELL @@ -40,11 +73,12 @@ ( -- * Running tests quickCheck - , Args(..), Result(..) + , Args(..), Result(..), TestProgress(..) , stdArgs , quickCheckWith , quickCheckWithResult , quickCheckResult + , recheck , isSuccess -- ** Running tests verbosely , verboseCheck @@ -98,6 +132,11 @@ , choose , chooseInt , chooseInteger +#ifndef NO_SPLITMIX + , chooseWord64 + , chooseInt64 + , chooseUpTo +#endif , chooseBoundedIntegral , chooseEnum , chooseAny @@ -202,24 +241,24 @@ -- -- @ -- -- Functions cannot be shown (but see 'Function') - -- prop_TakeDropWhile ('Blind' p) (xs :: ['A']) = + -- prop_TakeDropWhile ('Blind' p) (xs :: ['Test.QuickCheck.Poly.A']) = -- takeWhile p xs ++ dropWhile p xs == xs -- @ -- -- @ - -- prop_TakeDrop ('NonNegative' n) (xs :: ['A']) = + -- prop_TakeDrop ('NonNegative' n) (xs :: ['Test.QuickCheck.Poly.A']) = -- take n xs ++ drop n xs == xs -- @ -- -- @ -- -- cycle does not work for empty lists - -- prop_Cycle ('NonNegative' n) ('NonEmpty' (xs :: ['A'])) = + -- prop_Cycle ('NonNegative' n) ('NonEmpty' (xs :: ['Test.QuickCheck.Poly.A'])) = -- take n (cycle xs) == take n (xs ++ cycle xs) -- @ -- -- @ -- -- Instead of 'forAll' 'orderedList' - -- prop_Sort ('Ordered' (xs :: ['OrdA'])) = + -- prop_Sort ('Ordered' (xs :: ['Test.QuickCheck.Poly.OrdA'])) = -- sort xs == xs -- @ , Blind(..) @@ -268,9 +307,13 @@ , verbose , verboseShrinking , noShrinking + , withNumTests , withMaxSuccess , within , discardAfter + , withDiscardRatio + , withMaxSize + , withMaxShrinks , once , again , mapSize @@ -278,11 +321,20 @@ , (.&.) , (.&&.) , conjoin + , Every (..) , (.||.) , disjoin + , Some (..) -- ** What to do on failure +#ifndef NO_TYPEABLE + , Witness(..) + , witness + , coerceWitness + , castWitness +#endif , counterexample , printTestCase + , withProgress , whenFail , whenFail' , expectFailure @@ -312,6 +364,7 @@ import Test.QuickCheck.Gen import Test.QuickCheck.Arbitrary import Test.QuickCheck.Modifiers +import Test.QuickCheck.Monoids import Test.QuickCheck.Property hiding ( Result(..) ) import Test.QuickCheck.Test import Test.QuickCheck.Exception diff --git a/src/Test/QuickCheck/All.hs b/src/Test/QuickCheck/All.hs --- a/src/Test/QuickCheck/All.hs +++ b/src/Test/QuickCheck/All.hs @@ -20,6 +20,7 @@ verboseCheckAll, forAllProperties, allProperties, + runQuickCheckAll, -- ** Testing polymorphic properties polyQuickCheck, polyVerboseCheck, diff --git a/src/Test/QuickCheck/Arbitrary.hs b/src/Test/QuickCheck/Arbitrary.hs --- a/src/Test/QuickCheck/Arbitrary.hs +++ b/src/Test/QuickCheck/Arbitrary.hs @@ -89,18 +89,20 @@ import Control.Applicative import Data.Foldable(toList) +#if MIN_VERSION_random(1,3,0) +import System.Random(Random, uniformByteArray) +#else import System.Random(Random) +#endif import Test.QuickCheck.Gen import Test.QuickCheck.Random import Test.QuickCheck.Gen.Unsafe - -{- -import Data.Generics - ( (:*:)(..) - , (:+:)(..) - , Unit(..) - ) --} +#if defined(__MHS__) +-- These two are not exported by Control.Applicative. +-- Why should they be? They are just bloat. +import Data.ZipList +import Control.WrappedMonad +#endif import Data.Char ( ord @@ -136,16 +138,25 @@ , nub ) + import Data.Version (Version (..)) #if defined(MIN_VERSION_base) -#if MIN_VERSION_base(4,2,0) +import Numeric.Natural + +import Data.List.NonEmpty (NonEmpty) +import qualified Data.List.NonEmpty as NonEmpty + import System.IO ( Newline(..) , NewlineMode(..) + , SeekMode(..) + , BufferMode(..) + , TextEncoding + , latin1, utf8, utf8_bom, utf16, utf16le, utf16be, utf32, utf32le, utf32be, localeEncoding, char8 + , IOMode(..) ) #endif -#endif import Control.Monad ( liftM @@ -165,14 +176,21 @@ #endif import qualified Data.Set as Set -import qualified Data.Map as Map import qualified Data.IntSet as IntSet +#if MIN_VERSION_containers(0,5,0) +import qualified Data.Map.Strict as Map +import qualified Data.IntMap.Strict as IntMap +#else +import qualified Data.Map as Map import qualified Data.IntMap as IntMap +#endif import qualified Data.Sequence as Sequence import qualified Data.Tree as Tree -import Data.Bits import qualified Data.Monoid as Monoid +#if defined(MIN_VERSION_base) +import qualified Data.Semigroup as Semigroup +#endif #ifndef NO_TRANSFORMERS import Data.Functor.Identity @@ -181,6 +199,28 @@ import Data.Functor.Product #endif +#if defined(MIN_VERSION_base) +import qualified Data.Semigroup as Semigroup +import Data.Ord + +import System.Console.GetOpt + ( ArgDescr(..), ArgOrder(..), OptDescr(..) ) + +import Data.Functor.Contravariant + +import Data.Array.Byte +import qualified GHC.Exts as Exts + +#if MIN_VERSION_base(4,16,0) +import Data.Tuple +#endif +#endif + +import Data.Bits +import Text.Printf + +import Test.QuickCheck.Compat + -------------------------------------------------------------------------- -- ** class Arbitrary @@ -197,7 +237,8 @@ -- It is worth spending time thinking about what sort of test data -- you want - good generators are often the difference between -- finding bugs and not finding them. You can use 'sample', - -- 'label' and 'classify' to check the quality of your test data. + -- 'Test.QuickCheck.label' and 'Test.QuickCheck.classify' to check the quality + -- of your test data. -- -- There is no generic @arbitrary@ implementation included because we don't -- know how to make a high-quality one. If you want one, consider using the @@ -238,8 +279,8 @@ -- > shrink (Branch x l r) = -- > -- shrink Branch to Nil -- > [Nil] ++ - -- > -- shrink to subterms - -- > [l, r] ++ + -- > -- shrink to non-Nil subterms + -- > [t | t@Branch{} <- [l, r]] ++ -- > -- recursively shrink subterms -- > [Branch x' l' r' | (x', l', r') <- shrink (x, l, r)] -- @@ -409,7 +450,7 @@ instance OVERLAPPING_ GSubtermsIncl (K1 i a) a where gSubtermsIncl (K1 x) = [x] -instance OVERLAPPING_ GSubtermsIncl (K1 i a) b where +instance GSubtermsIncl (K1 i a) b where gSubtermsIncl (K1 _) = [] #endif @@ -487,19 +528,30 @@ xs1 = take k xs xs2 = drop k xs -{- - -- "standard" definition for lists: - shrink [] = [] - shrink (x:xs) = [ xs ] - ++ [ x:xs' | xs' <- shrink xs ] - ++ [ x':xs | x' <- shrink x ] --} +#if defined(MIN_VERSION_base) +instance Arbitrary1 NonEmpty where + liftArbitrary arb = NonEmpty.fromList <$> listOf1 arb + liftShrink shr xs = [ NonEmpty.fromList xs' | xs' <- liftShrink shr (NonEmpty.toList xs), not (null xs') ] +instance Arbitrary a => Arbitrary (NonEmpty a) where + arbitrary = arbitrary1 + shrink = shrink1 +#endif + instance Integral a => Arbitrary (Ratio a) where - arbitrary = arbitrarySizedFractional - shrink = shrinkRealFrac + arbitrary = sized $ \ n -> do + denom <- chooseInt (1, max 1 n) + let lb | isNonNegativeType fromI = 0 + | otherwise = (-n*denom) + -- NOTE: this is a trick to make sure we get around lack of scoped type + -- variables by pinning the result-type of fromIntegral. + fromI = fromIntegral + numer <- chooseInt (lb, n*denom) + pure $ fromI numer % fromI denom + shrink = shrinkRealFrac -#if defined(MIN_VERSION_base) && MIN_VERSION_base(4,4,0) + +#if defined(MIN_VERSION_base) instance Arbitrary a => Arbitrary (Complex a) where #else instance (RealFloat a, Arbitrary a) => Arbitrary (Complex a) where @@ -631,6 +683,12 @@ arbitrary = arbitrarySizedIntegral shrink = shrinkIntegral +#if defined(MIN_VERSION_base) +instance Arbitrary Natural where + arbitrary = arbitrarySizedNatural + shrink = shrinkIntegral +#endif + instance Arbitrary Int where arbitrary = arbitrarySizedIntegral shrink = shrinkIntegral @@ -708,7 +766,7 @@ ] where smallDenominators = sized $ \n -> do - i <- chooseInt (0, n) + i <- chooseInt (0, min n 256) pure (fromRational (streamNth i rationalUniverse)) uniform = sized $ \n -> do @@ -734,7 +792,7 @@ ] where smallDenominators = sized $ \n -> do - i <- chooseInt (0, n) + i <- chooseInt (0, min n 256) pure (fromRational (streamNth i rationalUniverse)) uniform = sized $ \n -> do @@ -852,27 +910,36 @@ shrink = shrinkDecimal -- Arbitrary instances for container types +-- | WARNING: Users working on the internals of the @Set@ type via e.g. @Data.Set.Internal@ +-- should be aware that this instance aims to give a good representation of @Set a@ +-- as mathematical sets but *does not* aim to provide a varied distribution over the +-- underlying representation. instance (Ord a, Arbitrary a) => Arbitrary (Set.Set a) where arbitrary = fmap Set.fromList arbitrary shrink = map Set.fromList . shrink . Set.toList instance (Ord k, Arbitrary k) => Arbitrary1 (Map.Map k) where liftArbitrary = fmap Map.fromList . liftArbitrary . liftArbitrary liftShrink shr = map Map.fromList . liftShrink (liftShrink shr) . Map.toList +-- | WARNING: The same warning as for @Arbitrary (Set a)@ applies here. instance (Ord k, Arbitrary k, Arbitrary v) => Arbitrary (Map.Map k v) where arbitrary = arbitrary1 shrink = shrink1 +-- | WARNING: The same warning as for @Arbitrary (Set a)@ applies here. instance Arbitrary IntSet.IntSet where arbitrary = fmap IntSet.fromList arbitrary shrink = map IntSet.fromList . shrink . IntSet.toList +-- | WARNING: The same warning as for @Arbitrary (Set a)@ applies here. instance Arbitrary1 IntMap.IntMap where liftArbitrary = fmap IntMap.fromList . liftArbitrary . liftArbitrary liftShrink shr = map IntMap.fromList . liftShrink (liftShrink shr) . IntMap.toList +-- | WARNING: The same warning as for @Arbitrary (Set a)@ applies here. instance Arbitrary a => Arbitrary (IntMap.IntMap a) where arbitrary = arbitrary1 shrink = shrink1 instance Arbitrary1 Sequence.Seq where liftArbitrary = fmap Sequence.fromList . liftArbitrary liftShrink shr = map Sequence.fromList . liftShrink shr . toList +-- | WARNING: The same warning as for @Arbitrary (Set a)@ applies here. instance Arbitrary a => Arbitrary (Sequence.Seq a) where arbitrary = arbitrary1 shrink = shrink1 @@ -997,7 +1064,6 @@ shrink = map Monoid.Product . shrink . Monoid.getProduct #if defined(MIN_VERSION_base) -#if MIN_VERSION_base(3,0,0) instance Arbitrary a => Arbitrary (Monoid.First a) where arbitrary = fmap Monoid.First arbitrary shrink = map Monoid.First . shrink . Monoid.getFirst @@ -1005,15 +1071,172 @@ instance Arbitrary a => Arbitrary (Monoid.Last a) where arbitrary = fmap Monoid.Last arbitrary shrink = map Monoid.Last . shrink . Monoid.getLast -#endif -#if MIN_VERSION_base(4,8,0) instance Arbitrary (f a) => Arbitrary (Monoid.Alt f a) where arbitrary = fmap Monoid.Alt arbitrary shrink = map Monoid.Alt . shrink . Monoid.getAlt + +instance Arbitrary a => Arbitrary (Semigroup.Min a) where + arbitrary = fmap Semigroup.Min arbitrary + shrink = map Semigroup.Min . shrink . Semigroup.getMin + +instance Arbitrary a => Arbitrary (Semigroup.Max a) where + arbitrary = fmap Semigroup.Max arbitrary + shrink = map Semigroup.Max . shrink . Semigroup.getMax + +instance Arbitrary a => Arbitrary (Semigroup.First a) where + arbitrary = fmap Semigroup.First arbitrary + shrink = map Semigroup.First . shrink . Semigroup.getFirst + +instance Arbitrary a => Arbitrary (Semigroup.Last a) where + arbitrary = fmap Semigroup.Last arbitrary + shrink = map Semigroup.Last . shrink . Semigroup.getLast + +instance (Arbitrary a, Arbitrary b) => Arbitrary (Semigroup.Arg a b) where + arbitrary = Semigroup.Arg <$> arbitrary <*> arbitrary + shrink (Semigroup.Arg a b) = uncurry Semigroup.Arg <$> shrink (a, b) + +instance Arbitrary a => Arbitrary (Semigroup.WrappedMonoid a) where + arbitrary = Semigroup.WrapMonoid <$> arbitrary + shrink = map Semigroup.WrapMonoid . shrink . Semigroup.unwrapMonoid + +#if !MIN_VERSION_base(4,15,0) +instance Arbitrary a => Arbitrary (Semigroup.Option a) where + arbitrary = Semigroup.Option <$> arbitrary + shrink = map Semigroup.Option . shrink . Semigroup.getOption + +instance CoArbitrary a => CoArbitrary (Semigroup.Option a) where + coarbitrary = coarbitrary . Semigroup.getOption #endif + +#if MIN_VERSION_base(4,16,0) +instance Arbitrary a => Arbitrary (Iff a) where + arbitrary = Iff <$> arbitrary + shrink = map Iff . shrink . getIff + +instance Arbitrary a => Arbitrary (Ior a) where + arbitrary = Ior <$> arbitrary + shrink = map Ior . shrink . getIor + +instance Arbitrary a => Arbitrary (Xor a) where + arbitrary = Xor <$> arbitrary + shrink = map Xor . shrink . getXor + +instance Arbitrary a => Arbitrary (And a) where + arbitrary = And <$> arbitrary + shrink = map And . shrink . getAnd + +instance CoArbitrary a => CoArbitrary (And a) where + coarbitrary = coarbitrary . getAnd + +instance CoArbitrary a => CoArbitrary (Iff a) where + coarbitrary = coarbitrary . getIff + +instance CoArbitrary a => CoArbitrary (Ior a) where + coarbitrary = coarbitrary . getIor + +instance CoArbitrary a => CoArbitrary (Xor a) where + coarbitrary = coarbitrary . getXor #endif +#if !defined(__MHS__) +instance Arbitrary ByteArray where +#if MIN_VERSION_random(1,3,0) + arbitrary = do + pin <- arbitrary + len <- abs <$> arbitrary + MkGen $ \ qcGen _ -> fst $ uniformByteArray pin len qcGen +#else + arbitrary = Exts.fromList <$> arbitrary +#endif + shrink = map Exts.fromList . shrink . Exts.toList + +instance CoArbitrary ByteArray where + coarbitrary = coarbitrary . Exts.toList + +-- MicroHs does not have Exts.fromList +#endif /* !defined(__MHS__) */ + +#if MIN_VERSION_base(4,16,0) + +instance Arbitrary a => Arbitrary (Solo a) where + arbitrary = mkSolo <$> arbitrary + shrink = map mkSolo . shrink . getSolo + +instance CoArbitrary a => CoArbitrary (Solo a) where + coarbitrary = coarbitrary . getSolo + +#endif + +instance Arbitrary a => Arbitrary (Down a) where + arbitrary = fmap Down arbitrary + shrink = map Down . shrink . getDown + +instance CoArbitrary a => CoArbitrary (Down a) where + coarbitrary = coarbitrary . getDown + +#endif + +#ifdef __GLASGOW_HASKELL__ + +instance Arbitrary a => Arbitrary (ArgDescr a) where + arbitrary = oneof [ NoArg <$> arbitrary + , ReqArg <$> arbitrary <*> arbitrary + , OptArg <$> arbitrary <*> arbitrary + ] + + shrink (NoArg i) = [ NoArg i' | i' <- shrink i ] + shrink (ReqArg a1 a2) = [ ReqArg a1' a2 | a1' <- shrink a1 ] ++ + [ ReqArg a1 a2' | a2' <- shrink a2 ] + shrink (OptArg a1 a2) = [ OptArg a1' a2 | a1' <- shrink a1 ] ++ + [ OptArg a1 a2' | a2' <- shrink a2 ] + +instance Arbitrary a => Arbitrary (ArgOrder a) where + arbitrary = oneof [ return RequireOrder + , return Permute + , ReturnInOrder <$> arbitrary + ] + + shrink RequireOrder = [] + shrink Permute = [] + shrink (ReturnInOrder a) = [ ReturnInOrder a' | a' <- shrink a ] + +instance Arbitrary a => Arbitrary (OptDescr a) where + arbitrary = Option + <$> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + + shrink (Option a b c d) = [ Option a' b c d | a' <- shrink a ] ++ + [ Option a b' c d | b' <- shrink b ] ++ + [ Option a b c' d | c' <- shrink c ] ++ + [ Option a b c d' | d' <- shrink d ] + +-- Data.Functor.Contravariant + +-- can maybe use Arbitrary1/2 for these +instance CoArbitrary a => Arbitrary (Predicate a) where + arbitrary = Predicate <$> arbitrary + + shrink (Predicate p) = [ Predicate p' | p' <- shrink p ] + +instance (Arbitrary a, CoArbitrary b) => Arbitrary (Op a b) where + arbitrary = Op <$> arbitrary + + shrink (Op f) = [ Op f' | f' <- shrink f ] + +instance CoArbitrary a => Arbitrary (Equivalence a) where + arbitrary = do + Comparison cmp <- arbitrary + return $ Equivalence (\x y -> cmp x y == EQ) + +instance CoArbitrary a => Arbitrary (Comparison a) where + arbitrary = do + Comparison . comparing <$> (liftArbitrary arbitrary :: Gen (a -> Integer)) + +#endif + -- | Generates 'Version' with non-empty non-negative @versionBranch@, and empty @versionTags@ instance Arbitrary Version where arbitrary = sized $ \n -> @@ -1042,7 +1265,6 @@ shrink _ = [] #if defined(MIN_VERSION_base) -#if MIN_VERSION_base(4,2,0) instance Arbitrary Newline where arbitrary = elements [LF, CRLF] @@ -1058,7 +1280,56 @@ arbitrary = NewlineMode <$> arbitrary <*> arbitrary shrink (NewlineMode inNL outNL) = [NewlineMode inNL' outNL' | (inNL', outNL') <- shrink (inNL, outNL)] -#endif + +instance Arbitrary GeneralCategory where + arbitrary = arbitraryBoundedEnum + shrink = shrinkBoundedEnum + +instance Arbitrary SeekMode where + arbitrary = elements [ AbsoluteSeek, RelativeSeek, SeekFromEnd ] + shrink x = takeWhile (x /=) [ AbsoluteSeek, RelativeSeek, SeekFromEnd ] + +instance Arbitrary TextEncoding where + arbitrary = elements [ latin1, utf8, utf8_bom, utf16, utf16le, utf16be, utf32, utf32le, utf32be, localeEncoding, char8 ] + +instance Arbitrary BufferMode where + arbitrary = oneof [ pure NoBuffering + , pure LineBuffering + , pure $ BlockBuffering Nothing + , BlockBuffering . Just . (+1) . fromIntegral <$> (arbitrary :: Gen Natural) + ] + shrink NoBuffering = [] + shrink LineBuffering = [ NoBuffering ] + shrink (BlockBuffering m) = [ NoBuffering, LineBuffering ] ++ map BlockBuffering (filter (maybe True (>0)) $ shrink m) + +instance Arbitrary IOMode where + arbitrary = elements [ReadMode, WriteMode, AppendMode, ReadWriteMode] + shrink x = takeWhile (/=x) [ReadMode, WriteMode, AppendMode, ReadWriteMode] + +instance Arbitrary FormatSign where + arbitrary = elements [SignPlus, SignSpace] + shrink SignPlus = [] + shrink SignSpace = [SignPlus] + +instance Arbitrary FormatAdjustment where + arbitrary = elements [LeftAdjust, ZeroPad] + shrink LeftAdjust = [] + shrink ZeroPad = [LeftAdjust] + +instance Arbitrary FormatParse where + arbitrary = FormatParse <$> arbitrary <*> arbitrary <*> arbitrary + shrink (FormatParse a b c) = [ FormatParse a' b' c' | (a', b', c') <- shrink (a, b, c) ] + +instance Arbitrary FieldFormat where + arbitrary = FieldFormat <$> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + shrink (FieldFormat a b c d e f g) = [ FieldFormat a' b' c' d' e' f' g' | (a', b', c', d', e', f', g') <- shrink (a, b, c, d, e, f, g) ] + #endif -- ** Helper functions for implementing arbitrary @@ -1082,10 +1353,20 @@ -- | Generates an integral number. The number can be positive or negative -- and its maximum absolute value depends on the size parameter. arbitrarySizedIntegral :: Integral a => Gen a -arbitrarySizedIntegral = - sized $ \n -> - inBounds fromIntegral (chooseInt (-n, n)) +arbitrarySizedIntegral + | isNonNegativeType fromI = arbitrarySizedNatural + | otherwise = sized $ \n -> inBounds fromI (chooseInt (-n, n)) + where + -- NOTE: this is a trick to make sure we get around lack of scoped type + -- variables by pinning the result-type of fromIntegral. + fromI = fromIntegral +isNonNegativeType :: Enum a => (Int -> a) -> Bool +isNonNegativeType fromI = + case enumFromThen (fromI 1) (fromI 0) of + [_, _] -> True + _ -> False + -- | Generates a natural number. The number's maximum value depends on -- the size parameter. arbitrarySizedNatural :: Integral a => Gen a @@ -1201,20 +1482,8 @@ -- | Shrink an integral number. shrinkIntegral :: Integral a => a -> [a] shrinkIntegral x = - nub $ - [ -x - | x < 0, -x > x - ] ++ - [ x' - | x' <- takeWhile (<< x) (0:[ x - i | i <- tail (iterate (`quot` 2) x) ]) - ] - where - -- a << b is "morally" abs a < abs b, but taking care of overflow. - a << b = case (a >= 0, b >= 0) of - (True, True) -> a < b - (False, False) -> a > b - (True, False) -> a + b < 0 - (False, True) -> a + b > 0 + [ -x | x < 0, -x > x ] ++ + [ x - i | i <- takeWhile (/= 0) (iterate (`quot` 2) x)] -- | Shrink an element of a bounded enumeration. -- @@ -1400,7 +1669,7 @@ coarbitrary = coarbitraryReal #endif -#if defined(MIN_VERSION_base) && MIN_VERSION_base(4,4,0) +#if defined(MIN_VERSION_base) instance CoArbitrary a => CoArbitrary (Complex a) where #else instance (RealFloat a, CoArbitrary a) => CoArbitrary (Complex a) where @@ -1481,6 +1750,11 @@ instance CoArbitrary Double where coarbitrary = coarbitraryReal +#if defined(MIN_VERSION_base) +instance CoArbitrary Natural where + coarbitrary = coarbitraryIntegral +#endif + -- Coarbitrary instances for container types instance CoArbitrary a => CoArbitrary (Set.Set a) where coarbitrary = coarbitrary. Set.toList @@ -1499,6 +1773,12 @@ instance CoArbitrary a => CoArbitrary (ZipList a) where coarbitrary = coarbitrary . getZipList +-- CoArbitrary instance for NonEmpty +#if defined(MIN_VERSION_base) +instance CoArbitrary a => CoArbitrary (NonEmpty a) where + coarbitrary (a NonEmpty.:| as) = coarbitrary (a, as) +#endif + #ifndef NO_TRANSFORMERS -- CoArbitrary instance for transformers' Functors instance CoArbitrary a => CoArbitrary (Identity a) where @@ -1532,34 +1812,99 @@ coarbitrary = coarbitrary . Monoid.getProduct #if defined(MIN_VERSION_base) -#if MIN_VERSION_base(3,0,0) instance CoArbitrary a => CoArbitrary (Monoid.First a) where coarbitrary = coarbitrary . Monoid.getFirst instance CoArbitrary a => CoArbitrary (Monoid.Last a) where coarbitrary = coarbitrary . Monoid.getLast -#endif -#if MIN_VERSION_base(4,8,0) instance CoArbitrary (f a) => CoArbitrary (Monoid.Alt f a) where coarbitrary = coarbitrary . Monoid.getAlt -#endif -#endif -instance CoArbitrary Version where - coarbitrary (Version a b) = coarbitrary (a, b) +instance CoArbitrary a => CoArbitrary (Semigroup.Max a) where + coarbitrary = coarbitrary . Semigroup.getMax -#if defined(MIN_VERSION_base) -#if MIN_VERSION_base(4,2,0) +instance CoArbitrary a => CoArbitrary (Semigroup.Min a) where + coarbitrary = coarbitrary . Semigroup.getMin + +instance CoArbitrary a => CoArbitrary (Semigroup.First a) where + coarbitrary = coarbitrary . Semigroup.getFirst + +instance CoArbitrary a => CoArbitrary (Semigroup.Last a) where + coarbitrary = coarbitrary . Semigroup.getLast + instance CoArbitrary Newline where coarbitrary LF = variant 0 coarbitrary CRLF = variant 1 instance CoArbitrary NewlineMode where coarbitrary (NewlineMode inNL outNL) = coarbitrary inNL . coarbitrary outNL + +instance (CoArbitrary a, CoArbitrary b) => CoArbitrary (Semigroup.Arg a b) where + coarbitrary (Semigroup.Arg a b) = coarbitrary (a, b) + +instance CoArbitrary GeneralCategory where + coarbitrary = coarbitrary . fromEnum + +instance CoArbitrary SeekMode where + coarbitrary = coarbitrary . fromEnum + +instance CoArbitrary IOMode where +#if !defined(__MHS__) + coarbitrary = coarbitrary . fromEnum +#else + coarbitrary ReadMode = variant 0 + coarbitrary WriteMode = variant 1 + coarbitrary AppendMode = variant 2 + coarbitrary ReadWriteMode = variant 3 #endif + +instance CoArbitrary FieldFormat where + coarbitrary ff = coarbitrary (fmtWidth ff) + . coarbitrary (fmtPrecision ff) + . coarbitrary (fmtAdjust ff) + . coarbitrary (fmtSign ff) + . coarbitrary (fmtAlternate ff) + . coarbitrary (fmtModifiers ff) + . coarbitrary (fmtChar ff) + +instance CoArbitrary FormatParse where + coarbitrary fp = coarbitrary (fpModifiers fp) + . coarbitrary (fpChar fp) + . coarbitrary (fpRest fp) + +instance CoArbitrary FormatAdjustment where + coarbitrary LeftAdjust = coarbitrary True + coarbitrary ZeroPad = coarbitrary False + +instance CoArbitrary FormatSign where + coarbitrary SignPlus = coarbitrary True + coarbitrary SignSpace = coarbitrary False + +instance CoArbitrary BufferMode where + coarbitrary = coarbitrary . embed + where embed NoBuffering = Left True + embed LineBuffering = Left False + embed (BlockBuffering m) = Right m + +instance CoArbitrary ExitCode where + coarbitrary = coarbitrary . embed + where embed ExitSuccess = Nothing + embed (ExitFailure i) = Just i + +#if !defined(__MHS__) +instance CoArbitrary TextEncoding where + coarbitrary = coarbitrary . show -- No other way as far as I can tell :( #endif +instance CoArbitrary a => CoArbitrary (Semigroup.WrappedMonoid a) where + coarbitrary = coarbitrary . Semigroup.unwrapMonoid + +#endif + +instance CoArbitrary Version where + coarbitrary (Version a b) = coarbitrary (a, b) + -- ** Helpers for implementing coarbitrary -- | A 'coarbitrary' implementation for integral numbers. @@ -1606,8 +1951,9 @@ streamNth n (x :< xs) | n <= 0 = x | otherwise = streamNth (n - 1) xs --- We read into this stream only with ~size argument, --- so it's ok to have it as CAF. +-- We read into this stream only with ~size argument, capped to 256, +-- so it's ok to have it as CAF. (256 chosen somewhat arbitrarily, the +-- point is just to stop this blowing up.) -- rationalUniverse :: Stream Rational rationalUniverse = 0 :< 1 :< (-1) :< go leftSideStream diff --git a/src/Test/QuickCheck/Compat.hs b/src/Test/QuickCheck/Compat.hs new file mode 100644 --- /dev/null +++ b/src/Test/QuickCheck/Compat.hs @@ -0,0 +1,34 @@ +-- This module provides tools to simplify compat code across different compiler and library versions +{-# LANGUAGE CPP #-} +module Test.QuickCheck.Compat where + +#if MIN_VERSION_base(4,16,0) +import Data.Tuple +#endif + +#if MIN_VERSION_base(4,16,0) + +#if !MIN_VERSION_base(4,18,0) + +getSolo :: Solo a -> a +getSolo (Solo a) = a + +mkSolo :: a -> Solo a +mkSolo = Solo + +#elif !MIN_VERSION_base(4,19,0) + +getSolo :: Solo a -> a +getSolo (MkSolo a) = a + +mkSolo :: a -> Solo a +mkSolo = MkSolo + +#else + +mkSolo :: a -> Solo a +mkSolo = MkSolo + +#endif + +#endif diff --git a/src/Test/QuickCheck/Exception.hs b/src/Test/QuickCheck/Exception.hs --- a/src/Test/QuickCheck/Exception.hs +++ b/src/Test/QuickCheck/Exception.hs @@ -10,7 +10,7 @@ #endif module Test.QuickCheck.Exception where -#if !defined(__GLASGOW_HASKELL__) || (__GLASGOW_HASKELL__ < 700) +#if (!defined(__GLASGOW_HASKELL__) || (__GLASGOW_HASKELL__ < 700)) && !defined(__MHS__) #define OLD_EXCEPTIONS #endif @@ -63,7 +63,7 @@ tryEvaluateIO m = E.tryJust notAsync (m >>= E.evaluate) where notAsync :: AnException -> Maybe AnException -#if MIN_VERSION_base(4,7,0) +#if defined(MIN_VERSION_base) notAsync e = case E.fromException e of Just (E.SomeAsyncException _) -> Nothing Nothing -> Just e @@ -74,8 +74,6 @@ #else notAsync e = Just e #endif - ---tryEvaluateIO m = Right `fmap` m evaluate :: a -> IO a evaluate = E.evaluate diff --git a/src/Test/QuickCheck/Features.hs b/src/Test/QuickCheck/Features.hs --- a/src/Test/QuickCheck/Features.hs +++ b/src/Test/QuickCheck/Features.hs @@ -11,6 +11,7 @@ import Test.QuickCheck.Gen import Test.QuickCheck.State import Test.QuickCheck.Text +import Test.QuickCheck.Random import qualified Data.Set as Set import Data.Set(Set) import Data.List (intersperse) @@ -28,7 +29,7 @@ f res = case ok res of Just True - | not (features (P.labels res) (Set.fromList (P.classes res)) `Set.isSubsetOf` feats) -> + | not (features (P.labels res) (Set.fromList (map fst $ filter snd $ P.classes res)) `Set.isSubsetOf` feats) -> res{ok = Just False, P.reason = "New feature found"} _ -> res @@ -49,7 +50,7 @@ -- > where count x xs = length (filter (== x) xs) -- -- 'labelledExamples' generates three example test cases, one for each label: --- +-- -- >>> labelledExamples prop_delete -- *** Found example of count x xs == 0 -- 0 @@ -85,26 +86,23 @@ -- | A variant of 'labelledExamples' that takes test arguments and returns a result. labelledExamplesWithResult :: Testable prop => Args -> prop -> IO Result -labelledExamplesWithResult args prop = - withState args $ \state -> do - let - loop :: Set String -> State -> IO Result - loop feats state = withNullTerminal $ \nullterm -> do - res <- test state{terminal = nullterm} (property (prop_noNewFeatures feats prop)) - let feats' = features (failingLabels res) (failingClasses res) - case res of - Failure{reason = "New feature found"} -> do - putLine (terminal state) $ - "*** Found example of " ++ - concat (intersperse ", " (Set.toList (feats' Set.\\ feats))) - mapM_ (putLine (terminal state)) (failingTestCase res) - putStrLn "" - loop (Set.union feats feats') - state{randomSeed = usedSeed res, computeSize = computeSize state `at0` usedSize res} - _ -> do - out <- terminalOutput nullterm - putStr out - return res - at0 f s 0 0 = s - at0 f s n d = f n d - loop Set.empty state +labelledExamplesWithResult args prop = loop Set.empty $ replay args + where + loop :: Set String -> Maybe (QCGen, Int) -> IO Result + loop feats replay = withNullTerminal $ \nullterm -> do + res <- quickCheckWithResult args{chatty = False, replay = replay} (prop_noNewFeatures feats prop) + let feats' = features (failingLabels res) (failingClasses res) + case res of + Failure{reason = "New feature found"} -> do + putStrLn $ + "*** Found example of " ++ + concat (intersperse ", " (Set.toList (feats' Set.\\ feats))) + mapM_ putStrLn (failingTestCase res) + putStrLn "" + loop (Set.union feats feats') (Just (usedSeed res, usedSize res)) + _ -> do + out <- terminalOutput nullterm + putStr out + return res + at0 f s 0 0 = s + at0 f s n d = f n d diff --git a/src/Test/QuickCheck/Function.hs b/src/Test/QuickCheck/Function.hs --- a/src/Test/QuickCheck/Function.hs +++ b/src/Test/QuickCheck/Function.hs @@ -1,6 +1,6 @@ {-# LANGUAGE TypeOperators, GADTs, CPP, Rank2Types #-} #ifndef NO_SAFE_HASKELL -{-# LANGUAGE Safe #-} +{-# LANGUAGE Trustworthy #-} #endif #if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 708 {-# LANGUAGE PatternSynonyms, ViewPatterns #-} @@ -37,6 +37,7 @@ -- See the @'Function' [a]@ instance for an example of the latter. module Test.QuickCheck.Function ( Fun(..) + , mkFun , applyFun , apply , applyFun2 @@ -83,15 +84,31 @@ import Data.Foldable(toList) import Data.Functor.Identity import qualified Data.Monoid as Monoid +import qualified Data.Semigroup as Semigroup +import qualified Data.List.NonEmpty as NonEmpty +import Numeric.Natural +import qualified Data.Bits as Bits +import Data.Tuple +import Data.Ord +import Data.Functor.Contravariant +import Text.Printf +import System.IO +import System.Exit +import Data.Version +import Data.Array.Byte +import qualified GHC.Exts as Exts +#if defined(__MHS__) +import Data.ZipList +import Control.WrappedMonad +#endif + #if defined(MIN_VERSION_base) -#if MIN_VERSION_base(4,2,0) import System.IO ( Newline(..) , NewlineMode(..) ) #endif -#endif #ifndef NO_FIXED import Data.Fixed @@ -101,6 +118,8 @@ import GHC.Generics hiding (C) #endif +import Test.QuickCheck.Compat + -------------------------------------------------------------------------- -- concrete functions @@ -136,7 +155,14 @@ -- turning a concrete function into an abstract function (with a default result) abstract :: (a :-> c) -> c -> (a -> c) +#if defined(__MHS__) +{- This is a temporary fix for a deficiency in the MicroHs type checker. -} +abstract (Pair p) d xy = + case xy of + (x,y) -> abstract (fmap (\q -> abstract q d y) p) d x +#else abstract (Pair p) d (x,y) = abstract (fmap (\q -> abstract q d y) p) d x +#endif abstract (p :+: q) d exy = either (abstract p d) (abstract q d) exy abstract (Unit c) _ _ = c abstract Nil d _ = d @@ -261,6 +287,12 @@ h (Left _) = [] h (Right (x,xs)) = x:xs +instance Function a => Function (NonEmpty.NonEmpty a) where + function = functionMap (\(a NonEmpty.:| as) -> (a, as)) (\(a, as) -> a NonEmpty.:| as) + +instance Function a => Function (ZipList a) where + function = functionMap getZipList ZipList + instance Function a => Function (Maybe a) where function = functionMap g h where @@ -309,6 +341,9 @@ instance Function Double where function = functionRealFrac +instance Function Natural where + function = functionIntegral + -- instances for assorted types in the base package instance Function Ordering where @@ -382,7 +417,6 @@ function = functionIntegral #if defined(MIN_VERSION_base) -#if MIN_VERSION_base(4,2,0) instance Function Newline where function = functionMap g h where @@ -398,7 +432,6 @@ g (NewlineMode inNL outNL) = (inNL,outNL) h (inNL,outNL) = NewlineMode inNL outNL #endif -#endif -- instances for Data.Monoid newtypes @@ -423,11 +456,113 @@ instance Function a => Function (Monoid.Last a) where function = functionMap Monoid.getLast Monoid.Last -#if MIN_VERSION_base(4,8,0) instance Function (f a) => Function (Monoid.Alt f a) where function = functionMap Monoid.getAlt Monoid.Alt + +instance Function a => Function (Semigroup.Min a) where + function = functionMap Semigroup.getMin Semigroup.Min + +instance Function a => Function (Semigroup.Max a) where + function = functionMap Semigroup.getMax Semigroup.Max + +instance Function a => Function (Semigroup.Last a) where + function = functionMap Semigroup.getLast Semigroup.Last + +instance Function a => Function (Semigroup.First a) where + function = functionMap Semigroup.getFirst Semigroup.First + +instance Function a => Function (Semigroup.WrappedMonoid a) where + function = functionMap Semigroup.unwrapMonoid Semigroup.WrapMonoid + +instance (Function a, Function b) => Function (Semigroup.Arg a b) where + function = functionMap (\(Semigroup.Arg a b) -> (a, b)) (uncurry Semigroup.Arg) + +#if MIN_VERSION_base(4,16,0) +instance Function a => Function (Bits.And a) where + function = functionMap Bits.getAnd Bits.And + +instance Function a => Function (Bits.Ior a) where + function = functionMap Bits.getIor Bits.Ior + +instance Function a => Function (Bits.Xor a) where + function = functionMap Bits.getXor Bits.Xor + +instance Function a => Function (Bits.Iff a) where + function = functionMap Bits.getIff Bits.Iff #endif +instance Function FormatSign where + function = functionMap (\x -> case x of SignPlus -> True; _ -> False) (\b -> if b then SignPlus else SignSpace) + +instance Function FormatAdjustment where + function = functionMap (\x -> case x of LeftAdjust -> True; _ -> False) (\b -> if b then LeftAdjust else ZeroPad) + +instance Function FormatParse where + function = functionMap to from + where to fp = (fpModifiers fp, fpChar fp, fpRest fp) + from (a, b, c) = FormatParse a b c + +instance Function FieldFormat where + function = functionMap to from + where to ff = ( fmtWidth ff + , fmtPrecision ff + , fmtAdjust ff + , fmtSign ff + , fmtAlternate ff + , fmtModifiers ff + , fmtChar ff) + from (a, b, c, d, e, f, g) = FieldFormat a b c d e f g + +instance Function GeneralCategory where + function = functionBoundedEnum + +instance Function SeekMode where + function = functionElements [AbsoluteSeek, RelativeSeek, SeekFromEnd] + +instance Function IOMode where + function = functionElements [ReadMode, WriteMode, AppendMode, ReadWriteMode] + +instance Function BufferMode where + function = functionMap to from + where to NoBuffering = Left True + to LineBuffering = Left False + to (BlockBuffering m) = Right m + + from (Left True) = NoBuffering + from (Left False) = LineBuffering + from (Right m) = BlockBuffering m + +instance Function ExitCode where + function = functionMap to from + where to ExitSuccess = Nothing + to (ExitFailure c) = Just c + + from Nothing = ExitSuccess + from (Just c) = ExitFailure c + +instance Function Version where + function = functionMap to from + where to (Version a b) = (a, b) + from (a, b) = Version a b + +#if !defined(__MHS__) +instance Function ByteArray where + function = functionMap Exts.toList Exts.fromList +#endif + +#if MIN_VERSION_base(4,16,0) +instance Function a => Function (Solo a) where + function = functionMap getSolo mkSolo +#endif + +instance Function a => Function (Down a) where + function = functionMap getDown Down + +#if !MIN_VERSION_base(4,15,0) +instance Function a => Function (Semigroup.Option a) where + function = functionMap Semigroup.getOption Semigroup.Option +#endif + -- poly instances instance Function A where @@ -521,6 +656,7 @@ where shrXy (x,y) = [(x,y') | y' <- shr y] + table :: Eq aa => [(aa,cc)] -> (aa :-> cc) -- MicroHs needs this table [] = Nil table xys = Table xys @@ -584,6 +720,8 @@ #endif #endif +-- | Create a `Fun` from a function representation and a default value (in case the function +-- is partial). mkFun :: (a :-> b) -> b -> Fun a b mkFun p d = Fun (p, d, NotShrunk) (abstract p d) diff --git a/src/Test/QuickCheck/Gen.hs b/src/Test/QuickCheck/Gen.hs --- a/src/Test/QuickCheck/Gen.hs +++ b/src/Test/QuickCheck/Gen.hs @@ -15,11 +15,12 @@ -------------------------------------------------------------------------- -- imports +import Test.QuickCheck.Exception + import System.Random ( Random , random , randomR - , split ) import Control.Monad @@ -45,6 +46,12 @@ import Data.Int import Data.Bits import Control.Applicative +#ifndef NO_CALLSTACK +import GHC.Stack +#define WITHCALLSTACK(ty) HasCallStack => ty +#else +#define WITHCALLSTACK(ty) ty +#endif -------------------------------------------------------------------------- -- ** Generator type @@ -57,7 +64,7 @@ -- -- provide monad transformer versions of @Gen@. newtype Gen a = MkGen{ - unGen :: QCGen -> Int -> a -- ^ Run the generator on a particular seed. + unGen :: QCGen -> Int -> a -- ^ Run the generator on a particular seed and size. -- If you just want to get a random value out, consider using 'generate'. } @@ -81,7 +88,7 @@ MkGen m >>= k = MkGen (\r n -> - case split r of + case splitImpl r of (r1, r2) -> let MkGen m' = k (m r1 n) in m' r2 n @@ -134,7 +141,7 @@ -- | Overrides the size parameter. Returns a generator which uses -- the given size instead of the runtime-size parameter. -resize :: Int -> Gen a -> Gen a +resize :: WITHCALLSTACK(Int -> Gen a -> Gen a) resize n _ | n < 0 = error "Test.QuickCheck.resize: negative size" resize n (MkGen g) = MkGen (\r _ -> g r n) @@ -149,7 +156,7 @@ choose :: Random a => (a,a) -> Gen a choose rng = MkGen (\r _ -> let (x,_) = randomR rng r in x) --- | Generates a random element over the natural range of `a`. +-- | Generates a random element over the natural range of @a@. chooseAny :: Random a => Gen a chooseAny = MkGen (\r _ -> let (x,_) = random r in x) @@ -236,11 +243,17 @@ sample' g = generate (sequence [ resize n g | n <- [0,2..20] ]) --- | Generates some example values and prints them to 'stdout'. +-- | Generates some example values and prints them to 'System.IO.stdout'. sample :: Show a => Gen a -> IO () sample g = - do cases <- sample' g - mapM_ print cases + sequence_ [ do r <- newQCGen + munit <- tryEvaluateIO (print $ unGen g r n) + case munit of + Left e + | isDiscard e -> putStrLn "" + | otherwise -> error $ unlines $ "Uncaught exception in sample: " : map (" " ++) (lines $ show e) + Right () -> return () + | n <- [0,2..20] ] -------------------------------------------------------------------------- -- ** Floating point @@ -289,13 +302,13 @@ -- | Randomly uses one of the given generators. The input list -- must be non-empty. -oneof :: [Gen a] -> Gen a +oneof :: WITHCALLSTACK([Gen a] -> Gen a) oneof [] = error "QuickCheck.oneof used with empty list" oneof gs = chooseInt (0,length gs - 1) >>= (gs !!) -- | Chooses one of the given generators, with a weighted random distribution. -- The input list must be non-empty. -frequency :: [(Int, Gen a)] -> Gen a +frequency :: WITHCALLSTACK([(Int, Gen a)] -> Gen a) frequency [] = error "QuickCheck.frequency used with empty list" frequency xs | any (< 0) (map fst xs) = @@ -312,7 +325,7 @@ pick _ _ = error "QuickCheck.pick used with empty list" -- | Generates one of the given values. The input list must be non-empty. -elements :: [a] -> Gen a +elements :: WITHCALLSTACK([a] -> Gen a) elements [] = error "QuickCheck.elements used with empty list" elements xs = (xs !!) `fmap` chooseInt (0, length xs - 1) @@ -330,7 +343,7 @@ -- among an initial segment of the list. The size of this initial -- segment increases with the size parameter. -- The input list must be non-empty. -growingElements :: [a] -> Gen a +growingElements :: WITHCALLSTACK([a] -> Gen a) growingElements [] = error "QuickCheck.growingElements used with empty list" growingElements xs = sized $ \n -> elements (take (1 `max` size n) xs) where diff --git a/src/Test/QuickCheck/Gen/Unsafe.hs b/src/Test/QuickCheck/Gen/Unsafe.hs --- a/src/Test/QuickCheck/Gen/Unsafe.hs +++ b/src/Test/QuickCheck/Gen/Unsafe.hs @@ -22,12 +22,11 @@ import Test.QuickCheck.Gen import Control.Monad +import Control.Applicative -- | Promotes a monadic generator to a generator of monadic values. promote :: Monad m => m (Gen a) -> Gen (m a) -promote m = do - eval <- delay - return (liftM eval m) +promote m = flip liftM m <$> delay -- | Randomly generates a function of type @'Gen' a -> a@, which -- you can then use to evaluate generators. Mostly useful in diff --git a/src/Test/QuickCheck/Modifiers.hs b/src/Test/QuickCheck/Modifiers.hs --- a/src/Test/QuickCheck/Modifiers.hs +++ b/src/Test/QuickCheck/Modifiers.hs @@ -24,24 +24,24 @@ -- -- @ -- -- Functions cannot be shown (but see "Test.QuickCheck.Function") --- prop_TakeDropWhile ('Blind' p) (xs :: ['A']) = +-- prop_TakeDropWhile ('Blind' p) (xs :: ['Test.QuickCheck.Poly.A']) = -- takeWhile p xs ++ dropWhile p xs == xs -- @ -- -- @ --- prop_TakeDrop ('NonNegative' n) (xs :: ['A']) = +-- prop_TakeDrop ('NonNegative' n) (xs :: ['Test.QuickCheck.Poly.A']) = -- take n xs ++ drop n xs == xs -- @ -- -- @ -- -- cycle does not work for empty lists --- prop_Cycle ('NonNegative' n) ('NonEmpty' (xs :: ['A'])) = +-- prop_Cycle ('NonNegative' n) ('NonEmpty' (xs :: ['Test.QuickCheck.Poly.A'])) = -- take n (cycle xs) == take n (xs ++ cycle xs) -- @ -- -- @ --- -- Instead of 'forAll' 'orderedList' --- prop_Sort ('Ordered' (xs :: ['OrdA'])) = +-- -- Instead of 'Test.QuickCheck.forAll' 'orderedList' +-- prop_Sort ('Ordered' (xs :: ['Test.QuickCheck.Poly.OrdA'])) = -- sort xs == xs -- @ module Test.QuickCheck.Modifiers @@ -62,6 +62,7 @@ , Small(..) , Smart(..) , Shrink2(..) + , NoShrink(..) #ifndef NO_MULTI_PARAM_TYPE_CLASSES , Shrinking(..) , ShrinkState(..) @@ -164,14 +165,13 @@ instance Functor NonEmptyList where fmap f (NonEmpty x) = NonEmpty (map f x) -instance Arbitrary a => Arbitrary (NonEmptyList a) where - arbitrary = NonEmpty `fmap` (arbitrary `suchThat` (not . null)) +instance Arbitrary1 NonEmptyList where + liftArbitrary = fmap NonEmpty . listOf1 + liftShrink shr = map NonEmpty . filter (not . null) . shrinkList shr . getNonEmpty - shrink (NonEmpty xs) = - [ NonEmpty xs' - | xs' <- shrink xs - , not (null xs') - ] +instance Arbitrary a => Arbitrary (NonEmptyList a) where + arbitrary = arbitrary1 + shrink = shrink1 ---------------------------------------------------------------------- -- | @InfiniteList xs _@: guarantees that xs is an infinite list. @@ -182,7 +182,7 @@ -- -- > prop_take_10 :: InfiniteList Char -> Bool -- > prop_take_10 (InfiniteList xs _) = --- > or [ x == 'a' | x <- take 10 xs ] +-- > or [ x == \'a\' | x <- take 10 xs ] -- -- In the following counterexample, the list must start with @"bbbbbbbbbb"@ but -- the remaining (infinite) part can contain anything: @@ -283,7 +283,7 @@ fmap f (Negative x) = Negative (f x) instance (Num a, Ord a, Arbitrary a) => Arbitrary (Negative a) where - arbitrary = fmap Negative (arbitrary `suchThat` (< 0)) + arbitrary = fmap Negative (fmap (negate . abs) arbitrary `suchThat` (< 0)) shrink (Negative x) = [ Negative x' | x' <- shrink x , x' < 0 ] -------------------------------------------------------------------------- @@ -411,6 +411,24 @@ ] where shrink_x = shrink x + +-------------------------------------------------------------------------- +-- | @NoShrink x@: no shrinking +newtype NoShrink a = NoShrink {getNoShrink :: a} + deriving ( Eq, Ord, Show, Read +#ifndef NO_NEWTYPE_DERIVING + , Num, Integral, Real, Enum, Ix +#endif +#ifndef NO_TYPEABLE + , Typeable +#endif + ) + +instance Functor NoShrink where + fmap f (NoShrink x) = NoShrink (f x) + +instance Arbitrary a => Arbitrary (NoShrink a) where + arbitrary = fmap NoShrink arbitrary -------------------------------------------------------------------------- -- | @Smart _ x@: tries a different order when shrinking. diff --git a/src/Test/QuickCheck/Monadic.hs b/src/Test/QuickCheck/Monadic.hs --- a/src/Test/QuickCheck/Monadic.hs +++ b/src/Test/QuickCheck/Monadic.hs @@ -1,11 +1,7 @@ {-# LANGUAGE CPP #-} #ifndef NO_SAFE_HASKELL -#if !defined(NO_ST_MONAD) && !(MIN_VERSION_base(4,8,0)) -{-# LANGUAGE Trustworthy #-} -#else {-# LANGUAGE Safe #-} #endif -#endif #ifndef NO_ST_MONAD {-# LANGUAGE Rank2Types #-} #endif @@ -72,6 +68,17 @@ , monadicST , runSTGen #endif + + -- * Exceptions + +#ifndef NO_EXCEPTIONS + , assertException + , assertExceptionIO +#ifndef NO_DEEPSEQ + , assertDeepException + , assertDeepExceptionIO +#endif +#endif ) where -------------------------------------------------------------------------- @@ -95,6 +102,13 @@ import qualified Control.Monad.Fail as Fail #endif +#ifndef NO_DEEPSEQ +import Control.DeepSeq +#endif + +#ifndef NO_EXCEPTIONS +import qualified Control.Exception as E +#endif -------------------------------------------------------------------------- -- type PropertyM @@ -124,9 +138,6 @@ instance Monad m => Monad (PropertyM m) where return = pure (>>=) = bind -#if !MIN_VERSION_base(4,13,0) - fail = fail_ -#endif #ifndef NO_MONADFAIL instance Monad m => Fail.MonadFail (PropertyM m) where @@ -296,6 +307,61 @@ runSTGen f = do Capture eval <- capture return (runST (eval f)) +#endif + +-- Exceptions + + +#ifndef NO_EXCEPTIONS + +-- | Evaluate the value to Weak Head Normal Form (WHNF) and fail if it does not result in +-- an expected exception being thrown. +assertException :: + E.Exception exc + => (exc -> Bool) -- ^ Return `True` if that is the exception that was expected + -> a -- ^ Value that should result in an exception, when evaluated to WHNF + -> Property +assertException isExc value = assertExceptionIO isExc (return value) + + +-- | Make sure that a specific exception is thrown during an IO action. The result is +-- evaluated to WHNF. +assertExceptionIO :: + E.Exception exc + => (exc -> Bool) -- ^ Return `True` if that is the exception that was expected + -> IO a -- ^ An action that should throw the expected exception + -> Property +assertExceptionIO isExc action = + monadicIO $ do + hasFailed <- + run + (E.catch + (do res <- action + res `seq` return False) + (return . isExc)) + assert hasFailed + +#ifndef NO_DEEPSEQ + +-- | Same as `assertException`, but evaluate the value to Normal Form (NF) and fail if it +-- does not result in an expected exception being thrown. +assertDeepException :: + (NFData a, E.Exception exc) + => (exc -> Bool) -- ^ Return True if that is the exception that was expected + -> a -- ^ Value that should result in an exception, when fully evaluated to NF + -> Property +assertDeepException isExc value = assertException isExc (rnf value) + +-- | Make sure that a specific exception is thrown during an IO action. The result is +-- evaluated to NF. +assertDeepExceptionIO :: + (NFData a, E.Exception exc) + => (exc -> Bool) -- ^ Return True if that is the exception that was expected + -> IO a -- ^ An action that should throw the expected exception + -> Property +assertDeepExceptionIO isExc action = assertExceptionIO isExc (fmap rnf action) + +#endif #endif -------------------------------------------------------------------------- diff --git a/src/Test/QuickCheck/Monoids.hs b/src/Test/QuickCheck/Monoids.hs new file mode 100644 --- /dev/null +++ b/src/Test/QuickCheck/Monoids.hs @@ -0,0 +1,83 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE Safe #-} + +module Test.QuickCheck.Monoids + ( Every (..) + , Some (..) + ) where + +#ifndef NO_SEMIGROUP +import Data.List.NonEmpty as NonEmpty +import Data.Semigroup (Semigroup (..)) +#else +import Data.Monoid (Monoid (..)) +#endif +import Test.QuickCheck.Property + +-- | Conjunction monoid built with `.&&.`. +-- +-- Use `property @Every` as an accessor which doesn't leak +-- existential variables. +-- +-- Note: monoid laws are satisfied up to 'Test.QuickCheck.isSuccess' unless one +-- is using `checkCoverage`. +-- +#ifndef NO_EXISTENTIAL_FIELD_SELECTORS +data Every = forall p. Testable p => Every { getEvery :: p } +#else +data Every = forall p. Testable p => Every p +#endif + +instance Testable Every where + property (Every p) = property p + +#ifndef NO_SEMIGROUP +instance Semigroup Every where + Every p <> Every p' = Every (p .&&. p') + sconcat = Every . conjoin . NonEmpty.toList + +instance Monoid Every where + mempty = Every True + mappend = (<>) + mconcat = Every . conjoin +#else +instance Monoid Every where + mempty = Every True + mappend (Every p) (Every p') = Every (p .&&. p') + mconcat = Every . conjoin +#endif + + +-- | Disjunction monoid built with `.||.`. +-- +-- Use `property @Some` as an accessor which doesn't leak +-- existential variables. +-- +-- Note: monoid laws are satisfied up to 'Test.QuickCheck.isSuccess' unless one +-- is using `checkCoverage`. +-- +#ifndef NO_EXISTENTIAL_FIELD_SELECTORS +data Some = forall p. Testable p => Some { getSome :: p } +#else +data Some = forall p. Testable p => Some p +#endif + +instance Testable Some where + property (Some p) = property p + +#ifndef NO_SEMIGROUP +instance Semigroup Some where + Some p <> Some p' = Some (p .||. p') + sconcat = Some . disjoin . NonEmpty.toList + +instance Monoid Some where + mempty = Some False + mappend = (<>) + mconcat = Some . disjoin +#else +instance Monoid Some where + mempty = Some False + mappend (Some p) (Some p') = Some (p .||. p') + mconcat = Some . disjoin +#endif diff --git a/src/Test/QuickCheck/Property.hs b/src/Test/QuickCheck/Property.hs --- a/src/Test/QuickCheck/Property.hs +++ b/src/Test/QuickCheck/Property.hs @@ -3,6 +3,7 @@ {-# LANGUAGE CPP #-} #ifndef NO_TYPEABLE {-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE ExistentialQuantification #-} #endif #ifndef NO_SAFE_HASKELL {-# LANGUAGE Safe #-} @@ -17,13 +18,16 @@ import Test.QuickCheck.Arbitrary import Test.QuickCheck.Text( isOneLine, putLine ) import Test.QuickCheck.Exception -import Test.QuickCheck.State( State(terminal), Confidence(..) ) +import Test.QuickCheck.State( State(terminal, numSuccessTests, numDiscardedTests, maxSuccessTests, numSuccessShrinks, numTryShrinks, numTotTryShrinks), Confidence(..), TestProgress(..) ) #ifndef NO_TIMEOUT import System.Timeout(timeout) #endif import Data.Maybe import Control.Applicative +#if defined(MIN_VERSION_base) +import Control.Exception (displayException) +#endif import Control.Monad import qualified Data.Map as Map import Data.Map(Map) @@ -33,7 +37,7 @@ import Control.DeepSeq #endif #ifndef NO_TYPEABLE -import Data.Typeable (Typeable) +import Data.Typeable (Typeable, cast) #endif import Data.Maybe @@ -85,11 +89,6 @@ -- | The class of properties, i.e., types which QuickCheck knows how to test. -- Typically a property will be a function returning 'Bool' or 'Property'. --- --- If a property does no quantification, i.e. has no --- parameters and doesn't use 'forAll', it will only be tested once. --- This may not be what you want if your property is an @IO Bool@. --- You can change this behaviour using the 'again' combinator. class Testable prop where -- | Convert the thing to a property. property :: prop -> Property @@ -142,7 +141,7 @@ property p = MkProperty . return . protectProp $ p instance Testable prop => Testable (Gen prop) where - property mp = MkProperty $ do p <- mp; unProperty (again p) + property mp = MkProperty $ do p <- mp; unProperty (property p) instance Testable Property where property (MkProperty mp) = MkProperty (fmap protectProp mp) @@ -157,9 +156,6 @@ -- Warning: any random values generated inside of the argument to @ioProperty@ -- will not currently be shrunk. For best results, generate all random values -- before calling @ioProperty@, or use 'idempotentIOProperty' if that is safe. --- --- Note: if your property does no quantification, it will only be tested once. --- To test it repeatedly, use 'again'. ioProperty :: Testable prop => IO prop -> Property ioProperty prop = idempotentIOProperty (fmap noShrinking prop) @@ -262,35 +258,61 @@ data CallbackKind = Counterexample -- ^ Affected by the 'verbose' combinator | NotCounterexample -- ^ Not affected by the 'verbose' combinator +#ifndef NO_TYPEABLE +data Witness = forall a. (Typeable a, Show a) => Wit a + +instance Show Witness where + show (Wit a) = show a + +coerceWitness :: Typeable a => Witness -> a +coerceWitness (Wit a) = case cast a of + Nothing -> error $ "Can't coerceWitness " ++ show a + Just a -> a + +castWitness :: Typeable a => Witness -> Maybe a +castWitness (Wit a) = cast a + +#define WITNESSES(a) , theWitnesses a +#else +#define WITNESSES(a) +#endif + -- | The result of a single test. data Result = MkResult - { ok :: Maybe Bool + { ok :: Maybe Bool -- ^ result of the test case; Nothing = discard - , expect :: Bool + , expect :: Bool -- ^ indicates what the expected result of the property is - , reason :: String + , reason :: String -- ^ a message indicating what went wrong - , theException :: Maybe AnException + , theException :: Maybe AnException -- ^ the exception thrown, if any - , abort :: Bool + , abort :: Bool -- ^ if True, the test should not be repeated - , maybeNumTests :: Maybe Int + , maybeNumTests :: Maybe Int -- ^ stop after this many tests - , maybeCheckCoverage :: Maybe Confidence + , maybeCheckCoverage :: Maybe Confidence -- ^ required coverage confidence - , labels :: [String] + , maybeDiscardedRatio :: Maybe Int + -- ^ maximum number of discarded tests per successful test + , maybeMaxShrinks :: Maybe Int + -- ^ maximum number of shrinks + , maybeMaxTestSize :: Maybe Int + -- ^ maximum test size + , labels :: [String] -- ^ test case labels - , classes :: [String] + , classes :: [(String, Bool)] -- ^ test case classes - , tables :: [(String, String)] + , tables :: [(String, String)] -- ^ test case tables - , requiredCoverage :: [(Maybe String, String, Double)] + , requiredCoverage :: [(Maybe String, String, Double)] -- ^ required coverage - , callbacks :: [Callback] + , callbacks :: [Callback] -- ^ the callbacks for this test case - , testCase :: [String] + , testCase :: [String] -- ^ the generated test case + WITNESSES(:: [Witness]) } exception :: String -> AnException -> Result @@ -300,7 +322,11 @@ theException = Just err } formatException :: String -> AnException -> String +#if defined(MIN_VERSION_base) +formatException msg err = msg ++ ":" ++ format (displayException err) +#else formatException msg err = msg ++ ":" ++ format (show err) +#endif where format xs | isOneLine xs = " '" ++ xs ++ "'" | otherwise = "\n" ++ unlines [ " " ++ l | l <- lines xs ] @@ -315,19 +341,23 @@ where result = MkResult - { ok = undefined - , expect = True - , reason = "" - , theException = Nothing - , abort = True - , maybeNumTests = Nothing - , maybeCheckCoverage = Nothing - , labels = [] - , classes = [] - , tables = [] - , requiredCoverage = [] - , callbacks = [] - , testCase = [] + { ok = undefined + , expect = True + , reason = "" + , theException = Nothing + , abort = False + , maybeNumTests = Nothing + , maybeCheckCoverage = Nothing + , maybeDiscardedRatio = Nothing + , maybeMaxShrinks = Nothing + , maybeMaxTestSize = Nothing + , labels = [] + , classes = [] + , tables = [] + , requiredCoverage = [] + , callbacks = [] + , testCase = [] + WITNESSES(= []) } -------------------------------------------------------------------------- @@ -420,6 +450,25 @@ then m else return () +-- | Performs an IO action every time a property is tested, after every test. +-- The IO action is allowed to depend on @TestProgress@, which contains information +-- regarding how testing is progressing. +-- +-- Note: QC invokes callbacks before the internal state has been updated to reflect the +-- most recent test. The means that e.g. @currentPassed@ will, after the first test has +-- been executed, still show 0. +withProgress :: Testable prop => (TestProgress -> IO ()) -> prop -> Property +withProgress m = + callback $ PostTest NotCounterexample $ \st _r -> + let tp = TestProgress { currentPassed = numSuccessTests st + , currentDiscarded = numDiscardedTests st + , maxTests = maxSuccessTests st + , currentShrinks = numSuccessShrinks st + , currentFailedShrinks = numTryShrinks st + , currentTotalShrinks = numTotTryShrinks st + } + in m tp + -- | Prints out the generated test case every time the property is tested. -- Only variables quantified over /inside/ the 'verbose' are printed. -- @@ -474,9 +523,62 @@ -- > quickCheck (withMaxSuccess 1000 p) -- -- will test @p@ up to 1000 times. +{-# DEPRECATED withMaxSuccess "Use withNumTests instead" #-} withMaxSuccess :: Testable prop => Int -> prop -> Property -withMaxSuccess n = n `seq` mapTotalResult (\res -> res{ maybeNumTests = Just n }) +withMaxSuccess = withNumTests +-- | Configures how many times a property will be tested. +-- +-- For example, +-- +-- > quickCheck (withNumTests 1000 p) +-- +-- will test @p@ up to 1000 times. +withNumTests :: Testable prop => Int -> prop -> Property +withNumTests n = n `seq` mapTotalResult (\res -> res{ maybeNumTests = Just n }) + +-- | Configures how many times a property is allowed to be discarded before failing. +-- +-- For example, +-- +-- > quickCheck (withDiscardRatio 10 p) +-- +-- will allow @p@ to fail up to 10 times per successful test. +withDiscardRatio :: Testable prop => Int -> prop -> Property +withDiscardRatio n = n `seq` mapTotalResult (\res -> res{ maybeDiscardedRatio = Just n }) + +-- | Configure the maximum number of times a property will be shrunk. +-- +-- For example, +-- +-- > quickCheck (withMaxShrinks 100 p) +-- +-- will cause @p@ to only attempt 100 shrinks on failure. +withMaxShrinks :: Testable prop => Int -> prop -> Property +withMaxShrinks n = n `seq` mapTotalResult (\res -> res{ maybeMaxShrinks = Just n }) + +-- | Configure the maximum size a property will be tested at. +withMaxSize :: Testable prop => Int -> prop -> Property +withMaxSize n = n `seq` mapTotalResult (\res -> res{ maybeMaxTestSize = Just n }) + +#ifndef NO_TYPEABLE +-- | Return a value in the 'Test.QuickCheck.witnesses' field of the 'Result' +-- returned by 'Test.QuickCheck.quickCheckResult'. Witnesses are returned +-- outer-most first. +-- +-- In ghci, for example: +-- +-- >>> [Wit x] <- fmap witnesses . quickCheckResult $ \ x -> witness x $ x == (0 :: Int) +-- *** Failed! Falsified (after 2 tests): +-- 1 +-- >>> x +-- 1 +-- >>> :t x +-- x :: Int +witness :: (Typeable a, Show a, Testable prop) => a -> prop -> Property +witness a = a `seq` mapTotalResult (\res -> res{ theWitnesses = Wit a : theWitnesses res }) +#endif + -- | Check that all coverage requirements defined by 'cover' and 'coverTable' -- are met, using a statistically sound test, and fail if they are not met. -- @@ -591,13 +693,13 @@ Bool -- ^ @True@ if the test case should be labelled. -> String -- ^ Label. -> prop -> Property -classify False _ = property -classify True s = +classify b s = #ifndef NO_DEEPSEQ s `deepseq` #endif + b `seq` mapTotalResult $ - \res -> res { classes = s:classes res } + \res -> res { classes = (s, b):classes res } -- | Checks that at least the given proportion of /successful/ test -- cases belong to the given class. Discarded tests (i.e. ones @@ -702,15 +804,16 @@ mapTotalResult $ \res -> res { tables = [(key, value) | value <- values] ++ tables res } --- | Checks that the values in a given 'table' appear a certain proportion of +-- | Checks that the values in a given @table@ appear a certain proportion of -- the time. A call to 'coverTable' @table@ @[(x1, p1), ..., (xn, pn)]@ asserts -- that of the values in @table@, @x1@ should appear at least @p1@ percent of --- the time, @x2@ at least @p2@ percent of the time, and so on. +-- the time that @table@ appears, @x2@ at least @p2@ percent of the time that +-- @table@ appears, and so on. -- -- __Note:__ If the coverage check fails, QuickCheck prints out a warning, but -- the property does /not/ fail. To make the property fail, use 'checkCoverage'. -- --- Continuing the example from the 'tabular' combinator... +-- Continuing the example from the 'tabulate' combinator... -- -- > data Command = LogIn | LogOut | SendMessage String deriving (Data, Show) -- > prop_chatroom :: [Command] -> Property @@ -794,7 +897,8 @@ onTimeout timeoutResult n = mapRoseResult f where f rose = ioRose $ do - let m `orError` x = fmap (fromMaybe x) m + let orError :: IO (Maybe a) -> a -> IO a + m `orError` x = fmap (fromMaybe x) m MkRose res roses <- timeout n (reduceRose rose) `orError` return timeoutResult res' <- timeout n (protectResult (return res)) `orError` @@ -839,32 +943,29 @@ :: Testable prop => Gen a -> (a -> [a]) -> (a -> prop) -> Property forAllShrinkBlind gen shrinker pf = - again $ MkProperty $ gen >>= \x -> unProperty $ shrinking shrinker x pf --- | Nondeterministic choice: 'p1' '.&.' 'p2' picks randomly one of --- 'p1' and 'p2' to test. If you test the property 100 times it +-- | Nondeterministic choice: @p1@ '.&.' @p2@ picks randomly one of +-- @p1@ and @p2@ to test. If you test the property 100 times it -- makes 100 random choices. (.&.) :: (Testable prop1, Testable prop2) => prop1 -> prop2 -> Property p1 .&. p2 = - again $ MkProperty $ arbitrary >>= \b -> unProperty $ counterexample (if b then "LHS" else "RHS") $ if b then property p1 else property p2 --- | Conjunction: 'p1' '.&&.' 'p2' passes if both 'p1' and 'p2' pass. +-- | Conjunction: @p1@ '.&&.' @p2@ passes if both @p1@ and @p2@ pass. (.&&.) :: (Testable prop1, Testable prop2) => prop1 -> prop2 -> Property p1 .&&. p2 = conjoin [property p1, property p2] -- | Take the conjunction of several properties. conjoin :: Testable prop => [prop] -> Property conjoin ps = - again $ MkProperty $ do roses <- mapM (fmap unProp . unProperty . property) ps return (MkProp (conj id roses)) @@ -896,14 +997,13 @@ classes = classes result ++ classes r, tables = tables result ++ tables r } --- | Disjunction: 'p1' '.||.' 'p2' passes unless 'p1' and 'p2' simultaneously fail. +-- | Disjunction: @p1@ '.||.' @p2@ passes unless @p1@ and @p2@ simultaneously fail. (.||.) :: (Testable prop1, Testable prop2) => prop1 -> prop2 -> Property p1 .||. p2 = disjoin [property p1, property p2] -- | Take the disjunction of several properties. disjoin :: Testable prop => [prop] -> Property disjoin ps = - again $ MkProperty $ do roses <- mapM (fmap unProp . unProperty . property) ps return (MkProp (foldr disj (MkRose failed []) roses)) @@ -930,6 +1030,9 @@ abort = False, maybeNumTests = Nothing, maybeCheckCoverage = Nothing, + maybeDiscardedRatio = Nothing, + maybeMaxShrinks = Nothing, + maybeMaxTestSize = Nothing, labels = [], classes = [], tables = [], @@ -940,7 +1043,9 @@ callbacks result2, testCase = testCase result1 ++ - testCase result2 } + testCase result2 + WITNESSES(= theWitnesses result1 ++ theWitnesses result2) + } Nothing -> result2 -- The "obvious" semantics of .||. has: -- discard .||. true = true diff --git a/src/Test/QuickCheck/Random.hs b/src/Test/QuickCheck/Random.hs --- a/src/Test/QuickCheck/Random.hs +++ b/src/Test/QuickCheck/Random.hs @@ -26,17 +26,25 @@ instance Read QCGen where readsPrec n xs = [(QCGen g, ys) | (g, ys) <- readsPrec n xs] -instance RandomGen QCGen where +splitImpl :: QCGen -> (QCGen, QCGen) #ifdef NO_SPLITMIX - split (QCGen g) = +splitImpl (QCGen g) = case split g of (g1, g2) -> (QCGen g1, QCGen g2) - genRange (QCGen g) = genRange g - next = wrapQCGen next #else - split (QCGen g) = +splitImpl (QCGen g) = case splitSMGen g of (g1, g2) -> (QCGen g1, QCGen g2) +#endif + +instance RandomGen QCGen where +#if !MIN_VERSION_random(1,3,0) + split = splitImpl +#endif +#ifdef NO_SPLITMIX + genRange (QCGen g) = genRange g + next = wrapQCGen next +#else genRange _ = (minBound, maxBound) next = wrapQCGen nextInt @@ -47,10 +55,17 @@ genWord64 = wrapQCGen genWord64 genWord32R r = wrapQCGen (genWord32R r) genWord64R r = wrapQCGen (genWord64R r) - genShortByteString n = wrapQCGen (genShortByteString n) +#if MIN_VERSION_random(1,3,0) + genShortByteString n = wrapQCGen (uniformShortByteString n) #endif #endif +#endif +#if MIN_VERSION_random(1,3,0) +instance SplitGen QCGen where + splitGen = splitImpl +#endif + {-# INLINE wrapQCGen #-} #ifdef NO_SPLITMIX wrapQCGen :: (StdGen -> (a, StdGen)) -> (QCGen -> (a, QCGen)) @@ -80,8 +95,8 @@ left, right :: a -> a instance Splittable QCGen where - left = fst . split - right = snd . split + left = fst . splitImpl + right = snd . splitImpl -- The logic behind 'variant'. Given a random number seed, and an integer, uses -- splitting to transform the seed according to the integer. We use a diff --git a/src/Test/QuickCheck/State.hs b/src/Test/QuickCheck/State.hs --- a/src/Test/QuickCheck/State.hs +++ b/src/Test/QuickCheck/State.hs @@ -25,12 +25,14 @@ , maxDiscardedRatio :: Int -- ^ maximum number of discarded tests per successful test , coverageConfidence :: Maybe Confidence - -- ^ required coverage confidence - , computeSize :: Int -> Int -> Int -- ^ how to compute the size of test cases from -- #tests and #discarded tests , numTotMaxShrinks :: !Int -- ^ How many shrinks to try before giving up + , replayStartSize :: Maybe Int + -- ^ Size to start at when replaying + , maxTestSize :: !Int + -- ^ Maximum size of test -- dynamic , numSuccessTests :: !Int @@ -61,35 +63,49 @@ -- ^ total number of failed shrinking steps } --- | The statistical parameters used by 'checkCoverage'. +-- | The statistical parameters used by 'Test.QuickCheck.checkCoverage'. data Confidence = Confidence { certainty :: Integer, - -- ^ How certain 'checkCoverage' must be before the property fails. - -- If the coverage requirement is met, and the certainty parameter is @n@, - -- then you should get a false positive at most one in @n@ runs of QuickCheck. - -- The default value is @10^9@. - -- - -- Lower values will speed up 'checkCoverage' at the cost of false - -- positives. + -- ^ How certain 'Test.QuickCheck.checkCoverage' must be before the property + -- fails. If the coverage requirement is met, and the certainty parameter is + -- @n@, then you should get a false positive at most one in @n@ runs of + -- QuickCheck. The default value is @10^9@. -- - -- If you are using 'checkCoverage' as part of a test suite, you should - -- be careful not to set @certainty@ too low. If you want, say, a 1% chance - -- of a false positive during a project's lifetime, then @certainty@ should - -- be set to at least @100 * m * n@, where @m@ is the number of uses of - -- 'cover' in the test suite, and @n@ is the number of times you expect the - -- test suite to be run during the project's lifetime. The default value - -- is chosen to be big enough for most projects. + -- Lower values will speed up 'Test.QuickCheck.checkCoverage' at the cost of + -- false positives. + -- + -- If you are using 'Test.QuickCheck.checkCoverage' as part of a test suite, + -- you should be careful not to set @certainty@ too low. If you want, say, a + -- 1% chance of a false positive during a project's lifetime, then + -- certainty@ should be set to at least @100 * m * n@, where @m@ is the + -- number of uses of 'Test.QuickCheck.cover' in the test suite, and @n@ is + -- the number of times you expect the test suite to be run during the + -- project's lifetime. The default value is chosen to be big enough for most + -- projects. tolerance :: Double - -- ^ For statistical reasons, 'checkCoverage' will not reject coverage - -- levels that are only slightly below the required levels. + -- ^ For statistical reasons, 'Test.QuickCheck.checkCoverage' will not + -- reject coverage levels that are only slightly below the required levels. -- If the required level is @p@ then an actual level of @tolerance * p@ -- will be accepted. The default value is @0.9@. -- - -- Lower values will speed up 'checkCoverage' at the cost of not detecting - -- minor coverage violations. + -- Lower values will speed up 'Test.QuickCheck.checkCoverage' at the cost of + -- not detecting minor coverage violations. } deriving Show + +-- | TestProgress, contains information that might be interesting to external +-- libraries, e.g. Tasty. From this it is possible to install your own callbacks +-- that reports e.g. progress. +data TestProgress + = TestProgress + { currentPassed :: Int -- ^ Number of tests passed so far + , currentDiscarded :: Int -- ^ Number of discared tests so far + , maxTests :: Int -- ^ Number of tests to execute + , currentShrinks :: Int -- ^ Number of successful shrinking steps + , currentFailedShrinks :: Int -- ^ Number of failed shrinking steps since last successful one + , currentTotalShrinks :: Int -- ^ Total number of failed shrinking steps + } deriving Show -------------------------------------------------------------------------- -- the end. diff --git a/src/Test/QuickCheck/Test.hs b/src/Test/QuickCheck/Test.hs --- a/src/Test/QuickCheck/Test.hs +++ b/src/Test/QuickCheck/Test.hs @@ -12,6 +12,7 @@ -------------------------------------------------------------------------- -- imports +import Control.Applicative import Test.QuickCheck.Gen import Test.QuickCheck.Property hiding ( Result( reason, theException, labels, classes, tables ), (.&.) ) import qualified Test.QuickCheck.Property as P @@ -20,7 +21,6 @@ import qualified Test.QuickCheck.State as S import Test.QuickCheck.Exception import Test.QuickCheck.Random -import System.Random(split) #if defined(MIN_VERSION_containers) #if MIN_VERSION_containers(0,5,0) import qualified Data.Map.Strict as Map @@ -50,6 +50,7 @@ import Text.Printf(printf) import Control.Monad import Data.Bits +import Data.Maybe #ifndef NO_TYPEABLE import Data.Typeable (Typeable) @@ -80,7 +81,7 @@ , chatty :: Bool -- ^ Whether to print anything , maxShrinks :: Int - -- ^ Maximum number of shrinks to before giving up. Setting this to zero + -- ^ Maximum number of shrinks to do before giving up. Setting this to zero -- turns shrinking off. } deriving ( Show, Read @@ -142,6 +143,10 @@ -- ^ The test case's labels (see 'label') , failingClasses :: Set String -- ^ The test case's classes (see 'classify') +#ifndef NO_TYPEABLE + , witnesses :: [Witness] + -- ^ The existentially quantified witnesses provided by 'witness' +#endif } -- | A property that should have failed did not | NoExpectedFailure @@ -171,10 +176,10 @@ , maxShrinks = maxBound } --- | Tests a property and prints the results to 'stdout'. +-- | Tests a property and prints the results to 'System.IO.stdout'. -- -- By default up to 100 tests are performed, which may not be enough --- to find all bugs. To run more tests, use 'withMaxSuccess'. +-- to find all bugs. To run more tests, use 'withNumTests'. -- -- If you want to get the counterexample as a Haskell value, -- rather than just printing it, try the @@ -184,19 +189,24 @@ quickCheck :: Testable prop => prop -> IO () quickCheck p = quickCheckWith stdArgs p --- | Tests a property, using test arguments, and prints the results to 'stdout'. +-- | Tests a property, using test arguments, and prints the results to 'System.IO.stdout'. quickCheckWith :: Testable prop => Args -> prop -> IO () quickCheckWith args p = quickCheckWithResult args p >> return () --- | Tests a property, produces a test result, and prints the results to 'stdout'. +-- | Tests a property, produces a test result, and prints the results to 'System.IO.stdout'. quickCheckResult :: Testable prop => prop -> IO Result quickCheckResult p = quickCheckWithResult stdArgs p --- | Tests a property, using test arguments, produces a test result, and prints the results to 'stdout'. +-- | Tests a property, using test arguments, produces a test result, and prints the results to 'System.IO.stdout'. quickCheckWithResult :: Testable prop => Args -> prop -> IO Result quickCheckWithResult a p = withState a (\s -> test s (property p)) +-- | Re-run a property with the seed and size that failed in a run of 'quickCheckResult'. +recheck :: Testable prop => Result -> prop -> IO () +recheck res@Failure{} = quickCheckWith stdArgs{ replay = Just (usedSeed res, usedSize res)} . once +recheck _ = error "Can only recheck tests that failed with a counterexample." + withState :: Args -> (State -> IO a) -> IO a withState a test = (if chatty a then withStdioTerminal else withNullTerminal) $ \tm -> do rnd <- case replay a of @@ -206,9 +216,8 @@ , maxSuccessTests = maxSuccess a , coverageConfidence = Nothing , maxDiscardedRatio = maxDiscardRatio a - , computeSize = case replay a of - Nothing -> computeSize' - Just (_,s) -> computeSize' `at0` s + , replayStartSize = snd <$> replay a + , maxTestSize = maxSize a , numTotMaxShrinks = maxShrinks a , numSuccessTests = 0 , numDiscardedTests = 0 @@ -223,19 +232,32 @@ , numTryShrinks = 0 , numTotTryShrinks = 0 } - where computeSize' n d - -- e.g. with maxSuccess = 250, maxSize = 100, goes like this: - -- 0, 1, 2, ..., 99, 0, 1, 2, ..., 99, 0, 2, 4, ..., 98. - | n `roundTo` maxSize a + maxSize a <= maxSuccess a || - n >= maxSuccess a || - maxSuccess a `mod` maxSize a == 0 = (n `mod` maxSize a + d `div` 10) `min` maxSize a - | otherwise = - ((n `mod` maxSize a) * maxSize a `div` (maxSuccess a `mod` maxSize a) + d `div` 10) `min` maxSize a - n `roundTo` m = (n `div` m) * m - at0 f s 0 0 = s - at0 f s n d = f n d --- | Tests a property and prints the results and all test cases generated to 'stdout'. +computeSize :: State -> Int +computeSize MkState{replayStartSize = Just s,numSuccessTests = 0,numRecentlyDiscardedTests=0} = s +-- NOTE: Beware that changing this means you also have to change `prop_discardCoverage` as that currently relies +-- on the sequence produced by this function. +computeSize MkState{maxSuccessTests = ms, maxTestSize = mts, maxDiscardedRatio = md,numSuccessTests=n,numRecentlyDiscardedTests=d} + -- e.g. with maxSuccess = 250, maxSize = 100, goes like this: + -- 0, 1, 2, ..., 99, 0, 1, 2, ..., 99, 0, 2, 4, ..., 98. + | n `roundTo` mts + mts <= ms || + n >= ms || + ms `mod` mts == 0 = (n `mod` mts + d `div` dDenom) `min` mts + | otherwise = + ((n `mod` mts) * mts `div` (ms `mod` mts) + d `div` dDenom) `min` mts + where + -- The inverse of the rate at which we increase size as a function of discarded tests + -- if the discard ratio is high we can afford this to be slow, but if the discard ratio + -- is low we risk bowing out too early + dDenom + | md > 0 = (ms * md `div` 3) `clamp` (1, 10) + | otherwise = 1 -- Doesn't matter because there will be no discards allowed + n `roundTo` m = (n `div` m) * m + +clamp :: Ord a => a -> (a, a) -> a +clamp x (l, h) = max l (min x h) + +-- | Tests a property and prints the results and all test cases generated to 'System.IO.stdout'. -- This is just a convenience function that means the same as @'quickCheck' . 'verbose'@. -- -- Note: for technical reasons, the test case is printed out /after/ @@ -244,7 +266,7 @@ verboseCheck :: Testable prop => prop -> IO () verboseCheck p = quickCheck (verbose p) --- | Tests a property, using test arguments, and prints the results and all test cases generated to 'stdout'. +-- | Tests a property, using test arguments, and prints the results and all test cases generated to 'System.IO.stdout'. -- This is just a convenience function that combines 'quickCheckWith' and 'verbose'. -- -- Note: for technical reasons, the test case is printed out /after/ @@ -253,7 +275,7 @@ verboseCheckWith :: Testable prop => Args -> prop -> IO () verboseCheckWith args p = quickCheckWith args (verbose p) --- | Tests a property, produces a test result, and prints the results and all test cases generated to 'stdout'. +-- | Tests a property, produces a test result, and prints the results and all test cases generated to 'System.IO.stdout'. -- This is just a convenience function that combines 'quickCheckResult' and 'verbose'. -- -- Note: for technical reasons, the test case is printed out /after/ @@ -262,7 +284,7 @@ verboseCheckResult :: Testable prop => prop -> IO Result verboseCheckResult p = quickCheckResult (verbose p) --- | Tests a property, using test arguments, produces a test result, and prints the results and all test cases generated to 'stdout'. +-- | Tests a property, using test arguments, produces a test result, and prints the results and all test cases generated to 'System.IO.stdout'. -- This is just a convenience function that combines 'quickCheckWithResult' and 'verbose'. -- -- Note: for technical reasons, the test case is printed out /after/ @@ -275,16 +297,71 @@ -- main test loop test :: State -> Property -> IO Result -test st f - | numSuccessTests st >= maxSuccessTests st && isNothing (coverageConfidence st) = - doneTesting st f - | numDiscardedTests st >= maxDiscardedRatio st * max (numSuccessTests st) (maxSuccessTests st) = - giveUp st f - | otherwise = - runATest st f +test st prop + | finishedSuccessfully st = doneTesting st + | finishedInsufficientCoverage st = failCoverage st + | tooManyDiscards st = giveUp st + | otherwise = runATest st prop -doneTesting :: State -> Property -> IO Result -doneTesting st _f +finishedSuccessfully :: State -> Bool +finishedSuccessfully st + | checkingCoverage st = + and [ timeToCheckCoverage st + , coverageKnownSufficient st + , numSuccessTests st >= maxSuccessTests st + ] + | otherwise = numSuccessTests st >= maxSuccessTests st + +finishedInsufficientCoverage :: State -> Bool +finishedInsufficientCoverage st = + and [ checkingCoverage st + , timeToCheckCoverage st + , coverageKnownInsufficient st + ] + +tooManyDiscards :: State -> Bool +tooManyDiscards st + | maxDiscardedRatio st > 0 = numDiscardedTests st `div` maxDiscardedRatio st >= max (numSuccessTests st) (maxSuccessTests st) + | otherwise = numDiscardedTests st > 0 + +checkingCoverage :: State -> Bool +checkingCoverage st = isJust (coverageConfidence st) + +timeToCheckCoverage :: State -> Bool +timeToCheckCoverage st + -- This is the time when we would normally finish testing, so lets check + -- it now to see if we can finish testing already + | numSuccessTests st == maxSuccessTests st && numRecentlyDiscardedTests st == 0 = True + -- We are on test 100 * 2^k for k > 0 + | otherwise = + and [ numSuccessTests st > 0 + , numSuccessTests st `mod` 100 == 0 + , powerOfTwo (numSuccessTests st `div` 100) + ] + where powerOfTwo n = n .&. (n - 1) == 0 + +coverageKnownSufficient :: State -> Bool +coverageKnownSufficient st@MkState{coverageConfidence=Just confidence} = + and [ sufficientlyCovered confidence tot n p | (_, _, tot, n, p) <- allCoverage st ] +coverageKnownSufficient _ = True + +coverageKnownInsufficient :: State -> Bool +coverageKnownInsufficient st@MkState{coverageConfidence=Just confidence} = + or [ insufficientlyCovered (Just (certainty confidence)) tot n p + | (_, _, tot, n, p) <- allCoverage st ] +coverageKnownInsufficient _ = False + +failCoverage :: State -> IO Result +failCoverage st = + -- The last test wasn't actually successful, as the coverage failed + -- also this prevents an off-by-one error in the printing + runATest st{numSuccessTests = numSuccessTests st - 1} + $ foldr counterexample (property failed{P.reason = "Insufficient coverage"}) + (paragraphs [theLabels, theTables]) + where (theLabels, theTables) = labelsAndTables st + +doneTesting :: State -> IO Result +doneTesting st | expected st == False = do putPart (terminal st) ( bold ("*** Failed!") @@ -305,8 +382,8 @@ theOutput <- terminalOutput (terminal st) return (k (numSuccessTests st) (numDiscardedTests st) (S.labels st) (S.classes st) (S.tables st) theOutput) -giveUp :: State -> Property -> IO Result -giveUp st _f = +giveUp :: State -> IO Result +giveUp st = do -- CALLBACK gave_up? putPart (terminal st) ( bold ("*** Gave up!") @@ -325,77 +402,88 @@ } showTestCount :: State -> String -showTestCount st = - number (numSuccessTests st) "test" - ++ concat [ "; " ++ show (numDiscardedTests st) ++ " discarded" - | numDiscardedTests st > 0 +showTestCount st = formatTestCount (numSuccessTests st) (numDiscardedTests st) + +formatTestCount :: Int -> Int -> String +formatTestCount succeeded discarded = + number succeeded "test" + ++ concat [ "; " ++ show discarded ++ " discarded" + | discarded > 0 ] runATest :: State -> Property -> IO Result -runATest st f = +runATest st prop = do -- CALLBACK before_test putTemp (terminal st) ( "(" ++ showTestCount st ++ ")" ) - let powerOfTwo n = n .&. (n - 1) == 0 - let f_or_cov = - case coverageConfidence st of - Just confidence | (1 + numSuccessTests st) `mod` 100 == 0 && powerOfTwo ((1 + numSuccessTests st) `div` 100) -> - addCoverageCheck confidence st f - _ -> f - let size = computeSize st (numSuccessTests st) (numRecentlyDiscardedTests st) - MkRose res ts <- protectRose (reduceRose (unProp (unGen (unProperty f_or_cov) rnd1 size))) + + let size = computeSize st + + MkRose res ts <- protectRose (reduceRose (unProp (unGen (unProperty prop) rnd1 size))) res <- callbackPostTest st res - let continue break st' | abort res = break st' - | otherwise = test st' + let continue :: (State -> IO Result) -> State -> IO Result + continue break st' + | abort res = break $ updateState st' + | otherwise = test (updateState st') prop - let st' = st{ coverageConfidence = maybeCheckCoverage res `mplus` coverageConfidence st - , maxSuccessTests = fromMaybe (maxSuccessTests st) (maybeNumTests res) - , S.labels = Map.insertWith (+) (P.labels res) 1 (S.labels st) - , S.classes = Map.unionWith (+) (S.classes st) (Map.fromList (zip (P.classes res) (repeat 1))) - , S.tables = - foldr (\(tab, x) -> Map.insertWith (Map.unionWith (+)) tab (Map.singleton x 1)) - (S.tables st) (P.tables res) - , S.requiredCoverage = - foldr (\(key, value, p) -> Map.insertWith max (key, value) p) - (S.requiredCoverage st) (P.requiredCoverage res) - , expected = expect res } + updateState st0 = addNewOptions $ st0{ randomSeed = rnd2 } + addNewOptions st0 = st0{ maxSuccessTests = fromMaybe (maxSuccessTests st0) (maybeNumTests res) + , maxDiscardedRatio = fromMaybe (maxDiscardedRatio st0) (maybeDiscardedRatio res) + , numTotMaxShrinks = fromMaybe (numTotMaxShrinks st0) (maybeMaxShrinks res) + , maxTestSize = fromMaybe (maxTestSize st0) (maybeMaxTestSize res) + , expected = expect res + } + + addCoverageInfo st0 = + st0{ coverageConfidence = maybeCheckCoverage res `mplus` coverageConfidence st0 + , S.labels = Map.insertWith (+) (P.labels res) 1 (S.labels st0) + , S.classes = Map.unionWith (+) (S.classes st0) + (Map.fromList [ (s, if b then 1 else 0) | (s, b) <- P.classes res ]) + , S.tables = + foldr (\(tab, x) -> Map.insertWith (Map.unionWith (+)) tab (Map.singleton x 1)) + (S.tables st0) (P.tables res) + , S.requiredCoverage = + foldr (\(key, value, p) -> Map.insertWith max (key, value) p) + (S.requiredCoverage st0) (P.requiredCoverage res) + } + + stC = addCoverageInfo st + case res of MkResult{ok = Just True} -> -- successful test do continue doneTesting - st'{ numSuccessTests = numSuccessTests st' + 1 + stC{ numSuccessTests = numSuccessTests st + 1 , numRecentlyDiscardedTests = 0 - , randomSeed = rnd2 - } f + } - MkResult{ok = Nothing, expect = expect, maybeNumTests = mnt, maybeCheckCoverage = mcc} -> -- discarded test + MkResult{ok = Nothing} -> -- discarded test do continue giveUp -- Don't add coverage info from this test - st{ numDiscardedTests = numDiscardedTests st' + 1 - , numRecentlyDiscardedTests = numRecentlyDiscardedTests st' + 1 - , randomSeed = rnd2 - } f + st{ numDiscardedTests = numDiscardedTests st + 1 + , numRecentlyDiscardedTests = numRecentlyDiscardedTests st + 1 + } MkResult{ok = Just False} -> -- failed test - do (numShrinks, totFailed, lastFailed, res) <- foundFailure st' res ts - theOutput <- terminalOutput (terminal st') + do (numShrinks, totFailed, lastFailed, res) <- foundFailure (addNewOptions stC) res ts + theOutput <- terminalOutput (terminal stC) if not (expect res) then - return Success{ labels = S.labels st', - classes = S.classes st', - tables = S.tables st', - numTests = numSuccessTests st'+1, - numDiscarded = numDiscardedTests st', + return Success{ labels = S.labels stC, + classes = S.classes stC, + tables = S.tables stC, + numTests = numSuccessTests stC+1, + numDiscarded = numDiscardedTests stC, output = theOutput } else do testCase <- mapM showCounterexample (P.testCase res) - return Failure{ usedSeed = randomSeed st' -- correct! (this will be split first) + return Failure{ usedSeed = randomSeed stC -- correct! (this will be split first) , usedSize = size - , numTests = numSuccessTests st'+1 - , numDiscarded = numDiscardedTests st' + , numTests = numSuccessTests stC + 1 + , numDiscarded = numDiscardedTests stC , numShrinks = numShrinks , numShrinkTries = totFailed , numShrinkFinal = lastFailed @@ -404,10 +492,13 @@ , theException = P.theException res , failingTestCase = testCase , failingLabels = P.labels res - , failingClasses = Set.fromList (P.classes res) + , failingClasses = Set.fromList (map fst $ filter snd $ P.classes res) +#ifndef NO_TYPEABLE + , witnesses = theWitnesses res +#endif } where - (rnd1,rnd2) = split (randomSeed st) + (rnd1,rnd2) = splitImpl (randomSeed st) failureSummary :: State -> P.Result -> String failureSummary st res = fst (failureSummaryAndReason st res) @@ -524,7 +615,9 @@ Right () -> do r <- tryEvaluate ts case r of - Left err -> + Left err + | isDiscard err -> localMinFound st res + | otherwise -> localMinFound st (exception "Exception while generating shrink-list" err) { callbacks = callbacks res } Right ts' -> localMin' st res ts' @@ -664,18 +757,6 @@ p_low = 0.02425 p_high = 1 - p_low -addCoverageCheck :: Confidence -> State -> Property -> Property -addCoverageCheck confidence st prop - | and [ sufficientlyCovered confidence tot n p - | (_, _, tot, n, p) <- allCoverage st ] = - -- Note: run prop once more so that we get labels for this test case run - once prop - | or [ insufficientlyCovered (Just (certainty confidence)) tot n p - | (_, _, tot, n, p) <- allCoverage st ] = - let (theLabels, theTables) = labelsAndTables st in - foldr counterexample (property failed{P.reason = "Insufficient coverage"}) - (paragraphs [theLabels, theTables]) - | otherwise = prop allCoverage :: State -> [(Maybe String, String, Int, Int, Double)] allCoverage st = diff --git a/test-hugs b/test-hugs --- a/test-hugs +++ b/test-hugs @@ -19,8 +19,11 @@ dotest() { echo "$2" | hugs -98 -Pquickcheck-hugs: -p'> ' "$1" | tee hugs.output - grep "$3" hugs.output || die + grep -q "$3" hugs.output || die } # Simple tests dotest Test.QuickCheck 'quickCheck $ \xs -> reverse (reverse xs) === (xs :: [Int])' "OK, passed 100 tests." +dotest Test.QuickCheck 'quickCheck $ \xs -> reverse xs === (xs :: [Int])' "\[0,1\]" +echo +echo 'All tests passed!' diff --git a/test-mhs b/test-mhs new file mode 100644 --- /dev/null +++ b/test-mhs @@ -0,0 +1,25 @@ +#!/bin/sh + +set -e + +mcabal -r install + +die() { + echo "TEST FAILED" + exit 1 +} + +dotest() { + cat >Main.hs < reverse (reverse xs) === (xs :: [Int])' "OK, passed 100 tests." +dotest Test.QuickCheck 'quickCheck $ \xs -> reverse xs === (xs :: [Int])' "\[0,1\]" +echo +echo 'All tests passed!' diff --git a/tests/CollectDataTypes.hs b/tests/CollectDataTypes.hs new file mode 100644 --- /dev/null +++ b/tests/CollectDataTypes.hs @@ -0,0 +1,199 @@ +{-# LANGUAGE TemplateHaskell, RecordWildCards, DeriveLift, TupleSections, CPP, TypeOperators #-} +module CollectDataTypes where + +import Language.Haskell.TH +import Language.Haskell.TH.Syntax +import Language.Haskell.TH.Ppr +import Language.Haskell.Interpreter hiding (lift) +import Data.Maybe +import Data.List +import System.Process +import Data.List.Split +import Control.Monad +import Control.Monad.Trans.Maybe +import Control.Monad.IO.Class +import Text.Printf +import Data.Either +import Data.Char +import Data.Function +import Test.QuickCheck +import Test.QuickCheck.Function + +data DataType = + DataType { + dt_package :: String, + dt_module :: String, + dt_type :: String } + deriving (Show, Lift) + +getPackageDataTypes :: String -> IO [DataType] +getPackageDataTypes pkg = do + mods <- filter isValidModule <$> getPackageModules pkg + typess <- mapM getModuleDataTypes mods + return [DataType pkg mod typ | (mod, types) <- zip mods typess, typ <- types] + +getPackageModules :: String -> IO [String] +getPackageModules pkg = + concatMap (parseWords . words) . splitOn ", " . unwords . words <$> readProcess cmd args "" + where + cmd:args = ["ghc-pkg", "field", pkg, "exposed-modules", "--simple-output"] + parseWords [mod, "from", _] = [mod] + parseWords xs = xs + +getModuleDataTypes :: String -> IO [String] +getModuleDataTypes mod = do + putStrLn mod + Right names <- runInterpreter $ getModuleExports mod + return [x | Data x _ <- names] + +haskellName :: DataType -> String +haskellName DataType{..} = printf "%s.%s" dt_module (stripParens dt_type) + where + stripParens = reverse . dropWhile (== ')') . reverse . dropWhile (== '(') + +dataTypeType :: DataType -> Q (Maybe Type) +dataTypeType dt = do + mname <- lookupTypeName (haskellName dt) + case mname of + Nothing -> return Nothing + Just name -> Just <$> reifyType name + +typeArity :: Type -> Maybe Int +typeArity (AppT (AppT ArrowT StarT) kind) = succ <$> typeArity kind +typeArity StarT = return 0 +typeArity _ = Nothing + +createProperties :: String -> Q [Dec] +createProperties pkg = do + datatypes0 <- runIO (getPackageDataTypes pkg) + let datatypes = [ dt | dt <- datatypes0, not $ haskellName dt `elem` typeBlacklist ] + let mkImport dt = printf "import %s -- for %s" (dt_module dt) (dt_type dt) + missingModules <- fmap (map mkImport . nubBy ((==) `on` dt_module)) $ filterM (\ dt -> isNothing <$> dataTypeType dt) datatypes + unless (null missingModules) $ error ("Missing the following imports:\n" ++ unlines missingModules) + namesAndDecs <- fmap concat $ mapM createProperty datatypes + let (allNames, props) = unzip namesAndDecs + allPropsDec <- [d| allProps = + $(pure $ ListE [ TupE [Just (LitE (StringL $ nameBase name)), Just (VarE name)] + | name <- allNames ] + ) + |] + return $ allPropsDec ++ props + +createProperty :: DataType -> Q [(Name, Dec)] +createProperty dt = do + mtype <- dataTypeType dt + -- TODO: monad?! + case mtype of + Nothing -> error $ "Can't find type in scope " ++ show dt + Just typ -> case typeArity typ of + Nothing -> pure [] + Just arity -> do + Just name <- lookupTypeName (haskellName dt) + Just int <- lookupTypeName "Int" + nm <- newName ("prop_" ++ filter isAlphaNum (haskellName dt)) + nmCo <- newName ("prop_co_" ++ filter isAlphaNum (haskellName dt)) + nmFunction <- newName ("prop_function_" ++ filter isAlphaNum (haskellName dt)) + let propName = pure $ VarP nm + let propNameCo = pure $ VarP nmCo + let propNameFunction = pure $ VarP nmFunction + let ty = pure $ foldl AppT (ConT name) $ replicate arity (ConT int) + dArbitrary <- map (nm,) <$> [d| $propName = forAllBlind (arbitrary :: Gen $ty) (\ x -> x `seq` True) |] + dCoArbitrary <- map (nmCo,) <$> [d| $propNameCo = forAllBlind (arbitrary :: Gen ($ty -> Integer)) (\ x -> x `seq` True) |] + dFunction <- map (nmFunction,) <$> [d| $propNameFunction = forAllBlind (arbitrary :: Gen ($ty :-> Integer)) (\ x -> x `seq` True) |] + return $ dArbitrary ++ dCoArbitrary ++ dFunction + +typeBlacklist :: [String] +typeBlacklist = [ "Prelude.IO" + , "Prelude.ReadS" + , "Prelude.ShowS" + , "System.IO.IO" + , "System.IO.Error.IOError" + , "Prelude.IOError" + , "Data.Kind.Type" + , "Data.Array.Byte.MutableByteArray" + , "Data.IORef.IORef" + , "Data.Kind.Constraint" + , "Data.Unique.Unique" + , "Data.STRef.STRef" + , "Data.STRef.Lazy.STRef" + , "Data.STRef.Strict.STRef" + , "Data.Void.Void" + , "Data.Proxy.KProxy" + , "Data.Monoid.Endo" + , "Data.Semigroup.Endo" + , "Data.List.[]" -- This is buggy and annoying + , "System.IO.HandlePosn" + , "System.IO.Handle" + , "Text.Printf.FieldFormatter" -- This is a function type and it + -- requires an annoying coarbitrary instance + , "Text.Printf.ModifierParser" + , "Text.Show.ShowS" + ] ++ + -- These are phantom types used for indexing + [ "Data.Fixed.E" ++ show i | i <- [0,1,2,3,6,9,12] ] ++ +#if MIN_VERSION_base(4,15,0) + -- Exists but is deprecated + [ "Data.Semigroup.Option" ] ++ +#endif + -- TODO: Some controversial ones? + [ "System.IO.Error.IOErrorType" ] ++ + -- Some higher order types we ignore for the sake of CoArbitrary and Function issues + [ "System.Console.GetOpt.OptDescr" + , "System.Console.GetOpt.ArgOrder" + , "System.Console.GetOpt.ArgDescr" + ] ++ + -- System specific and, likewise, not easily doable in Function + [ "System.IO.TextEncoding" ] ++ + -- Ignored for `Function` because the test monomorphises to `Int`. fixme. + [ "Data.Complex.Complex" ] + + + + +modulePrefixBlacklist :: [String] +modulePrefixBlacklist = [ "GHC" + , "Foreign" + , "Control.Exception" + -- Exports things like MVar etc + , "Control.Concurrent" + -- Exports ST and RealWorld that we can't support + , "Control.Monad.ST" + -- Existential wrapper around a Typeable thing, could + -- be supported but would be a bit artificially + -- limited to wrapping a bunch of types we can list + , "Data.Dynamic" + -- We _could_ support this, but it would result in + -- the same problem as with Dynamic + , "Data.Typeable" + , "Type.Reflection" + -- System.Mem.Weak and System.Mem.Stable export + -- pointer types we don't support + , "System.Mem" + -- Exports an exception + , "System.Timeout" + -- Exports types, but not the constructors (or ways of + -- creating them, e.g. Number). No feasible way to + -- create meaningful generator + , "Text.Read" + -- Old generics implementation that doesn't fit nicely + -- with arbitrary, as it has the same kind of problem + -- that Typeable and Dynamic face + , "Data.Data" + -- Platform specific types that one could implement but + -- would be tricky to keep consistent and correct + -- across a number of platforms, esp. since we don't + -- have good CI tests for them + , "System.Posix" + -- This exports a bunch of combinators whose only real + -- role is to build a parser of an opaque type, + -- consequently there isn't some super-interesting + -- useful work you can do with it and it should be OK + -- not to provide instances for it + , "Text.ParserCombinators.ReadP" + -- Slightly controversial, but this is only ignored for + -- the sake of CoArbitrary and Function + , "Data.Functor.Contravariant" + ] + +isValidModule :: String -> Bool +isValidModule mod = not $ any (`isPrefixOf` mod) modulePrefixBlacklist diff --git a/tests/DiscardRatio.hs b/tests/DiscardRatio.hs new file mode 100644 --- /dev/null +++ b/tests/DiscardRatio.hs @@ -0,0 +1,56 @@ +module Main where + +import Control.Monad +import System.Exit +import Test.QuickCheck + +assert :: String -> Bool -> IO () +assert s False = do + putStrLn $ s ++ " failed!" + exitFailure +assert _ _ = return () + +quickCheckYesWith, quickCheckNoWith :: Testable p => Args -> p -> IO () +quickCheckYesWith args p = do + res <- quickCheckWithResult args p + unless (isSuccess res) exitFailure +quickCheckNoWith args p = do + res <- quickCheckWithResult args p + when (isSuccess res) exitFailure +quickCheckYes, quickCheckNo :: Testable p => p -> IO () +quickCheckYes = quickCheckYesWith stdArgs +quickCheckNo = quickCheckNoWith stdArgs + +check :: Result -> Int -> Int -> IO () +check res n d = do + quickCheckYes $ once $ n === numTests res + quickCheckYes $ once $ d === numDiscarded res + +main :: IO () +main = do + putStrLn "Expecting gave up after 200 tries: False ==> True" + res <- quickCheckResult $ withDiscardRatio 2 $ False ==> True + check res 0 200 + res <- quickCheckWithResult stdArgs{maxDiscardRatio = 2} $ False ==> True + check res 0 200 + + putStrLn "\nExpecting success after 100 tests: x == x" + res <- quickCheckResult $ withDiscardRatio 2 $ \ x -> (x :: Int) == x + check res 100 0 + res <- quickCheckWithResult stdArgs{maxDiscardRatio = 2} $ \ x -> (x :: Int) == x + check res 100 0 + + -- The real ratio is 20, if 1 works or 40 doesn't it's + -- probably because we broke something! + let p50 = forAll (choose (1, 1000)) $ \ x -> (x :: Int) < 50 ==> True + putStrLn "\nExpecting failure (discard ratio 1): x < 50 ==> True" + quickCheckNo $ withDiscardRatio 1 p50 + quickCheckNoWith stdArgs{maxDiscardRatio = 1} p50 + putStrLn "\nExpecting success (discard ratio 40): x < 50 ==> True" + quickCheckYes $ withDiscardRatio 40 p50 + quickCheckYesWith stdArgs{maxDiscardRatio = 40} p50 + + -- Annoying interactions of discard and cover + quickCheckYes $ forAllBlind (oneof [return True, return discard]) $ \ b -> cover 10 b "b" True + quickCheck $ cover 10 discard "b" True + quickCheck $ classify discard "b" True diff --git a/tests/GCoArbitraryExample.hs b/tests/GCoArbitraryExample.hs --- a/tests/GCoArbitraryExample.hs +++ b/tests/GCoArbitraryExample.hs @@ -17,7 +17,7 @@ prop_coarbitrary (Fun _ f) = expectFailure $ - withMaxSuccess 1000 $ + withNumTests 1000 $ f (C1 (2::Int)) `elem` [0, 1 :: Int] return [] diff --git a/tests/Generators.hs b/tests/Generators.hs --- a/tests/Generators.hs +++ b/tests/Generators.hs @@ -29,7 +29,7 @@ path p (Path xs) = all p xs somePath :: (a -> Bool) -> Path a -> Property -somePath p = expectFailure . withMaxSuccess 1000 . path (not . p) +somePath p = expectFailure . withNumTests 1000 . path (not . p) newtype Extremal a = Extremal { getExtremal :: a } deriving (Show, Eq, Ord, Num, Enum, Real, Integral) @@ -139,7 +139,7 @@ reachesBound :: (Bounded a, Integral a, Arbitrary a) => a -> Property -reachesBound x = withMaxSuccess 1000 (expectFailure (x < 3 * (maxBound `div` 4))) +reachesBound x = withNumTests 1000 (expectFailure (x < 3 * (maxBound `div` 4))) prop_reachesBound_Int8 = reachesBound :: Int8 -> Property prop_reachesBound_Int16 = reachesBound :: Int16 -> Property diff --git a/tests/Misc.hs b/tests/Misc.hs --- a/tests/Misc.hs +++ b/tests/Misc.hs @@ -3,6 +3,8 @@ {-# LANGUAGE TemplateHaskell #-} import Test.QuickCheck import Test.QuickCheck.Random +import Data.Map +import Control.Monad prop_verbose :: Blind (Int -> Int -> Bool) -> Property prop_verbose (Blind p) = @@ -20,7 +22,29 @@ let [x, y, z] = failingTestCase res return (not (p (read x) (read y) (read z))) +prop_maxSize :: Property +prop_maxSize = withMaxSize 10 (forAll (arbitrary :: Gen Int) $ \ x -> abs x < 10) + +prop_cover :: Property +prop_cover = withNumTests 1000 + $ checkCoverage + $ forAll (arbitrary :: Gen Int) + $ \ x -> cover 5 (x > 0) "positive" True + +-- Issue #382 +prop_discardCoverage :: Property +prop_discardCoverage = checkCoverage $ forAll (sized $ \ n -> pure n) $ \ x -> cover 10 True "label" $ x /= 99 ==> True + return [] main = do True <- $quickCheckAll - return () + Success{classes=cls} <- quickCheckResult $ classify False "A" $ classify True "B" True + [("A",0),("B",100)] <- return $ toList cls + Success{numTests=1000} <- quickCheckResult prop_cover + forM_ [const discard, const [discard], \ x -> discard : shrink x] $ \ shr -> do + Failure{reason="Falsified"} <- quickCheckResult $ forAllShrink arbitrary shr (odd :: Int -> Bool) + return () + -- These shouldn't crash + sample (discard :: Gen Int) + sample (oneof [discard, return 1] :: Gen Int) + sample (oneof [return (1, discard), return (1, 1)] :: Gen (Int, Int)) diff --git a/tests/Monoids.hs b/tests/Monoids.hs new file mode 100644 --- /dev/null +++ b/tests/Monoids.hs @@ -0,0 +1,146 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE ConstraintKinds #-} + +#if __GLASGOW_HASKELL__ >= 800 +{-# OPTIONS_GHC -Wno-orphans #-} +#endif +{-# LANGUAGE FlexibleInstances #-} + +module Main (main) where + +#ifndef NO_SEMIGROUP_CLASS +import Data.List.NonEmpty +import Data.Semigroup (Semigroup (..)) +#else +import Data.Monoid (Monoid (..), (<>)) +#endif + +import Test.QuickCheck + +#ifdef NO_SEMIGROUP_CLASS +type Semigroup = Monoid +sconcat :: Monoid a => [a] -> a +sconcat = mconcat +#endif + +instance Arbitrary Every where + arbitrary = oneof [ pure $ Every True + , pure $ Every False + , pure $ Every (counterexample "False" False) + , pure $ Every (counterexample "True" True) + , pure $ Every (ioProperty (return True)) + , pure $ Every (ioProperty (return False)) + , pure $ Every (checkCoverage $ cover 100 True "" True) + , pure $ Every (checkCoverage $ cover 100 True "" False) + , pure $ Every (checkCoverage $ cover 100 False "" False) + ] + + +instance Arbitrary Some where + arbitrary = oneof [ pure $ Some True + , pure $ Some False + , pure $ Some (counterexample "False" False) + , pure $ Some (counterexample "True" True) + , pure $ Some (ioProperty (return True)) + , pure $ Some (ioProperty (return False)) + , pure $ Some (checkCoverage $ cover 100 True "" True) + , pure $ Some (checkCoverage $ cover 100 True "" False) + , pure $ Some (checkCoverage $ cover 100 False "" True) + , pure $ Some (checkCoverage $ cover 100 False "" False) + ] + + +newtype Fail a = Fail a + +instance Arbitrary (Fail Every) where + arbitrary = oneof [ Fail <$> (arbitrary :: Gen Every) + , pure $ Fail $ Every (checkCoverage $ cover 100 False "" True) + ] + + +check_associative_law :: (Testable p, Semigroup p) => Blind p -> Blind p -> Blind p -> Property +check_associative_law (Blind a) (Blind b) (Blind c) = ioProperty $ do + x <- isSuccess <$> quickCheckWithResult args (a <> (b <> c)) + y <- isSuccess <$> quickCheckWithResult args ((a <> b) <> c) + return (x == y) + + +#ifndef NO_SEMIGROUP_SUPERCLASS +check_unit_law :: (Testable p, Monoid p) => Blind p -> Property +#else +check_unit_law :: (Testable p, Monoid p, Semigroup p) => Blind p -> Property +#endif +check_unit_law (Blind a) = ioProperty $ do + x <- isSuccess <$> quickCheckWithResult args (a <> mempty) + y <- isSuccess <$> quickCheckWithResult args (mempty <> a) + z <- isSuccess <$> quickCheckWithResult args a + return (x == y .&&. y == z) + + +#ifndef NO_SEMIGROUP_CLASS +check_sconcat_law :: (Testable p, Semigroup p) => Blind p -> Blind p -> Property +check_sconcat_law (Blind a) (Blind b) = ioProperty $ do + x <- isSuccess <$> quickCheckWithResult args (sconcat $ a :| [b]) + y <- isSuccess <$> quickCheckWithResult args (a <> b) + return (x == y) +#endif + + +#ifndef NO_SEMIGROUP_SUPERCLASS +check_mconcat_law :: (Testable p, Monoid p) => Blind p -> Blind p -> Property +#else +check_mconcat_law :: (Testable p, Monoid p, Semigroup p) => Blind p -> Blind p -> Property +#endif +check_mconcat_law (Blind a) (Blind b) = ioProperty $ do + x <- isSuccess <$> quickCheckWithResult args (mconcat [a, b]) + y <- isSuccess <$> quickCheckWithResult args (a <> b) + return (x == y) + + +-- +-- Auxiliary definitions +-- + +args :: Args +args = stdArgs { chatty = False, maxShrinks = 0 } + +-- +-- Properties +-- + +prop_every_associative :: Blind Every -> Blind Every -> Blind Every -> Property +prop_every_associative = check_associative_law + +prop_every_unit :: Blind Every -> Property +prop_every_unit = check_unit_law + +prop_every_unit_fail :: Blind (Fail Every) -> Property +prop_every_unit_fail (Blind (Fail a)) = + expectFailure $ check_unit_law (Blind a) + +#ifndef NO_SEMIGROUP_CLASS +prop_every_sconcat_law :: Blind Every -> Blind Every -> Property +prop_every_sconcat_law = check_sconcat_law +#endif + +prop_every_mconcat_law :: Blind Every -> Blind Every -> Property +prop_every_mconcat_law = check_mconcat_law + +prop_some_associative :: Blind Some -> Blind Some -> Blind Some -> Property +prop_some_associative = check_associative_law + +prop_some_unit :: Blind Some -> Property +prop_some_unit = check_unit_law + +#ifndef NO_SEMIGROUP_CLASS +prop_some_sconcat_law :: Blind Some -> Blind Some -> Property +prop_some_sconcat_law = check_sconcat_law +#endif + +prop_some_mconcat_law :: Blind Some -> Blind Some -> Property +prop_some_mconcat_law = check_mconcat_law + +return [] +main = do True <- $quickCheckAll; return () + diff --git a/tests/RunCollectDataTypes.hs b/tests/RunCollectDataTypes.hs new file mode 100644 --- /dev/null +++ b/tests/RunCollectDataTypes.hs @@ -0,0 +1,89 @@ +{-# LANGUAGE TemplateHaskell, CPP #-} +{-# OPTIONS_GHC -ddump-splices #-} +import CollectDataTypes +import Language.Haskell.TH +import Test.QuickCheck.All +import Test.QuickCheck + +import Control.Applicative +import Control.Arrow +import Control.Concurrent +import Control.Concurrent.Chan +import Control.Concurrent.MVar +import Control.Concurrent.QSem +import Control.Concurrent.QSemN +import Control.Exception +import Control.Exception.Base +import Control.Monad.ST +import Control.Monad.ST.Lazy +import Control.Monad.ST.Strict +#if defined(MIN_VERSION_base) +#if MIN_VERSION_base(4,17,0) +import Data.Array.Byte +#endif +#endif +import Data.Bits +import Data.Bool +import Data.Char +import Data.Complex +import Data.Data +import Data.Dynamic +import Data.Either +import Data.Fixed +import Data.Functor.Compose +import Data.Functor.Const +import Data.Functor.Contravariant +import Data.Functor.Identity +import Data.Functor.Product +import Data.Functor.Sum +import Data.IORef +import Data.Int +import Data.Kind +import Data.List.NonEmpty +import Data.Maybe +import Data.Monoid +import Data.Ord +import Data.Proxy +import Data.Ratio +import Data.STRef +import Data.STRef.Lazy +import Data.STRef.Strict +import Data.Semigroup +import Data.String +import Data.Tuple +import Data.Type.Bool +import Data.Type.Coercion +import Data.Type.Equality +#if defined(MIN_VERSION_base) +#if MIN_VERSION_base(4,16,0) +import Data.Type.Ord +#endif +#endif +import Data.Typeable +import Data.Unique +import Data.Version +import Data.Void +import Data.Word +import Numeric.Natural +import System.Console.GetOpt +import System.Exit +import System.IO +import System.IO.Error +import System.Mem.StableName +import System.Mem.Weak +import System.Posix.Internals +import System.Posix.Types +import System.Timeout +import Text.ParserCombinators.ReadP +import Text.ParserCombinators.ReadPrec +import Text.Printf +import Text.Read +import Text.Read.Lex +import Text.Show +import Type.Reflection +import Type.Reflection.Unsafe +import Unsafe.Coerce + +$(createProperties "base") + +main = runQuickCheckAll allProps quickCheckResult diff --git a/tests/Strictness.hs b/tests/Strictness.hs new file mode 100644 --- /dev/null +++ b/tests/Strictness.hs @@ -0,0 +1,42 @@ +-- Strictness tests. + +{-# LANGUAGE CPP, TemplateHaskell #-} +import Test.QuickCheck + +import Control.Exception (Exception (..), throw) + +#if MIN_VERSION_containers(0,5,0) +import Control.Exception (evaluate, try) +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as Map +#endif + +data Thunk + +instance Arbitrary Thunk where + arbitrary = throw ThunkError + +instance Show Thunk where + show _ = "Thunk" + +data ThunkError = ThunkError deriving Show + +instance Exception ThunkError + +prop_strictMap :: Property +#if MIN_VERSION_containers(0,5,0) +prop_strictMap = again . ioProperty $ do + m <- generate arbitrary + result <- try $ evaluate m :: IO (Either ThunkError (Map Int Thunk)) + pure $ case result of + Right _ | not (Map.null m) -> counterexample ("Thunks in Map: " ++ show m) False + _ -> property True +#else +prop_strictMap = once $ property True +#endif + +return [] +main :: IO () +main = do + True <- $quickCheckAll + return () diff --git a/tests/Terminal.hs b/tests/Terminal.hs --- a/tests/Terminal.hs +++ b/tests/Terminal.hs @@ -63,7 +63,7 @@ -- * Anything written to stderr (presumably by putTemp) is erased prop_terminal :: [Command] -> Property prop_terminal cmds = - withMaxSuccess 1000 $ ioProperty $ + withNumTests 1000 $ ioProperty $ withPipe $ \stdout_read stdout_write -> withPipe $ \stderr_read stderr_write -> do out <- withHandleTerminal stdout_write (Just stderr_write) $ \tm -> do diff --git a/tests/WithProgress.hs b/tests/WithProgress.hs new file mode 100644 --- /dev/null +++ b/tests/WithProgress.hs @@ -0,0 +1,68 @@ +import Test.QuickCheck +import Test.QuickCheck.Monadic + +import Data.IORef +import System.Exit (exitSuccess, exitFailure) +import Control.Monad (when) + +main :: IO () +main = do + succ <- newIORef 0 + disc <- newIORef 0 + + -- test 1 + quickCheck (propTestWithProgress succ) + i <- readIORef succ + when (i /= 99) exitFailure + + modifyIORef succ (const 0) + + -- test 2 + quickCheck (proptestWithProgressDiscard succ disc) + i1 <- readIORef succ + i2 <- readIORef disc + putStrLn $ show i1 + putStrLn $ show i2 + when (i1 /= 0 || i2 /= 999) exitFailure + + modifyIORef succ (const 0) + modifyIORef disc (const 0) + + -- test 3 + quickCheck (proptestWithProgressNotInstalled succ disc) + i1 <- readIORef succ + i2 <- readIORef disc + putStrLn $ show i1 + putStrLn $ show i2 + when (i1 /= 0 || i2 /= 0) exitFailure + + exitSuccess + +-- all these tests succeed, incrementing the counter every time +propTestWithProgress :: IORef Int -> Property +propTestWithProgress ref = + forAll (arbitrary :: Gen Int) $ \n -> + withProgress (\p -> modifyIORef ref (\_ -> currentPassed p)) + $ n == n + +-- all of these tests are discarded, never updating the currentPassed counter, but always +-- the currentDiscarded one. +proptestWithProgressDiscard :: IORef Int -> IORef Int -> Property +proptestWithProgressDiscard succ disc = + forAll (arbitrary :: Gen Int) $ \n -> + withProgress (\p -> do + modifyIORef succ (\_ -> currentPassed p) + modifyIORef disc (\_ -> currentDiscarded p)) + $ n > 1000 ==> + n == n + +-- The callback is installed after the test on n, meaning that since all tests are +-- discarded, it will never be called. It will never be executed. +proptestWithProgressNotInstalled :: IORef Int -> IORef Int -> Property +proptestWithProgressNotInstalled succ disc = + forAll (arbitrary :: Gen Int) $ \n -> + n > 1000 ==> + withProgress (\p -> do + modifyIORef succ (\_ -> currentPassed p) + modifyIORef disc (\_ -> currentDiscarded p)) + $ n == n