QuickCheck 2.14.2 → 2.18.0.0

raw patch · 41 files changed

Files

• QuickCheck.cabal +92/−49
• README +1/−3
• changelog +0/−381
• changelog.md +457/−0
• examples/Heap.hs +12/−15
• examples/Heap_Program.hs +1/−1
• examples/Heap_ProgramAlgebraic.hs +1/−1
• examples/Merge.hs +1/−1
• examples/Set.hs +1/−7
• examples/Simple.hs +1/−1
• make-hugs +2/−1
• src/Test/QuickCheck.hs +62/−7
• src/Test/QuickCheck/All.hs +21/−10
• src/Test/QuickCheck/Arbitrary.hs +560/−65
• src/Test/QuickCheck/Compat.hs +34/−0
• src/Test/QuickCheck/Exception.hs +5/−4
• src/Test/QuickCheck/Features.hs +28/−26
• src/Test/QuickCheck/Function.hs +183/−3
• src/Test/QuickCheck/Gen.hs +47/−14
• src/Test/QuickCheck/Gen/Unsafe.hs +2/−3
• src/Test/QuickCheck/Modifiers.hs +32/−14
• src/Test/QuickCheck/Monadic.hs +96/−7
• src/Test/QuickCheck/Monoids.hs +83/−0
• src/Test/QuickCheck/Property.hs +177/−59
• src/Test/QuickCheck/Random.hs +23/−8
• src/Test/QuickCheck/State.hs +41/−21
• src/Test/QuickCheck/Test.hs +176/−95
• src/Test/QuickCheck/Text.hs +10/−6
• test-hugs +4/−1
• test-mhs +25/−0
• tests/CollectDataTypes.hs +199/−0
• tests/DiscardRatio.hs +56/−0
• tests/GCoArbitraryExample.hs +1/−1
• tests/Generators.hs +15/−3
• tests/Misc.hs +25/−1
• tests/Monoids.hs +146/−0
• tests/RunCollectDataTypes.hs +89/−0
• tests/Split.hs +1/−1
• tests/Strictness.hs +42/−0
• tests/Terminal.hs +1/−1
• tests/WithProgress.hs +68/−0

@@ -1,5 +1,5 @@ Name: QuickCheck-Version: 2.14.2+Version: 2.18.0.0 Cabal-Version: >= 1.10 Build-type: Simple License: BSD3@@ -8,7 +8,7 @@ Author: Koen Claessen <koen@chalmers.se> Maintainer: Nick Smallbone <nick@smallbone.se> 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,19 +58,21 @@ source-repository this   type:     git   location: https://github.com/nick8325/quickcheck-  tag:      2.14.2+  tag:      2.18  flag templateHaskell   Description: Build Test.QuickCheck.All, which uses Template Haskell.   Default: True+  Manual: True  flag old-random   Description: Build against a pre-1.2.0 version of the random package.   Default: False+  Manual: False  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.@@ -77,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).@@ -86,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,@@ -106,67 +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-    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@@ -183,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@@ -203,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@@ -214,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@@ -223,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@@ -232,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

@@ -1,8 +1,6 @@ This is QuickCheck 2, a library for random testing of program properties. -Install it in the usual way:--$ cabal install+Add `QuickCheck` to your package dependencies to use it in tests or REPL.  The quickcheck-instances [1] companion package provides instances for types in Haskell Platform packages at the cost of additional dependencies.

@@ -1,381 +0,0 @@-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.

@@ -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.

@@ -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 

@@ -187,7 +187,7 @@ -- main  return []-main = $(quickCheckAll)+main = do True <- $quickCheckAll; return ()  -------------------------------------------------------------------------- -- the end.

@@ -245,7 +245,7 @@ -- main  return []-main = $(quickCheckAll)+main = do True <- $quickCheckAll; return ()  -------------------------------------------------------------------------- -- the end.

@@ -110,7 +110,7 @@ --  mapSize (`div` 2) $ \(xss :: [OrderedList Int]) ->  return []-main = $quickCheckAll+main = do True <- $quickCheckAll; return ()  -------------------------------------------------------------------------- -- the end.

