QuickCheck 2.9.2 → 2.10

raw patch · 26 files changed

+2263/−398 lines, 26 filesdep +deepseqdep −natsdep −semigroupsdep −test-frameworkdep ~QuickCheckdep ~basedep ~randomPVP ok

version bump matches the API change (PVP)

Dependencies added: deepseq

Dependencies removed: nats, semigroups, test-framework

Dependency ranges changed: QuickCheck, base, random, transformers

API changes (from Hackage documentation)

Files

• LICENSE +4/−3
• QuickCheck.cabal +46/−46
• README +2/−8
• Test/QuickCheck.hs +57/−54
• Test/QuickCheck/Arbitrary.hs +357/−82
• Test/QuickCheck/Exception.hs +13/−1
• Test/QuickCheck/Function.hs +82/−35
• Test/QuickCheck/Gen.hs +44/−14
• Test/QuickCheck/Gen/Unsafe.hs +3/−0
• Test/QuickCheck/Modifiers.hs +34/−2
• Test/QuickCheck/Monadic.hs +34/−11
• Test/QuickCheck/Poly.hs +63/−17
• Test/QuickCheck/Property.hs +152/−51
• Test/QuickCheck/Random.hs +1/−1
• Test/QuickCheck/State.hs +1/−1
• Test/QuickCheck/Test.hs +100/−68
• Test/QuickCheck/Text.hs +0/−1
• changelog +68/−0
• examples/Heap.hs +0/−2
• examples/Heap_Program.hs +197/−0
• examples/Heap_ProgramAlgebraic.hs +254/−0
• examples/Lambda.hs +363/−0
• examples/Merge.hs +116/−0
• examples/Set.hs +213/−0
• examples/Simple.hs +46/−0
• tests/Generators.hs +13/−1

@@ -1,7 +1,8 @@-Copyright (c) 2000-2016, Koen Claessen+(The following is the 3-clause BSD license.)++Copyright (c) 2000-2017, Koen Claessen Copyright (c) 2006-2008, Björn Bringert-Copyright (c) 2009-2016, Nick Smallbone-All rights reserved.+Copyright (c) 2009-2017, Nick Smallbone  Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met:

@@ -1,35 +1,47 @@ Name: QuickCheck-Version: 2.9.2+Version: 2.10 Cabal-Version: >= 1.8 Build-type: Simple License: BSD3 License-file: LICENSE-Extra-source-files: README changelog-Copyright: 2000-2016 Koen Claessen, 2006-2008 Björn Bringert, 2009-2016 Nick Smallbone+Copyright: 2000-2017 Koen Claessen, 2006-2008 Björn Bringert, 2009-2017 Nick Smallbone Author: Koen Claessen <koen@chalmers.se>-Maintainer: QuickCheck developers <quickcheck@projects.haskell.org>-Bug-reports: mailto:quickcheck@projects.haskell.org-Tested-with: GHC >= 7+Maintainer: Nick Smallbone <nick@smallbone.se>; see also QuickCheck mailing list (https://groups.google.com/forum/#!forum/haskell-quickcheck)+Bug-reports: https://github.com/nick8325/quickcheck/issues+Tested-with: GHC == 7.0.4, GHC == 7.2.2, GHC >= 7.4 Homepage: https://github.com/nick8325/quickcheck Category:       Testing Synopsis:       Automatic testing of Haskell programs Description:   QuickCheck is a library for random testing of program properties.   .-  The programmer provides a specification of the program, in-  the form of properties which functions should satisfy, and-  QuickCheck then tests that the properties hold in a large number-  of randomly generated cases.+  The programmer provides a specification of the program, in the form of+  properties which functions should satisfy, and QuickCheck then tests that the+  properties hold in a large number of randomly generated cases.   .-  Specifications are expressed in-  Haskell, using combinators defined in the QuickCheck library.-  QuickCheck provides combinators to define properties, observe-  the distribution of test data, and define test-  data generators.+  Specifications are expressed in Haskell, using combinators defined in the+  QuickCheck library. QuickCheck provides combinators to define properties,+  observe the distribution of test data, and define test data generators.   .-  You can find a (slightly out-of-date but useful) manual at-  <http://www.cse.chalmers.se/~rjmh/QuickCheck/manual.html>.+  The <http://www.cse.chalmers.se/~rjmh/QuickCheck/manual.html official QuickCheck manual>+  explains how to write generators and properties;+  it is out-of-date in some details but still full of useful advice.+  .+  A user of QuickCheck has written an unofficial, but detailed, tutorial which+  you can find at+  <https://begriffs.com/posts/2017-01-14-design-use-quickcheck.html>. +extra-source-files:+  README+  changelog+  examples/Heap.hs+  examples/Heap_Program.hs+  examples/Heap_ProgramAlgebraic.hs+  examples/Lambda.hs+  examples/Merge.hs+  examples/Set.hs+  examples/Simple.hs+ source-repository head   type:     git   location: https://github.com/nick8325/quickcheck@@ -37,7 +49,7 @@ source-repository this   type:     git   location: https://github.com/nick8325/quickcheck-  tag:      2.9.2+  tag:      2.10  flag templateHaskell   Description: Build Test.QuickCheck.All, which uses Template Haskell.@@ -65,9 +77,9 @@   -- GHC-specific modules.   if impl(ghc)     Exposed-Modules: Test.QuickCheck.Function-    Build-depends: transformers >= 0.2+    Build-depends: transformers >= 0.3, deepseq   else-    cpp-options: -DNO_TRANSFORMERS+    cpp-options: -DNO_TRANSFORMERS -DNO_DEEPSEQ    if impl(ghc) && flag(templateHaskell)     Build-depends: template-haskell >= 2.4@@ -76,6 +88,9 @@   else     cpp-options: -DNO_TEMPLATE_HASKELL +  if !impl(ghc >= 7.4)+    cpp-options: -DNO_CTYPES+   -- The new generics appeared in GHC 7.2...   if impl(ghc < 7.2)     cpp-options: -DNO_GENERICS@@ -93,19 +108,11 @@   else     cpp-options: -DNO_TF_RANDOM -  if impl(ghc)-    if impl(ghc < 7.10)-      -- `Numeric.Natural` is available in base only since GHC 7.10 / base 4.8-      build-depends: nats>=1-  else-      cpp-options: -DNO_NATURALS+  if !impl(ghc >= 7.6)+      cpp-options: -DNO_POLYKINDS -  if impl(ghc)-    -- 'Data.List.NonEmpty' is available in base only since GHC 8.0 / base 4.9-    if impl(ghc < 8.0)-      build-depends: semigroups >=0.9-  else-      cpp-options: -DNO_NONEMPTY+  if !impl(ghc >= 8.0)+    cpp-options: -DNO_MONADFAIL    -- Switch off most optional features on non-GHC systems.   if !impl(ghc)@@ -131,23 +138,16 @@     hs-source-dirs:         examples     main-is: Heap.hs-    build-depends:-      base,-      containers,-      QuickCheck == 2.9.2,-      template-haskell >= 2.4,-      test-framework >= 0.4 && < 0.9-    if flag(templateHaskell)-        Buildable: True-    else+    build-depends: base, QuickCheck+    if !flag(templateHaskell)         Buildable: False  Test-Suite test-quickcheck-gcoarbitrary     type: exitcode-stdio-1.0     hs-source-dirs: tests     main-is: GCoArbitraryExample.hs-    build-depends: base, QuickCheck == 2.9.2-    if impl(ghc < 7.2)+    build-depends: base, QuickCheck+    if !impl(ghc >= 7.2)         buildable: False     if impl(ghc >= 7.2) && impl(ghc < 7.6)         build-depends: ghc-prim@@ -156,7 +156,7 @@     type: exitcode-stdio-1.0     hs-source-dirs: tests     main-is: Generators.hs-    build-depends: base, QuickCheck == 2.9.2+    build-depends: base, QuickCheck     if !flag(templateHaskell)         Buildable: False @@ -164,8 +164,8 @@     type: exitcode-stdio-1.0     hs-source-dirs: tests     main-is: GShrinkExample.hs-    build-depends: base, QuickCheck == 2.9.2-    if impl(ghc < 7.2)+    build-depends: base, QuickCheck+    if !impl(ghc >= 7.2)         buildable: False     if impl(ghc >= 7.2) && impl(ghc < 7.6)         build-depends: ghc-prim

@@ -4,11 +4,5 @@  $ cabal install -Please report bugs to the QuickCheck mailing list at-quickcheck@projects.haskell.org.--If you get errors about Template Haskell, try--$ cabal install -f-templateHaskell--but please report this as a bug.+There is a Google group for user discussion and questions at+https://groups.google.com/forum/#!forum/haskell-quickcheck.

@@ -1,74 +1,42 @@-{-| For further information see the <http://www.cse.chalmers.se/~rjmh/QuickCheck/manual.html QuickCheck manual>.+{-|+The <http://www.cse.chalmers.se/~rjmh/QuickCheck/manual.html QuickCheck manual>+gives detailed information about using QuickCheck effectively. -To use QuickCheck to check a property, first define a function-expressing that property (functions expressing properties under test-tend to be prefixed with @prop_@). Testing that @n + m = m + n@ holds-for @Integer@s one might write:+To start using QuickCheck, write down your property as a function returning @Bool@.+For example, to check that reversing a list twice gives back the same list you can write:  @ import Test.QuickCheck -prop_commutativeAdd :: Integer -> Integer -> Bool-prop_commutativeAdd n m = n + m == m + n+prop_reverse :: [Int] -> Bool+prop_reverse xs = reverse (reverse xs) == xs @ -and testing:-->>> quickCheck prop_commutativeAdd-+++ OK, passed 100 tests.--which tests @prop_commutativeAdd@ on 100 random @(Integer, Integer)@ pairs.--'verboseCheck' can be used to see the actual values generated:+You can then use QuickCheck to test @prop_reverse@ on 100 random lists: ->>> verboseCheck prop_commutativeAdd-Passed:-0-0-  …98 tests omitted…-Passed:--68-6+>>> quickCheck prop_reverse +++ OK, passed 100 tests. -and if more than 100 tests are needed the number of tests can be-increased by updating the 'stdArgs' record:-->>> quickCheckWith stdArgs { maxSuccess = 500 } prop_commutativeAdd-+++ OK, passed 500 tests.--To let QuickCheck generate values of your own data type an 'Arbitrary'-instance must be defined:--@-data Point = MkPoint Int Int deriving Eq--instance Arbitrary Point where-  arbitrary = do-    x <- 'arbitrary'-    y <- arbitrary-    return (MkPoint x y)--swapPoint :: Point -> Point-swapPoint (MkPoint x y) = MkPoint y x---- swapPoint . swapPoint = id-prop_swapInvolution point = swapPoint (swapPoint point) == point-@+To run more tests you can use the 'withMaxSuccess' combinator: ->>> quickCheck prop_swapInvolution-+++ OK, passed 100 tests.+>>> quickCheck (withMaxSuccess 10000 prop_reverse)++++ OK, passed 10000 tests. -See "Test.QuickCheck.Function" for generating random shrinkable,-showable functions used for testing higher-order functions and-"Test.QuickCheck.Monadic" for testing impure or monadic code-(e.g. effectful code in 'IO').+To use QuickCheck on your own data types you will need to write 'Arbitrary'+instances for those types. See the+<http://www.cse.chalmers.se/~rjmh/QuickCheck/manual.html QuickCheck manual> for+details about how to do that. +This module exports most of QuickCheck's functionality, but see also+"Test.QuickCheck.Monadic" which helps with testing impure or monadic code. -} {-# LANGUAGE CPP #-} #ifndef NO_SAFE_HASKELL {-# LANGUAGE Safe #-} #endif+#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 708+{-# LANGUAGE PatternSynonyms #-}+#endif module Test.QuickCheck   (     -- * Running tests@@ -103,9 +71,11 @@   , elements   , growingElements   , sized+  , getSize   , resize   , scale   , suchThat+  , suchThatMap   , suchThatMaybe   , listOf   , listOf1@@ -127,6 +97,14 @@   , Arbitrary(..)   , CoArbitrary(..) +  -- ** Unary and Binary classes+  , Arbitrary1(..)+  , arbitrary1+  , shrink1+  , Arbitrary2(..)+  , arbitrary2+  , shrink2+     -- ** Helper functions for implementing arbitrary   , arbitrarySizedIntegral   , arbitrarySizedNatural@@ -135,6 +113,9 @@   , arbitraryBoundedIntegral   , arbitraryBoundedRandom   , arbitraryBoundedEnum+  , arbitraryUnicodeChar+  , arbitraryASCIIChar+  , arbitraryPrintableChar     -- ** Helper functions for implementing shrink #ifndef NO_GENERICS   , genericCoarbitrary@@ -144,6 +125,8 @@ #endif   , shrinkNothing   , shrinkList+  , shrinkMap+  , shrinkMapBy   , shrinkIntegral   , shrinkRealFrac     -- ** Helper functions for implementing coarbitrary@@ -170,7 +153,23 @@   , Shrinking(..)   , ShrinkState(..) #endif+  , ASCIIString(..)+  , UnicodeString(..)+  , PrintableString(..) +    -- ** Functions+  , Fun+  , applyFun+  , applyFun2+  , applyFun3+#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 708+  , pattern Fn+  , pattern Fn2+  , pattern Fn3+#endif+  , Function (..)+  , functionMap+     -- * Properties   , Property, Testable(..)     -- ** Property combinators@@ -179,11 +178,15 @@   , shrinking   , (==>)   , (===)+#ifndef NO_DEEPSEQ+  , total+#endif   , ioProperty     -- *** Controlling property execution   , verbose   , once   , again+  , withMaxSuccess   , within   , noShrinking     -- *** Conjunction and disjunction@@ -218,8 +221,8 @@ import Test.QuickCheck.Modifiers import Test.QuickCheck.Property hiding ( Result(..) ) import Test.QuickCheck.Test-import Test.QuickCheck.Text import Test.QuickCheck.Exception+import Test.QuickCheck.Function #ifndef NO_TEMPLATE_HASKELL import Test.QuickCheck.All #endif

@@ -1,13 +1,20 @@ -- | Type classes for random generation of values. {-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleContexts #-} #ifndef NO_GENERICS {-# LANGUAGE DefaultSignatures, FlexibleContexts, TypeOperators #-} {-# LANGUAGE FlexibleInstances, KindSignatures, ScopedTypeVariables #-} {-# LANGUAGE MultiParamTypeClasses #-}-#if __GLASGOW_HASKELL__ < 710+#if __GLASGOW_HASKELL__ >= 710+#define OVERLAPPING_ {-# OVERLAPPING #-}+#else {-# LANGUAGE OverlappingInstances  #-}+#define OVERLAPPING_ #endif #endif+#ifndef NO_POLYKINDS+{-# LANGUAGE PolyKinds #-}+#endif #ifndef NO_SAFE_HASKELL {-# LANGUAGE Safe #-} #endif@@ -17,6 +24,14 @@     Arbitrary(..)   , CoArbitrary(..) +  -- ** Unary and Binary classes+  , Arbitrary1(..)+  , arbitrary1+  , shrink1+  , Arbitrary2(..)+  , arbitrary2+  , shrink2+   -- ** Helper functions for implementing arbitrary   , arbitrarySizedIntegral        -- :: Integral a => Gen a   , arbitrarySizedNatural         -- :: Integral a => Gen a@@ -25,6 +40,10 @@   , arbitrarySizedFractional      -- :: Fractional a => Gen a   , arbitraryBoundedRandom        -- :: (Bounded a, Random a) => Gen a   , arbitraryBoundedEnum          -- :: (Bounded a, Enum a) => Gen a+  -- ** Generators for various kinds of character+  , arbitraryUnicodeChar   -- :: Gen Char+  , arbitraryASCIIChar     -- :: Gen Char+  , arbitraryPrintableChar -- :: Gen Char   -- ** Helper functions for implementing shrink #ifndef NO_GENERICS   , genericShrink      -- :: (Generic a, Arbitrary a, RecursivelyShrink (Rep a), GSubterms (Rep a) a) => a -> [a]@@ -34,6 +53,8 @@ #endif   , shrinkNothing            -- :: a -> [a]   , shrinkList               -- :: (a -> [a]) -> [a] -> [[a]]+  , shrinkMap                -- :: Arbitrary a -> (a -> b) -> (b -> a) -> b -> [b]+  , shrinkMapBy              -- :: (a -> b) -> (b -> a) -> (a -> [a]) -> b -> [b]   , shrinkIntegral           -- :: Integral a => a -> [a]   , shrinkRealFrac           -- :: RealFrac a => a -> [a]   -- ** Helper functions for implementing coarbitrary@@ -57,6 +78,7 @@ import Data.Foldable(toList) import System.Random(Random) import Test.QuickCheck.Gen+import Test.QuickCheck.Random import Test.QuickCheck.Gen.Unsafe  {-@@ -68,13 +90,15 @@ -}  import Data.Char-  ( chr-  , ord+  ( ord   , isLower   , isUpper   , toLower   , isDigit   , isSpace+  , isPrint+  , generalCategory+  , GeneralCategory(..)   )  #ifndef NO_FIXED@@ -84,10 +108,6 @@   ) #endif -#ifndef NO_NATURALS-import Numeric.Natural-#endif- import Data.Ratio   ( Ratio   , (%)@@ -103,11 +123,6 @@   , nub   ) -#ifndef NO_NONEMPTY-import Data.List.NonEmpty (NonEmpty (..), nonEmpty)-import Data.Maybe (mapMaybe)-#endif- import Data.Version (Version (..))  import Control.Monad@@ -120,6 +135,10 @@  import Data.Int(Int8, Int16, Int32, Int64) import Data.Word(Word, Word8, Word16, Word32, Word64)+import System.Exit (ExitCode(..))+#ifndef NO_CTYPES+import Foreign.C.Types+#endif  #ifndef NO_GENERICS import GHC.Generics@@ -136,25 +155,52 @@ #ifndef NO_TRANSFORMERS import Data.Functor.Identity import Data.Functor.Constant+import Data.Functor.Compose+import Data.Functor.Product #endif  -------------------------------------------------------------------------- -- ** class Arbitrary  -- | Random generation and shrinking of values.+--+-- QuickCheck provides @Arbitrary@ instances for most types in @base@,+-- except those which incur extra dependencies.+-- For a wider range of @Arbitrary@ instances see the+-- <http://hackage.haskell.org/package/quickcheck-instances quickcheck-instances>+-- package. class Arbitrary a where   -- | A generator for values of the given type.+  --+  -- 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.+  --+  -- 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+  -- <http://hackage.haskell.org/package/testing-feat testing-feat> package.+  --+  -- The <http://www.cse.chalmers.se/~rjmh/QuickCheck/manual.html QuickCheck manual>+  -- goes into detail on how to write good generators. Make sure to look at it,+  -- especially if your type is recursive!   arbitrary :: Gen a    -- | Produces a (possibly) empty list of all the possible-  -- immediate shrinks of the given value. The default implementation-  -- returns the empty list, so will not try to shrink the value.+  -- immediate shrinks of the given value.   --+  -- The default implementation returns the empty list, so will not try to+  -- shrink the value. If your data type has no special invariants, you can+  -- enable shrinking by defining @shrink = 'genericShrink'@, but by customising+  -- the behaviour of @shrink@ you can often get simpler counterexamples.+  --   -- Most implementations of 'shrink' should try at least three things:   --   -- 1. Shrink a term to any of its immediate subterms.+  --    You can use 'subterms' to do this.   --   -- 2. Recursively apply 'shrink' to all immediate subterms.+  --    You can use 'recursivelyShrink' to do this.   --   -- 3. Type-specific shrinkings such as replacing a constructor by a   --    simpler constructor.@@ -188,8 +234,7 @@   --   the three is fully shrunk.   --   -- There is a fair bit of boilerplate in the code above.-  -- We can avoid it with the help of some generic functions;-  -- note that these only work on GHC 7.2 and above.+  -- We can avoid it with the help of some generic functions.   -- The function 'genericShrink' tries shrinking a term to all of its   -- subterms and, failing that, recursively shrinks the subterms.   -- Using it, we can define 'shrink' as:@@ -214,6 +259,30 @@   shrink :: a -> [a]   shrink _ = [] +-- | Lifting of the 'Arbitrary' class to unary type constructors.+class Arbitrary1 f where+  liftArbitrary :: Gen a -> Gen (f a)+  liftShrink    :: (a -> [a]) -> f a -> [f a]+  liftShrink _ _ = []++arbitrary1 :: (Arbitrary1 f, Arbitrary a) => Gen (f a)+arbitrary1 = liftArbitrary arbitrary++shrink1 :: (Arbitrary1 f, Arbitrary a) => f a -> [f a]+shrink1 = liftShrink shrink++-- | Lifting of the 'Arbitrary' class to binary type constructors.+class Arbitrary2 f where+  liftArbitrary2 :: Gen a -> Gen b -> Gen (f a b)+  liftShrink2    :: (a -> [a]) -> (b -> [b]) -> f a b -> [f a b]+  liftShrink2 _ _ _ = []++arbitrary2 :: (Arbitrary2 f, Arbitrary a, Arbitrary b) => Gen (f a b)+arbitrary2 = liftArbitrary2 arbitrary arbitrary++shrink2 :: (Arbitrary2 f, Arbitrary a, Arbitrary b) => f a b -> [f a b]+shrink2 = liftShrink2 shrink shrink+ #ifndef NO_GENERICS -- | Shrink a term to any of its immediate subterms, -- and also recursively shrink all subterms.@@ -314,18 +383,21 @@   gSubtermsIncl (M1 x) = gSubtermsIncl x  -- This is the important case: We've found a term of the same type.-instance {-# OVERLAPPING #-} GSubtermsIncl (K1 i a) a where+instance OVERLAPPING_ GSubtermsIncl (K1 i a) a where   gSubtermsIncl (K1 x) = [x] -instance {-# OVERLAPPING #-} GSubtermsIncl (K1 i a) b where+instance OVERLAPPING_ GSubtermsIncl (K1 i a) b where   gSubtermsIncl (K1 _) = []  #endif  -- instances +instance (CoArbitrary a) => Arbitrary1 ((->) a) where+  liftArbitrary arbB = promote (`coarbitrary` arbB)+ instance (CoArbitrary a, Arbitrary b) => Arbitrary (a -> b) where-  arbitrary = promote (`coarbitrary` arbitrary)+  arbitrary = arbitrary1  instance Arbitrary () where   arbitrary = return ()@@ -341,27 +413,37 @@   shrink LT = [EQ]   shrink EQ = [] +instance Arbitrary1 Maybe where+  liftArbitrary arb = frequency [(1, return Nothing), (3, liftM Just arb)]++  liftShrink shr (Just x) = Nothing : [ Just x' | x' <- shr x ]+  liftShrink _   Nothing  = []+ instance Arbitrary a => Arbitrary (Maybe a) where-  arbitrary = frequency [(1, return Nothing), (3, liftM Just arbitrary)]+  arbitrary = arbitrary1+  shrink = shrink1 -  shrink (Just x) = Nothing : [ Just x' | x' <- shrink x ]-  shrink _        = []+instance Arbitrary2 Either where+  liftArbitrary2 arbA arbB = oneof [liftM Left arbA, liftM Right arbB] +  liftShrink2 shrA _ (Left x)  = [ Left  x' | x' <- shrA x ]+  liftShrink2 _ shrB (Right y) = [ Right y' | y' <- shrB y ]++instance Arbitrary a => Arbitrary1 (Either a) where+  liftArbitrary = liftArbitrary2 arbitrary+  liftShrink = liftShrink2 shrink+ instance (Arbitrary a, Arbitrary b) => Arbitrary (Either a b) where-  arbitrary = oneof [liftM Left arbitrary, liftM Right arbitrary]+  arbitrary = arbitrary2+  shrink = shrink2 -  shrink (Left x)  = [ Left  x' | x' <- shrink x ]-  shrink (Right y) = [ Right y' | y' <- shrink y ]+instance Arbitrary1 [] where+  liftArbitrary = listOf+  liftShrink = shrinkList  instance Arbitrary a => Arbitrary [a] where-  arbitrary = listOf arbitrary-  shrink xs = shrinkList shrink xs--#ifndef NO_NONEMPTY-instance Arbitrary a => Arbitrary (NonEmpty a) where-  arbitrary = liftM2 (:|) arbitrary arbitrary-  shrink (x :| xs) = mapMaybe nonEmpty . shrinkList shrink $ x : xs-#endif+  arbitrary = arbitrary1+  shrink = shrink1  -- | Shrink a list of values given a shrinking function for individual values. shrinkList :: (a -> [a]) -> [a] -> [[a]]@@ -405,15 +487,20 @@   shrink    = shrinkRealFrac #endif -instance (Arbitrary a, Arbitrary b)-      => Arbitrary (a,b)- where-  arbitrary = liftM2 (,) arbitrary arbitrary+instance Arbitrary2 (,) where+  liftArbitrary2 = liftM2 (,)+  liftShrink2 shrA shrB (x, y) =+       [ (x', y) | x' <- shrA x ]+    ++ [ (x, y') | y' <- shrB y ] -  shrink (x, y) =-       [ (x', y) | x' <- shrink x ]-    ++ [ (x, y') | y' <- shrink y ]+instance (Arbitrary a) => Arbitrary1 ((,) a) where+  liftArbitrary = liftArbitrary2 arbitrary+  liftShrink = liftShrink2 shrink +instance (Arbitrary a, Arbitrary b) => Arbitrary (a,b) where+  arbitrary = arbitrary2+  shrink = shrink2+ instance (Arbitrary a, Arbitrary b, Arbitrary c)       => Arbitrary (a,b,c)  where@@ -517,12 +604,6 @@   arbitrary = arbitrarySizedIntegral   shrink    = shrinkIntegral -#ifndef NO_NATURALS-instance Arbitrary Natural where-  arbitrary = arbitrarySizedNatural-  shrink    = shrinkIntegral-#endif- instance Arbitrary Int where   arbitrary = arbitrarySizedIntegral   shrink    = shrinkIntegral@@ -564,22 +645,26 @@   shrink    = shrinkIntegral  instance Arbitrary Char where-  arbitrary = chr `fmap` oneof [choose (0,127), choose (0,255)]-  shrink c  = filter (<. c) $ nub+  arbitrary =+    frequency+      [(3, arbitraryASCIIChar),+       (1, arbitraryUnicodeChar)]++  shrink c = filter (<. c) $ nub             $ ['a','b','c']-           ++ [ toLower c | isUpper c ]-           ++ ['A','B','C']-           ++ ['1','2','3']-           ++ [' ','\n']-   where-    a <. b  = stamp a < stamp b-    stamp a = ( (not (isLower a)-              , not (isUpper a)-              , not (isDigit a))-              , (not (a==' ')-              , not (isSpace a)-              , a)-              )+            ++ [ toLower c | isUpper c ]+            ++ ['A','B','C']+            ++ ['1','2','3']+            ++ [' ','\n']+     where+      a <. b  = stamp a < stamp b+      stamp a = ( (not (isLower a)+                , not (isUpper a)+                , not (isDigit a))+                , (not (a==' ')+                , not (isSpace a)+                , a)+                )  instance Arbitrary Float where   arbitrary = arbitrarySizedFractional@@ -589,44 +674,199 @@   arbitrary = arbitrarySizedFractional   shrink    = shrinkRealFrac +#ifndef NO_CTYPES+instance Arbitrary CChar where+  arbitrary = CChar <$> arbitrary+  shrink (CChar x) = CChar <$> shrink x++instance Arbitrary CSChar where+  arbitrary = CSChar <$> arbitrary+  shrink (CSChar x) = CSChar <$> shrink x++instance Arbitrary CUChar where+  arbitrary = CUChar <$> arbitrary+  shrink (CUChar x) = CUChar <$> shrink x++instance Arbitrary CShort where+  arbitrary = CShort <$> arbitrary+  shrink (CShort x) = CShort <$> shrink x++instance Arbitrary CUShort where+  arbitrary = CUShort <$> arbitrary+  shrink (CUShort x) = CUShort <$> shrink x++instance Arbitrary CInt where+  arbitrary = CInt <$> arbitrary+  shrink (CInt x) = CInt <$> shrink x++instance Arbitrary CUInt where+  arbitrary = CUInt <$> arbitrary+  shrink (CUInt x) = CUInt <$> shrink x++instance Arbitrary CLong where+  arbitrary = CLong <$> arbitrary+  shrink (CLong x) = CLong <$> shrink x++instance Arbitrary CULong where+  arbitrary = CULong <$> arbitrary+  shrink (CULong x) = CULong <$> shrink x++instance Arbitrary CPtrdiff where+  arbitrary = CPtrdiff <$> arbitrary+  shrink (CPtrdiff x) = CPtrdiff <$> shrink x++instance Arbitrary CSize where+  arbitrary = CSize <$> arbitrary+  shrink (CSize x) = CSize <$> shrink x++instance Arbitrary CWchar where+  arbitrary = CWchar <$> arbitrary+  shrink (CWchar x) = CWchar <$> shrink x++instance Arbitrary CSigAtomic where+  arbitrary = CSigAtomic <$> arbitrary+  shrink (CSigAtomic x) = CSigAtomic <$> shrink x++instance Arbitrary CLLong where+  arbitrary = CLLong <$> arbitrary+  shrink (CLLong x) = CLLong <$> shrink x++instance Arbitrary CULLong where+  arbitrary = CULLong <$> arbitrary+  shrink (CULLong x) = CULLong <$> shrink x++instance Arbitrary CIntPtr where+  arbitrary = CIntPtr <$> arbitrary+  shrink (CIntPtr x) = CIntPtr <$> shrink x++instance Arbitrary CUIntPtr where+  arbitrary = CUIntPtr <$> arbitrary+  shrink (CUIntPtr x) = CUIntPtr <$> shrink x++instance Arbitrary CIntMax where+  arbitrary = CIntMax <$> arbitrary+  shrink (CIntMax x) = CIntMax <$> shrink x++instance Arbitrary CUIntMax where+  arbitrary = CUIntMax <$> arbitrary+  shrink (CUIntMax x) = CUIntMax <$> shrink x++instance Arbitrary CClock where+  arbitrary = CClock <$> arbitrary+  shrink (CClock x) = CClock <$> shrink x++instance Arbitrary CTime where+  arbitrary = CTime <$> arbitrary+  shrink (CTime x) = CTime <$> shrink x++instance Arbitrary CUSeconds where+  arbitrary = CUSeconds <$> arbitrary+  shrink (CUSeconds x) = CUSeconds <$> shrink x++instance Arbitrary CSUSeconds where+  arbitrary = CSUSeconds <$> arbitrary+  shrink (CSUSeconds x) = CSUSeconds <$> shrink x++instance Arbitrary CFloat where+  arbitrary = CFloat <$> arbitrary+  shrink (CFloat x) = CFloat <$> shrink x++instance Arbitrary CDouble where+  arbitrary = CDouble <$> arbitrary+  shrink (CDouble x) = CDouble <$> shrink x+#endif+ -- Arbitrary instances for container types instance (Ord a, Arbitrary a) => Arbitrary (Set.Set a) where   arbitrary = fmap Set.fromList arbitrary   shrink = map Set.fromList . shrink . Set.toList+instance (Ord k, Arbitrary k) => Arbitrary1 (Map.Map k) where+  liftArbitrary = fmap Map.fromList . liftArbitrary . liftArbitrary+  liftShrink shr = map Map.fromList . liftShrink (liftShrink shr) . Map.toList instance (Ord k, Arbitrary k, Arbitrary v) => Arbitrary (Map.Map k v) where-  arbitrary = fmap Map.fromList arbitrary-  shrink = map Map.fromList . shrink . Map.toList+  arbitrary = arbitrary1+  shrink = shrink1 instance Arbitrary IntSet.IntSet where   arbitrary = fmap IntSet.fromList arbitrary   shrink = map IntSet.fromList . shrink . IntSet.toList+instance Arbitrary1 IntMap.IntMap where+  liftArbitrary = fmap IntMap.fromList . liftArbitrary . liftArbitrary+  liftShrink shr = map IntMap.fromList . liftShrink (liftShrink shr) . IntMap.toList instance Arbitrary a => Arbitrary (IntMap.IntMap a) where-  arbitrary = fmap IntMap.fromList arbitrary-  shrink = map IntMap.fromList . shrink . IntMap.toList+  arbitrary = arbitrary1+  shrink = shrink1+instance Arbitrary1 Sequence.Seq where+  liftArbitrary = fmap Sequence.fromList . liftArbitrary+  liftShrink shr = map Sequence.fromList . liftShrink shr . toList instance Arbitrary a => Arbitrary (Sequence.Seq a) where-  arbitrary = fmap Sequence.fromList arbitrary-  shrink = map Sequence.fromList . shrink . toList+  arbitrary = arbitrary1+  shrink = shrink1  -- Arbitrary instance for Ziplist+instance Arbitrary1 ZipList where+  liftArbitrary = fmap ZipList . liftArbitrary+  liftShrink shr = map ZipList . liftShrink shr . getZipList instance Arbitrary a => Arbitrary (ZipList a) where-  arbitrary = fmap ZipList arbitrary-  shrink = map ZipList . shrink . getZipList+  arbitrary = arbitrary1+  shrink = shrink1  #ifndef NO_TRANSFORMERS -- Arbitrary instance for transformers' Functors+instance Arbitrary1 Identity where+  liftArbitrary = fmap Identity+  liftShrink shr = map Identity . shr . runIdentity instance Arbitrary a => Arbitrary (Identity a) where-  arbitrary = fmap Identity arbitrary-  shrink = map Identity . shrink . runIdentity+  arbitrary = arbitrary1+  shrink = shrink1 +instance Arbitrary2 Constant where+  liftArbitrary2 arbA _ = fmap Constant arbA+  liftShrink2 shrA _ = fmap Constant . shrA . getConstant+instance Arbitrary a => Arbitrary1 (Constant a) where+  liftArbitrary = liftArbitrary2 arbitrary+  liftShrink = liftShrink2 shrink+-- Have to be defined explicitly, as Constant is kind polymorphic instance Arbitrary a => Arbitrary (Constant a b) where   arbitrary = fmap Constant arbitrary   shrink = map Constant . shrink . getConstant++instance (Arbitrary1 f, Arbitrary1 g) => Arbitrary1 (Product f g) where+  liftArbitrary arb = liftM2 Pair (liftArbitrary arb) (liftArbitrary arb)+  liftShrink shr (Pair f g) =+    [ Pair f' g | f' <- liftShrink shr f ] +++    [ Pair f g' | g' <- liftShrink shr g ]+instance (Arbitrary1 f, Arbitrary1 g, Arbitrary a) => Arbitrary (Product f g a) where+  arbitrary = arbitrary1+  shrink = shrink1++instance (Arbitrary1 f, Arbitrary1 g) => Arbitrary1 (Compose f g) where+  liftArbitrary = fmap Compose . liftArbitrary . liftArbitrary+  liftShrink shr = map Compose . liftShrink (liftShrink shr) . getCompose+instance (Arbitrary1 f, Arbitrary1 g, Arbitrary a) => Arbitrary (Compose f g a) where+  arbitrary = arbitrary1+  shrink = shrink1 #endif  -- Arbitrary instance for Const+instance Arbitrary2 Const where+  liftArbitrary2 arbA _ = fmap Const arbA+  liftShrink2 shrA _ = fmap Const . shrA . getConst+instance Arbitrary a => Arbitrary1 (Const a) where+  liftArbitrary = liftArbitrary2 arbitrary+  liftShrink = liftShrink2 shrink+-- Have to be defined explicitly, as Const is kind polymorphic instance Arbitrary a => Arbitrary (Const a b) where   arbitrary = fmap Const arbitrary   shrink = map Const . shrink . getConst +instance Arbitrary (m a) => Arbitrary (WrappedMonad m a) where+  arbitrary = WrapMonad <$> arbitrary+  shrink (WrapMonad a) = map WrapMonad (shrink a)++instance Arbitrary (a b c) => Arbitrary (WrappedArrow a b c) where+  arbitrary = WrapArrow <$> arbitrary+  shrink (WrapArrow a) = map WrapArrow (shrink a)+ -- Arbitrary instances for Monoid instance Arbitrary a => Arbitrary (Monoid.Dual a) where   arbitrary = fmap Monoid.Dual arbitrary@@ -688,6 +928,17 @@     , all (>=0) xs'     ] +instance Arbitrary QCGen where+  arbitrary = MkGen (\g _ -> g)++instance Arbitrary ExitCode where+  arbitrary = frequency [(1, return ExitSuccess), (3, liftM ExitFailure arbitrary)]++  shrink (ExitFailure x) = ExitSuccess : [ ExitFailure x' | x' <- shrink x ]+  shrink _        = []+++ -- ** Helper functions for implementing arbitrary  -- | Generates an integral number. The number can be positive or negative@@ -759,12 +1010,46 @@        n <- choose (toInteger mn `max` (-k), toInteger mx `min` k)        return (fromInteger n) +-- ** Generators for various kinds of character++-- | Generates any Unicode character (but not a surrogate)+arbitraryUnicodeChar :: Gen Char+arbitraryUnicodeChar =+  arbitraryBoundedEnum `suchThat` (not . isSurrogate)+  where+    isSurrogate c = generalCategory c == Surrogate++-- | Generates a random ASCII character (0-127).+arbitraryASCIIChar :: Gen Char+arbitraryASCIIChar = choose ('\0', '\127')++-- | Generates a printable Unicode character.+arbitraryPrintableChar :: Gen Char+arbitraryPrintableChar = arbitrary `suchThat` isPrint+ -- ** Helper functions for implementing shrink  -- | Returns no shrinking alternatives. shrinkNothing :: a -> [a] shrinkNothing _ = [] +-- | Map a shrink function to another domain. This is handy if your data type+-- has special invariants, but is /almost/ isomorphic to some other type.+--+-- @+-- shrinkOrderedList :: (Ord a, Arbitrary a) => [a] -> [[a]]+-- shrinkOrderedList = shrinkMap sort id+--+-- shrinkSet :: (Ord a, Arbitrary a) => Set a -> Set [a]+-- shrinkSet = shrinkMap fromList toList+-- @+shrinkMap :: Arbitrary a => (a -> b) -> (b -> a) -> b -> [b]+shrinkMap f g = shrinkMapBy f g shrink++-- | Non-overloaded version of `shrinkMap`.+shrinkMapBy :: (a -> b) -> (b -> a) -> (a -> [a]) -> b -> [b]+shrinkMapBy f g shr = map f . shr . g+ -- | Shrink an integral number. shrinkIntegral :: Integral a => a -> [a] shrinkIntegral x =@@ -892,11 +1177,6 @@   coarbitrary []     = variant 0   coarbitrary (x:xs) = variant 1 . coarbitrary (x,xs) -#ifndef NO_NONEMPTY-instance CoArbitrary a => CoArbitrary (NonEmpty a) where-  coarbitrary (x :| xs) = coarbitrary (x, xs)-#endif- instance (Integral a, CoArbitrary a) => CoArbitrary (Ratio a) where   coarbitrary r = coarbitrary (numerator r,denominator r) @@ -943,11 +1223,6 @@ instance CoArbitrary Integer where   coarbitrary = coarbitraryIntegral -#ifndef NO_NATURALS-instance CoArbitrary Natural where-  coarbitrary = coarbitraryIntegral-#endif- instance CoArbitrary Int where   coarbitrary = coarbitraryIntegral @@ -1084,7 +1359,7 @@ orderedList :: (Ord a, Arbitrary a) => Gen [a] orderedList = sort `fmap` arbitrary --- | Generate an infinite list.+-- | Generates an infinite list. infiniteList :: Arbitrary a => Gen [a] infiniteList = infiniteListOf arbitrary 

@@ -56,7 +56,19 @@ tryEvaluate x = tryEvaluateIO (return x)  tryEvaluateIO :: IO a -> IO (Either AnException a)-tryEvaluateIO m = E.try (m >>= E.evaluate)+tryEvaluateIO m = E.tryJust notAsync (m >>= E.evaluate)+  where+    notAsync :: E.SomeException -> Maybe AnException+#if MIN_VERSION_base(4,7,0)+    notAsync e = case E.fromException e of+        Just (E.SomeAsyncException _) -> Nothing+        Nothing                       -> Just e+#else+    notAsync e = case E.fromException e :: Maybe E.AsyncException of+        Just _  -> Nothing+        Nothing -> Just e+#endif+ --tryEvaluateIO m = Right `fmap` m  evaluate :: a -> IO a

@@ -1,13 +1,19 @@ {-# LANGUAGE TypeOperators, GADTs, CPP #-}-+#ifndef NO_SAFE_HASKELL+{-# LANGUAGE Safe #-}+#endif #if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 708-{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE PatternSynonyms, ViewPatterns #-} #endif  #ifndef NO_GENERICS {-# LANGUAGE DefaultSignatures, FlexibleContexts #-} #endif +#ifndef NO_POLYKINDS+{-# LANGUAGE PolyKinds #-}+#endif+ -- | Generation of random shrinkable, showable functions. -- See the paper \"Shrinking and showing functions\" by Koen Claessen. --@@ -28,7 +34,10 @@ -- See the @'Function' [a]@ instance for an example of the latter. module Test.QuickCheck.Function   ( Fun(..)+  , applyFun   , apply+  , applyFun2+  , applyFun3   , (:->)   , Function(..)   , functionMap@@ -38,6 +47,8 @@   , functionBoundedEnum #if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 708   , pattern Fn+  , pattern Fn2+  , pattern Fn3 #endif   )  where@@ -51,16 +62,13 @@ import Data.Char import Data.Word import Data.List( intersperse )-import Data.Maybe( fromJust ) import Data.Ratio-import Control.Arrow( (&&&) ) import qualified Data.IntMap as IntMap import qualified Data.IntSet as IntSet import qualified Data.Map as Map import qualified Data.Set as Set import qualified Data.Sequence as Sequence import Data.Int-import Data.Word import Data.Complex import Data.Foldable(toList) @@ -68,14 +76,6 @@ import Data.Fixed #endif -#ifndef NO_NATURALS-import Numeric.Natural-#endif--#ifndef NO_NONEMPTY-import Data.List.NonEmpty(NonEmpty(..))-#endif- #ifndef NO_GENERICS import GHC.Generics hiding (C) #endif@@ -135,6 +135,12 @@ -------------------------------------------------------------------------- -- Function +-- | The class @Function a@ is used for random generation of showable+-- functions of type @a -> b@.+--+-- There is a default implementation for 'function', which you can use+-- if your type has structural equality. Otherwise, you can normally+-- use 'functionMap' or 'functionShow'. class Function a where   function :: (a->b) -> (a:->b) #ifndef NO_GENERICS@@ -250,6 +256,9 @@ instance Function Int where   function = functionIntegral +instance Function Word where+  function = functionIntegral+ instance Function Char where   function = functionMap ord chr @@ -272,14 +281,6 @@       h (Left True)  = EQ       h (Right _)    = GT -#ifndef NO_NONEMPTY-instance Function a => Function (NonEmpty a) where-  function = functionMap g h-   where-     g (x :| xs) = (x,   xs)-     h (x,   xs) =  x :| xs-#endif- instance (Integral a, Function a) => Function (Ratio a) where   function = functionMap g h    where@@ -312,11 +313,6 @@ instance Function a => Function (Sequence.Seq a) where   function = functionMap toList Sequence.fromList -#ifndef NO_NATURALS-instance Function Natural where-  function = functionIntegral-#endif- instance Function Int8 where   function = functionBoundedEnum @@ -449,26 +445,77 @@ -------------------------------------------------------------------------- -- the Fun modifier -data Fun a b = Fun (a :-> b, b, Bool) (a -> b)+-- | Generation of random shrinkable, showable functions.+--+-- To generate random values of type @'Fun' a b@,+-- you must have an instance @'Function' a@.+--+-- See also 'applyFun', and 'Fn' with GHC >= 7.8.+data Fun a b = Fun (a :-> b, b, Shrunk) (a -> b)+data Shrunk = Shrunk | NotShrunk deriving Eq  #if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 708--- | A pattern for matching against the function only:+-- | A modifier for testing functions. -- -- > prop :: Fun String Integer -> Bool -- > prop (Fn f) = f "banana" == f "monkey" -- >            || f "banana" == f "elephant"-pattern Fn f <- Fun _ f+#if __GLASGOW_HASKELL__ >= 800+pattern Fn :: (a -> b) -> Fun a b #endif+pattern Fn f <- (applyFun -> f) +-- | A modifier for testing binary functions.+--+-- > prop_zipWith :: Fun (Int, Bool) Char -> [Int] -> [Bool] -> Bool+-- > prop_zipWith (Fn2 f) xs ys = zipWith f xs ys == [ f x y | (x, y) <- zip xs ys]+#if __GLASGOW_HASKELL__ >= 800+pattern Fn2 :: (a -> b -> c) -> Fun (a, b) c+#endif+pattern Fn2 f <- (applyFun2 -> f)++-- | A modifier for testing ternary functions.+#if __GLASGOW_HASKELL__ >= 800+pattern Fn3 :: (a -> b -> c -> d) -> Fun (a, b, c) d+#endif+pattern Fn3 f <- (applyFun3 -> f)+#endif+ mkFun :: (a :-> b) -> b -> Fun a b-mkFun p d = Fun (p, d, False) (abstract p d)+mkFun p d = Fun (p, d, NotShrunk) (abstract p d) +-- | Alias to 'applyFun'. apply :: Fun a b -> (a -> b)-apply (Fun _ f) = f+apply = applyFun +-- | Extracts the value of a function.+--+-- 'Fn' is the pattern equivalent of this function.+--+-- > prop :: Fun String Integer -> Bool+-- > prop f = applyFun f "banana" == applyFun f "monkey"+-- >       || applyFun f "banana" == applyFun f "elephant"+applyFun :: Fun a b -> (a -> b)+applyFun (Fun _ f) = f++-- | Extracts the value of a binary function.+--+-- 'Fn2' is the pattern equivalent of this function.+--+--  > prop_zipWith :: Fun (Int, Bool) Char -> [Int] -> [Bool] -> Bool+--  > prop_zipWith f xs ys = zipWith (applyFun2 f) xs ys == [ applyFun2 f x y | (x, y) <- zip xs ys]+--+applyFun2 :: Fun (a, b) c -> (a -> b -> c)+applyFun2 (Fun _ f) a b = f (a, b)++-- | Extracts the value of a ternary function. 'Fn3' is the+-- pattern equivalent of this function.+applyFun3 :: Fun (a, b, c) d -> (a -> b -> c -> d)+applyFun3 (Fun _ f) a b c = f (a, b, c)+ instance (Show a, Show b) => Show (Fun a b) where-  show (Fun (_, _, False) _) = "<fun>"-  show (Fun (p, d, True) _)  = showFunction p (Just d)+  show (Fun (_, _, NotShrunk) _) = "<fun>"+  show (Fun (p, d, Shrunk) _)    = showFunction p (Just d)  instance (Function a, CoArbitrary a, Arbitrary b) => Arbitrary (Fun a b) where   arbitrary =@@ -476,9 +523,9 @@        d <- arbitrary        return (mkFun p d) -  shrink (Fun (p, d, b) f) =+  shrink (Fun (p, d, s) f) =     [ mkFun p' d' | (p', d') <- shrink (p, d) ] ++-    [ Fun (p, d, True) f | not b ]+    [ Fun (p, d, Shrunk) f | s == NotShrunk ]  -------------------------------------------------------------------------- -- the end.

@@ -10,37 +10,33 @@  import System.Random   ( Random-  , StdGen   , random   , randomR   , split-  , newStdGen   )  import Control.Monad-  ( liftM-  , ap+  ( ap   , replicateM   , filterM   )  import Control.Applicative-  ( Applicative(..)-  , (<$>)-  )--import Control.Arrow-  ( second-  )+  ( Applicative(..) )  import Test.QuickCheck.Random import Data.List import Data.Ord+import Data.Maybe  -------------------------------------------------------------------------- -- ** Generator type  -- | A generator for values of type @a@.+--+-- The third-party package+-- <http://hackage.haskell.org/package/QuickCheck-GenT QuickCheck-GenT>+-- provides a monad transformer version of @GenT@. newtype Gen a = MkGen{   unGen :: QCGen -> Int -> a -- ^ Run the generator on a particular seed.                              -- If you just want to get a random value out, consider using 'generate'.@@ -60,9 +56,10 @@    MkGen m >>= k =     MkGen (\r n ->-      let (r1,r2)  = split r-          MkGen m' = k (m r1 n)-       in m' r2 n+      case split r of+        (r1, r2) ->+          let MkGen m' = k (m r1 n)+          in m' r2 n     )  --------------------------------------------------------------------------@@ -73,9 +70,35 @@ variant k (MkGen g) = MkGen (\r n -> g (variantQCGen k r) n)  -- | Used to construct generators that depend on the size parameter.+--+-- For example, 'listOf', which uses the size parameter as an upper bound on+-- length of lists it generates, can be defined like this:+--+-- > listOf :: Gen a -> Gen [a]+-- > listOf gen = sized $ \n ->+-- >   do k <- choose (0,n)+-- >      vectorOf k gen+--+-- You can also do this using 'getSize'. sized :: (Int -> Gen a) -> Gen a sized f = MkGen (\r n -> let MkGen m = f n in m r n) +-- | Generates the size parameter. Used to construct generators that depend on+-- the size parameter.+--+-- For example, 'listOf', which uses the size parameter as an upper bound on+-- length of lists it generates, can be defined like this:+--+-- > listOf :: Gen a -> Gen [a]+-- > listOf gen = do+-- >   n <- getSize+-- >   k <- choose (0,n)+-- >   vectorOf k gen+--+-- You can also do this using 'sized'.+getSize :: Gen Int+getSize = sized pure+ -- | Overrides the size parameter. Returns a generator which uses -- the given size instead of the runtime-size parameter. resize :: Int -> Gen a -> Gen a@@ -124,7 +147,14 @@        Just x  -> return x        Nothing -> sized (\n -> resize (n+1) (gen `suchThat` p)) +-- | Generates a value for which the given function returns a 'Just', and then+-- applies the function.+suchThatMap :: Gen a -> (a -> Maybe b) -> Gen b+gen `suchThatMap` f =+  fmap fromJust $ fmap f gen `suchThat` isJust+ -- | Tries to generate a value that satisfies a predicate.+-- If it fails to do so after enough attempts, returns @Nothing@. suchThatMaybe :: Gen a -> (a -> Bool) -> Gen (Maybe a) gen `suchThatMaybe` p = sized (try 0 . max 1)  where

@@ -1,4 +1,7 @@ {-# LANGUAGE CPP #-}+#ifndef NO_SAFE_HASKELL+{-# LANGUAGE Safe #-}+#endif #ifndef NO_ST_MONAD {-# LANGUAGE Rank2Types #-} #endif

@@ -56,6 +56,9 @@   , Shrinking(..)   , ShrinkState(..) #endif+  , ASCIIString(..)+  , UnicodeString(..)+  , PrintableString(..)   )  where @@ -68,6 +71,7 @@ import Data.List   ( sort   )+import Data.Ix (Ix)  -------------------------------------------------------------------------- -- | @Blind x@: as x, but x does not have to be in the 'Show' class.@@ -214,7 +218,7 @@ newtype Large a = Large {getLarge :: a}  deriving ( Eq, Ord, Show, Read #ifndef NO_NEWTYPE_DERIVING-          , Num, Integral, Real, Enum+          , Num, Integral, Real, Enum, Ix #endif           ) @@ -231,7 +235,7 @@ newtype Small a = Small {getSmall :: a}  deriving ( Eq, Ord, Show, Read #ifndef NO_NEWTYPE_DERIVING-          , Num, Integral, Real, Enum+          , Num, Integral, Real, Enum, Ix #endif           ) @@ -343,4 +347,32 @@ #endif /* NO_MULTI_PARAM_TYPE_CLASSES */  --------------------------------------------------------------------------+-- | @ASCIIString@: generates an ASCII string.+newtype ASCIIString = ASCIIString {getASCIIString :: String}+  deriving ( Eq, Ord, Show, Read )++instance Arbitrary ASCIIString where+  arbitrary = ASCIIString `fmap` listOf arbitraryASCIIChar+  shrink (ASCIIString xs) = ASCIIString `fmap` shrink xs++--------------------------------------------------------------------------+-- | @UnicodeString@: generates a unicode String.+-- The string will not contain surrogate pairs.+newtype UnicodeString = UnicodeString {getUnicodeString :: String}+  deriving ( Eq, Ord, Show, Read )++instance Arbitrary UnicodeString where+  arbitrary = UnicodeString `fmap` listOf arbitraryUnicodeChar+  shrink (UnicodeString xs) = UnicodeString `fmap` shrink xs++--------------------------------------------------------------------------+-- | @PrintableString@: generates a printable unicode String.+-- The string will not contain surrogate pairs.+newtype PrintableString = PrintableString {getPrintableString :: String}+  deriving ( Eq, Ord, Show, Read )++instance Arbitrary PrintableString where+  arbitrary = PrintableString `fmap` listOf arbitraryPrintableChar+  shrink (PrintableString xs) = PrintableString `fmap` shrink xs+ -- the end.

@@ -1,4 +1,11 @@ {-# 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@@ -83,6 +90,10 @@ import Control.Monad.Trans.Class #endif +#ifndef NO_MONADFAIL+import qualified Control.Monad.Fail as Fail+#endif+ -------------------------------------------------------------------------- -- type PropertyM @@ -95,18 +106,30 @@ newtype PropertyM m a =   MkPropertyM { unPropertyM :: (a -> Gen (m Property)) -> Gen (m Property) } +bind :: PropertyM m a -> (a -> PropertyM m b) -> PropertyM m b+MkPropertyM m `bind` f = MkPropertyM (\k -> m (\a -> unPropertyM (f a) k))++fail_ :: Monad m => String -> PropertyM m a+fail_ s = stop (failed { reason = s })+ instance Functor (PropertyM m) where   fmap f (MkPropertyM m) = MkPropertyM (\k -> m (k . f)) -instance Monad m => Applicative (PropertyM m) where-  pure = return-  (<*>) = liftM2 ($)+instance Applicative (PropertyM m) where+  pure x = MkPropertyM (\k -> k x)+  mf <*> mx =+    mf `bind` \f -> mx `bind` \x -> pure (f x)  instance Monad m => Monad (PropertyM m) where-  return x            = MkPropertyM (\k -> k x)-  MkPropertyM m >>= f = MkPropertyM (\k -> m (\a -> unPropertyM (f a) k))-  fail s              = stop (failed { reason = s })+  return = pure+  (>>=) = bind+  fail = fail_ +#ifndef NO_MONADFAIL+instance Monad m => Fail.MonadFail (PropertyM m) where+  fail = fail_+#endif+ #ifndef NO_TRANSFORMERS instance MonadTrans PropertyM where   lift = run@@ -201,11 +224,11 @@  -- run functions -monadic :: Monad m => (m Property -> Property) -> PropertyM m a -> Property+monadic :: (Testable a, Monad m) => (m Property -> Property) -> PropertyM m a -> Property monadic runner m = property (fmap runner (monadic' m)) -monadic' :: Monad m => PropertyM m a -> Gen (m Property)-monadic' (MkPropertyM m) = m (const (return (return (property True))))+monadic' :: (Testable a, Monad m) => PropertyM m a -> Gen (m Property)+monadic' (MkPropertyM m) = m (\prop -> return (return (property prop)))  -- | Runs the property monad for 'IO'-computations. --@@ -221,7 +244,7 @@ -- >>> quickCheck prop_cat -- +++ OK, passed 100 tests. ---monadicIO :: PropertyM IO a -> Property+monadicIO :: Testable a => PropertyM IO a -> Property monadicIO = monadic ioProperty  #ifndef NO_ST_MONAD@@ -240,7 +263,7 @@ -- >>> quickCheck prop_sortST -- +++ OK, passed 100 tests. ---monadicST :: (forall s. PropertyM (ST s) a) -> Property+monadicST :: Testable a => (forall s. PropertyM (ST s) a) -> Property monadicST m = property (runSTGen (monadic' m))  runSTGen :: (forall s. Gen (ST s a)) -> Gen a

@@ -1,6 +1,6 @@ {-# LANGUAGE CPP #-}-#ifndef NO_NEWTYPE_DERIVING-{-# LANGUAGE GeneralizedNewtypeDeriving #-}+#ifndef NO_SAFE_HASKELL+{-# LANGUAGE Safe #-} #endif -- | Types to help with testing polymorphic properties. --@@ -75,12 +75,28 @@ -- OrdA  newtype OrdA = OrdA{ unOrdA :: Integer }-  deriving ( Eq, Ord-#ifndef NO_NEWTYPE_DERIVING-           , Num-#endif-           )+  deriving ( Eq, Ord ) +liftOrdA+    :: (Integer -> Integer)+    -> OrdA -> OrdA+liftOrdA f (OrdA x) = OrdA (f x)++liftOrdA2+    :: (Integer -> Integer -> Integer)+    -> OrdA -> OrdA -> OrdA+liftOrdA2 f (OrdA x) (OrdA y) = OrdA (f x y)++instance Num OrdA where+    (+)         = liftOrdA2 (+)+    (*)         = liftOrdA2 (*)+    (-)         = liftOrdA2 (-)+    negate      = liftOrdA negate+    abs         = liftOrdA abs+    signum      = liftOrdA signum+    fromInteger = OrdA . fromInteger++ instance Show OrdA where   showsPrec n (OrdA x) = showsPrec n x @@ -94,12 +110,27 @@ -- OrdB  newtype OrdB = OrdB{ unOrdB :: Integer }-  deriving ( Eq, Ord-#ifndef NO_NEWTYPE_DERIVING-           , Num-#endif-           )+  deriving ( Eq, Ord ) +liftOrdB+    :: (Integer -> Integer)+    -> OrdB -> OrdB+liftOrdB f (OrdB x) = OrdB (f x)++liftOrdB2+    :: (Integer -> Integer -> Integer)+    -> OrdB -> OrdB -> OrdB+liftOrdB2 f (OrdB x) (OrdB y) = OrdB (f x y)++instance Num OrdB where+    (+)         = liftOrdB2 (+)+    (*)         = liftOrdB2 (*)+    (-)         = liftOrdB2 (-)+    negate      = liftOrdB negate+    abs         = liftOrdB abs+    signum      = liftOrdB signum+    fromInteger = OrdB . fromInteger+ instance Show OrdB where   showsPrec n (OrdB x) = showsPrec n x @@ -113,11 +144,26 @@ -- OrdC  newtype OrdC = OrdC{ unOrdC :: Integer }-  deriving ( Eq, Ord-#ifndef NO_NEWTYPE_DERIVING-           , Num-#endif-           )+  deriving ( Eq, Ord )++liftOrdC+    :: (Integer -> Integer)+    -> OrdC -> OrdC+liftOrdC f (OrdC x) = OrdC (f x)++liftOrdC2+    :: (Integer -> Integer -> Integer)+    -> OrdC -> OrdC -> OrdC+liftOrdC2 f (OrdC x) (OrdC y) = OrdC (f x y)++instance Num OrdC where+    (+)         = liftOrdC2 (+)+    (*)         = liftOrdC2 (*)+    (-)         = liftOrdC2 (-)+    negate      = liftOrdC negate+    abs         = liftOrdC abs+    signum      = liftOrdC signum+    fromInteger = OrdC . fromInteger  instance Show OrdC where   showsPrec n (OrdC x) = showsPrec n x

@@ -11,7 +11,7 @@ import Test.QuickCheck.Gen import Test.QuickCheck.Gen.Unsafe import Test.QuickCheck.Arbitrary-import Test.QuickCheck.Text( showErr, isOneLine, putLine )+import Test.QuickCheck.Text( isOneLine, putLine ) import Test.QuickCheck.Exception import Test.QuickCheck.State hiding (labels) @@ -25,6 +25,9 @@ import Data.Map(Map) import qualified Data.Set as Set import Data.Set(Set)+#ifndef NO_DEEPSEQ+import Control.DeepSeq+#endif  -------------------------------------------------------------------------- -- fixities@@ -69,7 +72,13 @@ -- | The type of properties. newtype Property = MkProperty { unProperty :: Gen Prop } --- | The class of things which can be tested, i.e. turned into a property.+-- | The class of properties, i.e., types which QuickCheck knows how to test.+-- Typically a property will be a function returning 'Bool' or 'Property'.+--+-- If a property does no quantification, i.e. has no+-- parameters and doesn't use 'forAll', it will only be tested once.+-- This may not be what you want if your property is an @IO Bool@.+-- You can change this behaviour using the 'again' combinator. class Testable prop where   -- | Convert the thing to a property.   property :: prop -> Property@@ -81,6 +90,14 @@ instance Testable Discard where   property _ = property rejected +-- This instance is here to make it easier to turn IO () into a Property.+instance Testable () where+  property = property . liftUnit+    where+      -- N.B. the unit gets forced only inside 'property',+      -- so that we turn exceptions into test failures+      liftUnit () = succeeded+ instance Testable Bool where   property = property . liftBool @@ -94,26 +111,22 @@   property mp = MkProperty $ do p <- mp; unProperty (again p)  instance Testable Property where-  property = property . unProperty+  property (MkProperty mp) = MkProperty $ do p <- mp; unProperty (property p) --- | Do I/O inside a property. This can obviously lead to unrepeatable--- testcases, so use with care.-{-# DEPRECATED morallyDubiousIOProperty "Use ioProperty instead" #-}+-- | Do I/O inside a property.+{-# DEPRECATED morallyDubiousIOProperty "Use 'ioProperty' instead" #-} morallyDubiousIOProperty :: Testable prop => IO prop -> Property-morallyDubiousIOProperty = ioProperty -- Silly names aren't all they're cracked up to be :)+morallyDubiousIOProperty = ioProperty --- | Do I/O inside a property. This can obviously lead to unrepeatable--- testcases, so use with care.------ For more advanced monadic testing you may want to look at--- "Test.QuickCheck.Monadic".+-- | Do I/O inside a property. ----- Note that if you use 'ioProperty' on a property of type @IO Bool@,--- or more generally a property that does no quantification, the property--- will only be executed once. To test the property repeatedly you must--- use the 'again' combinator.+-- Warning: any random values generated inside of the argument to @ioProperty@+-- will not currently be shrunk. For best results, generate all random values+-- before calling @ioProperty@. ioProperty :: Testable prop => IO prop -> Property-ioProperty = MkProperty . fmap (MkProp . ioRose . fmap unProp) . promote . fmap (unProperty . property)+ioProperty =+  MkProperty . fmap (MkProp . ioRose . fmap unProp) .+  promote . fmap (unProperty . noShrinking)  instance (Arbitrary a, Show a, Testable prop) => Testable (a -> prop) where   property f = forAllShrink arbitrary shrink f@@ -194,14 +207,16 @@ -- | The result of a single test. data Result   = MkResult-  { ok           :: Maybe Bool        -- ^ result of the test case; Nothing = discard-  , expect       :: Bool              -- ^ indicates what the expected result of the property is-  , reason       :: String            -- ^ a message indicating what went wrong-  , theException :: Maybe AnException -- ^ the exception thrown, if any-  , abort        :: Bool              -- ^ if True, the test should not be repeated-  , labels       :: Map String Int    -- ^ all labels used by this property-  , stamp        :: Set String        -- ^ the collected values for this test case-  , callbacks    :: [Callback]        -- ^ the callbacks for this test case+  { ok            :: Maybe Bool        -- ^ result of the test case; Nothing = discard+  , expect        :: Bool              -- ^ indicates what the expected result of the property is+  , reason        :: String            -- ^ a message indicating what went wrong+  , theException  :: Maybe AnException -- ^ the exception thrown, if any+  , abort         :: Bool              -- ^ if True, the test should not be repeated+  , maybeNumTests :: Maybe Int         -- ^ stop after this many tests+  , labels        :: Map String Int    -- ^ all labels used by this property+  , stamp         :: Set String        -- ^ the collected labels for this test case+  , callbacks     :: [Callback]        -- ^ the callbacks for this test case+  , testCase      :: [String]          -- ^ the generated test case   }  exception :: String -> AnException -> Result@@ -226,14 +241,16 @@   where     result =       MkResult-      { ok           = undefined-      , expect       = True-      , reason       = ""-      , theException = Nothing-      , abort        = True-      , labels       = Map.empty-      , stamp        = Set.empty-      , callbacks    = []+      { ok            = undefined+      , expect        = True+      , reason        = ""+      , theException  = Nothing+      , abort         = True+      , maybeNumTests = Nothing+      , labels        = Map.empty+      , stamp         = Set.empty+      , callbacks     = []+      , testCase      = []       }  --------------------------------------------------------------------------@@ -263,8 +280,8 @@ mapSize :: Testable prop => (Int -> Int) -> prop -> Property mapSize f p = MkProperty (sized ((`resize` unProperty (property p)) . f)) --- | Shrinks the argument to property if it fails. Shrinking is done--- automatically for most types. This is only needed when you want to+-- | Shrinks the argument to a property if it fails. Shrinking is done+-- automatically for most types. This function is only needed when you want to -- override the default behavior. shrinking :: Testable prop =>              (a -> [a])  -- ^ 'shrink'-like function.@@ -283,18 +300,27 @@ callback :: Testable prop => Callback -> prop -> Property callback cb = mapTotalResult (\res -> res{ callbacks = cb : callbacks res }) --- | Adds the given string to the counterexample.+-- | Adds the given string to the counterexample if the property fails. counterexample :: Testable prop => String -> prop -> Property counterexample s =-  callback $ PostFinalFailure Counterexample $ \st _res -> do-    res <- tryEvaluateIO (putLine (terminal st) s)+  mapTotalResult (\res -> res{ testCase = s:testCase res }) .+  callback (PostFinalFailure Counterexample $ \st _res -> do+    s <- showCounterexample s+    putLine (terminal st) s)++showCounterexample :: String -> IO String+showCounterexample s = do+  let force [] = return ()+      force (x:xs) = x `seq` force xs+  res <- tryEvaluateIO (force s)+  return $     case res of       Left err ->-        putLine (terminal st) (formatException "Exception thrown while printing test case" err)+        formatException "Exception thrown while showing test case" err       Right () ->-        return ()+        s --- | Adds the given string to the counterexample.+-- | Adds the given string to the counterexample if the property fails. {-# DEPRECATED printTestCase "Use counterexample instead" #-} printTestCase :: Testable prop => String -> prop -> Property printTestCase = counterexample@@ -321,7 +347,8 @@ verbose = mapResult (\res -> res { callbacks = newCallbacks (callbacks res) ++ callbacks res })   where newCallbacks cbs =           PostTest Counterexample (\st res -> putLine (terminal st) (status res ++ ":")):-          [ PostTest Counterexample f | PostFinalFailure Counterexample f <- cbs ]+          [ PostTest Counterexample f | PostFinalFailure Counterexample f <- cbs ] +++          [ PostTest Counterexample (\st res -> putLine (terminal st) "") ]         status MkResult{ok = Just True} = "Passed"         status MkResult{ok = Just False} = "Failed"         status MkResult{ok = Nothing} = "Skipped (precondition false)"@@ -332,25 +359,79 @@ expectFailure = mapTotalResult (\res -> res{ expect = False })  -- | Modifies a property so that it only will be tested once.+-- Opposite of 'again'. once :: Testable prop => prop -> Property once = mapTotalResult (\res -> res{ abort = True }) --- | Undoes the effect of 'once'.+-- | Modifies a property so that it will be tested repeatedly.+-- Opposite of 'once'. again :: Testable prop => prop -> Property again = mapTotalResult (\res -> res{ abort = False }) +-- | Configures how many times a property will be tested.+--+-- For example,+--+-- > quickCheck (withMaxSuccess 1000 p)+--+-- will test @p@ up to 1000 times.+withMaxSuccess :: Testable prop => Int -> prop -> Property+withMaxSuccess n = n `seq` mapTotalResult (\res -> res{ maybeNumTests = Just n })+ -- | Attaches a label to a property. This is used for reporting -- test case distribution.+--+-- For example:+--+-- > prop_reverse_reverse :: [Int] -> Property+-- > prop_reverse_reverse xs =+-- >   label ("length of input is " ++ show (length xs)) $+-- >     reverse (reverse xs) === xs+--+-- >>> quickCheck prop_reverse_reverse+-- +++ OK, passed 100 tests:+-- 7% length of input is 7+-- 6% length of input is 3+-- 5% length of input is 4+-- 4% length of input is 6+-- ... label :: Testable prop => String -> prop -> Property label s = classify True s --- | Labels a property with a value:+-- | Attaches a label to a property. This is used for reporting+-- test case distribution. -- -- > collect x = label (show x)+--+-- For example:+--+-- > prop_reverse_reverse :: [Int] -> Property+-- > prop_reverse_reverse xs =+-- >   collect (length xs) $+-- >     reverse (reverse xs) === xs+--+-- >>> quickCheck prop_reverse_reverse+-- +++ OK, passed 100 tests:+-- 7% 7+-- 6% 3+-- 5% 4+-- 4% 6+-- ... collect :: (Show a, Testable prop) => a -> prop -> Property collect x = label (show x) --- | Conditionally labels test case.+-- | Records how many test cases satisfy a given condition.+--+-- For example:+--+-- > prop_sorted_sort :: [Int] -> Property+-- > prop_sorted_sort xs =+-- >   sorted xs ==>+-- >   classify (length xs > 1) "non-trivial" $+-- >   sort xs === xs+--+-- >>> quickCheck prop_sorted_sort+-- +++ OK, passed 100 tests (22% non-trivial). classify :: Testable prop =>             Bool    -- ^ @True@ if the test case should be labelled.          -> String  -- ^ Label.@@ -360,6 +441,17 @@ -- | Checks that at least the given proportion of /successful/ test -- cases belong to the given class. Discarded tests (i.e. ones -- with a false precondition) do not affect coverage.+--+-- For example:+--+-- > prop_sorted_sort :: [Int] -> Property+-- > prop_sorted_sort xs =+-- >   sorted xs ==>+-- >   cover (length xs > 1) 50 "non-trivial" $+-- >   sort xs === xs+--+-- >>> quickCheck prop_sorted_sort+-- *** Insufficient coverage after 100 tests (only 24% non-trivial, not 50%). cover :: Testable prop =>          Bool   -- ^ @True@ if the test case belongs to the class.       -> Int    -- ^ The required percentage (0-100) of test cases.@@ -385,16 +477,16 @@ -- the given number of microseconds. within :: Testable prop => Int -> prop -> Property within n = mapRoseResult f-  -- We rely on the fact that the property will catch the timeout-  -- exception and turn it into a failed test case.   where     f rose = ioRose $ do-      let m `orError` x = fmap (fromMaybe (error x)) m+      let m `orError` x = fmap (fromMaybe x) m       MkRose res roses <- timeout n (reduceRose rose) `orError`-                          "within: timeout exception not caught in Rose Result"+        return timeoutResult       res' <- timeout n (protectResult (return res)) `orError`-              "within: timeout exception not caught in Result"+        timeoutResult       return (MkRose res' (map f roses))++    timeoutResult = failed { reason = "Timeout" } #ifdef NO_TIMEOUT     timeout _ = fmap Just #endif@@ -498,12 +590,16 @@                    -- The following three fields are not important because the                    -- test case has failed anyway                    abort = False,+                   maybeNumTests = Nothing,                    labels = Map.empty,                    stamp = Set.empty,                    callbacks =                      callbacks result1 ++                      [PostFinalFailure Counterexample $ \st _res -> putLine (terminal st) ""] ++-                     callbacks result2 }+                     callbacks result2,+                   testCase =+                     testCase result1 +++                     testCase result2 }                Nothing -> result2          Nothing -> do            result2 <- q@@ -523,6 +619,11 @@ x === y =   counterexample (show x ++ " /= " ++ show y) (x == y) +#ifndef NO_DEEPSEQ+-- | Checks that a value is total, i.e., doesn't crash when evaluated.+total :: NFData a => a -> Property+total x = property (rnf x)+#endif  -------------------------------------------------------------------------- -- the end.

@@ -63,7 +63,7 @@ newtype QCGen = QCGen TheGen  instance Show QCGen where-  showsPrec n (QCGen g) = showsPrec n g+  showsPrec n (QCGen g) s = showsPrec n g "" ++ s instance Read QCGen where   readsPrec n xs = [(QCGen g, ys) | (g, ys) <- readsPrec n xs] 

@@ -3,7 +3,6 @@  import Test.QuickCheck.Text import Test.QuickCheck.Random-import qualified Data.Map as Map import Data.Map(Map) import Data.Set(Set) @@ -20,6 +19,7 @@   , maxDiscardedTests         :: Int               -- ^ maximum number of tests that can be discarded   , computeSize               :: Int -> Int -> Int -- ^ how to compute the size of test cases from                                                    --   #tests and #discarded tests+  , numTotMaxShrinks          :: !Int              -- ^ How many shrinks to try before giving up    -- dynamic   , numSuccessTests           :: !Int              -- ^ the current number of tests that have succeeded

@@ -34,10 +34,15 @@  import Data.List   ( sort+  , sortBy   , group-  , groupBy   , intersperse   )++import Data.Maybe(fromMaybe)+import Data.Ord(comparing)+import Text.Printf(printf)+ -------------------------------------------------------------------------- -- quickCheck @@ -53,13 +58,18 @@     -- If you want to store a test case permanently you should save     -- the test case itself.   , maxSuccess      :: Int-    -- ^ Maximum number of successful tests before succeeding+    -- ^ Maximum number of successful tests before succeeding. Testing stops+    -- at the first failure. If all tests are passing and you want to run more tests,+    -- increase this number.   , maxDiscardRatio :: Int     -- ^ Maximum number of discarded tests per successful test before giving up   , maxSize         :: Int     -- ^ Size to use for the biggest test cases   , chatty          :: Bool     -- ^ Whether to print anything+  , maxShrinks      :: Int+    -- ^ Maximum number of shrinks to before giving up. Setting this to zero+    --   turns shrinking off.   }  deriving ( Show, Read ) @@ -68,38 +78,39 @@   -- | A successful test run   = Success     { numTests       :: Int               -- ^ Number of tests performed-    , labels         :: [(String,Int)]    -- ^ Labels and frequencies found during all successful tests+    , labels         :: [(String,Double)] -- ^ Labels and frequencies found during all successful tests     , output         :: String            -- ^ Printed output     }   -- | Given up   | GaveUp     { numTests       :: Int               --   Number of tests performed-    , labels         :: [(String,Int)]    --   Labels and frequencies found during all successful tests+    , labels         :: [(String,Double)] --   Labels and frequencies found during all successful tests     , output         :: String            --   Printed output     }   -- | A failed test run   | Failure-    { numTests       :: Int               --   Number of tests performed-    , numShrinks     :: Int               -- ^ Number of successful shrinking steps performed-    , numShrinkTries :: Int               -- ^ Number of unsuccessful shrinking steps performed-    , numShrinkFinal :: Int               -- ^ Number of unsuccessful shrinking steps performed since last successful shrink-    , usedSeed       :: QCGen             -- ^ What seed was used-    , usedSize       :: Int               -- ^ What was the test size-    , reason         :: String            -- ^ Why did the property fail-    , theException   :: Maybe AnException -- ^ The exception the property threw, if any-    , labels         :: [(String,Int)]    --   Labels and frequencies found during all successful tests-    , output         :: String            --   Printed output+    { numTests        :: Int               --   Number of tests performed+    , numShrinks      :: Int               -- ^ Number of successful shrinking steps performed+    , numShrinkTries  :: Int               -- ^ Number of unsuccessful shrinking steps performed+    , numShrinkFinal  :: Int               -- ^ Number of unsuccessful shrinking steps performed since last successful shrink+    , usedSeed        :: QCGen             -- ^ What seed was used+    , usedSize        :: Int               -- ^ What was the test size+    , reason          :: String            -- ^ Why did the property fail+    , theException    :: Maybe AnException -- ^ The exception the property threw, if any+    , labels          :: [(String,Double)] --   Labels and frequencies found during all successful tests+    , output          :: String            --   Printed output+    , failingTestCase :: [String]          -- ^ The test case which provoked the failure     }   -- | A property that should have failed did not   | NoExpectedFailure     { numTests       :: Int               --   Number of tests performed-    , labels         :: [(String,Int)]    --   Labels and frequencies found during all successful tests+    , labels         :: [(String,Double)] --   Labels and frequencies found during all successful tests     , output         :: String            --   Printed output     }  -- | The tests passed but a use of 'cover' had insufficient coverage  | InsufficientCoverage     { numTests       :: Int               --   Number of tests performed-    , labels         :: [(String,Int)]    --   Labels and frequencies found during all successful tests+    , labels         :: [(String,Double)] --   Labels and frequencies found during all successful tests     , output         :: String            --   Printed output     }  deriving ( Show )@@ -117,10 +128,13 @@   , maxDiscardRatio = 10   , maxSize         = 100   , chatty          = True--- noShrinking flag?+  , maxShrinks      = maxBound   }  -- | Tests a property and prints the results to 'stdout'.+--+-- By default up to 100 tests are performed, which may not be enough+-- to find all bugs. To run more tests, use 'withMaxSuccess'. quickCheck :: Testable prop => prop -> IO () quickCheck p = quickCheckWith stdArgs p @@ -144,6 +158,7 @@                  , computeSize               = case replay a of                                                  Nothing    -> computeSize'                                                  Just (_,s) -> computeSize' `at0` s+                 , numTotMaxShrinks          = maxShrinks a                  , numSuccessTests           = 0                  , numDiscardedTests         = 0                  , numRecentlyDiscardedTests = 0@@ -206,7 +221,7 @@        ++ " tests (expected failure)"         )       finished NoExpectedFailure-  | insufficientCoverage st = do+  | not (null (insufficientlyCovered st)) = do       putPart (terminal st)         ( bold ("*** Insufficient coverage after ")        ++ show (numSuccessTests st)@@ -264,20 +279,22 @@            | otherwise = x:xs       case res of-       MkResult{ok = Just True, stamp = stamp, expect = expect} -> -- successful test+       MkResult{ok = Just True, stamp = stamp, expect = expect, maybeNumTests = mnt} -> -- successful test          do continue doneTesting               st{ numSuccessTests           = numSuccessTests st + 1                 , numRecentlyDiscardedTests = 0+                , maxSuccessTests           = fromMaybe (maxSuccessTests st) mnt                 , randomSeed                = rnd2                 , S.labels                  = Map.unionWith max (S.labels st) (P.labels res)                 , collected                 = stamp `cons` collected st                 , expectedFailure           = expect                 } f -       MkResult{ok = Nothing, expect = expect} -> -- discarded test+       MkResult{ok = Nothing, expect = expect, maybeNumTests = mnt} -> -- discarded test          do continue giveUp               st{ numDiscardedTests         = numDiscardedTests st + 1                 , numRecentlyDiscardedTests = numRecentlyDiscardedTests st + 1+                , maxSuccessTests           = fromMaybe (maxSuccessTests st) mnt                 , randomSeed                = rnd2                 , S.labels                  = Map.unionWith max (S.labels st) (P.labels res)                 , expectedFailure           = expect@@ -287,36 +304,40 @@          do if expect res               then putPart (terminal st) (bold "*** Failed! ")               else putPart (terminal st) "+++ OK, failed as expected. "-            (numShrinks, totFailed, lastFailed) <- foundFailure st res ts+            (numShrinks, totFailed, lastFailed, res) <- foundFailure st res ts             theOutput <- terminalOutput (terminal st)             if not (expect res) then               return Success{ labels = summary st,                               numTests = numSuccessTests st+1,                               output = theOutput }-             else-              return Failure{ usedSeed       = randomSeed st -- correct! (this will be split first)-                            , usedSize       = size-                            , numTests       = numSuccessTests st+1-                            , numShrinks     = numShrinks-                            , numShrinkTries = totFailed-                            , numShrinkFinal = lastFailed-                            , output         = theOutput-                            , reason         = P.reason res-                            , theException   = P.theException res-                            , labels         = summary st+             else do+              testCase <- mapM showCounterexample (P.testCase res)+              return Failure{ usedSeed        = randomSeed st -- correct! (this will be split first)+                            , usedSize        = size+                            , numTests        = numSuccessTests st+1+                            , numShrinks      = numShrinks+                            , numShrinkTries  = totFailed+                            , numShrinkFinal  = lastFailed+                            , output          = theOutput+                            , reason          = P.reason res+                            , theException    = P.theException res+                            , labels          = summary st+                            , failingTestCase = testCase                             }  where   (rnd1,rnd2) = split (randomSeed st) -summary :: State -> [(String,Int)]+summary :: State -> [(String, Double)] summary st = reverse-           . sort-           . map (\ss -> (head ss, (length ss * 100) `div` numSuccessTests st))+           . sortBy (comparing snd)+           . map (\ss -> (head ss, fromIntegral (length ss) * 100 / fromIntegral (numSuccessTests st)))            . group            . sort-           $ [ concat (intersperse ", " (Set.toList s))+           $ [ concat (intersperse ", " s')              | s <- collected st-             , not (Set.null s)+               -- HACK: don't print out labels that were created by 'cover'.+             , let s' = [ t | t <- Set.toList s, Map.lookup t (S.labels st) == Just 0 ]+             , not (null s')              ]  success :: State -> IO ()@@ -329,48 +350,59 @@                  ++ ")."                   )     cases -> do putLine (terminal st) ":"-                sequence_ [ putLine (terminal st) pt | pt <- cases ]+                mapM_ (putLine $ terminal st) cases  where-  allLabels = reverse-            . sort-            . map (\ss -> (showP ((length ss * 100) `div` numSuccessTests st) ++ head ss))-            . group-            . sort-            $ [ concat (intersperse ", " s')-              | s <- collected st-              , let s' = [ t | t <- Set.toList s, Map.lookup t (S.labels st) == Just 0 ]-              , not (null s')-              ]+  allLabels :: [String]+  allLabels = map (formatLabel (numSuccessTests st) True) (summary st) -  covers = [ ("only " ++ show (labelPercentage l st) ++ "% " ++ l ++ ", not " ++ show reqP ++ "%")-           | (l, reqP) <- Map.toList (S.labels st)-           , labelPercentage l st < reqP-           ]+  covers :: [String]+  covers = [ ("only " ++ formatLabel (numSuccessTests st) False (l, p) ++ ", not " ++ show reqP ++ "%")+           | (l, reqP, p) <- insufficientlyCovered st ] -  showP p = (if p < 10 then " " else "") ++ show p ++ "% "+formatLabel :: Int -> Bool -> (String, Double) -> String+formatLabel n pad (x, p) = showP pad p ++ " " ++ x+ where+  showP :: Bool -> Double -> String+  showP pad p =+    (if pad && p < 10 then " " else "") +++    printf "%.*f" places p ++ "%" -labelPercentage :: String -> State -> Int-labelPercentage l st =+  -- Show no decimal places if <= 100 successful tests,+  -- one decimal place if <= 1000 successful tests,+  -- two decimal places if <= 10000 successful tests, and so on.+  places :: Integer+  places =+    ceiling (logBase 10 (fromIntegral n) - 2 :: Double) `max` 0++labelCount :: String -> State -> Int+labelCount l st =   -- XXX in case of a disjunction, a label can occur several times,   -- need to think what to do there-  (100 * occur) `div` maxSuccessTests st-  where-    occur = length [ l' | l' <- concat (map Set.toList (collected st)), l == l' ]+  length [ l' | l' <- concat (map Set.toList (collected st)), l == l' ] -insufficientCoverage :: State -> Bool-insufficientCoverage st =-  or [ labelPercentage l st < reqP | (l, reqP) <- Map.toList (S.labels st) ]+percentage :: Integral a => State -> a -> Double+percentage st n =+  fromIntegral n * 100 / fromIntegral (numSuccessTests st) +insufficientlyCovered :: State -> [(String, Int, Double)]+insufficientlyCovered st =+  [ (l, reqP, p)+  | (l, reqP) <- Map.toList (S.labels st),+    let p = percentage st (labelCount l st),+    p < fromIntegral reqP ]+ -------------------------------------------------------------------------- -- main shrinking loop -foundFailure :: State -> P.Result -> [Rose P.Result] -> IO (Int, Int, Int)+foundFailure :: State -> P.Result -> [Rose P.Result] -> IO (Int, Int, Int, P.Result) foundFailure st res ts =   do localMin st{ numTryShrinks = 0 } res res ts -localMin :: State -> P.Result -> P.Result -> [Rose P.Result] -> IO (Int, Int, Int)-localMin st MkResult{P.theException = Just e} lastRes _-  | isInterrupt e = localMinFound st lastRes+localMin :: State -> P.Result -> P.Result -> [Rose P.Result] -> IO (Int, Int, Int, P.Result)+-- Don't try to shrink for too long+localMin st res _ ts+  | numSuccessShrinks st + numTotTryShrinks st >= numTotMaxShrinks st =+    localMinFound st res localMin st res _ ts = do   r <- tryEvaluateIO $     putTemp (terminal st)@@ -398,7 +430,7 @@             (exception "Exception while generating shrink-list" err) { callbacks = callbacks res }         Right ts' -> localMin' st res ts' -localMin' :: State -> P.Result -> [Rose P.Result] -> IO (Int, Int, Int)+localMin' :: State -> P.Result -> [Rose P.Result] -> IO (Int, Int, Int, P.Result) localMin' st res [] = localMinFound st res localMin' st res (t:ts) =   do -- CALLBACK before_test@@ -410,7 +442,7 @@       else localMin st{ numTryShrinks    = numTryShrinks st + 1,                         numTotTryShrinks = numTotTryShrinks st + 1 } res res ts -localMinFound :: State -> P.Result -> IO (Int, Int, Int)+localMinFound :: State -> P.Result -> IO (Int, Int, Int, P.Result) localMinFound st res =   do let report = concat [            "(after " ++ number (numSuccessTests st+1) "test",@@ -430,7 +462,7 @@      callbackPostFinalFailure st res      -- NB no need to check if callbacks threw an exception because      -- we are about to return to the user anyway-     return (numSuccessShrinks st, numTotTryShrinks st - numTryShrinks st, numTryShrinks st)+     return (numSuccessShrinks st, numTotTryShrinks st - numTryShrinks st, numTryShrinks st, res)  -------------------------------------------------------------------------- -- callbacks

@@ -25,7 +25,6 @@ -------------------------------------------------------------------------- -- imports -import Control.Applicative import System.IO   ( hFlush   , hPutStr

@@ -1,3 +1,71 @@+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 'timeout' combinator or 'verboseCheck' instead.+	  ('timeout' 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

@@ -5,8 +5,6 @@ -- imports  import Test.QuickCheck-import Test.QuickCheck.Text-import Test.QuickCheck.All  import Data.List   ( sort

@@ -0,0 +1,197 @@+{-# LANGUAGE ScopedTypeVariables, TemplateHaskell #-}+module Main where++--------------------------------------------------------------------------+-- imports++import Test.QuickCheck+import Test.QuickCheck.Poly++import Data.List+  ( sort+  , (\\)+  )++import Control.Monad+  ( liftM+  , liftM2+  )++--------------------------------------------------------------------------+-- skew heaps++data Heap a+  = Node a (Heap a) (Heap a)+  | Nil+ deriving ( Eq, Ord, Show )++empty :: Heap a+empty = Nil++isEmpty :: Heap a -> Bool+isEmpty Nil = True+isEmpty _   = False++unit :: a -> Heap a+unit x = Node x empty empty++size :: Heap a -> Int+size Nil            = 0+size (Node _ h1 h2) = 1 + size h1 + size h2++insert :: Ord a => a -> Heap a -> Heap a+insert x h = unit x `merge` h++removeMin :: Ord a => Heap a -> Maybe (a, Heap a)+removeMin Nil            = Nothing+removeMin (Node x h1 h2) = Just (x, h1 `merge` h2)++merge :: Ord a => Heap a -> Heap a -> Heap a+h1  `merge` Nil = h1+Nil `merge` h2  = h2+h1@(Node x h11 h12) `merge` h2@(Node y h21 h22)+  | x <= y    = Node x (h12 `merge` h2) h11+  | otherwise = Node y (h22 `merge` h1) h21++fromList :: Ord a => [a] -> Heap a+fromList xs = merging [ unit x | x <- xs ]+ where+  merging []  = empty+  merging [h] = h+  merging hs  = merging (sweep hs)++  sweep []         = []+  sweep [h]        = [h]+  sweep (h1:h2:hs) = (h1 `merge` h2) : sweep hs++toList :: Heap a -> [a]+toList h = toList' [h]+ where+  toList' []                  = []+  toList' (Nil          : hs) = toList' hs+  toList' (Node x h1 h2 : hs) = x : toList' (h1:h2:hs)++toSortedList :: Ord a => Heap a -> [a]+toSortedList Nil            = []+toSortedList (Node x h1 h2) = x : toList (h1 `merge` h2)++--------------------------------------------------------------------------+-- heap programs++data HeapP a+  = Empty+  | Unit a+  | Insert a (HeapP a)+  | SafeRemoveMin (HeapP a)+  | Merge (HeapP a) (HeapP a)+  | FromList [a]+ deriving (Show)++heap :: Ord a => HeapP a -> Heap a+heap Empty             = empty+heap (Unit x)          = unit x+heap (Insert x p)      = insert x (heap p)+heap (SafeRemoveMin p) = case removeMin (heap p) of+                           Nothing    -> empty -- arbitrary choice+                           Just (_,h) -> h+heap (Merge p q)       = heap p `merge` heap q+heap (FromList xs)     = fromList xs++instance Arbitrary a => Arbitrary (HeapP a) where+  arbitrary = sized arbHeapP+   where+    arbHeapP s =+      frequency+      [ (1, do return Empty)+      , (1, do x <- arbitrary+               return (Unit x))+      , (s, do x <- arbitrary+               p <- arbHeapP s1+               return (Insert x p))+      , (s, do p <- arbHeapP s1+               return (SafeRemoveMin p))+      , (s, do p <- arbHeapP s2+               q <- arbHeapP s2+               return (Merge p q))+      , (1, do xs <- arbitrary+               return (FromList xs))+      ]+     where+      s1 = s-1+      s2 = s`div`2+++  shrink (Unit x)          = [ Unit x' | x' <- shrink x ]+  shrink (FromList xs)     = [ Unit x | x <- xs ]+                          ++ [ FromList xs' | xs' <- shrink xs ]+  shrink (Insert x p)      = [ p ]+                          ++ [ Insert x p' | p' <- shrink p ]+                          ++ [ Insert x' p | x' <- shrink x ]+  shrink (SafeRemoveMin p) = [ p ]+                          ++ [ SafeRemoveMin p' | p' <- shrink p ]+  shrink (Merge p q)       = [ p, q ]+                          ++ [ Merge p' q | p' <- shrink p ]+                          ++ [ Merge p q' | q' <- shrink q ]+  shrink _                 = []++data HeapPP a = HeapPP (HeapP a) (Heap a)+ deriving (Show)++instance (Ord a, Arbitrary a) => Arbitrary (HeapPP a) where+  arbitrary =+    do p <- arbitrary+       return (HeapPP p (heap p))++  shrink (HeapPP p _) =+    [ HeapPP p' (heap p') | p' <- shrink p ]++--------------------------------------------------------------------------+-- properties++(==?) :: Heap OrdA -> [OrdA] -> Bool+h ==? xs = sort (toList h) == sort xs++prop_Empty =+  empty ==? []++prop_IsEmpty (HeapPP _ h) =+  isEmpty h == null (toList h)++prop_Unit x =+  unit x ==? [x]++prop_Size (HeapPP _ h) =+  size h == length (toList h)++prop_Insert x (HeapPP _ h) =+  insert x h ==? (x : toList h)++prop_RemoveMin (HeapPP _ h) =+  cover (size h > 1) 80 "non-trivial" $+  case removeMin h of+    Nothing     -> h ==? []+    Just (x,h') -> x == minimum (toList h) && h' ==? (toList h \\ [x])++prop_Merge (HeapPP _ h1) (HeapPP _ h2) =+  (h1 `merge` h2) ==? (toList h1 ++ toList h2)++prop_FromList xs =+  fromList xs ==? xs++prop_ToSortedList (HeapPP _ h) =+  h ==? xs && xs == sort xs+ where+  xs = toSortedList h++--------------------------------------------------------------------------+-- main++return []+main = $(quickCheckAll)++--------------------------------------------------------------------------+-- the end.++-- toSortedList (Node x h1 h2) = x : toSortedList (h1 `merge` h2)++

@@ -0,0 +1,254 @@+{-# LANGUAGE ScopedTypeVariables, TemplateHaskell, GADTs #-}+module Main where++--------------------------------------------------------------------------+-- imports++import Test.QuickCheck+import Test.QuickCheck.Poly++import Data.List+  ( sort+  , nub+  , (\\)+  )++import Data.Maybe+  ( fromJust+  )++import Control.Monad+  ( liftM+  , liftM2+  )++--------------------------------------------------------------------------+-- skew heaps++data Heap a+  = Node a (Heap a) (Heap a)+  | Nil+ deriving ( Eq, Ord, Show )++empty :: Heap a+empty = Nil++isEmpty :: Heap a -> Bool+isEmpty Nil = True+isEmpty _   = False++unit :: a -> Heap a+unit x = Node x empty empty++size :: Heap a -> Int+size Nil            = 0+size (Node _ h1 h2) = 1 + size h1 + size h2++insert :: Ord a => a -> Heap a -> Heap a+insert x h = unit x `merge` h++removeMin :: Ord a => Heap a -> Maybe (a, Heap a)+removeMin Nil            = Nothing+removeMin (Node x h1 h2) = Just (x, h1 `merge` h2)++merge :: Ord a => Heap a -> Heap a -> Heap a+h1  `merge` Nil = h1+Nil `merge` h2  = h2+h1@(Node x h11 h12) `merge` h2@(Node y h21 h22)+  | x <= y    = Node x (h12 `merge` h2) h11+  | otherwise = Node y (h22 `merge` h1) h21++fromList :: Ord a => [a] -> Heap a+fromList xs = merging [ unit x | x <- xs ] []+ where+  merging []       [] = empty+  merging [p]      [] = p+  merging (p:q:ps) qs = merging ps ((p`merge`q):qs)+  merging ps       qs = merging (ps ++ reverse qs) []++toList :: Heap a -> [a]+toList h = toList' [h]+ where+  toList' []                  = []+  toList' (Nil          : hs) = toList' hs+  toList' (Node x h1 h2 : hs) = x : toList' (h1:h2:hs)++toSortedList :: Ord a => Heap a -> [a]+toSortedList Nil            = []+toSortedList (Node x h1 h2) = x : toSortedList (h1 `merge` h2)++--------------------------------------------------------------------------+-- heap programs++data HeapP a+  = Empty+  | Unit a+  | Insert a (HeapP a)+  | SafeRemoveMin (HeapP a)+  | Merge (HeapP a) (HeapP a)+  | FromList [a]+ deriving (Show)++safeRemoveMin :: Ord a => Heap a -> Heap a+safeRemoveMin h = case removeMin h of+                    Nothing    -> empty -- arbitrary choice+                    Just (_,h) -> h++heap :: Ord a => HeapP a -> Heap a+heap Empty             = empty+heap (Unit x)          = unit x+heap (Insert x p)      = insert x (heap p)+heap (SafeRemoveMin p) = safeRemoveMin (heap p)+heap (Merge p q)       = heap p `merge` heap q+heap (FromList xs)     = fromList xs++instance (Ord a, Arbitrary a) => Arbitrary (HeapP a) where+  arbitrary = sized arbHeapP+   where+    arbHeapP s =+      frequency+      [ (1, do return Empty)+      , (1, do x <- arbitrary+               return (Unit x))+      , (s, do x <- arbitrary+               p <- arbHeapP s1+               return (Insert x p))+      , (s, do p <- arbHeapP s1+               return (SafeRemoveMin p))+      , (s, do p <- arbHeapP s2+               q <- arbHeapP s2+               return (Merge p q))+      , (1, do xs <- arbitrary+               return (FromList xs))+      ]+     where+      s1 = s-1+      s2 = s`div`2+++  shrink Empty         = []+  shrink (Unit x)      = [ Unit x' | x' <- shrink x ]+  shrink (FromList xs) = [ Unit x | x <- xs ]+                      ++ [ FromList xs' | xs' <- shrink xs ]+  shrink p             =+    [ FromList (toList (heap p)) ] +++    case p of+      Insert x p      -> [ p ]+                      ++ [ Insert x p' | p' <- shrink p ]+                      ++ [ Insert x' p | x' <- shrink x ]+      SafeRemoveMin p -> [ p ]+                      ++ [ SafeRemoveMin p' | p' <- shrink p ]+      Merge p q       -> [ p, q ]+                      ++ [ Merge p' q | p' <- shrink p ]+                      ++ [ Merge p q' | q' <- shrink q ]++data HeapPP a = HeapPP (HeapP a) (Heap a)+ deriving (Show)++instance (Ord a, Arbitrary a) => Arbitrary (HeapPP a) where+  arbitrary =+    do p <- arbitrary+       return (HeapPP p (heap p))++  shrink (HeapPP p _) =+    [ HeapPP p' (heap p') | p' <- shrink p ]++--------------------------------------------------------------------------+-- properties++data Context a where+  Context :: Eq b => (Heap a -> b) -> Context a++instance (Ord a, Arbitrary a) => Arbitrary (Context a) where+  arbitrary =+    do f <- sized arbContext+       let vec h = (size h, toSortedList h, isEmpty h)+       return (Context (vec . f))+   where+    arbContext s =+      frequency+      [ (1, do return id)+      , (s, do x <- arbitrary+               f <- arbContext (s-1)+               return (insert x . f))+      , (s, do f <- arbContext (s-1)+               return (safeRemoveMin . f))+      , (s, do HeapPP _ h <- arbitrary+               f <- arbContext (s`div`2)+               elements [ (h `merge`) . f, (`merge` h) . f ])+      ]++instance Show (Context a) where+  show _ = "*"++(=~) :: Heap Char -> Heap Char -> Property+--h1 =~ h2 = sort (toList h1) == sort (toList h2)+--h1 =~ h2 = property (nub (sort (toList h1)) == nub (sort (toList h2))) -- bug!+h1 =~ h2 = property (\(Context c) -> c h1 == c h2)++{-+The normal form is:++  insert x1 (insert x2 (... empty)...)++where x1 <= x2 <= ...+-}++-- heap creating operations++prop_Unit x =+  unit x =~ insert x empty++prop_RemoveMin_Empty =+  removeMin (empty :: Heap OrdA) == Nothing++prop_RemoveMin_Insert1 x =+  removeMin (insert x empty :: Heap OrdA) == Just (x, empty)++prop_RemoveMin_Insert2 x y (HeapPP _ h) =+  removeMin (insert x (insert y h)) ==~+    (insert (max x y) `maph` removeMin (insert (min x y) h))+ where+  f `maph` Just (x,h) = Just (x, f h)+  f `maph` Nothing    = Nothing++  Nothing     ==~ Nothing     = property True+  Just (x,h1) ==~ Just (y,h2) = x==y .&&. h1 =~ h2++prop_InsertSwap x y (HeapPP _ h) =+  insert x (insert y h) =~ insert y (insert x h)++prop_MergeInsertLeft x (HeapPP _ h1) (HeapPP _ h2) =+  (insert x h1 `merge` h2) =~ insert x (h1 `merge` h2)++prop_MergeInsertRight x (HeapPP _ h1) (HeapPP _ h2) =+  (h1 `merge` insert x h2) =~ insert x (h1 `merge` h2)++-- heap observing operations++prop_Size_Empty =+  size empty == 0++prop_Size_Insert x (HeapPP _ (h :: Heap OrdA)) =+  size (insert x h) == 1 + size h++prop_ToList_Empty =+  toList empty == ([] :: [OrdA])++prop_ToList_Insert x (HeapPP _ (h :: Heap OrdA)) =+  sort (toList (insert x h)) == sort (x : toList h)++prop_ToSortedList (HeapPP _ (h :: Heap OrdA)) =+  toSortedList h == sort (toList h)++--------------------------------------------------------------------------+-- main++return []+main = $(quickCheckAll)++--------------------------------------------------------------------------+-- the end.+++

@@ -0,0 +1,363 @@+{-# LANGUAGE ScopedTypeVariables, TemplateHaskell #-}+module Main where++--------------------------------------------------------------------------+-- imports++import Test.QuickCheck++import Control.Monad+  ( liftM+  , liftM2+  )++import Data.Char+  ( toUpper+  )++import Data.Set (Set)+import qualified Data.Set as Set++--------------------------------------------------------------------------+-- types for lambda expressions++-- variables++newtype Var = MkVar String+  deriving ( Eq, Ord )++instance Show Var where+  show (MkVar s) = s++varList :: [Var]+varList = [ MkVar s+          | let vs = [ c:v | v <- "" : vs, c <- ['a'..'z'] ]+          , s <- vs+          ]++instance Arbitrary Var where+  arbitrary = growingElements [ MkVar [c] | c <- ['a'..'z'] ]++-- constants++newtype Con = MkCon String+  deriving ( Eq, Ord )++instance Show Con where+  show (MkCon s) = s++instance Arbitrary Con where+  arbitrary = growingElements [ MkCon [c] | c <- ['A'..'Z'] ]++-- expressions++data Exp+  = Lam Var Exp+  | App Exp Exp+  | Var Var+  | Con Con+ deriving ( Eq, Ord )++instance Show Exp where+  showsPrec n (Lam x t) = showParen (n>0) (showString "\\" . shows x . showString "." . shows t)+  showsPrec n (App s t) = showParen (n>1) (showsPrec 1 s . showString " " . showsPrec 2 t)+  showsPrec _ (Var x)   = shows x+  showsPrec _ (Con c)   = shows c++instance Arbitrary Exp where+  arbitrary = sized arbExp+   where+    arbExp n =+      frequency $+        [ (2, liftM Var arbitrary)+        , (1, liftM Con arbitrary)+        ] +++        concat+        [ [ (5, liftM2 Lam arbitrary arbExp1)+          , (5, liftM2 App arbExp2 arbExp2)+          ]+        | n > 0+        ]+       where+        arbExp1 = arbExp (n-1)+        arbExp2 = arbExp (n `div` 2)++  shrink (Lam x a) = [ a ]+                  ++ [ Lam x a' | a' <- shrink a ]+  shrink (App a b) = [ a, b ]+                  ++ [ ab+                     | Lam x a' <- [a]+                     , let ab = subst x b a'+                     , length (show ab) < length (show (App a b))+                     ]+                  ++ [ App a' b | a' <- shrink a ]+                  ++ [ App a b' | b' <- shrink b ]+  shrink (Var x)   = [Con (MkCon (map toUpper (show x)))]+  shrink _         = []++--------------------------------------------------------------------------+-- functions for lambda expressions++free :: Exp -> Set Var+free (Lam x a) = Set.delete x (free a)+free (App a b) = free a `Set.union` free b+free (Var x)   = Set.singleton x+free (Con _)   = Set.empty++subst :: Var -> Exp -> Exp -> Exp+subst x c (Var y)   | x == y = c+subst x b (Lam y a) | x /= y = Lam y (subst x b a)+subst x c (App a b)          = App (subst x c a) (subst x c b)+subst x c a                  = a++fresh :: Var -> Set Var -> Var+fresh x ys = head (filter (`Set.notMember` ys) (x:varList))++rename :: Var -> Var -> Exp -> Exp+rename x y a | x == y    = a+             | otherwise = subst x (Var y) a++-- different bugs:+--subst x b (Lam y a) | x /= y = Lam y (subst x b a) -- bug 1+--subst x b (Lam y a) | x /= y = Lam y' (subst x b (rename y y' a)) where y':_ = (y:varList) \\ free b -- bug 2+--subst x b (Lam y a) | x /= y = Lam y' (subst x b (rename y y' a)) where y' = (y:varList) \\ (x:free b) -- bug 3+--subst x b (Lam y a) | x /= y = Lam y' (subst x b (rename y y' a)) where y' = fresh y (x:free b) -- bug 4+--subst x c (Lam y a) | x /= y = Lam y' (subst x c (rename y y' a)) where y' = fresh y (x `insert` delete y (free a) `union` free c)++--------------------------------------------------------------------------+-- properties for substitutions++showResult :: (Show a, Testable prop) => a -> (a -> prop) -> Property+showResult x f =+  whenFail (putStrLn ("Result: " ++ show x)) $+    f x++prop_SubstFreeNoVarCapture a x b =+  showResult (subst x b a) $ \subst_x_b_a ->+    x `Set.member` free_a ==>+      free subst_x_b_a == (Set.delete x free_a `Set.union` free b)+ where+  free_a = free a++prop_SubstNotFreeSame a x b =+  showResult (subst x b a) $ \subst_x_b_a ->+    x `Set.notMember` free a ==>+      subst_x_b_a == a++prop_SubstNotFreeSameVars a x b =+  showResult (subst x b a) $ \subst_x_b_a ->+    x `Set.notMember` free a ==>+      free subst_x_b_a == free a++main1 =+  do quickCheck prop_SubstFreeNoVarCapture+     quickCheck prop_SubstNotFreeSame+     quickCheck prop_SubstNotFreeSameVars++--expectFailure $+++++++++--------------------------------------------------------------------------+-- eval++eval :: Exp -> Exp+eval (Var x)   = error "eval: free variable"+eval (App a b) =+  case eval a of+    Lam x a' -> eval (subst x b a')+    a'       -> App a' (eval b)+eval a         = a++--------------------------------------------------------------------------+-- closed lambda expressions++newtype ClosedExp = Closed Exp deriving ( Show )++instance Arbitrary ClosedExp where+  arbitrary = Closed `fmap` sized (arbExp [])+   where+    arbExp xs n =+      frequency $+        [ (8, liftM Var (elements xs))+        | not (null xs)+        ] +++        [ (2, liftM Con arbitrary)+        ] +++        [ (20, do x <- arbitrary+                  t <- arbExp (x:xs) n'+                  return (Lam x t))+        | n > 0 || null xs+        ] +++        [ (20, liftM2 App (arbExp xs n2) (arbExp xs n2))+        | n > 0+        ]+     where+      n' = n-1+      n2 = n `div` 2++  shrink (Closed a) =+    [ Closed a' | a' <- shrink a, Set.null (free a') ]++--------------------------------------------------------------------------+-- properties for closed lambda expressions++isValue :: Exp -> Bool+isValue (Var _)           = False+isValue (App (Lam _ _) _) = False+isValue (App a b)         = isValue a && isValue b+isValue _                 = True++prop_ClosedExpIsClosed (Closed a) =+  Set.null (free a)++prop_EvalProducesValue (Closed a) =+  within 1000 $+    isValue (eval a)++main2 =+  do quickCheck prop_ClosedExpIsClosed+     quickCheck prop_EvalProducesValue++--  expectFailure $++--------------------------------------------------------------------------+-- main++main =+  do main1+     main2++--------------------------------------------------------------------------+-- the end.++{-+instance Arbitrary Exp where+  arbitrary = sized (arbExp [])+   where++  arbitrary = repair [] `fmap` sized arbExp+   where+    arbExp n =+      frequency $+        [ (1, liftM Var arbitrary)+        ] ++ concat+        [ [ (3, liftM2 Lam arbitrary   (arbExp n'))+          , (4, liftM2 App (arbExp n2) (arbExp n2))+          ]+        | n > 0+        ]+     where+      n' = n-1+      n2 = n `div` 2++    repair xs (Var x)+      | x `elem` xs = Var x+      | null xs     = Lam x (Var x)+      | otherwise   = Var (xs !! (ord (last (show x)) `mod` length xs))+    repair xs (App a b) = App (repair xs a) (repair xs b)+    repair xs (Lam x a) = Lam x (repair (x:xs) a)++  -- lots of clever shrinking added+  shrinkRec (Lam x a) = [ a | x `notElem` free a ]+  shrinkRec (App a b) = [ a, b ]+                     ++ [ red+                        | Lam x a' <- [a]+                        , let red = subst x b a'+                        , length (show red) < length (show (App a b))+                        ]+  shrinkRec (Var x)   = [Con (MkCon (map toUpper (show x)))]+  shrinkRec _         = []++-- types++data Type+  = Base Con+  | Type :-> Type+ deriving ( Eq, Show )++instance Arbitrary Type where+  arbitrary = sized arbType+   where+    arbType n =+      frequency $+        [ (1, liftM Base arbitrary)+        ] +++        [ (4, liftM2 (:->) arbType2 arbType2)+        | n > 0+        ]+     where+      arbType2 = arbType (n `div` 2)++newtype WellTypedExp = WellTyped Exp+ deriving ( Eq, Show )++arbExpWithType n env t =+  frequency $+    [ (2, liftM Var (elements xs))+    | let xs = [ x | (x,t') <- env, t == t' ]+    , not (null xs)+    ] +++    [ (1, return (Con b))+    | Base b <- [t]+    ] +++    [ (if n > 0 then 5 else 1+        , do x <- arbitrary+             b <- arbExpWithType n1 ((x,ta):[ xt | xt <- env, fst xt /= x ]) tb+             return (Lam x b))+    | ta :-> tb <- [t]+    ] +++    [ (5, do tb <- arbitrary+             a <- arbExpWithType n2 env (tb :-> t)+             b <- arbExpWithType n2 env tb+             return (App a b))+    | n > 0+    ]+   where+    n1 = n-1+    n2 = n `div` 2++instance Arbitrary WellTypedExp where+  arbitrary =+    do t <- arbitrary+       e <- sized (\n -> arbExpWithType n [] t)+       return (WellTyped e)++  shrink _ = []++newtype OpenExp = Open Exp+ deriving ( Eq, Show )++instance Arbitrary OpenExp where+  arbitrary = Open `fmap` sized arbExp+   where+    arbExp n =+      frequency $+        [ (2, liftM Var arbitrary)+        , (1, liftM Con arbitrary)+        ] +++        concat+        [ [ (5, liftM2 Lam arbitrary arbExp1)+          , (5, liftM2 App arbExp2 arbExp2)+          ]+        | n > 0+        ]+       where+        arbExp1 = arbExp (n-1)+        arbExp2 = arbExp (n `div` 2)++  shrink (Open a) = map Open (shrink a)++prop_EvalProducesValueWT (WellTyped a) =+  isValue (eval a)++-}++x = MkVar "x"+y = MkVar "y"+

@@ -0,0 +1,116 @@+{-# LANGUAGE ScopedTypeVariables, TemplateHaskell #-}+module Main where++--------------------------------------------------------------------------+-- imports++import Test.QuickCheck++import Data.List+  ( sort+  )++--------------------------------------------------------------------------+-- merge sort++msort :: Ord a => [a] -> [a]+msort xs = merging [ [x] | x <- xs ]++merging :: Ord a => [[a]] -> [a]+merging []   = []+merging [xs] = xs+merging xss  = merging (sweep xss)++sweep :: Ord a => [[a]] -> [[a]]+sweep []          = []+sweep [xs]        = [xs]+sweep (xs:ys:xss) = merge xs ys : sweep xss++merge :: Ord a => [a] -> [a] -> [a]+merge xs     []     = xs+merge []     ys     = ys+merge (x:xs) (y:ys)+  | x <= y          = x : merge xs (y:ys)+  | otherwise       = y : merge (x:xs) ys++--------------------------------------------------------------------------+-- example properties++ordered :: Ord a => [a] -> Bool+ordered []       = True+ordered [x]      = True+ordered (x:y:xs) = x <= y && ordered (y:xs)++prop_Merge xs (ys :: [Int]) =+  ordered xs && ordered ys ==>+    collect (length xs + length ys) $+    ordered (xs `merge` ys)++--  collect (sort [length xs, length ys]) $++++++++++++++++++++--------------------------------------------------------------------------+-- quantificiation++--prop_Merge (Ordered xs) (Ordered (ys :: [Int])) =+--  ordered (xs `merge` ys)++++++++++++++--  classify (length xs `min` length ys >= 5) "not trivial" $+--  cover (length xs `min` length ys >= 5) 70 "not trivial" $++{-+  shrink (Ordered xs) =+    [ Ordered xs'+    | xs' <- shrink xs+    , ordered xs'+    ]+-}++--------------------------------------------------------------------------+-- merging++prop_Merging (xss :: [OrderedList Int]) =+  ordered (merging [ xs | Ordered xs <- xss ])++++++++--  mapSize (`div` 2) $ \(xss :: [OrderedList Int]) ->++return []+main = $quickCheckAll++--------------------------------------------------------------------------+-- the end.

@@ -0,0 +1,213 @@+{-# LANGUAGE ScopedTypeVariables, TemplateHaskell #-}+module Main where++--------------------------------------------------------------------------+-- imports++import Test.QuickCheck++import Text.Show.Functions+import Data.List+  ( sort+  , group+  , nub+  , (\\)+  )++import Control.Monad+  ( liftM+  , liftM2+  )++import Data.Maybe++--import Text.Show.Functions++--------------------------------------------------------------------------+-- binary search trees++data Set a+  = Node a (Set a) (Set a)+  | Empty+ deriving ( Eq, Ord, Show )++empty :: Set a+empty = Empty++isEmpty :: Set a -> Bool+isEmpty Empty = True+isEmpty _     = False++unit :: a -> Set a+unit x = Node x empty empty++size :: Set a -> Int+size Empty          = 0+size (Node _ s1 s2) = 1 + size s1 + size s2++insert :: Ord a => a -> Set a -> Set a+insert x s = s `union` unit x++merge :: Set a -> Set a -> Set a+s `merge` Empty                      = s+s `merge` Node x Empty s2            = Node x s s2+s `merge` Node x (Node y s11 s12) s2 = Node y s (Node x (s11 `merge` s12) s2)++delete :: Ord a => a -> Set a -> Set a+delete x Empty = Empty+delete x (Node x' s1 s2) =+  case x `compare` x' of+    LT -> Node x' (delete x s1) s2+    EQ -> s1 `merge` s2+    GT -> Node x' s1 (delete x s2)++union :: Ord a => Set a -> Set a -> Set a+{-+s1    `union` Empty = s1+Empty `union` s2    = s2+s1@(Node x s11 s12) `union` s2@(Node y s21 s22) =+  case x `compare` y of+    LT -> Node x s11 (s12 `union` Node y Empty s22) `union` s21+    EQ -> Node x (s11 `union` s21) (s12 `union` s22)+    --GT -> s11 `union` Node y s21 (Node x Empty s12 `union` s22)+    GT -> Node x (s11 `union` Node y s21 Empty) s12 `union` s22 +-}+s1             `union` Empty = s1+Empty          `union` s2    = s2+Node x s11 s12 `union` s2    = Node x (s11 `union` s21) (s12 `union` s22)+ where+  (s21,s22) = split x s2++split :: Ord a => a -> Set a -> (Set a, Set a)+split x Empty = (Empty, Empty)+split x (Node y s1 s2) =+  case x `compare` y of+    LT -> (s11, Node y s12 s2)+    EQ -> (s1, s2)+    GT -> (Node y s1 s21, s22)+ where+  (s11,s12) = split x s1+  (s21,s22) = split x s2+  +mapp :: (a -> b) -> Set a -> Set b+mapp f Empty          = Empty+mapp f (Node x s1 s2) = Node (f x) (mapp f s1) (mapp f s2)++fromList :: Ord a => [a] -> Set a+--fromList xs = build [ (empty,x) | x <- sort xs ]+fromList xs = build [ (empty,head x) | x <- group (sort xs) ]+ where+  build []      = empty+  build [(s,x)] = attach x s+  build sxs     = build (sweep sxs)++  sweep []                    = []+  sweep [sx]                  = [sx]+  sweep ((s1,x1):(s2,x2):sxs) = (Node x1 s1 s2,x2) : sweep sxs++  attach x Empty          = unit x+  attach x (Node y s1 s2) = Node y s1 (attach x s2)++toList :: Set a -> [a]+toList s = toSortedList s++toSortedList :: Set a -> [a]+toSortedList s = toList' s []+ where+  toList' Empty          xs = xs+  toList' (Node x s1 s2) xs = toList' s1 (x : toList' s2 xs)++--------------------------------------------------------------------------+-- generators++instance (Ord a, Arbitrary a) => Arbitrary (Set a) where+  arbitrary = sized (arbSet Nothing Nothing)+   where+    arbSet mx my n =+      frequency $+        [ (1, return Empty) ] +++        [ (7, do mz <- arbitrary `suchThatMaybe` (isOK mx my)+                 case mz of+                   Nothing -> return Empty+                   Just z  -> liftM2 (Node z) (arbSet mx mz n2)+                                              (arbSet mz my n2)+                    where n2 = n `div` 2)+        | n > 0+        ]++    isOK mx my z =+      maybe True (<z) mx && maybe True (z<) my++  shrink Empty            = []+  shrink t@(Node x s1 s2) = [ s1, s2 ]+                         ++ [ t' | x' <- shrink x, let t' = Node x' s1 s2, invariant t' ]++-- instance (Ord a, ShrinkSub a) => ShrinkSub (Set a)++--------------------------------------------------------------------------+-- properties++(.<) :: Ord a => Set a -> a -> Bool+Empty      .< x = True+Node y _ s .< x = y < x && s .< x++(<.) :: Ord a => a -> Set a -> Bool+x <. Empty      = True+x <. Node y _ s = x < y && x <. s++(==?) :: Ord a => Set a -> [a] -> Bool+s ==? xs = invariant s && sort (toList s) == nub (sort xs)++invariant :: Ord a => Set a -> Bool+invariant Empty          = True+invariant (Node x s1 s2) = s1 .< x && x <. s2 && invariant s1 && invariant s2++prop_Invariant (s :: Set Int) =+  invariant s++prop_Empty =+  empty ==? ([] :: [Int])++prop_Unit (x :: Int) =+  unit x ==? [x]++prop_Size (s :: Set Int) =+  cover (size s >= 15) 60 "large" $+    size s == length (toList s)++prop_Insert x (s :: Set Int) =+  insert x s ==? (x : toList s)++prop_Delete x (s :: Set Int) =+  delete x s ==? (toList s \\ [x])++prop_Union s1 (s2 :: Set Int) =+  (s1 `union` s2) ==? (toList s1 ++ toList s2)++prop_Mapp (f :: Int -> Int) (s :: Set Int) =+  expectFailure $+    whenFail (putStrLn ("Fun: " ++ show [ (x,f x) | x <- toList s])) $+      mapp f s ==? map f (toList s)++prop_FromList (xs :: [Int]) =+  fromList xs ==? xs++prop_ToSortedList (s :: Set Int) =+  s ==? xs && xs == sort xs+ where+  xs = toSortedList s+  +--  whenFail (putStrLn ("Result: " ++ show (fromList xs))) $++prop_FromList' (xs :: [Int]) =+  shrinking shrink xs $ \xs' ->+    fromList xs ==? xs++--------------------------------------------------------------------------+-- main++return []+main = $quickCheckAll++--------------------------------------------------------------------------+-- the end.

@@ -0,0 +1,46 @@+{-# LANGUAGE ScopedTypeVariables, TemplateHaskell #-}+module Main where++--------------------------------------------------------------------------+-- imports++import Test.QuickCheck++--------------------------------------------------------------------------+-- example 1++allEqual  x y z = x == y && y == z+allEqual' x y z = 2*x == y + z++prop_SimonThompson x y (z :: Int) =+  allEqual x y z == allEqual' x y z++--------------------------------------------------------------------------+-- example 2++prop_ReverseReverse :: Eq a => [a] -> Bool+prop_ReverseReverse xs =+  reverse (reverse xs) == xs++prop_Reverse xs =+  reverse xs == xs++--------------------------------------------------------------------------+-- example 3++prop_Error (x,y) =+  2*x <= 5*y++--------------------------------------------------------------------------+-- main++return []+prop_conj = counterexample "Simon Thompson" $(monomorphic 'prop_SimonThompson) .&&.+            counterexample "reverse" $(monomorphic 'prop_Reverse)+prop_disj = counterexample "reverse" $(monomorphic 'prop_Reverse) .||.+            counterexample "Simon Thompson" $(monomorphic 'prop_SimonThompson)+return []+main = $quickCheckAll++--------------------------------------------------------------------------+-- the end.

@@ -142,5 +142,17 @@ prop_reachesBound_Word32 = reachesBound :: Word32 -> Property prop_reachesBound_Word64 = reachesBound :: Word64 -> Property +-- Bad shrink: infinite list+--+-- remove unexpectedFailure in prop_B1, shrinking should not loop forever.+data B1 = B1 Int deriving (Eq, Show)++instance Arbitrary B1 where+    arbitrary = fmap B1 arbitrary+    shrink x = x : shrink x++prop_B1 :: B1 -> Property+prop_B1 (B1 n) = expectFailure $ n === n + 1+ return []-main = $quickCheckAll >>= print+main = $forAllProperties (quickCheckWithResult stdArgs { maxShrinks = 10000 }) >>= print