diff --git a/QuickCheck.cabal b/QuickCheck.cabal --- a/QuickCheck.cabal +++ b/QuickCheck.cabal @@ -1,5 +1,5 @@ Name: QuickCheck -Version: 2.15.0.1 +Version: 2.18.0.0 Cabal-Version: >= 1.10 Build-type: Simple License: BSD3 @@ -8,15 +8,7 @@ Author: Koen Claessen Maintainer: Nick Smallbone Bug-reports: https://github.com/nick8325/quickcheck/issues -Tested-with: GHC == 7.0.4 || - == 7.2.2 || - == 7.4.1 || - == 7.4.2 || - == 7.6.3 || - == 7.8.4 || - == 7.10.3 || - == 8.0.2 || - >= 8.2.2 && < 9.10 +Tested-with: GHC >= 8.10 && < 9.15, hugs Homepage: https://github.com/nick8325/quickcheck Category: Testing Synopsis: Automatic testing of Haskell programs @@ -47,7 +39,7 @@ extra-source-files: README - changelog + changelog.md examples/Heap.hs examples/Heap_Program.hs examples/Heap_ProgramAlgebraic.hs @@ -57,6 +49,7 @@ examples/Simple.hs make-hugs test-hugs + test-mhs source-repository head type: git @@ -65,7 +58,7 @@ source-repository this type: git location: https://github.com/nick8325/quickcheck - tag: 2.15.0.1 + tag: 2.18 flag templateHaskell Description: Build Test.QuickCheck.All, which uses Template Haskell. @@ -79,7 +72,7 @@ library Hs-source-dirs: src - Build-depends: base >=4.3 && <5, containers + Build-depends: base >=4.14 && <5, containers Default-language: Haskell2010 -- New vs old random. @@ -87,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). @@ -98,13 +91,18 @@ else 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, @@ -116,57 +114,41 @@ Test.QuickCheck.Features -- GHC-specific modules. - if impl(ghc) + if impl(ghc) || impl(mhs) Exposed-Modules: Test.QuickCheck.Function Build-depends: transformers >= 0.3, deepseq >= 1.1.0.0 - else - cpp-options: -DNO_TRANSFORMERS -DNO_DEEPSEQ if impl(ghc) && flag(templateHaskell) Build-depends: template-haskell >= 2.4 - if impl(ghc >=8.0) - Other-Extensions: TemplateHaskellQuotes - else - Other-Extensions: TemplateHaskell + Other-Extensions: TemplateHaskellQuotes Exposed-Modules: Test.QuickCheck.All else cpp-options: -DNO_TEMPLATE_HASKELL - if !impl(ghc >= 8.0) + if !impl(ghc) && !impl(mhs) cpp-options: -DNO_CALLSTACK - - 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 + -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 - - if !impl(ghc >= 7.6) - cpp-options: -DNO_POLYKINDS - - if !impl(ghc >= 8.0) - cpp-options: -DNO_MONADFAIL + , containers >=0.4.2.1 if impl(ghc >= 9.8) ghc-options: -Wno-x-partial + 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 @@ -175,17 +157,14 @@ 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 @@ -202,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 @@ -222,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 @@ -233,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 @@ -242,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 @@ -260,7 +235,7 @@ hs-source-dirs: tests main-is: Strictness.hs build-depends: base, QuickCheck, containers - if !flag(templateHaskell) || !impl(ghc >= 7.10) + if !flag(templateHaskell) buildable: False Test-Suite test-quickcheck-misc @@ -269,7 +244,7 @@ hs-source-dirs: tests main-is: Misc.hs build-depends: base, QuickCheck, containers - if !flag(templateHaskell) || !impl(ghc >= 7.10) + if !flag(templateHaskell) buildable: False Test-Suite test-quickcheck-discard @@ -278,3 +253,34 @@ hs-source-dirs: tests main-is: DiscardRatio.hs build-depends: base, QuickCheck + +Test-Suite test-quickcheck-monoids + type: exitcode-stdio-1.0 + Default-language: Haskell2010 + hs-source-dirs: tests + main-is: Monoids.hs + build-depends: base, QuickCheck + +Test-Suite test-quickcheck-withprogress + type: exitcode-stdio-1.0 + Default-language: Haskell2010 + hs-source-dirs: tests + main-is: WithProgress.hs + build-depends: base, QuickCheck + +Test-Suite test-quickcheck-instances + type: exitcode-stdio-1.0 + Default-language: Haskell2010 + hs-source-dirs: tests + other-modules: CollectDataTypes + main-is: RunCollectDataTypes.hs + build-depends: + base, + QuickCheck, + transformers, + split, + process, + template-haskell, + hint + if !flag(templateHaskell) || impl(ghc <= 8.10) + buildable: False diff --git a/changelog b/changelog deleted file mode 100644 --- a/changelog +++ /dev/null @@ -1,424 +0,0 @@ -QuickCheck 2.15 - * BREAKING: properties without quantification are no longer implicitly - wrapped in once - * Add witness property modifier and witnesses field in result on - compilers that support Typeable to allow conveniently exposing - counterexamples - * Add assertException, assertExceptionIO, assertDeepException, and - assertDeepExceptionIO (thanks to Alexey Kuleshevich) - * Add withMaxSize, withMaxShrinks, and withMaxDiscardRatio combinators - * Add recheck - * Add HasCallStack to partial top-level functions - * Updated some documentation - * Fix overflow bug when calculating discard ratio - * Fix error printing bug when shrinks are discarded - * Fix withMaxSuccess not working when checkCoverage is turned on - * Fix a bug whereby an unfortunately timed discard could unduly fail a - property running with checkCoverage - * Fix Arbitrary intance for Map breaking invariants from - Data.Map.Strict (thanks to Neil Mayhew) - * Fix non-covered classes not showing up in output as 0% covered - * Fix Negative's Arbitrary instance discarding an unnecessary number - of generated values. - * Fix promote doing an unnecessary seed split - * Fix a bug whereby maxSuccess and discardRatio would interact poorly - to produce too few size increases. - * Fix a couple of underflow bugs in generators for Small Natural and - Ratio Natural - * Fix a bug whereby the internal DISCARDED exception would show up - user-side in sample - -QuickCheck 2.14.3 (released 2023-05-31) - * Add shrinkBoundedEnum (thanks to Jonathan Knowles) - * Add discardAfter for discarding tests on timeout (thanks to Justus Sagemüller) - * Add assertWith for monadic testing (thanks to KtorZ) - * Add functionElements to Test.QuickCheck.Function (thanks to Oleg Grenrus) - * Add Arbitrary instance for Newline (thanks to Daniel Bramucci) - * Improve Arbitrary instances for Float and Double (thanks to Oleg Grenrus) - * Improve arbitrarySizedFractional (thanks to Bodigrim) - * Fix shrinkRealFrac and shrinkDecimal, which were broken - * Speed up printing of progress messages (thanks to Bodigrim) - * Add COMPLETE pragmas for Fn and family (thanks to ilkecan) - * Make templateHaskell flag manual (thanks to Oleg Grenrus) - -QuickCheck 2.14.2 (released 2020-11-14) - * Add Arbitrary instances for Tree (thanks to Oleg Grenrus) - * GHC 9.0 compatibility (thanks to Vilem-Benjamin Liepelt) - -QuickCheck 2.14.1 (released 2020-07-05) - * Compatibility with random >= 1.2. - -QuickCheck 2.14 (released 2020-03-28) - * QuickCheck is now much faster at generating test data! - As a result, many properties can now be tested a lot faster; - the examples distributed with QuickCheck run about twice as - fast as before, for example. Of course, your mileage may vary. - - The reason for this is that there are now specialised versions - of the 'choose' combinator for various types. These are: - chooseInt, chooseInteger, chooseBoundedIntegral, and chooseEnum. - These combinators are identical to 'choose' but much faster. - All QuickCheck combinators, with the exception of 'choose' - itself, use the new combinators behind the scenes. - - You should see a speedup without doing anything, but to get a - further speedup, consider replacing any uses of 'choose' in your - own generators with the new combinators. - - We are hoping that future releases of the 'random' library may - speed up 'choose', in which case these combinators may no longer - be needed. - - Thanks to Oleg Grenrus for suggesting to bypass 'choose' for - random number generation, and providing the appropriate - primitive in his 'splitmix' random number library. - - * Smaller changes and bugfixes: - - RecursivelyShrink and GSubterms are exported from - Test.QuickCheck.Test (thanks to Tom Mortiboy). - - Don't generate invalid unicode characters - (thanks to Boris Stepanov). - - When a call to 'within' fails, include the duration of the - timeout in the failure report (thanks to William Rusnack). - - In Gen, avoid splitting the seed in the implementation of - >>, *> and <* (thanks to David Feuer). - - Fix a couple of bugs with shrinking of floating-point - numbers. - - Export functionMapWith, functionEitherWith and - functionPairWith from Test.QuickCheck.Function - (thanks to Oleg Grenrus). - - Remove redundant RealFloat constraint from - Arbitrary/CoArbitrary instances for Complex - (thanks to Bodigrim). - -QuickCheck 2.13.2 (released 2019-06-30) - * Compatibility with GHC 8.8 (thanks to Bodigrim) - * Improve error message when 'frequency' is used with only zero weights - * Add 'functionVoid' combinator (thanks to Oleg Grenrus) - * Tighten bounds for random package (thanks to Oleg Grenrus) - -QuickCheck 2.13.1 (released 2019-03-29) - * A couple of bug fixes - -QuickCheck 2.13 (released 2019-03-26) - * Properties with multiple arguments now shrink better. - Previously, the first argument was shrunk, then the second, and - so on. Now, the arguments are shrunk as a whole, so shrink steps - for different arguments can be interleaved. - - * New features: - - New modifiers Negative and NonPositive - - A Testable instance for Maybe prop (where Nothing means 'discard - the test case') - * Dependencies on C code removed: - - Use splitmix instead of tf-random for random number generation - - Remove dependency on 'erf' package - * Small changes: - - Say 'Falsified' instead of 'Falsifiable' when a property fails - * Compatibility improvements: - - Explicitly derive instance Typeable Args - - Lower bound on deepseq - - A script for building Hugs packages - -QuickCheck 2.12.6 (released 2018-10-02) - * Make arbitrarySizedBoundedIntegral handle huge sizes correctly. - * Add changelog for QuickCheck 2.12.5 :) - -QuickCheck 2.12.5 (released 2018-09-30) - * Export isSuccess from Test.QuickCheck. - * Export CoArbitrary even when generics are disabled (bugfix). - * Fix bug in shrinkDecimal. - * Include Test.QuickCheck.Gen in exposed modules for Haddock. - -QuickCheck 2.12.3, 2.12.4 (released 2018-09-12) - * Shrinking for Float and Decimal now works by reducing the number - of digits in the number. The new function shrinkDecimal - implements this shrinking behaviour. - * Shrinking for Rational now tries to make the numerator and - denominator of the number smaller. Previously it tried to reduce - the magnitude of the number. - -QuickCheck 2.12.2 (released 2018-09-10) - * Fix infinite shrinking loop for fractional types. - * Add SortedList modifier. - -QuickCheck 2.12.1 (released 2018-09-06) - * Fix bug in 'classify'. - -QuickCheck 2.12 (released 2018-09-03) - * Silently breaking changes! - - The Arbitrary instance for Word now generates only small - values, the same as Int - - cover no longer causes a property failure if coverage is - insufficient. It just prints a warning. (But see next item!) - - * Overhaul of label/cover family of combinators: - - New property combinator checkCoverage, which checks coverage - requirements in a statistically sound way, and *does* fail if - they are not met. - - Order of arguments to cover swapped, to make it easier to - switch between classify and cover - - New combinators tabulate and coverTable, for reporting test - case distribution more flexibly than label. - - When label is called multiple times in a property, each call - produces a separate table of frequencies. - - * New functions: - - (=/=): like (/=), but prints a counterexample - (thanks to tom-bop) - - forAllShow/forAllShrinkShow: quantification using an - explicit show function (thanks to Stevan Andjelkovic) - - forAllBlind/forAllShrinkBlind: quantification without - printing anything - - verboseShrinking: see how a counterexample is shrunk - - labelledExamples: given a property which uses label, - generate an example test case for each label - - idempotentIOProperty: a variant of ioProperty which shrinks - better but only works for idempotent I/O actions - - * Other improvements: - - MonadFix Gen instance (thanks to Jon Fowler) - - Rational numbers shrink using continued fractions - (thanks to Justus Sagemüller) - - Function instances for Const, Identity, and the types in - Data.Monoid; instance Functor Fun (thanks to Erik Schnetter - and Xia Li-yao) - - More of Test.QuickCheck.Function is exported from - Test.QuickCheck - - Semantics of .||. changed to improve short-circuiting: - if the left argument's precondition is false, the right - argument is not evaluated and the whole disjunction is - considered to have a false precondition - - Bug fix: suchThatMaybe always increased size to at least 1 - - * Miscellaneous API changes: - - Result type has changed a bit: - - InsufficientCovered constructor is gone - - Type of labels has changed - - New fields classes, tables - -QuickCheck 2.11.1 - 2.11.3 (released 2018-01-12) - * Cosmetic fixes. - -QuickCheck 2.11 (released 2018-01-12) - * New features: - - InfiniteList modifier generates infinite lists and shows - only the relevant part. - - applyArbitrary2/3/4 for applying a function to random - arguments. - - Template Haskell function allProperties returns all - properties in a module. - - * Applicative Gen instances do less splitting. - * Property now has a Typeable instance. - * (===) now prints correct output when the property is true. - * Test.QuickCheck now exports Fun constructor. - * verboseCheck output is now slightly less confusing. - -QuickCheck 2.10.1 (released 2017-10-06) - * Arbitrary instances for Foreign.C.Types are available in more - GHC versions. - * Fixed a bug where withMaxSuccess didn't adjust the allowed - number of discarded tests. - * Remove quadratic behaviour in terminal output. - -QuickCheck 2.10 (released 2017-06-15) - * New combinators: - - withMaxSuccess sets the maximum number of test cases for a property. - - shrinkMap/shrinkMapBy are helpers for defining shrink functions. - - total checks that a value is non-crashing. - - suchThatMap is similar to 'suchThat' - but takes a Maybe-returning function instead of a predicate. - - getSize returns the current test case size. - - * Random strings and characters now include Unicode characters by - default. To generate only ASCII characters, use the new - ASCIIString modifier or arbitraryASCIIChar generator. - The following modifiers and generators also control the - kind of strings generated: UnicodeString, PrintableString, - arbitraryUnicodeChar, arbitraryPrintableChar. - - * QuickCheck no longer catches asynchronous exceptions, which - means that pressing ctrl-C will now cancel testing without - printing a counterexample. If you are debugging an infinite loop, - please use the 'within' combinator or 'verboseCheck' instead. - ('within' is better as it allows the counterexample to be - shrunk.) - - * Much of Test.QuickCheck.Function (showable random functions) - is now exported from Test.QuickCheck. - - Test.QuickCheck.Function now defines functions and - pattern synonyms which simplify testing functions of - more than one argument: apply2, apply3, Fn2, Fn3. - - * New typeclasses Arbitrary1 and Arbitrary2 which lift Arbitrary - to unary/binary type constructors, like in Data.Functor.Classes. - - * Some Arbitrary instances have been removed: NonEmpty, Natural. - This is because they resulted in a lot of extra dependencies. - You can now find them in the quickcheck-instances package. - Alternatively, use the NonEmptyList and NonNegative modifiers. - - * New Arbitrary instances for the following types: Proxy, ExitCode, - WrappedMonad, WrappedArrow, QCGen, and the types in - Foreign.C.Types and Data.Functor.{Product,Compose}. - Also a Function instance for Word. - - * The functions in Test.QuickCheck.Monadic which take an argument - of type PropertyM m a now expect that 'a' to be Testable, and test it. - To reduce breakage from this, () is now an instance of Testable which - always succeeds. - - PropertyM now has a MonadFail instance on recent GHCs. - Furthermore, the constraints on some instances were loosened. - - * Miscellaneous API changes: - - Result now returns the counterexample as a list of strings. - See the "failingTestCase" field. - - Args now has a `maxShrinks` argument, the maximum number of - shrinks to try before giving up shrinking. - - The 'labels' field of Result now encodes frequencies as Doubles - rather than Ints. - - * Bugfixes: - - 'Test.QuickCheck.Function', 'Test.QuickCheck.Poly', and - 'Test.QuickCheck.Monadic' are now Safe modules. - - Result.theException and Result.reason were taken from - the pre-shrunk counterexample, not the shrunk one. - - The Testable Property instance improperly used 'again'. - - Gen.>>= is strict in the result of split, fixing a space leak. - - within now gives a better error message on timeout - - * Some more examples and links have been added to the documentation. - -QuickCheck 2.9.2 (released 2016-09-15) - * Fix a bug where some properties were only being tested once - * Make shrinking of floating-point values less aggressive - * Add function chooseAny :: Random a => Gen a - -QuickCheck 2.9.1 (released 2016-07-11) - * 'again' was only used in forAllShrink, not forAll - -QuickCheck 2.9 (released 2016-07-10) - * Arbitrary, CoArbitrary and Function instances for more types - * Generics for automatic Function instances - * A new combinator "again" which undoes the effect of "once" - * Remove "exhaustive" from Testable typeclass; - instead, combinators which are nonexhaustive (such as forAll) - call "again", which should be more robust - - * Drop support for GHC 6.x - - * Fixed bugs: - * arbitrarySizedBoundedIntegral wasn't generating huge integers - * verboseCheck failed with Test.QuickCheck.Function - * label had a space leak - -QuickCheck 2.8.2 (released 2016-01-15) - * GHC 8 support - * Add Arbitrary and CoArbitrary instances for types in - containers package - * Improve speed of shuffle combinator - * Only print to stderr if it's a terminal. - * Small changes: slightly improve documentation, - remove redundant constraints from some functions' types, - small improvements to Test.QuickCheck.All. - -QuickCheck 2.8.1 (released 2015-04-03) - * Fix bug where exceptions thrown printing counterexamples weren't - being caught when terminal output was disabled - * Don't export Test.QuickCheck.Property.result - -QuickCheck 2.8 (released 2015-03-18) - * New features: - * Support for GHC 7.10 - * Arbitrary instance for Natural - * New generators shuffle and sublistOf - * Support for generic coarbitrary - * When using the cover combinator, insufficient coverage now - causes the property to fail - - * API changes: - * Test.QuickCheck.Function: new pattern synonym Fn - * genericShrink no longer requires Typeable - * Result has a new constructor InsufficientCoverage - * resize throws an error if the size is negative - - * Bug fixes: - * Fix memory leaks - * Exceptions thrown by callbacks now cause the test to fail - * Fixed a bug where the cover combinator wouldn't give a - warning if coverage was 0% - -QuickCheck 2.7.3 (released 2014-03-24) - * Add annotations for Safe Haskell. - -QuickCheck 2.7.2 (released 2014-03-22) - * Fix bug in cabal file which broke cabal test - -QuickCheck 2.7.1 (released 2014-03-20) - * Fixed bug - the Small modifier didn't work on unsigned types - * Changed arbitrarySizedIntegral to have an Integral constraint - instead of just Num - -QuickCheck 2.7 (released 2014-03-19) - - * New features: - * New genericShrink function provides generic shrinking with GHC. - * New combinator x === y: fails if x /= y, but also prints their values - * New function generate :: Gen a -> IO a for running a generator. - * New combinators infiniteList and infiniteListOf for generating infinite lists. - * Several combinators added to the main Test.QuickCheck module which - were previously languishing in other modules. Of particular interest: - quickCheckAll, ioProperty. - * New combinators delay and capture which can be used (unsafely!) - to reuse the random number seed. Useful for generating - polymorphic (rank-2) values. - * A new Discard data type and a Testable instance for discarding test cases. - * All modifiers now have Functor instances and accessor functions. - * Pressing ctrl-C during shrinking now shows the last failed - test case, rather than the current shrinking candidate. - * Experimental support for UHC. You will need the latest version of Cabal from git. - - * Better distribution of test data: - * The Int generator now only generates fairly small numbers. - * The new Small and Large modifiers control the distribution of integers - (Small generates small numbers, Large from the whole range). - * Floating-point numbers shrink better. - - * Improved random number generation: - * QuickCheck now uses TFGen rather than StdGen on newer versions - of GHC, because StdGen's random numbers aren't always random. - * 'variant' now uses a prefix code. This should prevent some - potential bananaskins with coarbitrary. - - * API changes: - * The Gen monad now uses an abstract type QCGen rather than StdGen. - * The Result type now returns the thrown exception and number - of failed shrink attempts. - * Property is now a newtype rather than Gen Prop as it was before. - * promote is moved into the new module Test.QuickCheck.Gen.Unsafe. - * 'printTestCase' is deprecated - its new name is 'counterexample' - * 'morallyDubiousIOProperty' is deprecated - its new name is - 'ioProperty', no moral judgement involved :) - -QuickCheck 2.6, released 2013-03-07 - - * Add convenience Function instances for up to 7-tuples - * Make stderr line buffered to reduce console I/O. - * Return a flag to say whether the test case was interrupted. - -QuickCheck 2.5, released 2012-06-18 - - * Replace maxDiscard with maxDiscardRatio - * Remove Testable () instance. - * Added a 'discard' exception that discards the current test case - * Add accessors for modifiers (where it makes sense) - * Rename 'stop' to 'abort' to avoid a name clash - * Added a 'once' combinator - * If a property is of type Bool, only run it once - * Add coarbitraryEnum to Test.QuickCheck module. - * Add 'coarbitrary' helper for Enums. - * Rejiggled the formatting code to support multi-line error messages - * Add instances for Ordering and Fixed. - * Added arbitraryBoundedEnum generator (thanks to Antoine Latter). - * Add verboseCheckAll and polyverboseCheck function for usability. diff --git a/changelog.md b/changelog.md new file mode 100644 --- /dev/null +++ b/changelog.md @@ -0,0 +1,457 @@ +## UNRELEASED + +## QuickCheck 2.18.0.0 (released 2026-02-26) +* BREAKING: Added a number of `CoArbitrary` and `Function` instances for types in `base` +* Improve implementation of `shrinkIntegral` (thanks tom93) +* Improve implementation of `Arbitrary NonEmptyList` (thanks konsumlamm) +* Convert changelog to markdown (thanks Artem) +* Deprecate `withMaxSuccess` in favour of the renamed `withNumTests` +* `Test.QuickCheck.Function` marked as `Trustworthy` not `Safe` +* Fix bug in heap example + +## QuickCheck 2.17.1.0 (released 2025-10-13) +* Fix random-1.2 support (thanks bodigrim) +* Update docs (thanks effectfully) + +## QuickCheck 2.17.0.0 (released 2025-10-07) +* Lower the memory use of `arbitrary` for `Double` and `Float` (thanks +ChickenProp) +* BREAKING: Remove `Gen.Class` +* BREAKING: Add `Arbitrary` instances for most of the types in `base` +* Add microHS support (thanks Lennart) + +## QuickCheck 2.16.0.0 (released 2025-06-17) +* Add a `Safe` declaration to `Test.QuickCheck.Monoids` +* Fix `Test.QuickCheck.Features` to not depend on the internal testing loop +* Add `withProgress` to install common callbacks for downstream tools +* Relax bounds on `random` dependency (thanks to LaurentRDC and +Andreas Abel) +* Fix some haddock issues (thanks to pgujjula) +* Use `displayException` instead of `show` (thanks Edsko) +* Added helper monoids `Every` and `Some` for predicates (thanks +Marcin) + +## QuickCheck 2.15 (released 2024-04-22) +* BREAKING: properties without quantification are no longer implicitly + wrapped in once +* Add witness property modifier and witnesses field in result on +compilers that support Typeable to allow conveniently exposing +counterexamples +* Add assertException, assertExceptionIO, assertDeepException, and +assertDeepExceptionIO (thanks to Alexey Kuleshevich) +* Add withMaxSize, withMaxShrinks, and withMaxDiscardRatio combinators +* Add recheck +* Add HasCallStack to partial top-level functions +* Updated some documentation +* Fix overflow bug when calculating discard ratio +* Fix error printing bug when shrinks are discarded +* Fix withMaxSuccess not working when checkCoverage is turned on +* Fix a bug whereby an unfortunately timed discard could unduly fail a +property running with checkCoverage +* Fix Arbitrary intance for Map breaking invariants from +Data.Map.Strict (thanks to Neil Mayhew) +* Fix non-covered classes not showing up in output as 0% covered +* Fix Negative's Arbitrary instance discarding an unnecessary number +of generated values. +* Fix promote doing an unnecessary seed split +* Fix a bug whereby maxSuccess and discardRatio would interact poorly +to produce too few size increases. +* Fix a couple of underflow bugs in generators for Small Natural and +Ratio Natural +* Fix a bug whereby the internal DISCARDED exception would show up +user-side in sample + +## QuickCheck 2.14.3 (released 2023-05-31) +* Add shrinkBoundedEnum (thanks to Jonathan Knowles) +* Add discardAfter for discarding tests on timeout (thanks to Justus Sagemüller) +* Add assertWith for monadic testing (thanks to KtorZ) +* Add functionElements to Test.QuickCheck.Function (thanks to Oleg Grenrus) +* Add Arbitrary instance for Newline (thanks to Daniel Bramucci) +* Improve Arbitrary instances for Float and Double (thanks to Oleg Grenrus) +* Improve arbitrarySizedFractional (thanks to Bodigrim) +* Fix shrinkRealFrac and shrinkDecimal, which were broken +* Speed up printing of progress messages (thanks to Bodigrim) +* Add COMPLETE pragmas for Fn and family (thanks to ilkecan) +* Make templateHaskell flag manual (thanks to Oleg Grenrus) + +## QuickCheck 2.14.2 (released 2020-11-14) +* Add Arbitrary instances for Tree (thanks to Oleg Grenrus) +* GHC 9.0 compatibility (thanks to Vilem-Benjamin Liepelt) + +## QuickCheck 2.14.1 (released 2020-07-05) +* Compatibility with random >= 1.2. + +## QuickCheck 2.14 (released 2020-03-28) +* QuickCheck is now much faster at generating test data! + As a result, many properties can now be tested a lot faster; + the examples distributed with QuickCheck run about twice as + fast as before, for example. Of course, your mileage may vary. + + The reason for this is that there are now specialised versions + of the 'choose' combinator for various types. These are: + chooseInt, chooseInteger, chooseBoundedIntegral, and chooseEnum. + These combinators are identical to 'choose' but much faster. + All QuickCheck combinators, with the exception of 'choose' + itself, use the new combinators behind the scenes. + + You should see a speedup without doing anything, but to get a + further speedup, consider replacing any uses of 'choose' in your + own generators with the new combinators. + + We are hoping that future releases of the 'random' library may + speed up 'choose', in which case these combinators may no longer + be needed. + + Thanks to Oleg Grenrus for suggesting to bypass 'choose' for + random number generation, and providing the appropriate + primitive in his 'splitmix' random number library. + +* Smaller changes and bugfixes: +- RecursivelyShrink and GSubterms are exported from + Test.QuickCheck.Test (thanks to Tom Mortiboy). +- Don't generate invalid unicode characters + (thanks to Boris Stepanov). +- When a call to 'within' fails, include the duration of the + timeout in the failure report (thanks to William Rusnack). +- In Gen, avoid splitting the seed in the implementation of + >>, *> and <* (thanks to David Feuer). +- Fix a couple of bugs with shrinking of floating-point + numbers. +- Export functionMapWith, functionEitherWith and + functionPairWith from Test.QuickCheck.Function + (thanks to Oleg Grenrus). +- Remove redundant RealFloat constraint from + Arbitrary/CoArbitrary instances for Complex + (thanks to Bodigrim). + +## QuickCheck 2.13.2 (released 2019-06-30) +* Compatibility with GHC 8.8 (thanks to Bodigrim) +* Improve error message when 'frequency' is used with only zero weights +* Add 'functionVoid' combinator (thanks to Oleg Grenrus) +* Tighten bounds for random package (thanks to Oleg Grenrus) + +## QuickCheck 2.13.1 (released 2019-03-29) +* A couple of bug fixes + +## QuickCheck 2.13 (released 2019-03-26) +* Properties with multiple arguments now shrink better. + Previously, the first argument was shrunk, then the second, and + so on. Now, the arguments are shrunk as a whole, so shrink steps + for different arguments can be interleaved. + +* New features: + - New modifiers Negative and NonPositive + - A Testable instance for Maybe prop (where Nothing means 'discard + the test case') +* Dependencies on C code removed: + - Use splitmix instead of tf-random for random number generation + - Remove dependency on 'erf' package +* Small changes: + - Say 'Falsified' instead of 'Falsifiable' when a property fails +* Compatibility improvements: + - Explicitly derive instance Typeable Args + - Lower bound on deepseq + - A script for building Hugs packages + +## QuickCheck 2.12.6 (released 2018-10-02) +* Make arbitrarySizedBoundedIntegral handle huge sizes correctly. +* Add changelog for QuickCheck 2.12.5 :) + +## QuickCheck 2.12.5 (released 2018-09-30) +* Export isSuccess from Test.QuickCheck. +* Export CoArbitrary even when generics are disabled (bugfix). +* Fix bug in shrinkDecimal. +* Include Test.QuickCheck.Gen in exposed modules for Haddock. + +## QuickCheck 2.12.3, 2.12.4 (released 2018-09-12) +* Shrinking for Float and Decimal now works by reducing the number + of digits in the number. The new function shrinkDecimal + implements this shrinking behaviour. +* Shrinking for Rational now tries to make the numerator and + denominator of the number smaller. Previously it tried to reduce + the magnitude of the number. + +## QuickCheck 2.12.2 (released 2018-09-10) +* Fix infinite shrinking loop for fractional types. +* Add SortedList modifier. + +## QuickCheck 2.12.1 (released 2018-09-06) +* Fix bug in 'classify'. + +## QuickCheck 2.12 (released 2018-09-03) +* Silently breaking changes! + - The Arbitrary instance for Word now generates only small + values, the same as Int + - cover no longer causes a property failure if coverage is + insufficient. It just prints a warning. (But see next item!) + +* Overhaul of label/cover family of combinators: + - New property combinator checkCoverage, which checks coverage + requirements in a statistically sound way, and *does* fail if + they are not met. + - Order of arguments to cover swapped, to make it easier to + switch between classify and cover + - New combinators tabulate and coverTable, for reporting test + case distribution more flexibly than label. + - When label is called multiple times in a property, each call + produces a separate table of frequencies. + +* New functions: + - (=/=): like (/=), but prints a counterexample + (thanks to tom-bop) + - forAllShow/forAllShrinkShow: quantification using an + explicit show function (thanks to Stevan Andjelkovic) + - forAllBlind/forAllShrinkBlind: quantification without + printing anything + - verboseShrinking: see how a counterexample is shrunk + - labelledExamples: given a property which uses label, + generate an example test case for each label + - idempotentIOProperty: a variant of ioProperty which shrinks + better but only works for idempotent I/O actions + +* Other improvements: + - MonadFix Gen instance (thanks to Jon Fowler) + - Rational numbers shrink using continued fractions + (thanks to Justus Sagemüller) + - Function instances for Const, Identity, and the types in + Data.Monoid; instance Functor Fun (thanks to Erik Schnetter + and Xia Li-yao) + - More of Test.QuickCheck.Function is exported from + Test.QuickCheck + - Semantics of .||. changed to improve short-circuiting: + if the left argument's precondition is false, the right + argument is not evaluated and the whole disjunction is + considered to have a false precondition + - Bug fix: suchThatMaybe always increased size to at least 1 + +* Miscellaneous API changes: + - Result type has changed a bit: + - InsufficientCovered constructor is gone + - Type of labels has changed + - New fields classes, tables + +## QuickCheck 2.11.1 - 2.11.3 (released 2018-01-12) +* Cosmetic fixes. + +## QuickCheck 2.11 (released 2018-01-12) +* New features: + - InfiniteList modifier generates infinite lists and shows + only the relevant part. + - applyArbitrary2/3/4 for applying a function to random + arguments. + - Template Haskell function allProperties returns all + properties in a module. + +* Applicative Gen instances do less splitting. +* Property now has a Typeable instance. +* (===) now prints correct output when the property is true. +* Test.QuickCheck now exports Fun constructor. +* verboseCheck output is now slightly less confusing. + +## QuickCheck 2.10.1 (released 2017-10-06) +* Arbitrary instances for Foreign.C.Types are available in more + GHC versions. +* Fixed a bug where withMaxSuccess didn't adjust the allowed + number of discarded tests. +* Remove quadratic behaviour in terminal output. + +## QuickCheck 2.10 (released 2017-06-15) +* New combinators: + - withMaxSuccess sets the maximum number of test cases for a property. + - shrinkMap/shrinkMapBy are helpers for defining shrink functions. + - total checks that a value is non-crashing. + - suchThatMap is similar to 'suchThat' + but takes a Maybe-returning function instead of a predicate. + - getSize returns the current test case size. + +* Random strings and characters now include Unicode characters by + default. To generate only ASCII characters, use the new + ASCIIString modifier or arbitraryASCIIChar generator. + The following modifiers and generators also control the + kind of strings generated: UnicodeString, PrintableString, + arbitraryUnicodeChar, arbitraryPrintableChar. + +* QuickCheck no longer catches asynchronous exceptions, which + means that pressing ctrl-C will now cancel testing without + printing a counterexample. If you are debugging an infinite loop, + please use the 'within' combinator or 'verboseCheck' instead. + ('within' is better as it allows the counterexample to be + shrunk.) + +* Much of Test.QuickCheck.Function (showable random functions) + is now exported from Test.QuickCheck. + - Test.QuickCheck.Function now defines functions and + pattern synonyms which simplify testing functions of + more than one argument: apply2, apply3, Fn2, Fn3. + +* New typeclasses Arbitrary1 and Arbitrary2 which lift Arbitrary + to unary/binary type constructors, like in Data.Functor.Classes. + +* Some Arbitrary instances have been removed: NonEmpty, Natural. + This is because they resulted in a lot of extra dependencies. + You can now find them in the quickcheck-instances package. + Alternatively, use the NonEmptyList and NonNegative modifiers. + +* New Arbitrary instances for the following types: Proxy, ExitCode, + WrappedMonad, WrappedArrow, QCGen, and the types in + Foreign.C.Types and Data.Functor.{Product,Compose}. + Also a Function instance for Word. + +* The functions in Test.QuickCheck.Monadic which take an argument + of type PropertyM m a now expect that 'a' to be Testable, and test it. + To reduce breakage from this, () is now an instance of Testable which + always succeeds. + - PropertyM now has a MonadFail instance on recent GHCs. + Furthermore, the constraints on some instances were loosened. + +* Miscellaneous API changes: + - Result now returns the counterexample as a list of strings. + See the "failingTestCase" field. + - Args now has a `maxShrinks` argument, the maximum number of + shrinks to try before giving up shrinking. + - The 'labels' field of Result now encodes frequencies as Doubles + rather than Ints. + +* Bugfixes: + - 'Test.QuickCheck.Function', 'Test.QuickCheck.Poly', and + 'Test.QuickCheck.Monadic' are now Safe modules. + - Result.theException and Result.reason were taken from + the pre-shrunk counterexample, not the shrunk one. + - The Testable Property instance improperly used 'again'. + - Gen.>>= is strict in the result of split, fixing a space leak. + - within now gives a better error message on timeout + +* Some more examples and links have been added to the documentation. + +## QuickCheck 2.9.2 (released 2016-09-15) +* Fix a bug where some properties were only being tested once +* Make shrinking of floating-point values less aggressive +* Add function chooseAny :: Random a => Gen a + +## QuickCheck 2.9.1 (released 2016-07-11) +* 'again' was only used in forAllShrink, not forAll + +## QuickCheck 2.9 (released 2016-07-10) +* Arbitrary, CoArbitrary and Function instances for more types +* Generics for automatic Function instances +* A new combinator "again" which undoes the effect of "once" +* Remove "exhaustive" from Testable typeclass; + instead, combinators which are nonexhaustive (such as forAll) + call "again", which should be more robust + +* Drop support for GHC 6.x + +* Fixed bugs: + * arbitrarySizedBoundedIntegral wasn't generating huge integers + * verboseCheck failed with Test.QuickCheck.Function + * label had a space leak + +## QuickCheck 2.8.2 (released 2016-01-15) +* GHC 8 support +* Add Arbitrary and CoArbitrary instances for types in + containers package +* Improve speed of shuffle combinator +* Only print to stderr if it's a terminal. +* Small changes: slightly improve documentation, + remove redundant constraints from some functions' types, + small improvements to Test.QuickCheck.All. + +## QuickCheck 2.8.1 (released 2015-04-03) +* Fix bug where exceptions thrown printing counterexamples weren't + being caught when terminal output was disabled +* Don't export Test.QuickCheck.Property.result + +## QuickCheck 2.8 (released 2015-03-18) +* New features: + * Support for GHC 7.10 + * Arbitrary instance for Natural + * New generators shuffle and sublistOf + * Support for generic coarbitrary + * When using the cover combinator, insufficient coverage now + causes the property to fail + +* API changes: + * Test.QuickCheck.Function: new pattern synonym Fn + * genericShrink no longer requires Typeable + * Result has a new constructor InsufficientCoverage + * resize throws an error if the size is negative + +* Bug fixes: + * Fix memory leaks + * Exceptions thrown by callbacks now cause the test to fail + * Fixed a bug where the cover combinator wouldn't give a + warning if coverage was 0% + +## QuickCheck 2.7.3 (released 2014-03-24) +* Add annotations for Safe Haskell. + +## QuickCheck 2.7.2 (released 2014-03-22) +* Fix bug in cabal file which broke cabal test + +## QuickCheck 2.7.1 (released 2014-03-20) +* Fixed bug - the Small modifier didn't work on unsigned types +* Changed arbitrarySizedIntegral to have an Integral constraint + instead of just Num + +## QuickCheck 2.7 (released 2014-03-19) + +* New features: + * New genericShrink function provides generic shrinking with GHC. + * New combinator x === y: fails if x /= y, but also prints their values + * New function generate :: Gen a -> IO a for running a generator. + * New combinators infiniteList and infiniteListOf for generating infinite lists. + * Several combinators added to the main Test.QuickCheck module which + were previously languishing in other modules. Of particular interest: + quickCheckAll, ioProperty. + * New combinators delay and capture which can be used (unsafely!) + to reuse the random number seed. Useful for generating + polymorphic (rank-2) values. + * A new Discard data type and a Testable instance for discarding test cases. + * All modifiers now have Functor instances and accessor functions. + * Pressing ctrl-C during shrinking now shows the last failed + test case, rather than the current shrinking candidate. + * Experimental support for UHC. You will need the latest version of Cabal from git. + +* Better distribution of test data: + * The Int generator now only generates fairly small numbers. + * The new Small and Large modifiers control the distribution of integers + (Small generates small numbers, Large from the whole range). + * Floating-point numbers shrink better. + +* Improved random number generation: + * QuickCheck now uses TFGen rather than StdGen on newer versions + of GHC, because StdGen's random numbers aren't always random. + * 'variant' now uses a prefix code. This should prevent some + potential bananaskins with coarbitrary. + +* API changes: + * The Gen monad now uses an abstract type QCGen rather than StdGen. + * The Result type now returns the thrown exception and number + of failed shrink attempts. + * Property is now a newtype rather than Gen Prop as it was before. + * promote is moved into the new module Test.QuickCheck.Gen.Unsafe. + * 'printTestCase' is deprecated - its new name is 'counterexample' + * 'morallyDubiousIOProperty' is deprecated - its new name is + 'ioProperty', no moral judgement involved :) + +## QuickCheck 2.6 (released 2013-03-07) + +* Add convenience Function instances for up to 7-tuples +* Make stderr line buffered to reduce console I/O. +* Return a flag to say whether the test case was interrupted. + +## QuickCheck 2.5 (released 2012-06-18) + +* Replace maxDiscard with maxDiscardRatio +* Remove Testable () instance. +* Added a 'discard' exception that discards the current test case +* Add accessors for modifiers (where it makes sense) +* Rename 'stop' to 'abort' to avoid a name clash +* Added a 'once' combinator +* If a property is of type Bool, only run it once +* Add coarbitraryEnum to Test.QuickCheck module. +* Add 'coarbitrary' helper for Enums. +* Rejiggled the formatting code to support multi-line error messages +* Add instances for Ordering and Fixed. +* Added arbitraryBoundedEnum generator (thanks to Antoine Latter). +* Add verboseCheckAll and polyverboseCheck function for usability. diff --git a/examples/Heap.hs b/examples/Heap.hs --- a/examples/Heap.hs +++ b/examples/Heap.hs @@ -72,7 +72,7 @@ toSortedList :: Ord a => Heap a -> [a] toSortedList Empty = [] -toSortedList (Node x h1 h2) = x : toList (h1 `merge` h2) +toSortedList (Node x h1 h2) = x : toSortedList (h1 `merge` h2) -------------------------------------------------------------------------- -- specification @@ -144,7 +144,7 @@ -- main return [] -main = $quickCheckAll +main = do True <- $quickCheckAll; return () -------------------------------------------------------------------------- -- the end. diff --git a/examples/Heap_Program.hs b/examples/Heap_Program.hs --- a/examples/Heap_Program.hs +++ b/examples/Heap_Program.hs @@ -187,7 +187,7 @@ -- main return [] -main = $(quickCheckAll) +main = do True <- $quickCheckAll; return () -------------------------------------------------------------------------- -- the end. diff --git a/examples/Heap_ProgramAlgebraic.hs b/examples/Heap_ProgramAlgebraic.hs --- a/examples/Heap_ProgramAlgebraic.hs +++ b/examples/Heap_ProgramAlgebraic.hs @@ -245,7 +245,7 @@ -- main return [] -main = $(quickCheckAll) +main = do True <- $quickCheckAll; return () -------------------------------------------------------------------------- -- the end. diff --git a/examples/Merge.hs b/examples/Merge.hs --- a/examples/Merge.hs +++ b/examples/Merge.hs @@ -110,7 +110,7 @@ -- mapSize (`div` 2) $ \(xss :: [OrderedList Int]) -> return [] -main = $quickCheckAll +main = do True <- $quickCheckAll; return () -------------------------------------------------------------------------- -- the end. diff --git a/examples/Set.hs b/examples/Set.hs --- a/examples/Set.hs +++ b/examples/Set.hs @@ -201,7 +201,7 @@ -- main return [] -main = $quickCheckAll +main = do True <- $quickCheckAll; return () -------------------------------------------------------------------------- -- the end. diff --git a/examples/Simple.hs b/examples/Simple.hs --- a/examples/Simple.hs +++ b/examples/Simple.hs @@ -40,7 +40,7 @@ prop_disj = counterexample "reverse" $(monomorphic 'prop_Reverse) .||. counterexample "Simon Thompson" $(monomorphic 'prop_SimonThompson) return [] -main = $quickCheckAll +main = do True <- $quickCheckAll; return () -------------------------------------------------------------------------- -- the end. diff --git a/make-hugs b/make-hugs --- a/make-hugs +++ b/make-hugs @@ -19,6 +19,7 @@ -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_CALLSTACK \ + -DNO_SEMIGROUP -DNO_EXISTENTIAL_FIELD_SELECTORS \ "$src" > "$tgt" done diff --git a/src/Test/QuickCheck.hs b/src/Test/QuickCheck.hs --- a/src/Test/QuickCheck.hs +++ b/src/Test/QuickCheck.hs @@ -19,9 +19,9 @@ >>> 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' @@ -50,8 +50,8 @@ +++ 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 +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: @ @@ -73,7 +73,7 @@ ( -- * Running tests quickCheck - , Args(..), Result(..) + , Args(..), Result(..), TestProgress(..) , stdArgs , quickCheckWith , quickCheckWithResult @@ -132,6 +132,11 @@ , choose , chooseInt , chooseInteger +#ifndef NO_SPLITMIX + , chooseWord64 + , chooseInt64 + , chooseUpTo +#endif , chooseBoundedIntegral , chooseEnum , chooseAny @@ -236,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(..) @@ -302,6 +307,7 @@ , verbose , verboseShrinking , noShrinking + , withNumTests , withMaxSuccess , within , discardAfter @@ -315,8 +321,10 @@ , (.&.) , (.&&.) , conjoin + , Every (..) , (.||.) , disjoin + , Some (..) -- ** What to do on failure #ifndef NO_TYPEABLE , Witness(..) @@ -326,6 +334,7 @@ #endif , counterexample , printTestCase + , withProgress , whenFail , whenFail' , expectFailure @@ -355,6 +364,7 @@ import Test.QuickCheck.Gen import Test.QuickCheck.Arbitrary import Test.QuickCheck.Modifiers +import Test.QuickCheck.Monoids import Test.QuickCheck.Property hiding ( Result(..) ) import Test.QuickCheck.Test import Test.QuickCheck.Exception diff --git a/src/Test/QuickCheck/All.hs b/src/Test/QuickCheck/All.hs --- a/src/Test/QuickCheck/All.hs +++ b/src/Test/QuickCheck/All.hs @@ -20,6 +20,7 @@ verboseCheckAll, forAllProperties, allProperties, + runQuickCheckAll, -- ** Testing polymorphic properties polyQuickCheck, polyVerboseCheck, diff --git a/src/Test/QuickCheck/Arbitrary.hs b/src/Test/QuickCheck/Arbitrary.hs --- a/src/Test/QuickCheck/Arbitrary.hs +++ b/src/Test/QuickCheck/Arbitrary.hs @@ -89,18 +89,20 @@ import Control.Applicative import Data.Foldable(toList) +#if MIN_VERSION_random(1,3,0) +import System.Random(Random, uniformByteArray) +#else import System.Random(Random) +#endif import Test.QuickCheck.Gen import Test.QuickCheck.Random import Test.QuickCheck.Gen.Unsafe - -{- -import Data.Generics - ( (:*:)(..) - , (:+:)(..) - , Unit(..) - ) --} +#if defined(__MHS__) +-- These two are not exported by Control.Applicative. +-- Why should they be? They are just bloat. +import Data.ZipList +import Control.WrappedMonad +#endif import Data.Char ( ord @@ -136,16 +138,25 @@ , nub ) + import Data.Version (Version (..)) #if defined(MIN_VERSION_base) -#if MIN_VERSION_base(4,2,0) +import Numeric.Natural + +import Data.List.NonEmpty (NonEmpty) +import qualified Data.List.NonEmpty as NonEmpty + import System.IO ( Newline(..) , NewlineMode(..) + , SeekMode(..) + , BufferMode(..) + , TextEncoding + , latin1, utf8, utf8_bom, utf16, utf16le, utf16be, utf32, utf32le, utf32be, localeEncoding, char8 + , IOMode(..) ) #endif -#endif import Control.Monad ( liftM @@ -175,9 +186,11 @@ #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 @@ -186,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 @@ -202,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 @@ -243,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)] -- @@ -492,14 +528,16 @@ 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 = sized $ \ n -> do denom <- chooseInt (1, max 1 n) @@ -512,7 +550,8 @@ 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 @@ -644,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 @@ -721,7 +766,7 @@ ] where smallDenominators = sized $ \n -> do - i <- chooseInt (0, n) + i <- chooseInt (0, min n 256) pure (fromRational (streamNth i rationalUniverse)) uniform = sized $ \n -> do @@ -747,7 +792,7 @@ ] where smallDenominators = sized $ \n -> do - i <- chooseInt (0, n) + i <- chooseInt (0, min n 256) pure (fromRational (streamNth i rationalUniverse)) uniform = sized $ \n -> do @@ -1019,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 @@ -1027,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 -> @@ -1064,7 +1265,6 @@ shrink _ = [] #if defined(MIN_VERSION_base) -#if MIN_VERSION_base(4,2,0) instance Arbitrary Newline where arbitrary = elements [LF, CRLF] @@ -1080,7 +1280,56 @@ arbitrary = NewlineMode <$> arbitrary <*> arbitrary shrink (NewlineMode inNL outNL) = [NewlineMode inNL' outNL' | (inNL', outNL') <- shrink (inNL, outNL)] -#endif + +instance Arbitrary GeneralCategory where + arbitrary = arbitraryBoundedEnum + shrink = shrinkBoundedEnum + +instance Arbitrary SeekMode where + arbitrary = elements [ AbsoluteSeek, RelativeSeek, SeekFromEnd ] + shrink x = takeWhile (x /=) [ AbsoluteSeek, RelativeSeek, SeekFromEnd ] + +instance Arbitrary TextEncoding where + arbitrary = elements [ latin1, utf8, utf8_bom, utf16, utf16le, utf16be, utf32, utf32le, utf32be, localeEncoding, char8 ] + +instance Arbitrary BufferMode where + arbitrary = oneof [ pure NoBuffering + , pure LineBuffering + , pure $ BlockBuffering Nothing + , BlockBuffering . Just . (+1) . fromIntegral <$> (arbitrary :: Gen Natural) + ] + shrink NoBuffering = [] + shrink LineBuffering = [ NoBuffering ] + shrink (BlockBuffering m) = [ NoBuffering, LineBuffering ] ++ map BlockBuffering (filter (maybe True (>0)) $ shrink m) + +instance Arbitrary IOMode where + arbitrary = elements [ReadMode, WriteMode, AppendMode, ReadWriteMode] + shrink x = takeWhile (/=x) [ReadMode, WriteMode, AppendMode, ReadWriteMode] + +instance Arbitrary FormatSign where + arbitrary = elements [SignPlus, SignSpace] + shrink SignPlus = [] + shrink SignSpace = [SignPlus] + +instance Arbitrary FormatAdjustment where + arbitrary = elements [LeftAdjust, ZeroPad] + shrink LeftAdjust = [] + shrink ZeroPad = [LeftAdjust] + +instance Arbitrary FormatParse where + arbitrary = FormatParse <$> arbitrary <*> arbitrary <*> arbitrary + shrink (FormatParse a b c) = [ FormatParse a' b' c' | (a', b', c') <- shrink (a, b, c) ] + +instance Arbitrary FieldFormat where + arbitrary = FieldFormat <$> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + shrink (FieldFormat a b c d e f g) = [ FieldFormat a' b' c' d' e' f' g' | (a', b', c', d', e', f', g') <- shrink (a, b, c, d, e, f, g) ] + #endif -- ** Helper functions for implementing arbitrary @@ -1233,20 +1482,8 @@ -- | Shrink an integral number. shrinkIntegral :: Integral a => a -> [a] shrinkIntegral x = - nub $ - [ -x - | x < 0, -x > x - ] ++ - [ x' - | x' <- takeWhile (<< x) (0:[ x - i | i <- tail (iterate (`quot` 2) x) ]) - ] - where - -- a << b is "morally" abs a < abs b, but taking care of overflow. - a << b = case (a >= 0, b >= 0) of - (True, True) -> a < b - (False, False) -> a > b - (True, False) -> a + b < 0 - (False, True) -> a + b > 0 + [ -x | x < 0, -x > x ] ++ + [ x - i | i <- takeWhile (/= 0) (iterate (`quot` 2) x)] -- | Shrink an element of a bounded enumeration. -- @@ -1432,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 @@ -1513,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 @@ -1531,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 @@ -1564,34 +1812,99 @@ coarbitrary = coarbitrary . Monoid.getProduct #if defined(MIN_VERSION_base) -#if MIN_VERSION_base(3,0,0) instance CoArbitrary a => CoArbitrary (Monoid.First a) where coarbitrary = coarbitrary . Monoid.getFirst instance CoArbitrary a => CoArbitrary (Monoid.Last a) where coarbitrary = coarbitrary . Monoid.getLast -#endif -#if MIN_VERSION_base(4,8,0) instance CoArbitrary (f a) => CoArbitrary (Monoid.Alt f a) where coarbitrary = coarbitrary . Monoid.getAlt -#endif -#endif -instance CoArbitrary Version where - coarbitrary (Version a b) = coarbitrary (a, b) +instance CoArbitrary a => CoArbitrary (Semigroup.Max a) where + coarbitrary = coarbitrary . Semigroup.getMax -#if defined(MIN_VERSION_base) -#if MIN_VERSION_base(4,2,0) +instance CoArbitrary a => CoArbitrary (Semigroup.Min a) where + coarbitrary = coarbitrary . Semigroup.getMin + +instance CoArbitrary a => CoArbitrary (Semigroup.First a) where + coarbitrary = coarbitrary . Semigroup.getFirst + +instance CoArbitrary a => CoArbitrary (Semigroup.Last a) where + coarbitrary = coarbitrary . Semigroup.getLast + instance CoArbitrary Newline where coarbitrary LF = variant 0 coarbitrary CRLF = variant 1 instance CoArbitrary NewlineMode where coarbitrary (NewlineMode inNL outNL) = coarbitrary inNL . coarbitrary outNL + +instance (CoArbitrary a, CoArbitrary b) => CoArbitrary (Semigroup.Arg a b) where + coarbitrary (Semigroup.Arg a b) = coarbitrary (a, b) + +instance CoArbitrary GeneralCategory where + coarbitrary = coarbitrary . fromEnum + +instance CoArbitrary SeekMode where + coarbitrary = coarbitrary . fromEnum + +instance CoArbitrary IOMode where +#if !defined(__MHS__) + coarbitrary = coarbitrary . fromEnum +#else + coarbitrary ReadMode = variant 0 + coarbitrary WriteMode = variant 1 + coarbitrary AppendMode = variant 2 + coarbitrary ReadWriteMode = variant 3 #endif + +instance CoArbitrary FieldFormat where + coarbitrary ff = coarbitrary (fmtWidth ff) + . coarbitrary (fmtPrecision ff) + . coarbitrary (fmtAdjust ff) + . coarbitrary (fmtSign ff) + . coarbitrary (fmtAlternate ff) + . coarbitrary (fmtModifiers ff) + . coarbitrary (fmtChar ff) + +instance CoArbitrary FormatParse where + coarbitrary fp = coarbitrary (fpModifiers fp) + . coarbitrary (fpChar fp) + . coarbitrary (fpRest fp) + +instance CoArbitrary FormatAdjustment where + coarbitrary LeftAdjust = coarbitrary True + coarbitrary ZeroPad = coarbitrary False + +instance CoArbitrary FormatSign where + coarbitrary SignPlus = coarbitrary True + coarbitrary SignSpace = coarbitrary False + +instance CoArbitrary BufferMode where + coarbitrary = coarbitrary . embed + where embed NoBuffering = Left True + embed LineBuffering = Left False + embed (BlockBuffering m) = Right m + +instance CoArbitrary ExitCode where + coarbitrary = coarbitrary . embed + where embed ExitSuccess = Nothing + embed (ExitFailure i) = Just i + +#if !defined(__MHS__) +instance CoArbitrary TextEncoding where + coarbitrary = coarbitrary . show -- No other way as far as I can tell :( #endif +instance CoArbitrary a => CoArbitrary (Semigroup.WrappedMonoid a) where + coarbitrary = coarbitrary . Semigroup.unwrapMonoid + +#endif + +instance CoArbitrary Version where + coarbitrary (Version a b) = coarbitrary (a, b) + -- ** Helpers for implementing coarbitrary -- | A 'coarbitrary' implementation for integral numbers. @@ -1638,8 +1951,9 @@ streamNth n (x :< xs) | n <= 0 = x | otherwise = streamNth (n - 1) xs --- We read into this stream only with ~size argument, --- so it's ok to have it as CAF. +-- We read into this stream only with ~size argument, capped to 256, +-- so it's ok to have it as CAF. (256 chosen somewhat arbitrarily, the +-- point is just to stop this blowing up.) -- rationalUniverse :: Stream Rational rationalUniverse = 0 :< 1 :< (-1) :< go leftSideStream diff --git a/src/Test/QuickCheck/Compat.hs b/src/Test/QuickCheck/Compat.hs new file mode 100644 --- /dev/null +++ b/src/Test/QuickCheck/Compat.hs @@ -0,0 +1,34 @@ +-- This module provides tools to simplify compat code across different compiler and library versions +{-# LANGUAGE CPP #-} +module Test.QuickCheck.Compat where + +#if MIN_VERSION_base(4,16,0) +import Data.Tuple +#endif + +#if MIN_VERSION_base(4,16,0) + +#if !MIN_VERSION_base(4,18,0) + +getSolo :: Solo a -> a +getSolo (Solo a) = a + +mkSolo :: a -> Solo a +mkSolo = Solo + +#elif !MIN_VERSION_base(4,19,0) + +getSolo :: Solo a -> a +getSolo (MkSolo a) = a + +mkSolo :: a -> Solo a +mkSolo = MkSolo + +#else + +mkSolo :: a -> Solo a +mkSolo = MkSolo + +#endif + +#endif diff --git a/src/Test/QuickCheck/Exception.hs b/src/Test/QuickCheck/Exception.hs --- a/src/Test/QuickCheck/Exception.hs +++ b/src/Test/QuickCheck/Exception.hs @@ -10,7 +10,7 @@ #endif module Test.QuickCheck.Exception where -#if !defined(__GLASGOW_HASKELL__) || (__GLASGOW_HASKELL__ < 700) +#if (!defined(__GLASGOW_HASKELL__) || (__GLASGOW_HASKELL__ < 700)) && !defined(__MHS__) #define OLD_EXCEPTIONS #endif @@ -63,7 +63,7 @@ tryEvaluateIO m = E.tryJust notAsync (m >>= E.evaluate) where notAsync :: AnException -> Maybe AnException -#if MIN_VERSION_base(4,7,0) +#if defined(MIN_VERSION_base) notAsync e = case E.fromException e of Just (E.SomeAsyncException _) -> Nothing Nothing -> Just e diff --git a/src/Test/QuickCheck/Features.hs b/src/Test/QuickCheck/Features.hs --- a/src/Test/QuickCheck/Features.hs +++ b/src/Test/QuickCheck/Features.hs @@ -11,6 +11,7 @@ import Test.QuickCheck.Gen import Test.QuickCheck.State import Test.QuickCheck.Text +import Test.QuickCheck.Random import qualified Data.Set as Set import Data.Set(Set) import Data.List (intersperse) @@ -85,26 +86,23 @@ -- | A variant of 'labelledExamples' that takes test arguments and returns a result. labelledExamplesWithResult :: Testable prop => Args -> prop -> IO Result -labelledExamplesWithResult args prop = - withState args $ \state -> do - let - loop :: Set String -> State -> IO Result - loop feats state = withNullTerminal $ \nullterm -> do - res <- test state{terminal = nullterm} (property (prop_noNewFeatures feats prop)) - let feats' = features (failingLabels res) (failingClasses res) - case res of - Failure{reason = "New feature found"} -> do - putLine (terminal state) $ - "*** Found example of " ++ - concat (intersperse ", " (Set.toList (feats' Set.\\ feats))) - mapM_ (putLine (terminal state)) (failingTestCase res) - putStrLn "" - loop (Set.union feats feats') - state{randomSeed = usedSeed res, replayStartSize = Just $ usedSize res} - _ -> do - out <- terminalOutput nullterm - putStr out - return res - at0 f s 0 0 = s - at0 f s n d = f n d - loop Set.empty state +labelledExamplesWithResult args prop = loop Set.empty $ replay args + where + loop :: Set String -> Maybe (QCGen, Int) -> IO Result + loop feats replay = withNullTerminal $ \nullterm -> do + res <- quickCheckWithResult args{chatty = False, replay = replay} (prop_noNewFeatures feats prop) + let feats' = features (failingLabels res) (failingClasses res) + case res of + Failure{reason = "New feature found"} -> do + putStrLn $ + "*** Found example of " ++ + concat (intersperse ", " (Set.toList (feats' Set.\\ feats))) + mapM_ putStrLn (failingTestCase res) + putStrLn "" + loop (Set.union feats feats') (Just (usedSeed res, usedSize res)) + _ -> do + out <- terminalOutput nullterm + putStr out + return res + at0 f s 0 0 = s + at0 f s n d = f n d diff --git a/src/Test/QuickCheck/Function.hs b/src/Test/QuickCheck/Function.hs --- a/src/Test/QuickCheck/Function.hs +++ b/src/Test/QuickCheck/Function.hs @@ -1,6 +1,6 @@ {-# LANGUAGE TypeOperators, GADTs, CPP, Rank2Types #-} #ifndef NO_SAFE_HASKELL -{-# LANGUAGE Safe #-} +{-# LANGUAGE Trustworthy #-} #endif #if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 708 {-# LANGUAGE PatternSynonyms, ViewPatterns #-} @@ -37,6 +37,7 @@ -- See the @'Function' [a]@ instance for an example of the latter. module Test.QuickCheck.Function ( Fun(..) + , mkFun , applyFun , apply , applyFun2 @@ -83,15 +84,31 @@ import Data.Foldable(toList) import Data.Functor.Identity import qualified Data.Monoid as Monoid +import qualified Data.Semigroup as Semigroup +import qualified Data.List.NonEmpty as NonEmpty +import Numeric.Natural +import qualified Data.Bits as Bits +import Data.Tuple +import Data.Ord +import Data.Functor.Contravariant +import Text.Printf +import System.IO +import System.Exit +import Data.Version +import Data.Array.Byte +import qualified GHC.Exts as Exts +#if defined(__MHS__) +import Data.ZipList +import Control.WrappedMonad +#endif + #if defined(MIN_VERSION_base) -#if MIN_VERSION_base(4,2,0) import System.IO ( Newline(..) , NewlineMode(..) ) #endif -#endif #ifndef NO_FIXED import Data.Fixed @@ -101,6 +118,8 @@ import GHC.Generics hiding (C) #endif +import Test.QuickCheck.Compat + -------------------------------------------------------------------------- -- concrete functions @@ -136,7 +155,14 @@ -- turning a concrete function into an abstract function (with a default result) abstract :: (a :-> c) -> c -> (a -> c) +#if defined(__MHS__) +{- This is a temporary fix for a deficiency in the MicroHs type checker. -} +abstract (Pair p) d xy = + case xy of + (x,y) -> abstract (fmap (\q -> abstract q d y) p) d x +#else abstract (Pair p) d (x,y) = abstract (fmap (\q -> abstract q d y) p) d x +#endif abstract (p :+: q) d exy = either (abstract p d) (abstract q d) exy abstract (Unit c) _ _ = c abstract Nil d _ = d @@ -261,6 +287,12 @@ h (Left _) = [] h (Right (x,xs)) = x:xs +instance Function a => Function (NonEmpty.NonEmpty a) where + function = functionMap (\(a NonEmpty.:| as) -> (a, as)) (\(a, as) -> a NonEmpty.:| as) + +instance Function a => Function (ZipList a) where + function = functionMap getZipList ZipList + instance Function a => Function (Maybe a) where function = functionMap g h where @@ -309,6 +341,9 @@ instance Function Double where function = functionRealFrac +instance Function Natural where + function = functionIntegral + -- instances for assorted types in the base package instance Function Ordering where @@ -382,7 +417,6 @@ function = functionIntegral #if defined(MIN_VERSION_base) -#if MIN_VERSION_base(4,2,0) instance Function Newline where function = functionMap g h where @@ -398,7 +432,6 @@ g (NewlineMode inNL outNL) = (inNL,outNL) h (inNL,outNL) = NewlineMode inNL outNL #endif -#endif -- instances for Data.Monoid newtypes @@ -423,11 +456,113 @@ instance Function a => Function (Monoid.Last a) where function = functionMap Monoid.getLast Monoid.Last -#if MIN_VERSION_base(4,8,0) instance Function (f a) => Function (Monoid.Alt f a) where function = functionMap Monoid.getAlt Monoid.Alt + +instance Function a => Function (Semigroup.Min a) where + function = functionMap Semigroup.getMin Semigroup.Min + +instance Function a => Function (Semigroup.Max a) where + function = functionMap Semigroup.getMax Semigroup.Max + +instance Function a => Function (Semigroup.Last a) where + function = functionMap Semigroup.getLast Semigroup.Last + +instance Function a => Function (Semigroup.First a) where + function = functionMap Semigroup.getFirst Semigroup.First + +instance Function a => Function (Semigroup.WrappedMonoid a) where + function = functionMap Semigroup.unwrapMonoid Semigroup.WrapMonoid + +instance (Function a, Function b) => Function (Semigroup.Arg a b) where + function = functionMap (\(Semigroup.Arg a b) -> (a, b)) (uncurry Semigroup.Arg) + +#if MIN_VERSION_base(4,16,0) +instance Function a => Function (Bits.And a) where + function = functionMap Bits.getAnd Bits.And + +instance Function a => Function (Bits.Ior a) where + function = functionMap Bits.getIor Bits.Ior + +instance Function a => Function (Bits.Xor a) where + function = functionMap Bits.getXor Bits.Xor + +instance Function a => Function (Bits.Iff a) where + function = functionMap Bits.getIff Bits.Iff #endif +instance Function FormatSign where + function = functionMap (\x -> case x of SignPlus -> True; _ -> False) (\b -> if b then SignPlus else SignSpace) + +instance Function FormatAdjustment where + function = functionMap (\x -> case x of LeftAdjust -> True; _ -> False) (\b -> if b then LeftAdjust else ZeroPad) + +instance Function FormatParse where + function = functionMap to from + where to fp = (fpModifiers fp, fpChar fp, fpRest fp) + from (a, b, c) = FormatParse a b c + +instance Function FieldFormat where + function = functionMap to from + where to ff = ( fmtWidth ff + , fmtPrecision ff + , fmtAdjust ff + , fmtSign ff + , fmtAlternate ff + , fmtModifiers ff + , fmtChar ff) + from (a, b, c, d, e, f, g) = FieldFormat a b c d e f g + +instance Function GeneralCategory where + function = functionBoundedEnum + +instance Function SeekMode where + function = functionElements [AbsoluteSeek, RelativeSeek, SeekFromEnd] + +instance Function IOMode where + function = functionElements [ReadMode, WriteMode, AppendMode, ReadWriteMode] + +instance Function BufferMode where + function = functionMap to from + where to NoBuffering = Left True + to LineBuffering = Left False + to (BlockBuffering m) = Right m + + from (Left True) = NoBuffering + from (Left False) = LineBuffering + from (Right m) = BlockBuffering m + +instance Function ExitCode where + function = functionMap to from + where to ExitSuccess = Nothing + to (ExitFailure c) = Just c + + from Nothing = ExitSuccess + from (Just c) = ExitFailure c + +instance Function Version where + function = functionMap to from + where to (Version a b) = (a, b) + from (a, b) = Version a b + +#if !defined(__MHS__) +instance Function ByteArray where + function = functionMap Exts.toList Exts.fromList +#endif + +#if MIN_VERSION_base(4,16,0) +instance Function a => Function (Solo a) where + function = functionMap getSolo mkSolo +#endif + +instance Function a => Function (Down a) where + function = functionMap getDown Down + +#if !MIN_VERSION_base(4,15,0) +instance Function a => Function (Semigroup.Option a) where + function = functionMap Semigroup.getOption Semigroup.Option +#endif + -- poly instances instance Function A where @@ -521,6 +656,7 @@ where shrXy (x,y) = [(x,y') | y' <- shr y] + table :: Eq aa => [(aa,cc)] -> (aa :-> cc) -- MicroHs needs this table [] = Nil table xys = Table xys @@ -584,6 +720,8 @@ #endif #endif +-- | Create a `Fun` from a function representation and a default value (in case the function +-- is partial). mkFun :: (a :-> b) -> b -> Fun a b mkFun p d = Fun (p, d, NotShrunk) (abstract p d) diff --git a/src/Test/QuickCheck/Gen.hs b/src/Test/QuickCheck/Gen.hs --- a/src/Test/QuickCheck/Gen.hs +++ b/src/Test/QuickCheck/Gen.hs @@ -21,7 +21,6 @@ ( Random , random , randomR - , split ) import Control.Monad @@ -89,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 @@ -157,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) @@ -244,7 +243,7 @@ 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 = sequence_ [ do r <- newQCGen diff --git a/src/Test/QuickCheck/Modifiers.hs b/src/Test/QuickCheck/Modifiers.hs --- a/src/Test/QuickCheck/Modifiers.hs +++ b/src/Test/QuickCheck/Modifiers.hs @@ -24,24 +24,24 @@ -- -- @ -- -- Functions cannot be shown (but see "Test.QuickCheck.Function") --- prop_TakeDropWhile ('Blind' p) (xs :: ['A']) = +-- prop_TakeDropWhile ('Blind' p) (xs :: ['Test.QuickCheck.Poly.A']) = -- takeWhile p xs ++ dropWhile p xs == xs -- @ -- -- @ --- prop_TakeDrop ('NonNegative' n) (xs :: ['A']) = +-- prop_TakeDrop ('NonNegative' n) (xs :: ['Test.QuickCheck.Poly.A']) = -- take n xs ++ drop n xs == xs -- @ -- -- @ -- -- cycle does not work for empty lists --- prop_Cycle ('NonNegative' n) ('NonEmpty' (xs :: ['A'])) = +-- prop_Cycle ('NonNegative' n) ('NonEmpty' (xs :: ['Test.QuickCheck.Poly.A'])) = -- take n (cycle xs) == take n (xs ++ cycle xs) -- @ -- -- @ --- -- Instead of 'forAll' 'orderedList' --- prop_Sort ('Ordered' (xs :: ['OrdA'])) = +-- -- Instead of 'Test.QuickCheck.forAll' 'orderedList' +-- prop_Sort ('Ordered' (xs :: ['Test.QuickCheck.Poly.OrdA'])) = -- sort xs == xs -- @ module Test.QuickCheck.Modifiers @@ -62,6 +62,7 @@ , Small(..) , Smart(..) , Shrink2(..) + , NoShrink(..) #ifndef NO_MULTI_PARAM_TYPE_CLASSES , Shrinking(..) , ShrinkState(..) @@ -164,14 +165,13 @@ instance Functor NonEmptyList where fmap f (NonEmpty x) = NonEmpty (map f x) -instance Arbitrary a => Arbitrary (NonEmptyList a) where - arbitrary = NonEmpty `fmap` (arbitrary `suchThat` (not . null)) +instance Arbitrary1 NonEmptyList where + liftArbitrary = fmap NonEmpty . listOf1 + liftShrink shr = map NonEmpty . filter (not . null) . shrinkList shr . getNonEmpty - shrink (NonEmpty xs) = - [ NonEmpty xs' - | xs' <- shrink xs - , not (null xs') - ] +instance Arbitrary a => Arbitrary (NonEmptyList a) where + arbitrary = arbitrary1 + shrink = shrink1 ---------------------------------------------------------------------- -- | @InfiniteList xs _@: guarantees that xs is an infinite list. @@ -182,7 +182,7 @@ -- -- > prop_take_10 :: InfiniteList Char -> Bool -- > prop_take_10 (InfiniteList xs _) = --- > or [ x == 'a' | x <- take 10 xs ] +-- > or [ x == \'a\' | x <- take 10 xs ] -- -- In the following counterexample, the list must start with @"bbbbbbbbbb"@ but -- the remaining (infinite) part can contain anything: @@ -411,6 +411,24 @@ ] where shrink_x = shrink x + +-------------------------------------------------------------------------- +-- | @NoShrink x@: no shrinking +newtype NoShrink a = NoShrink {getNoShrink :: a} + deriving ( Eq, Ord, Show, Read +#ifndef NO_NEWTYPE_DERIVING + , Num, Integral, Real, Enum, Ix +#endif +#ifndef NO_TYPEABLE + , Typeable +#endif + ) + +instance Functor NoShrink where + fmap f (NoShrink x) = NoShrink (f x) + +instance Arbitrary a => Arbitrary (NoShrink a) where + arbitrary = fmap NoShrink arbitrary -------------------------------------------------------------------------- -- | @Smart _ x@: tries a different order when shrinking. diff --git a/src/Test/QuickCheck/Monadic.hs b/src/Test/QuickCheck/Monadic.hs --- a/src/Test/QuickCheck/Monadic.hs +++ b/src/Test/QuickCheck/Monadic.hs @@ -1,11 +1,7 @@ {-# LANGUAGE CPP #-} #ifndef NO_SAFE_HASKELL -#if !defined(NO_ST_MONAD) && !(MIN_VERSION_base(4,8,0)) -{-# LANGUAGE Trustworthy #-} -#else {-# LANGUAGE Safe #-} #endif -#endif #ifndef NO_ST_MONAD {-# LANGUAGE Rank2Types #-} #endif @@ -142,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 diff --git a/src/Test/QuickCheck/Monoids.hs b/src/Test/QuickCheck/Monoids.hs new file mode 100644 --- /dev/null +++ b/src/Test/QuickCheck/Monoids.hs @@ -0,0 +1,83 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE Safe #-} + +module Test.QuickCheck.Monoids + ( Every (..) + , Some (..) + ) where + +#ifndef NO_SEMIGROUP +import Data.List.NonEmpty as NonEmpty +import Data.Semigroup (Semigroup (..)) +#else +import Data.Monoid (Monoid (..)) +#endif +import Test.QuickCheck.Property + +-- | Conjunction monoid built with `.&&.`. +-- +-- Use `property @Every` as an accessor which doesn't leak +-- existential variables. +-- +-- Note: monoid laws are satisfied up to 'Test.QuickCheck.isSuccess' unless one +-- is using `checkCoverage`. +-- +#ifndef NO_EXISTENTIAL_FIELD_SELECTORS +data Every = forall p. Testable p => Every { getEvery :: p } +#else +data Every = forall p. Testable p => Every p +#endif + +instance Testable Every where + property (Every p) = property p + +#ifndef NO_SEMIGROUP +instance Semigroup Every where + Every p <> Every p' = Every (p .&&. p') + sconcat = Every . conjoin . NonEmpty.toList + +instance Monoid Every where + mempty = Every True + mappend = (<>) + mconcat = Every . conjoin +#else +instance Monoid Every where + mempty = Every True + mappend (Every p) (Every p') = Every (p .&&. p') + mconcat = Every . conjoin +#endif + + +-- | Disjunction monoid built with `.||.`. +-- +-- Use `property @Some` as an accessor which doesn't leak +-- existential variables. +-- +-- Note: monoid laws are satisfied up to 'Test.QuickCheck.isSuccess' unless one +-- is using `checkCoverage`. +-- +#ifndef NO_EXISTENTIAL_FIELD_SELECTORS +data Some = forall p. Testable p => Some { getSome :: p } +#else +data Some = forall p. Testable p => Some p +#endif + +instance Testable Some where + property (Some p) = property p + +#ifndef NO_SEMIGROUP +instance Semigroup Some where + Some p <> Some p' = Some (p .||. p') + sconcat = Some . disjoin . NonEmpty.toList + +instance Monoid Some where + mempty = Some False + mappend = (<>) + mconcat = Some . disjoin +#else +instance Monoid Some where + mempty = Some False + mappend (Some p) (Some p') = Some (p .||. p') + mconcat = Some . disjoin +#endif diff --git a/src/Test/QuickCheck/Property.hs b/src/Test/QuickCheck/Property.hs --- a/src/Test/QuickCheck/Property.hs +++ b/src/Test/QuickCheck/Property.hs @@ -18,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) @@ -319,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 ] @@ -443,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. -- @@ -497,9 +523,20 @@ -- > 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, @@ -525,8 +562,9 @@ withMaxSize n = n `seq` mapTotalResult (\res -> res{ maybeMaxTestSize = Just n }) #ifndef NO_TYPEABLE --- | Return a value in the 'witnesses' field of the 'Result' returned by 'quickCheckResult'. Witnesses --- are returned outer-most first. +-- | 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: -- @@ -766,7 +804,7 @@ 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 that @table@ appears, @x2@ at least @p2@ percent of the time that @@ -775,7 +813,7 @@ -- __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 @@ -859,7 +897,8 @@ onTimeout timeoutResult n = mapRoseResult f where f rose = ioRose $ do - let m `orError` x = fmap (fromMaybe x) m + let orError :: IO (Maybe a) -> a -> IO a + m `orError` x = fmap (fromMaybe x) m MkRose res roses <- timeout n (reduceRose rose) `orError` return timeoutResult res' <- timeout n (protectResult (return res)) `orError` @@ -909,8 +948,8 @@ 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 = @@ -920,7 +959,7 @@ 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] @@ -958,7 +997,7 @@ 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] diff --git a/src/Test/QuickCheck/Random.hs b/src/Test/QuickCheck/Random.hs --- a/src/Test/QuickCheck/Random.hs +++ b/src/Test/QuickCheck/Random.hs @@ -26,17 +26,25 @@ instance Read QCGen where readsPrec n xs = [(QCGen g, ys) | (g, ys) <- readsPrec n xs] -instance RandomGen QCGen where +splitImpl :: QCGen -> (QCGen, QCGen) #ifdef NO_SPLITMIX - split (QCGen g) = +splitImpl (QCGen g) = case split g of (g1, g2) -> (QCGen g1, QCGen g2) - genRange (QCGen g) = genRange g - next = wrapQCGen next #else - split (QCGen g) = +splitImpl (QCGen g) = case splitSMGen g of (g1, g2) -> (QCGen g1, QCGen g2) +#endif + +instance RandomGen QCGen where +#if !MIN_VERSION_random(1,3,0) + split = splitImpl +#endif +#ifdef NO_SPLITMIX + genRange (QCGen g) = genRange g + next = wrapQCGen next +#else genRange _ = (minBound, maxBound) next = wrapQCGen nextInt @@ -47,10 +55,17 @@ genWord64 = wrapQCGen genWord64 genWord32R r = wrapQCGen (genWord32R r) genWord64R r = wrapQCGen (genWord64R r) - genShortByteString n = wrapQCGen (genShortByteString n) +#if MIN_VERSION_random(1,3,0) + genShortByteString n = wrapQCGen (uniformShortByteString n) #endif #endif +#endif +#if MIN_VERSION_random(1,3,0) +instance SplitGen QCGen where + splitGen = splitImpl +#endif + {-# INLINE wrapQCGen #-} #ifdef NO_SPLITMIX wrapQCGen :: (StdGen -> (a, StdGen)) -> (QCGen -> (a, QCGen)) @@ -80,8 +95,8 @@ left, right :: a -> a instance Splittable QCGen where - left = fst . split - right = snd . split + left = fst . splitImpl + right = snd . splitImpl -- The logic behind 'variant'. Given a random number seed, and an integer, uses -- splitting to transform the seed according to the integer. We use a diff --git a/src/Test/QuickCheck/State.hs b/src/Test/QuickCheck/State.hs --- a/src/Test/QuickCheck/State.hs +++ b/src/Test/QuickCheck/State.hs @@ -63,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@. + -- ^ 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@. -- - -- Lower values will speed up 'checkCoverage' at the cost of false - -- positives. + -- Lower values will speed up 'Test.QuickCheck.checkCoverage' at the cost of + -- false positives. -- - -- 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. + -- If you are using 'Test.QuickCheck.checkCoverage' as part of a test suite, + -- you should be careful not to set @certainty@ too low. If you want, say, a + -- 1% chance of a false positive during a project's lifetime, then + -- certainty@ should be set to at least @100 * m * n@, where @m@ is the + -- number of uses of 'Test.QuickCheck.cover' in the test suite, and @n@ is + -- the number of times you expect the test suite to be run during the + -- project's lifetime. The default value is chosen to be big enough for most + -- projects. tolerance :: Double - -- ^ For statistical reasons, 'checkCoverage' will not reject coverage - -- levels that are only slightly below the required levels. + -- ^ For statistical reasons, 'Test.QuickCheck.checkCoverage' will not + -- reject coverage levels that are only slightly below the required levels. -- If the required level is @p@ then an actual level of @tolerance * p@ -- will be accepted. The default value is @0.9@. -- - -- Lower values will speed up 'checkCoverage' at the cost of not detecting - -- minor coverage violations. + -- Lower values will speed up 'Test.QuickCheck.checkCoverage' at the cost of + -- not detecting minor coverage violations. } deriving Show + +-- | TestProgress, contains information that might be interesting to external +-- libraries, e.g. Tasty. From this it is possible to install your own callbacks +-- that reports e.g. progress. +data TestProgress + = TestProgress + { currentPassed :: Int -- ^ Number of tests passed so far + , currentDiscarded :: Int -- ^ Number of discared tests so far + , maxTests :: Int -- ^ Number of tests to execute + , currentShrinks :: Int -- ^ Number of successful shrinking steps + , currentFailedShrinks :: Int -- ^ Number of failed shrinking steps since last successful one + , currentTotalShrinks :: Int -- ^ Total number of failed shrinking steps + } deriving Show -------------------------------------------------------------------------- -- the end. diff --git a/src/Test/QuickCheck/Test.hs b/src/Test/QuickCheck/Test.hs --- a/src/Test/QuickCheck/Test.hs +++ b/src/Test/QuickCheck/Test.hs @@ -21,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 @@ -177,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 @@ -190,15 +189,15 @@ 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)) @@ -258,7 +257,7 @@ 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 'stdout'. +-- | 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/ @@ -267,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/ @@ -276,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/ @@ -285,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/ @@ -299,9 +298,9 @@ test :: State -> Property -> IO Result test st prop - | finishedSuccessfully st = doneTesting st prop - | finishedInsufficientCoverage st = failCoverage st prop - | tooManyDiscards st = giveUp st prop + | finishedSuccessfully st = doneTesting st + | finishedInsufficientCoverage st = failCoverage st + | tooManyDiscards st = giveUp st | otherwise = runATest st prop finishedSuccessfully :: State -> Bool @@ -352,8 +351,8 @@ | (_, _, tot, n, p) <- allCoverage st ] coverageKnownInsufficient _ = False -failCoverage :: State -> Property -> IO Result -failCoverage st prop = +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} @@ -361,8 +360,8 @@ (paragraphs [theLabels, theTables]) where (theLabels, theTables) = labelsAndTables st -doneTesting :: State -> Property -> IO Result -doneTesting st _f +doneTesting :: State -> IO Result +doneTesting st | expected st == False = do putPart (terminal st) ( bold ("*** Failed!") @@ -383,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!") @@ -426,9 +425,10 @@ MkRose res ts <- protectRose (reduceRose (unProp (unGen (unProperty prop) rnd1 size))) res <- callbackPostTest st res - let continue break st' + let continue :: (State -> IO Result) -> State -> IO Result + continue break st' | abort res = break $ updateState st' - | otherwise = test $ updateState st' + | otherwise = test (updateState st') prop updateState st0 = addNewOptions $ st0{ randomSeed = rnd2 } @@ -459,14 +459,14 @@ do continue doneTesting stC{ numSuccessTests = numSuccessTests st + 1 , numRecentlyDiscardedTests = 0 - } prop + } 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 - } prop + } MkResult{ok = Just False} -> -- failed test do (numShrinks, totFailed, lastFailed, res) <- foundFailure (addNewOptions stC) res ts @@ -498,7 +498,7 @@ #endif } where - (rnd1,rnd2) = split (randomSeed st) + (rnd1,rnd2) = splitImpl (randomSeed st) failureSummary :: State -> P.Result -> String failureSummary st res = fst (failureSummaryAndReason st res) diff --git a/test-mhs b/test-mhs new file mode 100644 --- /dev/null +++ b/test-mhs @@ -0,0 +1,25 @@ +#!/bin/sh + +set -e + +mcabal -r install + +die() { + echo "TEST FAILED" + exit 1 +} + +dotest() { + cat >Main.hs < reverse (reverse xs) === (xs :: [Int])' "OK, passed 100 tests." +dotest Test.QuickCheck 'quickCheck $ \xs -> reverse xs === (xs :: [Int])' "\[0,1\]" +echo +echo 'All tests passed!' diff --git a/tests/CollectDataTypes.hs b/tests/CollectDataTypes.hs new file mode 100644 --- /dev/null +++ b/tests/CollectDataTypes.hs @@ -0,0 +1,199 @@ +{-# LANGUAGE TemplateHaskell, RecordWildCards, DeriveLift, TupleSections, CPP, TypeOperators #-} +module CollectDataTypes where + +import Language.Haskell.TH +import Language.Haskell.TH.Syntax +import Language.Haskell.TH.Ppr +import Language.Haskell.Interpreter hiding (lift) +import Data.Maybe +import Data.List +import System.Process +import Data.List.Split +import Control.Monad +import Control.Monad.Trans.Maybe +import Control.Monad.IO.Class +import Text.Printf +import Data.Either +import Data.Char +import Data.Function +import Test.QuickCheck +import Test.QuickCheck.Function + +data DataType = + DataType { + dt_package :: String, + dt_module :: String, + dt_type :: String } + deriving (Show, Lift) + +getPackageDataTypes :: String -> IO [DataType] +getPackageDataTypes pkg = do + mods <- filter isValidModule <$> getPackageModules pkg + typess <- mapM getModuleDataTypes mods + return [DataType pkg mod typ | (mod, types) <- zip mods typess, typ <- types] + +getPackageModules :: String -> IO [String] +getPackageModules pkg = + concatMap (parseWords . words) . splitOn ", " . unwords . words <$> readProcess cmd args "" + where + cmd:args = ["ghc-pkg", "field", pkg, "exposed-modules", "--simple-output"] + parseWords [mod, "from", _] = [mod] + parseWords xs = xs + +getModuleDataTypes :: String -> IO [String] +getModuleDataTypes mod = do + putStrLn mod + Right names <- runInterpreter $ getModuleExports mod + return [x | Data x _ <- names] + +haskellName :: DataType -> String +haskellName DataType{..} = printf "%s.%s" dt_module (stripParens dt_type) + where + stripParens = reverse . dropWhile (== ')') . reverse . dropWhile (== '(') + +dataTypeType :: DataType -> Q (Maybe Type) +dataTypeType dt = do + mname <- lookupTypeName (haskellName dt) + case mname of + Nothing -> return Nothing + Just name -> Just <$> reifyType name + +typeArity :: Type -> Maybe Int +typeArity (AppT (AppT ArrowT StarT) kind) = succ <$> typeArity kind +typeArity StarT = return 0 +typeArity _ = Nothing + +createProperties :: String -> Q [Dec] +createProperties pkg = do + datatypes0 <- runIO (getPackageDataTypes pkg) + let datatypes = [ dt | dt <- datatypes0, not $ haskellName dt `elem` typeBlacklist ] + let mkImport dt = printf "import %s -- for %s" (dt_module dt) (dt_type dt) + missingModules <- fmap (map mkImport . nubBy ((==) `on` dt_module)) $ filterM (\ dt -> isNothing <$> dataTypeType dt) datatypes + unless (null missingModules) $ error ("Missing the following imports:\n" ++ unlines missingModules) + namesAndDecs <- fmap concat $ mapM createProperty datatypes + let (allNames, props) = unzip namesAndDecs + allPropsDec <- [d| allProps = + $(pure $ ListE [ TupE [Just (LitE (StringL $ nameBase name)), Just (VarE name)] + | name <- allNames ] + ) + |] + return $ allPropsDec ++ props + +createProperty :: DataType -> Q [(Name, Dec)] +createProperty dt = do + mtype <- dataTypeType dt + -- TODO: monad?! + case mtype of + Nothing -> error $ "Can't find type in scope " ++ show dt + Just typ -> case typeArity typ of + Nothing -> pure [] + Just arity -> do + Just name <- lookupTypeName (haskellName dt) + Just int <- lookupTypeName "Int" + nm <- newName ("prop_" ++ filter isAlphaNum (haskellName dt)) + nmCo <- newName ("prop_co_" ++ filter isAlphaNum (haskellName dt)) + nmFunction <- newName ("prop_function_" ++ filter isAlphaNum (haskellName dt)) + let propName = pure $ VarP nm + let propNameCo = pure $ VarP nmCo + let propNameFunction = pure $ VarP nmFunction + let ty = pure $ foldl AppT (ConT name) $ replicate arity (ConT int) + dArbitrary <- map (nm,) <$> [d| $propName = forAllBlind (arbitrary :: Gen $ty) (\ x -> x `seq` True) |] + dCoArbitrary <- map (nmCo,) <$> [d| $propNameCo = forAllBlind (arbitrary :: Gen ($ty -> Integer)) (\ x -> x `seq` True) |] + dFunction <- map (nmFunction,) <$> [d| $propNameFunction = forAllBlind (arbitrary :: Gen ($ty :-> Integer)) (\ x -> x `seq` True) |] + return $ dArbitrary ++ dCoArbitrary ++ dFunction + +typeBlacklist :: [String] +typeBlacklist = [ "Prelude.IO" + , "Prelude.ReadS" + , "Prelude.ShowS" + , "System.IO.IO" + , "System.IO.Error.IOError" + , "Prelude.IOError" + , "Data.Kind.Type" + , "Data.Array.Byte.MutableByteArray" + , "Data.IORef.IORef" + , "Data.Kind.Constraint" + , "Data.Unique.Unique" + , "Data.STRef.STRef" + , "Data.STRef.Lazy.STRef" + , "Data.STRef.Strict.STRef" + , "Data.Void.Void" + , "Data.Proxy.KProxy" + , "Data.Monoid.Endo" + , "Data.Semigroup.Endo" + , "Data.List.[]" -- This is buggy and annoying + , "System.IO.HandlePosn" + , "System.IO.Handle" + , "Text.Printf.FieldFormatter" -- This is a function type and it + -- requires an annoying coarbitrary instance + , "Text.Printf.ModifierParser" + , "Text.Show.ShowS" + ] ++ + -- These are phantom types used for indexing + [ "Data.Fixed.E" ++ show i | i <- [0,1,2,3,6,9,12] ] ++ +#if MIN_VERSION_base(4,15,0) + -- Exists but is deprecated + [ "Data.Semigroup.Option" ] ++ +#endif + -- TODO: Some controversial ones? + [ "System.IO.Error.IOErrorType" ] ++ + -- Some higher order types we ignore for the sake of CoArbitrary and Function issues + [ "System.Console.GetOpt.OptDescr" + , "System.Console.GetOpt.ArgOrder" + , "System.Console.GetOpt.ArgDescr" + ] ++ + -- System specific and, likewise, not easily doable in Function + [ "System.IO.TextEncoding" ] ++ + -- Ignored for `Function` because the test monomorphises to `Int`. fixme. + [ "Data.Complex.Complex" ] + + + + +modulePrefixBlacklist :: [String] +modulePrefixBlacklist = [ "GHC" + , "Foreign" + , "Control.Exception" + -- Exports things like MVar etc + , "Control.Concurrent" + -- Exports ST and RealWorld that we can't support + , "Control.Monad.ST" + -- Existential wrapper around a Typeable thing, could + -- be supported but would be a bit artificially + -- limited to wrapping a bunch of types we can list + , "Data.Dynamic" + -- We _could_ support this, but it would result in + -- the same problem as with Dynamic + , "Data.Typeable" + , "Type.Reflection" + -- System.Mem.Weak and System.Mem.Stable export + -- pointer types we don't support + , "System.Mem" + -- Exports an exception + , "System.Timeout" + -- Exports types, but not the constructors (or ways of + -- creating them, e.g. Number). No feasible way to + -- create meaningful generator + , "Text.Read" + -- Old generics implementation that doesn't fit nicely + -- with arbitrary, as it has the same kind of problem + -- that Typeable and Dynamic face + , "Data.Data" + -- Platform specific types that one could implement but + -- would be tricky to keep consistent and correct + -- across a number of platforms, esp. since we don't + -- have good CI tests for them + , "System.Posix" + -- This exports a bunch of combinators whose only real + -- role is to build a parser of an opaque type, + -- consequently there isn't some super-interesting + -- useful work you can do with it and it should be OK + -- not to provide instances for it + , "Text.ParserCombinators.ReadP" + -- Slightly controversial, but this is only ignored for + -- the sake of CoArbitrary and Function + , "Data.Functor.Contravariant" + ] + +isValidModule :: String -> Bool +isValidModule mod = not $ any (`isPrefixOf` mod) modulePrefixBlacklist diff --git a/tests/GCoArbitraryExample.hs b/tests/GCoArbitraryExample.hs --- a/tests/GCoArbitraryExample.hs +++ b/tests/GCoArbitraryExample.hs @@ -17,7 +17,7 @@ prop_coarbitrary (Fun _ f) = expectFailure $ - withMaxSuccess 1000 $ + withNumTests 1000 $ f (C1 (2::Int)) `elem` [0, 1 :: Int] return [] diff --git a/tests/Generators.hs b/tests/Generators.hs --- a/tests/Generators.hs +++ b/tests/Generators.hs @@ -29,7 +29,7 @@ path p (Path xs) = all p xs somePath :: (a -> Bool) -> Path a -> Property -somePath p = expectFailure . withMaxSuccess 1000 . path (not . p) +somePath p = expectFailure . withNumTests 1000 . path (not . p) newtype Extremal a = Extremal { getExtremal :: a } deriving (Show, Eq, Ord, Num, Enum, Real, Integral) @@ -139,7 +139,7 @@ reachesBound :: (Bounded a, Integral a, Arbitrary a) => a -> Property -reachesBound x = withMaxSuccess 1000 (expectFailure (x < 3 * (maxBound `div` 4))) +reachesBound x = withNumTests 1000 (expectFailure (x < 3 * (maxBound `div` 4))) prop_reachesBound_Int8 = reachesBound :: Int8 -> Property prop_reachesBound_Int16 = reachesBound :: Int16 -> Property diff --git a/tests/Misc.hs b/tests/Misc.hs --- a/tests/Misc.hs +++ b/tests/Misc.hs @@ -26,7 +26,7 @@ prop_maxSize = withMaxSize 10 (forAll (arbitrary :: Gen Int) $ \ x -> abs x < 10) prop_cover :: Property -prop_cover = withMaxSuccess 1000 +prop_cover = withNumTests 1000 $ checkCoverage $ forAll (arbitrary :: Gen Int) $ \ x -> cover 5 (x > 0) "positive" True diff --git a/tests/Monoids.hs b/tests/Monoids.hs new file mode 100644 --- /dev/null +++ b/tests/Monoids.hs @@ -0,0 +1,146 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE ConstraintKinds #-} + +#if __GLASGOW_HASKELL__ >= 800 +{-# OPTIONS_GHC -Wno-orphans #-} +#endif +{-# LANGUAGE FlexibleInstances #-} + +module Main (main) where + +#ifndef NO_SEMIGROUP_CLASS +import Data.List.NonEmpty +import Data.Semigroup (Semigroup (..)) +#else +import Data.Monoid (Monoid (..), (<>)) +#endif + +import Test.QuickCheck + +#ifdef NO_SEMIGROUP_CLASS +type Semigroup = Monoid +sconcat :: Monoid a => [a] -> a +sconcat = mconcat +#endif + +instance Arbitrary Every where + arbitrary = oneof [ pure $ Every True + , pure $ Every False + , pure $ Every (counterexample "False" False) + , pure $ Every (counterexample "True" True) + , pure $ Every (ioProperty (return True)) + , pure $ Every (ioProperty (return False)) + , pure $ Every (checkCoverage $ cover 100 True "" True) + , pure $ Every (checkCoverage $ cover 100 True "" False) + , pure $ Every (checkCoverage $ cover 100 False "" False) + ] + + +instance Arbitrary Some where + arbitrary = oneof [ pure $ Some True + , pure $ Some False + , pure $ Some (counterexample "False" False) + , pure $ Some (counterexample "True" True) + , pure $ Some (ioProperty (return True)) + , pure $ Some (ioProperty (return False)) + , pure $ Some (checkCoverage $ cover 100 True "" True) + , pure $ Some (checkCoverage $ cover 100 True "" False) + , pure $ Some (checkCoverage $ cover 100 False "" True) + , pure $ Some (checkCoverage $ cover 100 False "" False) + ] + + +newtype Fail a = Fail a + +instance Arbitrary (Fail Every) where + arbitrary = oneof [ Fail <$> (arbitrary :: Gen Every) + , pure $ Fail $ Every (checkCoverage $ cover 100 False "" True) + ] + + +check_associative_law :: (Testable p, Semigroup p) => Blind p -> Blind p -> Blind p -> Property +check_associative_law (Blind a) (Blind b) (Blind c) = ioProperty $ do + x <- isSuccess <$> quickCheckWithResult args (a <> (b <> c)) + y <- isSuccess <$> quickCheckWithResult args ((a <> b) <> c) + return (x == y) + + +#ifndef NO_SEMIGROUP_SUPERCLASS +check_unit_law :: (Testable p, Monoid p) => Blind p -> Property +#else +check_unit_law :: (Testable p, Monoid p, Semigroup p) => Blind p -> Property +#endif +check_unit_law (Blind a) = ioProperty $ do + x <- isSuccess <$> quickCheckWithResult args (a <> mempty) + y <- isSuccess <$> quickCheckWithResult args (mempty <> a) + z <- isSuccess <$> quickCheckWithResult args a + return (x == y .&&. y == z) + + +#ifndef NO_SEMIGROUP_CLASS +check_sconcat_law :: (Testable p, Semigroup p) => Blind p -> Blind p -> Property +check_sconcat_law (Blind a) (Blind b) = ioProperty $ do + x <- isSuccess <$> quickCheckWithResult args (sconcat $ a :| [b]) + y <- isSuccess <$> quickCheckWithResult args (a <> b) + return (x == y) +#endif + + +#ifndef NO_SEMIGROUP_SUPERCLASS +check_mconcat_law :: (Testable p, Monoid p) => Blind p -> Blind p -> Property +#else +check_mconcat_law :: (Testable p, Monoid p, Semigroup p) => Blind p -> Blind p -> Property +#endif +check_mconcat_law (Blind a) (Blind b) = ioProperty $ do + x <- isSuccess <$> quickCheckWithResult args (mconcat [a, b]) + y <- isSuccess <$> quickCheckWithResult args (a <> b) + return (x == y) + + +-- +-- Auxiliary definitions +-- + +args :: Args +args = stdArgs { chatty = False, maxShrinks = 0 } + +-- +-- Properties +-- + +prop_every_associative :: Blind Every -> Blind Every -> Blind Every -> Property +prop_every_associative = check_associative_law + +prop_every_unit :: Blind Every -> Property +prop_every_unit = check_unit_law + +prop_every_unit_fail :: Blind (Fail Every) -> Property +prop_every_unit_fail (Blind (Fail a)) = + expectFailure $ check_unit_law (Blind a) + +#ifndef NO_SEMIGROUP_CLASS +prop_every_sconcat_law :: Blind Every -> Blind Every -> Property +prop_every_sconcat_law = check_sconcat_law +#endif + +prop_every_mconcat_law :: Blind Every -> Blind Every -> Property +prop_every_mconcat_law = check_mconcat_law + +prop_some_associative :: Blind Some -> Blind Some -> Blind Some -> Property +prop_some_associative = check_associative_law + +prop_some_unit :: Blind Some -> Property +prop_some_unit = check_unit_law + +#ifndef NO_SEMIGROUP_CLASS +prop_some_sconcat_law :: Blind Some -> Blind Some -> Property +prop_some_sconcat_law = check_sconcat_law +#endif + +prop_some_mconcat_law :: Blind Some -> Blind Some -> Property +prop_some_mconcat_law = check_mconcat_law + +return [] +main = do True <- $quickCheckAll; return () + diff --git a/tests/RunCollectDataTypes.hs b/tests/RunCollectDataTypes.hs new file mode 100644 --- /dev/null +++ b/tests/RunCollectDataTypes.hs @@ -0,0 +1,89 @@ +{-# LANGUAGE TemplateHaskell, CPP #-} +{-# OPTIONS_GHC -ddump-splices #-} +import CollectDataTypes +import Language.Haskell.TH +import Test.QuickCheck.All +import Test.QuickCheck + +import Control.Applicative +import Control.Arrow +import Control.Concurrent +import Control.Concurrent.Chan +import Control.Concurrent.MVar +import Control.Concurrent.QSem +import Control.Concurrent.QSemN +import Control.Exception +import Control.Exception.Base +import Control.Monad.ST +import Control.Monad.ST.Lazy +import Control.Monad.ST.Strict +#if defined(MIN_VERSION_base) +#if MIN_VERSION_base(4,17,0) +import Data.Array.Byte +#endif +#endif +import Data.Bits +import Data.Bool +import Data.Char +import Data.Complex +import Data.Data +import Data.Dynamic +import Data.Either +import Data.Fixed +import Data.Functor.Compose +import Data.Functor.Const +import Data.Functor.Contravariant +import Data.Functor.Identity +import Data.Functor.Product +import Data.Functor.Sum +import Data.IORef +import Data.Int +import Data.Kind +import Data.List.NonEmpty +import Data.Maybe +import Data.Monoid +import Data.Ord +import Data.Proxy +import Data.Ratio +import Data.STRef +import Data.STRef.Lazy +import Data.STRef.Strict +import Data.Semigroup +import Data.String +import Data.Tuple +import Data.Type.Bool +import Data.Type.Coercion +import Data.Type.Equality +#if defined(MIN_VERSION_base) +#if MIN_VERSION_base(4,16,0) +import Data.Type.Ord +#endif +#endif +import Data.Typeable +import Data.Unique +import Data.Version +import Data.Void +import Data.Word +import Numeric.Natural +import System.Console.GetOpt +import System.Exit +import System.IO +import System.IO.Error +import System.Mem.StableName +import System.Mem.Weak +import System.Posix.Internals +import System.Posix.Types +import System.Timeout +import Text.ParserCombinators.ReadP +import Text.ParserCombinators.ReadPrec +import Text.Printf +import Text.Read +import Text.Read.Lex +import Text.Show +import Type.Reflection +import Type.Reflection.Unsafe +import Unsafe.Coerce + +$(createProperties "base") + +main = runQuickCheckAll allProps quickCheckResult diff --git a/tests/Terminal.hs b/tests/Terminal.hs --- a/tests/Terminal.hs +++ b/tests/Terminal.hs @@ -63,7 +63,7 @@ -- * Anything written to stderr (presumably by putTemp) is erased prop_terminal :: [Command] -> Property prop_terminal cmds = - withMaxSuccess 1000 $ ioProperty $ + withNumTests 1000 $ ioProperty $ withPipe $ \stdout_read stdout_write -> withPipe $ \stderr_read stderr_write -> do out <- withHandleTerminal stdout_write (Just stderr_write) $ \tm -> do diff --git a/tests/WithProgress.hs b/tests/WithProgress.hs new file mode 100644 --- /dev/null +++ b/tests/WithProgress.hs @@ -0,0 +1,68 @@ +import Test.QuickCheck +import Test.QuickCheck.Monadic + +import Data.IORef +import System.Exit (exitSuccess, exitFailure) +import Control.Monad (when) + +main :: IO () +main = do + succ <- newIORef 0 + disc <- newIORef 0 + + -- test 1 + quickCheck (propTestWithProgress succ) + i <- readIORef succ + when (i /= 99) exitFailure + + modifyIORef succ (const 0) + + -- test 2 + quickCheck (proptestWithProgressDiscard succ disc) + i1 <- readIORef succ + i2 <- readIORef disc + putStrLn $ show i1 + putStrLn $ show i2 + when (i1 /= 0 || i2 /= 999) exitFailure + + modifyIORef succ (const 0) + modifyIORef disc (const 0) + + -- test 3 + quickCheck (proptestWithProgressNotInstalled succ disc) + i1 <- readIORef succ + i2 <- readIORef disc + putStrLn $ show i1 + putStrLn $ show i2 + when (i1 /= 0 || i2 /= 0) exitFailure + + exitSuccess + +-- all these tests succeed, incrementing the counter every time +propTestWithProgress :: IORef Int -> Property +propTestWithProgress ref = + forAll (arbitrary :: Gen Int) $ \n -> + withProgress (\p -> modifyIORef ref (\_ -> currentPassed p)) + $ n == n + +-- all of these tests are discarded, never updating the currentPassed counter, but always +-- the currentDiscarded one. +proptestWithProgressDiscard :: IORef Int -> IORef Int -> Property +proptestWithProgressDiscard succ disc = + forAll (arbitrary :: Gen Int) $ \n -> + withProgress (\p -> do + modifyIORef succ (\_ -> currentPassed p) + modifyIORef disc (\_ -> currentDiscarded p)) + $ n > 1000 ==> + n == n + +-- The callback is installed after the test on n, meaning that since all tests are +-- discarded, it will never be called. It will never be executed. +proptestWithProgressNotInstalled :: IORef Int -> IORef Int -> Property +proptestWithProgressNotInstalled succ disc = + forAll (arbitrary :: Gen Int) $ \n -> + n > 1000 ==> + withProgress (\p -> do + modifyIORef succ (\_ -> currentPassed p) + modifyIORef disc (\_ -> currentDiscarded p)) + $ n == n