@@ -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.

@@ -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.

@@ -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 

@@ -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 <http://www.cse.chalmers.se/~rjmh/QuickCheck/manual.html QuickCheck manual> 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@@ -81,6 +115,7 @@   , shrinkMapBy   , shrinkIntegral   , shrinkRealFrac+  , shrinkBoundedEnum   , shrinkDecimal      -- ** Lifting of 'Arbitrary' to unary and binary type constructors@@ -97,6 +132,11 @@   , choose   , chooseInt   , chooseInteger+#ifndef NO_SPLITMIX+  , chooseWord64+  , chooseInt64+  , chooseUpTo+#endif   , chooseBoundedIntegral   , chooseEnum   , chooseAny@@ -201,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(..)@@ -267,8 +307,13 @@   , verbose   , verboseShrinking   , noShrinking+  , withNumTests   , withMaxSuccess   , within+  , discardAfter+  , withDiscardRatio+  , withMaxSize+  , withMaxShrinks   , once   , again   , mapSize@@ -276,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@@ -310,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

@@ -1,4 +1,9 @@-{-# LANGUAGE TemplateHaskell, Rank2Types, CPP #-}+{-# LANGUAGE Rank2Types, CPP #-}+#if __GLASGOW_HASKELL__ >= 800+{-# LANGUAGE TemplateHaskellQuotes #-}+#else+{-# LANGUAGE TemplateHaskell #-}+#endif #ifndef NO_SAFE_HASKELL {-# LANGUAGE Trustworthy #-} #endif@@ -15,6 +20,7 @@   verboseCheckAll,   forAllProperties,   allProperties,+  runQuickCheckAll,   -- ** Testing polymorphic properties   polyQuickCheck,   polyVerboseCheck,@@ -24,7 +30,7 @@ import Test.QuickCheck.Property hiding (Result) import Test.QuickCheck.Test import Data.Char-import Data.List+import Data.List (isPrefixOf, nubBy) import Control.Monad  import qualified System.IO as S@@ -44,7 +50,7 @@ -- property, the same scoping problems pop up as in 'quickCheckAll': -- see the note there about @return []@. polyQuickCheck :: Name -> ExpQ-polyQuickCheck x = [| quickCheck $(monomorphic x) |]+polyQuickCheck x = [| quickCheck |] `appE` monomorphic x  -- | Test a polymorphic property, defaulting all type variables to 'Integer'. -- This is just a convenience function that combines 'verboseCheck' and 'monomorphic'.@@ -53,7 +59,7 @@ -- property, the same scoping problems pop up as in 'quickCheckAll': -- see the note there about @return []@. polyVerboseCheck :: Name -> ExpQ-polyVerboseCheck x = [| verboseCheck $(monomorphic x) |]+polyVerboseCheck x = [| verboseCheck |] `appE` monomorphic x  type Error = forall a. String -> a @@ -132,7 +138,7 @@ -- 'forAllProperties' has the same issue with scoping as 'quickCheckAll': -- see the note there about @return []@. forAllProperties :: Q Exp -- :: (Property -> IO Result) -> IO Bool-forAllProperties = [| runQuickCheckAll $allProperties |]+forAllProperties = [| runQuickCheckAll |] `appE` allProperties  -- | List all properties in the current module. --@@ -155,10 +161,15 @@       quickCheckOne :: (Int, String) -> Q [Exp]       quickCheckOne (l, x) = do         exists <- (warning x >> return False) `recover` (reify (mkName x) >> return True)-        if exists then sequence [ [| ($(stringE $ x ++ " from " ++ filename ++ ":" ++ show l),-                                     property $(monomorphic (mkName x))) |] ]+        if exists+         then sequence+          [ tupE+            [ stringE $ x ++ " from " ++ filename ++ ":" ++ show l+            , [| property |] `appE` monomorphic (mkName x)+            ]+          ]          else return []-  [| $(fmap (ListE . concat) (mapM quickCheckOne idents)) :: [(String, Property)] |]+  fmap (ListE . concat) (mapM quickCheckOne idents) `sigE` [t| [(String, Property)] |]  readUTF8File name = S.openFile name S.ReadMode >>=                     set_utf8_io_enc >>=@@ -195,7 +206,7 @@ -- of the module, which means that the later call to 'quickCheckAll' -- can see everything that was defined before the @return []@. Yikes! quickCheckAll :: Q Exp-quickCheckAll = [| $(forAllProperties) quickCheckResult |]+quickCheckAll = forAllProperties `appE` [| quickCheckResult |]  -- | Test all properties in the current module. -- This is just a convenience function that combines 'quickCheckAll' and 'verbose'.@@ -203,7 +214,7 @@ -- 'verboseCheckAll' has the same issue with scoping as 'quickCheckAll': -- see the note there about @return []@. verboseCheckAll :: Q Exp-verboseCheckAll = [| $(forAllProperties) verboseCheckResult |]+verboseCheckAll = forAllProperties `appE` [| verboseCheckResult |]  runQuickCheckAll :: [(String, Property)] -> (Property -> IO Result) -> IO Bool runQuickCheckAll ps qc =

@@ -68,6 +68,7 @@   , shrinkMapBy              -- :: (a -> b) -> (b -> a) -> (a -> [a]) -> b -> [b]   , shrinkIntegral           -- :: Integral a => a -> [a]   , shrinkRealFrac           -- :: RealFrac a => a -> [a]+  , shrinkBoundedEnum        -- :: (Bounded a, Enum a) => a -> [a]   , shrinkDecimal            -- :: RealFrac a => a -> [a]   -- ** Helper functions for implementing coarbitrary   , coarbitraryIntegral      -- :: Integral a => a -> Gen b -> Gen b@@ -88,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@@ -135,8 +138,26 @@   , nub   ) + import Data.Version (Version (..)) +#if defined(MIN_VERSION_base)+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+ import Control.Monad   ( liftM   , liftM2@@ -155,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@@ -171,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 @@ -187,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@@ -228,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)]   --@@ -399,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@@ -477,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@@ -621,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@@ -684,11 +752,55 @@                 )  instance Arbitrary Float where-  arbitrary = arbitrarySizedFractional+  arbitrary = oneof+    -- generate 0..1 numbers with full precision+    [ genFloat+    -- generate integral numbers+    , fromIntegral <$> (arbitrary :: Gen Int)+    -- generate fractions with small denominators+    , smallDenominators+    -- uniform -size..size with with denominators ~ size+    , uniform+    -- and uniform -size..size with higher precision+    , arbitrarySizedFractional+    ]+    where+      smallDenominators = sized $ \n -> do+        i <- chooseInt (0, min n 256)+        pure (fromRational (streamNth i rationalUniverse))++      uniform = sized $ \n -> do+        let n' = toInteger n+        b <- chooseInteger (1, max 1 n')+        a <- chooseInteger ((-n') * b, n' * b)+        return (fromRational (a % b))+   shrink    = shrinkDecimal  instance Arbitrary Double where-  arbitrary = arbitrarySizedFractional+  arbitrary = oneof+    -- generate 0..1 numbers with full precision+    [ genDouble+    -- generate integral numbers+    , fromIntegral <$> (arbitrary :: Gen Int)+    -- generate fractions with small denominators+    , smallDenominators+    -- uniform -size..size with with denominators ~ size+    , uniform+    -- and uniform -size..size with higher precision+    , arbitrarySizedFractional+    ]+    where+      smallDenominators = sized $ \n -> do+        i <- chooseInt (0, min n 256)+        pure (fromRational (streamNth i rationalUniverse))++      uniform = sized $ \n -> do+        let n' = toInteger n+        b <- chooseInteger (1, max 1 n')+        a <- chooseInteger ((-n') * b, n' * b)+        return (fromRational (a % b))+   shrink    = shrinkDecimal  instance Arbitrary CChar where@@ -798,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@@ -943,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@@ -951,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 ->@@ -987,8 +1264,74 @@   shrink (ExitFailure x) = ExitSuccess : [ ExitFailure x' | x' <- shrink x ]   shrink _        = [] +#if defined(MIN_VERSION_base)+instance Arbitrary Newline where+  arbitrary = elements [LF, CRLF] +  -- The behavior of code for LF is generally simpler than for CRLF+  -- See the documentation for this type, which states that Haskell+  -- Internally always assumes newlines are \n and this type represents+  -- how to translate that to and from the outside world, where LF means+  -- no translation.+  shrink LF = []+  shrink CRLF = [LF] +instance Arbitrary NewlineMode where+  arbitrary = NewlineMode <$> arbitrary <*> arbitrary++  shrink (NewlineMode inNL outNL) = [NewlineMode inNL' outNL' | (inNL', outNL') <- shrink (inNL, outNL)]++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  -- | Apply a binary function to random arguments.@@ -1010,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@@ -1024,17 +1377,14 @@ inBounds :: Integral a => (Int -> a) -> Gen Int -> Gen a inBounds fi g = fmap fi (g `suchThat` (\x -> toInteger x == toInteger (fi x))) --- | Generates a fractional number. The number can be positive or negative+-- | Uniformly generates a fractional number. The number can be positive or negative -- and its maximum absolute value depends on the size parameter. arbitrarySizedFractional :: Fractional a => Gen a arbitrarySizedFractional =-  sized $ \n ->-    let n' = toInteger n in-      do b <- chooseInteger (1, precision)-         a <- chooseInteger ((-n') * b, n' * b)-         return (fromRational (a % b))- where-  precision = 9999999999999 :: Integer+  sized $ \n -> do+    denom <- chooseInt (1, max 1 n)+    numer <- chooseInt (-n*denom, n*denom)+    pure $ fromIntegral numer / fromIntegral denom  -- Useful for getting at minBound and maxBound without having to -- fiddle around with asTypeOf.@@ -1119,7 +1469,7 @@ -- shrinkOrderedList :: (Ord a, Arbitrary a) => [a] -> [[a]] -- shrinkOrderedList = shrinkMap sort id ----- shrinkSet :: (Ord a, Arbitrary a) => Set a -> Set [a]+-- shrinkSet :: (Ord a, Arbitrary a) => Set a -> [Set a] -- shrinkSet = shrinkMap fromList toList -- @ shrinkMap :: Arbitrary a => (a -> b) -> (b -> a) -> b -> [b]@@ -1132,29 +1482,45 @@ -- | 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.+--+-- === __Example__+--+-- @+-- data MyEnum = E0 | E1 | E2 | E3 | E4 | E5 | E6 | E7 | E8 | E9+--    deriving (Bounded, Enum, Eq, Ord, Show)+-- @+--+-- >>> shrinkBoundedEnum E9+-- [E0,E5,E7,E8]+--+-- >>> shrinkBoundedEnum E5+-- [E0,E3,E4]+--+-- >>> shrinkBoundedEnum E0+-- []+--+shrinkBoundedEnum :: (Bounded a, Enum a, Eq a) => a -> [a]+shrinkBoundedEnum a+  | a == minBound =+    []+  | otherwise =+    toEnum <$> filter (>= minBoundInt) (shrinkIntegral $ fromEnum a)+  where+    minBoundInt :: Int+    minBoundInt = fromEnum (minBound `asTypeOf` a)+ -- | Shrink a fraction, preferring numbers with smaller -- numerators or denominators. See also 'shrinkDecimal'. shrinkRealFrac :: RealFrac a => a -> [a] shrinkRealFrac x-  | not (x == x)  = 0 : take 10 (iterate (*2) 0) -- NaN-  | not (2*x+1>x) = 0 : takeWhile (<x) (iterate (*2) 0) -- infinity+  | not (x == x)  = 0 : takeWhile (< 1000) numbers -- NaN+  | x > 0 && not (2*x+1>x) = 0 : takeWhile (<x) numbers -- infinity   | x < 0 = negate x:map negate (shrinkRealFrac (negate x))-  | otherwise =+  | otherwise = -- x is finite and >= 0     -- To ensure termination     filter (\y -> abs y < abs x) $       -- Try shrinking to an integer first@@ -1168,14 +1534,16 @@   where     num = numerator (toRational x)     denom = denominator (toRational x)+    numbers = iterate (*2) 1  -- | Shrink a real number, preferring numbers with shorter -- decimal representations. See also 'shrinkRealFrac'. shrinkDecimal :: RealFrac a => a -> [a] shrinkDecimal x-  | not (x == x)  = 0 : take 10 (iterate (*2) 0)        -- NaN-  | not (2*abs x+1>abs x) = 0 : takeWhile (<x) (iterate (*2) 0) -- infinity-  | otherwise =+  | not (x == x)  = 0 : takeWhile (< 1000) numbers -- NaN+  | not (2*abs x+1>abs x) = 0 : takeWhile (<x) numbers -- infinity+  | x < 0 = negate x:map negate (shrinkDecimal (negate x))+  | otherwise = -- x is finite and >= 0     -- e.g. shrink pi =     --   shrink 3 ++ map (/ 10) (shrink 31) ++     --   map (/ 100) (shrink 314) + ...,@@ -1187,6 +1555,9 @@       n <- m:shrink m,       let y = fromRational (fromInteger n / precision),       abs y < abs x ]+  where+    -- 1, 2, 3, ..., 10, 20, 30, ..., 100, 200, 300, etc.+    numbers = concat $ iterate (map (*10)) (map fromInteger [1..9])  -------------------------------------------------------------------------- -- ** CoArbitrary@@ -1298,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@@ -1379,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@@ -1397,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@@ -1430,20 +1812,96 @@   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++instance CoArbitrary a => CoArbitrary (Semigroup.Max a) where+  coarbitrary = coarbitrary . Semigroup.getMax++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) @@ -1481,6 +1939,43 @@ -- | Generates an infinite list. infiniteList :: Arbitrary a => Gen [a] infiniteList = infiniteListOf arbitrary+++--------------------------------------------------------------------------+-- ** Rational helper++infixr 5 :<+data Stream a = !a :< Stream a++streamNth :: Int -> Stream a -> a+streamNth n (x :< xs) | n <= 0    = x+                      | otherwise = streamNth (n - 1) xs++-- 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+  where+    go (x :< xs) =+      let nx = -x+          rx = recip x+          nrx = -rx+      in nx `seq` rx `seq` nrx `seq` (x :< rx :< nx :< nrx :< go xs)++-- All the rational numbers on the left side of the Calkin-Wilf tree,+-- in breadth-first order.+leftSideStream :: Stream Rational+leftSideStream = (1 % 2) :< go leftSideStream+  where+    go (x :< xs) =+        lChild `seq` rChild `seq`+        (lChild :< rChild :< go xs)+      where+        nd = numerator x + denominator x+        lChild = numerator x % nd+        rChild = nd % denominator x  -------------------------------------------------------------------------- -- the end.

@@ -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

@@ -5,9 +5,12 @@  {-# OPTIONS_HADDOCK hide #-} {-# LANGUAGE CPP #-}+#ifndef NO_SAFE_HASKELL+{-# LANGUAGE Safe #-}+#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 @@ -60,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@@ -71,8 +74,6 @@ #else     notAsync e = Just e #endif----tryEvaluateIO m = Right `fmap` m  evaluate :: a -> IO a evaluate = E.evaluate

@@ -1,3 +1,7 @@+{-# LANGUAGE CPP #-}+#ifndef NO_SAFE_HASKELL+{-# LANGUAGE Safe #-}+#endif {-# OPTIONS_HADDOCK hide #-} module Test.QuickCheck.Features where @@ -7,9 +11,10 @@ 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+import Data.List (intersperse) import Data.IORef import Data.Maybe @@ -24,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 @@ -45,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@@ -81,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

@@ -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@@ -48,6 +49,7 @@   , functionIntegral   , functionRealFrac   , functionBoundedEnum+  , functionElements   , functionVoid   , functionMapWith   , functionEitherWith@@ -82,7 +84,32 @@ 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)+import System.IO+  ( Newline(..)+  , NewlineMode(..)+  )+#endif+ #ifndef NO_FIXED import Data.Fixed #endif@@ -91,6 +118,8 @@ import GHC.Generics hiding (C) #endif +import Test.QuickCheck.Compat+ -------------------------------------------------------------------------- -- concrete functions @@ -126,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@@ -165,8 +201,12 @@ -- Use only for small types (i.e. not integers): creates -- the list @['minBound'..'maxBound']@! functionBoundedEnum :: (Eq a, Bounded a, Enum a) => (a->b) -> (a:->b)-functionBoundedEnum f = Table [(x,f x) | x <- [minBound..maxBound]]+functionBoundedEnum = functionElements [minBound..maxBound] +-- | Provides a 'Function' instance for small finite types.+functionElements :: Eq a => [a] ->  (a->b) -> (a:->b)+functionElements xs f = Table [(x,f x) | x <- xs]+ -- | Provides a 'Function' instance for types with 'RealFrac'. functionRealFrac :: RealFrac a => (a->b) -> (a:->b) functionRealFrac = functionMap toRational fromRational@@ -247,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@@ -295,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@@ -367,6 +416,23 @@ instance Function Word64 where   function = functionIntegral +#if defined(MIN_VERSION_base)+instance Function Newline where+  function = functionMap g h+    where+      g LF = False+      g CRLF = True++      h False = LF+      h True = CRLF++instance Function NewlineMode where+  function = functionMap g h+    where+      g (NewlineMode inNL outNL) = (inNL,outNL)+      h (inNL,outNL) = NewlineMode inNL outNL+#endif+ -- instances for Data.Monoid newtypes  instance Function a => Function (Monoid.Dual a) where@@ -390,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@@ -488,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 @@ -525,6 +694,9 @@ pattern Fn :: (a -> b) -> Fun a b #endif pattern Fn f <- (applyFun -> f)+#if __GLASGOW_HASKELL__ >= 802+{-# COMPLETE Fn #-}+#endif  -- | A modifier for testing binary functions. --@@ -534,14 +706,22 @@ pattern Fn2 :: (a -> b -> c) -> Fun (a, b) c #endif pattern Fn2 f <- (applyFun2 -> f)+#if __GLASGOW_HASKELL__ >= 802+{-# COMPLETE Fn2 #-}+#endif  -- | A modifier for testing ternary functions. #if __GLASGOW_HASKELL__ >= 800 pattern Fn3 :: (a -> b -> c -> d) -> Fun (a, b, c) d #endif pattern Fn3 f <- (applyFun3 -> f)+#if __GLASGOW_HASKELL__ >= 802+{-# COMPLETE Fn3 #-} #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) 

@@ -2,6 +2,9 @@ #ifndef NO_ST_MONAD {-# LANGUAGE Rank2Types #-} #endif+#ifndef NO_SAFE_HASKELL+{-# LANGUAGE Safe #-}+#endif -- | Test case generation. -- -- __Note__: the contents of this module (except for the definition of@@ -12,11 +15,12 @@ -------------------------------------------------------------------------- -- imports +import Test.QuickCheck.Exception+ import System.Random   ( Random   , random   , randomR-  , split   )  import Control.Monad@@ -32,16 +36,22 @@   ( Applicative(..) )  import Test.QuickCheck.Random-import Data.List+import Data.List (sortBy) import Data.Ord import Data.Maybe #ifndef NO_SPLITMIX-import System.Random.SplitMix(bitmaskWithRejection64', SMGen, nextInteger)+import System.Random.SplitMix(bitmaskWithRejection64', nextInteger, nextDouble, nextFloat, SMGen) #endif import Data.Word 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@@ -54,7 +64,7 @@ -- <http://hackage.haskell.org/package/quickcheck-transformer quickcheck-transformer> -- 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'.   } @@ -78,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@@ -131,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) @@ -146,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) @@ -233,13 +243,36 @@ 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 "<DISCARDED>"+                    | otherwise -> error $ unlines $ "Uncaught exception in sample: " : map ("  " ++) (lines $ show e)+                  Right () -> return ()+            | n <- [0,2..20] ]  --------------------------------------------------------------------------+-- ** Floating point++-- | Generate 'Double' in 0..1 range+genDouble :: Gen Double++-- | Generate 'Float' in 0..1 range+genFloat :: Gen Float++#ifndef NO_SPLITMIX+genDouble = MkGen $ \(QCGen g) _ -> fst (nextDouble g)+genFloat  = MkGen $ \(QCGen g) _ -> fst (nextFloat g)+#else+genDouble = choose (0,1)+genFloat  = choose (0,1)+#endif++-------------------------------------------------------------------------- -- ** Common generator combinators  -- | Generates a value that satisfies a predicate.@@ -269,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) =@@ -292,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) @@ -310,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

@@ -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

@@ -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.

@@ -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@@ -56,6 +52,7 @@   -- * Monadic specification combinators   , run   , assert+  , assertWith   , pre   , wp   , pick@@ -71,6 +68,17 @@   , monadicST   , runSTGen #endif++  -- * Exceptions++#ifndef NO_EXCEPTIONS+  , assertException+  , assertExceptionIO+#ifndef NO_DEEPSEQ+  , assertDeepException+  , assertDeepExceptionIO+#endif+#endif   ) where  --------------------------------------------------------------------------@@ -94,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 @@ -123,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@@ -150,6 +162,28 @@ assert True  = return () assert False = fail "Assertion failed" +-- | Like 'assert' but allows caller to specify an explicit message to show on failure.+--+-- __Example:__+--+-- @+-- do+--   assertWith True  "My first predicate."+--   assertWith False "My other predicate."+--   ...+-- @+--+-- @+-- Assertion failed (after 2 tests):+--     Passed: My first predicate+--     Failed: My other predicate+-- @+assertWith :: Monad m => Bool -> String -> PropertyM m ()+assertWith condition msg = do+    let prefix = if condition then "Passed: " else "Failed: "+    monitor $ counterexample $ prefix ++ msg+    assert condition+ -- should think about strictness/exceptions here -- | Tests preconditions. Unlike 'assert' this does not cause the -- property to fail, rather it discards them just like using the@@ -273,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  --------------------------------------------------------------------------

@@ -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

@@ -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) @@ -217,12 +213,12 @@   fmap f (MkRose x rs) = MkRose (f x) [ fmap f r | r <- rs ]  instance Applicative Rose where-  pure = return+  pure x = MkRose x []   -- f must be total   (<*>) = liftM2 ($)  instance Monad Rose where-  return x = MkRose x []+  return = pure   -- k must be total   m >>= k  = joinRose (fmap k m) @@ -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@@ -778,21 +881,35 @@ -- -- Bad: @prop_foo a b c = ...; main = quickCheck (within 1000000 prop_foo)@ within :: Testable prop => Int -> prop -> Property-within n = mapRoseResult f+within n = onTimeout+   (failed { reason = "Timeout of " ++ show n ++ " microseconds exceeded." })+   n++-- | Discards the test case if it does not complete within the given+-- number of microseconds. This can be useful when testing algorithms+-- that have pathological cases where they run extremely slowly.+discardAfter :: Testable prop => Int -> prop -> Property+discardAfter n = onTimeout+   (rejected { reason = "Timeout of " ++ show n ++ " microseconds exceeded." })+   n++onTimeout :: Testable prop => Result -> Int -> prop -> Property+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`         timeoutResult       return (MkRose res' (map f roses))--    timeoutResult = failed { reason = "Timeout of " ++ show n ++ " microseconds exceeded." } #ifdef NO_TIMEOUT     timeout _ = fmap Just #endif ++ -- | Explicit universal quantification: uses an explicitly given -- test case generator. forAll :: (Show a, Testable prop)@@ -826,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))@@ -883,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))@@ -917,6 +1030,9 @@                    abort = False,                    maybeNumTests = Nothing,                    maybeCheckCoverage = Nothing,+                   maybeDiscardedRatio = Nothing,+                   maybeMaxShrinks = Nothing,+                   maybeMaxTestSize = Nothing,                    labels = [],                    classes = [],                    tables = [],@@ -927,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

@@ -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

@@ -1,3 +1,7 @@+{-# LANGUAGE CPP #-}+#ifndef NO_SAFE_HASKELL+{-# LANGUAGE Safe #-}+#endif {-# OPTIONS_HADDOCK hide #-} -- | QuickCheck's internal state. Internal QuickCheck module. module Test.QuickCheck.State where@@ -21,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@@ -57,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.

@@ -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 =

@@ -1,3 +1,7 @@+{-# LANGUAGE CPP #-}+#ifndef NO_SAFE_HASKELL+{-# LANGUAGE Safe #-}+#endif {-# OPTIONS_HADDOCK hide #-} -- | Terminal control and text helper functions. Internal QuickCheck module. module Test.QuickCheck.Text@@ -43,7 +47,7 @@   )  import Data.IORef-import Data.List+import Data.List (intersperse, transpose) import Text.Printf import Test.QuickCheck.Exception @@ -222,11 +226,11 @@ putLine tm s = putPart tm (s ++ "\n")  putTemp tm@(MkTerminal _ tmp _ err) s =-  do n <- readIORef tmp-     err $-       replicate n ' ' ++ replicate n '\b' ++-       s ++ [ '\b' | _ <- s ]-     writeIORef tmp (length s)+  do oldLen <- readIORef tmp+     let newLen = length s+         maxLen = max newLen oldLen+     err $ s ++ replicate (maxLen - newLen) ' ' ++ replicate maxLen '\b'+     writeIORef tmp newLen  -------------------------------------------------------------------------- -- the end.

@@ -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!'

@@ -0,0 +1,25 @@+#!/bin/sh++set -e++mcabal -r install++die() {+    echo "TEST FAILED"+    exit 1+}++dotest() {+  cat >Main.hs <<EOF+import $1+main = $2+EOF+  mhs Main.hs -oMain && ./Main | tee mhs.output+  grep -q "$3" mhs.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!'

@@ -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

@@ -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

@@ -17,7 +17,7 @@  prop_coarbitrary (Fun _ f) =   expectFailure $-  withMaxSuccess 1000 $+  withNumTests 1000 $   f (C1 (2::Int)) `elem` [0, 1 :: Int]  return []

@@ -1,7 +1,7 @@ {-# LANGUAGE TemplateHaskell, GeneralizedNewtypeDeriving, Rank2Types, NoMonomorphismRestriction #-} import Test.QuickCheck import Test.QuickCheck.Gen.Unsafe-import Data.List+import Data.List (inits, sort, nub) import Data.Int import Data.Word import Data.Version@@ -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@@ -203,6 +203,18 @@  prop_B1 :: B1 -> Property prop_B1 (B1 n) = expectFailure $ n === n + 1++-- Double properties:++-- We occasionaly generate duplicates.+prop_double_duplicate_list :: [Double] -> Property+prop_double_duplicate_list xs = expectFailure $ nub xs === xs where+  sorted = sort xs++-- And enough numbers to show basic IEEE pit falls.+prop_double_assoc :: Double -> Double -> Double -> Property+prop_double_assoc x y z = expectFailure $ x + (y + z) === (x + y) + z+  return [] main = do True <- $forAllProperties (quickCheckWithResult stdArgs { maxShrinks = 10000 }); return ()

@@ -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))

@@ -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 ()+

@@ -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

@@ -1,6 +1,6 @@ import Test.QuickCheck import Test.QuickCheck.Random-import Data.List+import Data.List (group, isPrefixOf, sort)  -- This type allows us to run integerVariant and get a list of bits out. newtype Splits = Splits { unSplits :: [Bool] } deriving (Eq, Ord, Show)

@@ -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 ()

@@ -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

@@ -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