QuickCheck 2.7.6 → 2.8

raw patch · 16 files changed

+693/−234 lines, 16 filesdep +containersdep ~QuickCheckdep ~basePVP ok

version bump matches the API change (PVP)

Dependencies added: containers

Dependency ranges changed: QuickCheck, base

API changes (from Hackage documentation)

Files

• LICENSE +2/−2
• QuickCheck.cabal +33/−11
• Test/QuickCheck.hs +72/−0
• Test/QuickCheck/All.hs +12/−2
• Test/QuickCheck/Arbitrary.hs +148/−25
• Test/QuickCheck/Exception.hs +1/−1
• Test/QuickCheck/Function.hs +24/−2
• Test/QuickCheck/Gen.hs +29/−2
• Test/QuickCheck/Gen/Unsafe.hs +1/−1
• Test/QuickCheck/Monadic.hs +151/−7
• Test/QuickCheck/Property.hs +56/−33
• Test/QuickCheck/State.hs +15/−11
• Test/QuickCheck/Test.hs +102/−83
• Test/QuickCheck/Text.hs +21/−49
• changelog +21/−0
• examples/Heap.hs +5/−5

@@ -1,6 +1,6 @@-Copyright (c) 2000-2014, Koen Claessen+Copyright (c) 2000-2015, Koen Claessen Copyright (c) 2006-2008, Björn Bringert-Copyright (c) 2009-2014, Nick Smallbone+Copyright (c) 2009-2015, Nick Smallbone All rights reserved.  Redistribution and use in source and binary forms, with or without

@@ -1,15 +1,15 @@ Name: QuickCheck-Version: 2.7.6+Version: 2.8 Cabal-Version: >= 1.8 Build-type: Simple License: BSD3 License-file: LICENSE Extra-source-files: README changelog-Copyright: 2000-2014 Koen Claessen, 2006-2008 Björn Bringert, 2009-2014 Nick Smallbone+Copyright: 2000-2015 Koen Claessen, 2006-2008 Björn Bringert, 2009-2015 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 >=6.8, Hugs, UHC+Tested-with: GHC >=6.10, Hugs, UHC Homepage: https://github.com/nick8325/quickcheck Category:       Testing Synopsis:       Automatic testing of Haskell programs@@ -26,6 +26,9 @@   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>.  source-repository head   type:     git@@ -34,7 +37,7 @@ source-repository this   type:     git   location: https://github.com/nick8325/quickcheck-  tag:      2.7.6+  tag:      2.8  flag base3   Description: Choose the new smaller, split-up base package.@@ -42,18 +45,27 @@ flag base4   Description: Choose the even newer base package with extensible exceptions. +flag base4point8+  Description: Choose the even more newer base package with natural numbers.+ flag templateHaskell   Description: Build Test.QuickCheck.All, which uses Template Haskell.  library   -- Choose which library versions to use.-  if flag(base4)-    Build-depends: base >= 4 && < 5, random+  if flag(base4point8)+    Build-depends: base >= 4.8 && < 5   else-    if flag(base3)-      Build-depends: base >= 3 && < 4, random+    if flag(base4)+      Build-depends: base >= 4 && < 4.8     else-      Build-depends: base < 3+      if flag(base3)+        Build-depends: base >= 3 && < 4+      else+        Build-depends: base < 3+  if flag(base4point8) || flag(base4) || flag(base3)+    Build-depends: random+  Build-depends: containers    -- Modules that are always built.   Exposed-Modules:@@ -110,11 +122,15 @@     cpp-options: -DNO_SAFE_HASKELL    -- Use tf-random on newer GHCs.-  if impl(ghc >= 7) && flag(base4)+  if impl(ghc >= 7) && (flag(base4point8) || flag(base4))     Build-depends: tf-random >= 0.4   else     cpp-options: -DNO_TF_RANDOM +  -- Natural numbers.+  if !flag(base4point8)+    cpp-options: -DNO_NATURALS+   -- Switch off most optional features on non-GHC systems.   if !impl(ghc)     -- If your Haskell compiler can cope without some of these, please@@ -141,6 +157,12 @@     main-is: Heap.hs     build-depends:       base,-      QuickCheck == 2.7.6,+      containers,+      QuickCheck == 2.8,       template-haskell >= 2.4,       test-framework >= 0.4 && < 0.9+    if flag(templateHaskell)+        Buildable: True+    else+        Buildable: False+

@@ -1,3 +1,70 @@+{-| For further information see the <http://www.cse.chalmers.se/~rjmh/QuickCheck/manual.html QuickCheck manual>.++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:++@+import Test.QuickCheck++prop_commutativeAdd :: Integer -> Integer -> Bool+prop_commutativeAdd n m = n + m == m + n+@++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:++>>> verboseCheck prop_commutativeAdd+Passed:+0+0+  …98 tests omitted…+Passed:+-68+6++++ 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+@++>>> quickCheck prop_swapInvolution++++ OK, passed 100 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').++-} {-# LANGUAGE CPP #-} #ifndef NO_SAFE_HASKELL {-# LANGUAGE Safe #-}@@ -37,12 +104,15 @@   , growingElements   , sized   , resize+  , scale   , suchThat   , suchThatMaybe   , listOf   , listOf1   , vectorOf   , infiniteListOf+  , shuffle+  , sublistOf     -- ** Generators which use Arbitrary   , vector   , orderedList@@ -59,6 +129,7 @@      -- ** Helper functions for implementing arbitrary   , arbitrarySizedIntegral+  , arbitrarySizedNatural   , arbitrarySizedFractional   , arbitrarySizedBoundedIntegral   , arbitraryBoundedIntegral@@ -66,6 +137,7 @@   , arbitraryBoundedEnum     -- ** Helper functions for implementing shrink #ifndef NO_GENERICS+  , genericCoarbitrary   , genericShrink   , subterms   , recursivelyShrink

@@ -79,8 +79,17 @@  deconstructType :: Error -> Type -> Q ([Name], Cxt, Type) deconstructType err ty0@(ForallT xs ctx ty) = do-  let plain (PlainTV _) = True-      plain _ = False+  let plain (PlainTV  _)       = True+#ifndef MIN_VERSION_template_haskell+      plain (KindedTV _ StarT) = True+#else+#if MIN_VERSION_template_haskell(2,8,0)+      plain (KindedTV _ StarT) = True+#else+      plain (KindedTV _ StarK) = True+#endif+#endif+      plain _                  = False   unless (all plain xs) $ err "Higher-kinded type variables in type"   return (map (\(PlainTV x) -> x) xs, ctx, ty) deconstructType _ ty = return ([], [], ty)@@ -177,3 +186,4 @@       Failure { } -> False       NoExpectedFailure { } -> False       GaveUp { } -> False+      InsufficientCoverage { } -> False

@@ -2,7 +2,12 @@ {-# LANGUAGE CPP #-} #ifndef NO_GENERICS {-# LANGUAGE DefaultSignatures, FlexibleContexts, TypeOperators #-}+{-# LANGUAGE FlexibleInstances, KindSignatures, ScopedTypeVariables #-}+{-# LANGUAGE MultiParamTypeClasses, OverlappingInstances #-} #endif+#ifndef NO_SAFE_HASKELL+{-# LANGUAGE Safe #-}+#endif module Test.QuickCheck.Arbitrary   (   -- * Arbitrary and CoArbitrary classes@@ -11,6 +16,7 @@    -- ** Helper functions for implementing arbitrary   , arbitrarySizedIntegral        -- :: Integral a => Gen a+  , arbitrarySizedNatural         -- :: Integral a => Gen a   , arbitraryBoundedIntegral      -- :: (Bounded a, Integral a) => Gen a   , arbitrarySizedBoundedIntegral -- :: (Bounded a, Integral a) => Gen a   , arbitrarySizedFractional      -- :: Fractional a => Gen a@@ -18,9 +24,10 @@   , arbitraryBoundedEnum          -- :: (Bounded a, Enum a) => Gen a   -- ** Helper functions for implementing shrink #ifndef NO_GENERICS-  , genericShrink      -- :: (Generic a, Typeable a, RecursivelyShrink (Rep a), Subterms (Rep a)) => a -> [a]-  , subterms           -- :: (Generic a, Subterms (Rep a)) => a -> [a]+  , genericShrink      -- :: (Generic a, Arbitrary a, RecursivelyShrink (Rep a), GSubterms (Rep a) a) => a -> [a]+  , subterms           -- :: (Generic a, Arbitrary a, GSubterms (Rep a) a) => a -> [a]   , recursivelyShrink  -- :: (Generic a, RecursivelyShrink (Rep a)) => a -> [a]+  , genericCoarbitrary -- :: (Generic a, GCoArbitrary (Rep a)) => a -> Gen b -> Gen b #endif   , shrinkNothing            -- :: a -> [a]   , shrinkList               -- :: (a -> [a]) -> [a] -> [[a]]@@ -44,6 +51,7 @@ -------------------------------------------------------------------------- -- imports +import Control.Applicative import System.Random(Random) import Test.QuickCheck.Gen import Test.QuickCheck.Gen.Unsafe@@ -73,6 +81,10 @@   ) #endif +#ifndef NO_NATURALS+import Numeric.Natural+#endif+ import Data.Ratio   ( Ratio   , (%)@@ -101,7 +113,6 @@  #ifndef NO_GENERICS import GHC.Generics-import Data.Typeable #endif  --------------------------------------------------------------------------@@ -176,7 +187,7 @@   -- infinite loop.   --   -- If all this leaves you bewildered, you might try @'shrink' = 'genericShrink'@ to begin with,-  -- after deriving @Generic@ and @Typeable@ for your type. However, if your data type has any+  -- after deriving @Generic@ for your type. However, if your data type has any   -- special invariants, you will need to check that 'genericShrink' can't break those invariants.   shrink :: a -> [a]   shrink _ = []@@ -184,7 +195,7 @@ #ifndef NO_GENERICS -- | Shrink a term to any of its immediate subterms, -- and also recursively shrink all subterms.-genericShrink :: (Generic a, Typeable a, RecursivelyShrink (Rep a), Subterms (Rep a)) => a -> [a]+genericShrink :: (Generic a, Arbitrary a, RecursivelyShrink (Rep a), GSubterms (Rep a) a) => a -> [a] genericShrink x = subterms x ++ recursivelyShrink x  -- | Recursively shrink all immediate subterms.@@ -212,33 +223,81 @@ instance RecursivelyShrink U1 where   grecursivelyShrink U1 = [] +instance RecursivelyShrink V1 where+  -- The empty type can't be shrunk to anything.+  grecursivelyShrink _ = []++ -- | All immediate subterms of a term.-subterms :: (Generic a, Typeable a, Subterms (Rep a)) => a -> [a]-subterms = gsubterms . from+subterms :: (Generic a, Arbitrary a, GSubterms (Rep a) a) => a -> [a]+subterms = gSubterms . from -class Subterms f where-  gsubterms :: Typeable b => f a -> [b] -instance (Subterms f, Subterms g) => Subterms (f :*: g) where-  gsubterms (x :*: y) =-    gsubterms x ++ gsubterms y+class GSubterms f a where+  -- | Provides the immediate subterms of a term that are of the same type+  -- as the term itself.+  --+  -- Requires a constructor to be stripped off; this means it skips through+  -- @M1@ wrappers and returns @[]@ on everything that's not `(:*:)` or `(:+:)`.+  --+  -- Once a `(:*:)` or `(:+:)` constructor has been reached, this function+  -- delegates to `gSubtermsIncl` to return the immediately next constructor+  -- available.+  gSubterms :: f a -> [a] -instance (Subterms f, Subterms g) => Subterms (f :+: g) where-  gsubterms (L1 x) = gsubterms x-  gsubterms (R1 x) = gsubterms x+instance GSubterms V1 a where+  -- The empty type can't be shrunk to anything.+  gSubterms _ = [] -instance Subterms f => Subterms (M1 i c f) where-  gsubterms (M1 x) = gsubterms x+instance GSubterms U1 a where+  gSubterms U1 = [] -instance Typeable a => Subterms (K1 i a) where-  gsubterms (K1 x) =-    case cast x of-      Nothing -> []-      Just y -> [y]+instance (GSubtermsIncl f a, GSubtermsIncl g a) => GSubterms (f :*: g) a where+  gSubterms (l :*: r) = gSubtermsIncl l ++ gSubtermsIncl r -instance Subterms U1 where-  gsubterms U1 = []+instance (GSubtermsIncl f a, GSubtermsIncl g a) => GSubterms (f :+: g) a where+  gSubterms (L1 x) = gSubtermsIncl x+  gSubterms (R1 x) = gSubtermsIncl x +instance GSubterms f a => GSubterms (M1 i c f) a where+  gSubterms (M1 x) = gSubterms x++instance GSubterms (K1 i a) b where+  gSubterms (K1 _) = []+++class GSubtermsIncl f a where+  -- | Provides the immediate subterms of a term that are of the same type+  -- as the term itself.+  --+  -- In contrast to `gSubterms`, this returns the immediate next constructor+  -- available.+  gSubtermsIncl :: f a -> [a]++instance GSubtermsIncl V1 a where+  -- The empty type can't be shrunk to anything.+  gSubtermsIncl _ = []++instance GSubtermsIncl U1 a where+  gSubtermsIncl U1 = []++instance (GSubtermsIncl f a, GSubtermsIncl g a) => GSubtermsIncl (f :*: g) a where+  gSubtermsIncl (l :*: r) = gSubtermsIncl l ++ gSubtermsIncl r++instance (GSubtermsIncl f a, GSubtermsIncl g a) => GSubtermsIncl (f :+: g) a where+  gSubtermsIncl (L1 x) = gSubtermsIncl x+  gSubtermsIncl (R1 x) = gSubtermsIncl x++instance GSubtermsIncl f a => GSubtermsIncl (M1 i c f) a where+  gSubtermsIncl (M1 x) = gSubtermsIncl x++-- This is the important case: We've found a term of the same type.+instance Arbitrary a => GSubtermsIncl (K1 i a) a where+  gSubtermsIncl (K1 x) = [x]++instance GSubtermsIncl (K1 i a) b where+  gSubtermsIncl (K1 _) = []+ #endif  -- instances@@ -363,6 +422,12 @@   arbitrary = arbitrarySizedIntegral   shrink    = shrinkIntegral +#ifndef NO_NATURALS+instance Arbitrary Natural where+  arbitrary = arbitrarySizedNatural+  shrink    = shrinkIntegral+#endif+ instance Arbitrary Int where   arbitrary = arbitrarySizedIntegral   shrink    = shrinkIntegral@@ -438,6 +503,13 @@   sized $ \n ->   inBounds fromInteger (choose (-toInteger n, toInteger n)) +-- | Generates a natural number. The number's maximum value depends on+-- the size parameter.+arbitrarySizedNatural :: Integral a => Gen a+arbitrarySizedNatural =+  sized $ \n ->+  inBounds fromInteger (choose (0, toInteger n))+ inBounds :: Integral a => (Integer -> a) -> Gen Integer -> Gen a inBounds fi g = fmap fi (g `suchThat` (\x -> toInteger (fi x) == x)) @@ -540,7 +612,25 @@ -------------------------------------------------------------------------- -- ** CoArbitrary +#ifndef NO_GENERICS -- | Used for random generation of functions.+--+-- If you are using a recent GHC, there is a default definition of+-- 'coarbitrary' using 'genericCoarbitrary', so if your type has a+-- 'Generic' instance it's enough to say+--+-- > instance CoArbitrary MyType+--+-- You should only use 'genericCoarbitrary' for data types where+-- equality is structural, i.e. if you can't have two different+-- representations of the same value. An example where it's not+-- safe is sets implemented using binary search trees: the same+-- set can be represented as several different trees.+-- Here you would have to explicitly define+-- @coarbitrary s = coarbitrary (toList s)@.+#else+-- | Used for random generation of functions.+#endif class CoArbitrary a where   -- | Used to generate a function of type @a -> b@.   -- The first argument is a value, the second a generator.@@ -553,9 +643,37 @@   --   coarbitrary []     = 'variant' 0   --   coarbitrary (x:xs) = 'variant' 1 . coarbitrary (x,xs)   -- @-   coarbitrary :: a -> Gen b -> Gen b+#ifndef NO_GENERICS+  default coarbitrary :: (Generic a, GCoArbitrary (Rep a)) => a -> Gen b -> Gen b+  coarbitrary = genericCoarbitrary +-- | Generic CoArbitrary implementation.+genericCoarbitrary :: (Generic a, GCoArbitrary (Rep a)) => a -> Gen b -> Gen b+genericCoarbitrary = gCoarbitrary . from++class GCoArbitrary f where+  gCoarbitrary :: f a -> Gen b -> Gen b++instance GCoArbitrary U1 where+  gCoarbitrary U1 = id++instance (GCoArbitrary f, GCoArbitrary g) => GCoArbitrary (f :*: g) where+  -- Like the instance for tuples.+  gCoarbitrary (l :*: r) = gCoarbitrary l . gCoarbitrary r++instance (GCoArbitrary f, GCoArbitrary g) => GCoArbitrary (f :+: g) where+  -- Like the instance for Either.+  gCoarbitrary (L1 x) = variant 0 . gCoarbitrary x+  gCoarbitrary (R1 x) = variant 1 . gCoarbitrary x++instance GCoArbitrary f => GCoArbitrary (M1 i c f) where+  gCoarbitrary (M1 x) = gCoarbitrary x++instance CoArbitrary a => GCoArbitrary (K1 i a) where+  gCoarbitrary (K1 x) = coarbitrary x+#endif+ {-# DEPRECATED (><) "Use ordinary function composition instead" #-} -- | Combine two generator perturbing functions, for example the -- results of calls to 'variant' or 'coarbitrary'.@@ -636,6 +754,11 @@  instance CoArbitrary Integer where   coarbitrary = coarbitraryIntegral++#ifndef NO_NATURALS+instance CoArbitrary Natural where+  coarbitrary = coarbitraryIntegral+#endif  instance CoArbitrary Int where   coarbitrary = coarbitraryIntegral

@@ -80,7 +80,7 @@ tryEvaluateIO m = E.try (m >>= E.evaluate) --tryEvaluateIO m = Right `fmap` m --- Test if an exception was a ^C.+-- | Test if an exception was a @^C@. -- QuickCheck won't try to shrink an interrupted test case. isInterrupt :: AnException -> Bool 

@@ -1,4 +1,9 @@-{-# LANGUAGE TypeOperators, GADTs #-}+{-# LANGUAGE TypeOperators, GADTs, CPP #-}++#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 708+{-# LANGUAGE PatternSynonyms #-}+#endif+ -- | Generation of random shrinkable, showable functions. -- See the paper \"Shrinking and showing functions\" by Koen Claessen. --@@ -24,6 +29,9 @@   , Function(..)   , functionMap   , functionShow+#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 708+  , pattern Fn+#endif   )  where @@ -37,11 +45,13 @@ import Data.Word import Data.List( intersperse ) import Data.Maybe( fromJust )+import Data.Ratio+import Control.Arrow( (&&&) )  -------------------------------------------------------------------------- -- concrete functions --- the type of possibly partial concrete functions+-- | The type of possibly partial concrete functions data a :-> c where   Pair  :: (a :-> (b :-> c)) -> ((a,b) :-> c)   (:+:) :: (a :-> c) -> (b :-> c) -> (Either a b :-> c)@@ -186,6 +196,9 @@     ord' c = fromIntegral (ord c) :: Word8     chr' n = chr (fromIntegral n) +instance (Function a, Integral a) => Function (Ratio a) where+  function = functionMap (numerator &&& denominator) (uncurry (%))+ -- poly instances  instance Function A where@@ -260,6 +273,15 @@ -- the Fun modifier  data Fun a b = Fun (a :-> b, b) (a -> b)++#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 708+-- | A pattern for matching against the function only:+--+-- > prop :: Fun String Integer -> Bool+-- > prop (Fn f) = f "banana" == f "monkey"+--              || f "banana" == f "elephant"+pattern Fn f <- Fun _ f+#endif  mkFun :: (a :-> b) -> b -> Fun a b mkFun p d = Fun (p,d) (abstract p d)

@@ -19,12 +19,19 @@ import Control.Monad   ( liftM   , ap+  , replicateM+  , filterM   )  import Control.Applicative   ( Applicative(..)+  , (<$>)   ) +import Control.Arrow+  ( second+  )+ import Test.QuickCheck.Random  --------------------------------------------------------------------------@@ -69,8 +76,14 @@ -- | Overrides the size parameter. Returns a generator which uses -- the given size instead of the runtime-size parameter. resize :: Int -> Gen a -> Gen a-resize n (MkGen m) = MkGen (\r _ -> m r n)+resize n _ | n < 0 = error "Test.QuickCheck.resize: negative size"+resize n (MkGen g) = MkGen (\r _ -> g r n) +-- | Adjust the size parameter, by transforming it with the given+-- function.+scale :: (Int -> Int) -> Gen a -> Gen a+scale f g = sized (\n -> resize (f n) g)+ -- | Generates a random element in the given inclusive range. choose :: Random a => (a,a) -> Gen a choose rng = MkGen (\r _ -> let (x,_) = randomR rng r in x)@@ -135,6 +148,20 @@ elements [] = error "QuickCheck.elements used with empty list" elements xs = (xs !!) `fmap` choose (0, length xs - 1) +-- | Generates a random subsequence of the given list.+sublistOf :: [a] -> Gen [a]+sublistOf xs = filterM (\_ -> choose (False, True)) xs++-- | Generates a random permutation of the given list.+shuffle :: [a] -> Gen [a]+shuffle [] = return []+shuffle xs = do+  (y, ys) <- elements (selectOne xs)+  (y:) <$> shuffle ys+  where+    selectOne [] = []+    selectOne (y:ys) = (y,ys) : map (second (y:)) (selectOne ys)+ -- | Takes a list of elements of increasing size, and chooses -- among an initial segment of the list. The size of this initial -- segment increases with the size parameter.@@ -171,7 +198,7 @@  -- | Generates a list of the given length. vectorOf :: Int -> Gen a -> Gen [a]-vectorOf k gen = sequence [ gen | _ <- [1..k] ]+vectorOf = replicateM  -- | Generates an infinite list. infiniteListOf :: Gen a -> Gen [a]

@@ -3,7 +3,7 @@ {-# LANGUAGE Rank2Types #-} #endif -- | Unsafe combinators for the 'Gen' monad.--- +-- -- 'Gen' is only morally a monad: two generators that are supposed -- to be equal will give the same probability distribution, but they -- might be different as functions from random number seeds to values.

@@ -2,11 +2,70 @@ #ifndef NO_ST_MONAD {-# LANGUAGE Rank2Types #-} #endif--- | Allows testing of monadic values.--- See the paper \"Testing Monadic Code with QuickCheck\":--- <http://www.cse.chalmers.se/~rjmh/Papers/QuickCheckST.ps>.-module Test.QuickCheck.Monadic where+{-|+Module   : Test.QuickCheck.Monadic +Allows testing of monadic values. Will generally follow this form:++@+prop_monadic a b = 'monadicIO' $ do+  a\' \<- 'run' (f a)+  b\' \<- 'run' (f b)+  -- ...+  'assert' someBoolean+@++Example using the @FACTOR(1)@ command-line utility:++@+import System.Process+import Test.QuickCheck+import Test.QuickCheck.Monadic++-- $ factor 16+-- 16: 2 2 2 2+factor :: Integer -> IO [Integer]+factor n = parse \`fmap\` 'System.Process.readProcess' \"factor\" [show n] \"\" where++  parse :: String -> [Integer]+  parse = map read . tail . words++prop_factor :: Positive Integer -> Property+prop_factor ('Test.QuickCheck.Modifiers.Positive' n) = 'monadicIO' $ do+  factors \<- 'run' (factor n)++  'assert' (product factors == n)+@++>>> quickCheck prop_factor++++ OK, passed 100 tests.++See the paper \"<http://www.cse.chalmers.se/~rjmh/Papers/QuickCheckST.ps Testing Monadic Code with QuickCheck>\".+-}+module Test.QuickCheck.Monadic (+  -- * Property monad+    PropertyM(..)++  -- * Monadic specification combinators+  , run+  , assert+  , pre+  , wp+  , pick+  , forAllM+  , monitor+  , stop++  -- * Run functions+  , monadic+  , monadic'+  , monadicIO+#ifndef NO_ST_MONAD+  , monadicST+  , runSTGen+#endif+  ) where+ -------------------------------------------------------------------------- -- imports @@ -27,6 +86,12 @@ -------------------------------------------------------------------------- -- type PropertyM +-- | The property monad is really a monad transformer that can contain+-- monadic computations in the monad @m@ it is parameterized by:+--+--   * @m@ - the @m@-computations that may be performed within @PropertyM@+--+-- Elements of @PropertyM m a@ may mix property operations and @m@-computations. newtype PropertyM m a =   MkPropertyM { unPropertyM :: (a -> Gen (m Property)) -> Gen (m Property) } @@ -54,20 +119,49 @@ stop p = MkPropertyM (\_k -> return (return (property p)))  -- should think about strictness/exceptions here---assert :: Testable prop => prop -> PropertyM m ()+-- assert :: Testable prop => prop -> PropertyM m ()+-- | Allows embedding non-monadic properties into monadic ones. assert :: Monad m => Bool -> PropertyM m ()-assert True = return ()+assert True  = return () assert False = fail "Assertion failed"  -- should think about strictness/exceptions here+-- | Tests preconditions. Unlike 'assert' this does not cause the+-- property to fail, rather it discards them just like using the+-- implication combinator 'Test.QuickCheck.Property.==>'.+--+-- This allows representing the <https://en.wikipedia.org/wiki/Hoare_logic Hoare triple>+--+-- > {p} x ← e{q}+--+-- as+--+-- @+-- pre p+-- x \<- run e+-- assert q+-- @+-- pre :: Monad m => Bool -> PropertyM m ()-pre True = return ()+pre True  = return () pre False = stop rejected  -- should be called lift?+-- | The lifting operation of the property monad. Allows embedding+-- monadic\/'IO'-actions in properties:+--+-- @+-- log :: Int -> IO ()+--+-- prop_foo n = monadicIO $ do+--   run (log n)+--   -- ...+-- @ run :: Monad m => m a -> PropertyM m a run m = MkPropertyM (liftM (m >>=) . promote) +-- | Quantification in a monadic property, fits better with+-- /do-notation/ than 'forAllM'. pick :: (Monad m, Show a) => Gen a -> PropertyM m a pick gen = MkPropertyM $ \k ->   do a <- gen@@ -75,12 +169,33 @@      return (do p <- mp                 return (forAll (return a) (const p))) +-- | The <https://en.wikipedia.org/wiki/Predicate_transformer_semantics#Weakest_preconditions weakest precondition>+--+-- > wp(x ← e, p)+--+-- can be expressed as in code as @wp e (\\x -> p)@. wp :: Monad m => m a -> (a -> PropertyM m b) -> PropertyM m b wp m k = run m >>= k +-- | An alternative to quantification a monadic properties to 'pick',+-- with a notation similar to 'forAll'.+ forAllM :: (Monad m, Show a) => Gen a -> (a -> PropertyM m b) -> PropertyM m b forAllM gen k = pick gen >>= k +-- | Allows making observations about the test data:+--+-- @+-- monitor ('collect' e)+-- @+--+-- collects the distribution of value of @e@.+--+-- @+-- monitor ('counterexample' "Failure!")+-- @+--+-- Adds @"Failure!"@ to the counterexamples. monitor :: Monad m => (Property -> Property) -> PropertyM m () monitor f = MkPropertyM (\k -> (f `liftM`) `fmap` (k ())) @@ -92,10 +207,39 @@ monadic' :: Monad m => PropertyM m a -> Gen (m Property) monadic' (MkPropertyM m) = m (const (return (return (property True)))) +-- | Runs the property monad for 'IO'-computations.+--+-- @+-- prop_cat msg = monadicIO $ do+--   (exitCode, stdout, _) \<- run ('System.Process.readProcessWithExitCode' "cat" [] msg)+--+--   pre ('System.Exit.ExitSuccess' == exitCode)+--+--   assert (stdout == msg)+-- @+--+-- >>> quickCheck prop_cat+-- +++ OK, passed 100 tests.+-- monadicIO :: PropertyM IO a -> Property monadicIO = monadic ioProperty  #ifndef NO_ST_MONAD+-- | Runs the property monad for 'ST'-computations.+--+-- @+-- -- Your mutable sorting algorithm here+-- sortST :: Ord a => [a] -> 'Control.Monad.ST.ST' s (MVector s a)+-- sortST = 'Data.Vector.thaw' . 'Data.Vector.fromList' . 'Data.List.sort'+--+-- prop_sortST xs = monadicST $ do+--   sorted  \<- run ('Data.Vector.freeze' =<< sortST xs)+--   assert ('Data.Vector.toList' sorted == sort xs)+-- @+--+-- >>> quickCheck prop_sortST+-- +++ OK, passed 100 tests.+-- monadicST :: (forall s. PropertyM (ST s) a) -> Property monadicST m = property (runSTGen (monadic' m)) 

@@ -13,7 +13,7 @@ import Test.QuickCheck.Arbitrary import Test.QuickCheck.Text( showErr, isOneLine, putLine ) import Test.QuickCheck.Exception-import Test.QuickCheck.State+import Test.QuickCheck.State hiding (labels)  #ifndef NO_TIMEOUT import System.Timeout(timeout)@@ -21,6 +21,10 @@ import Data.Maybe import Control.Applicative import Control.Monad+import qualified Data.Map as Map+import Data.Map(Map)+import qualified Data.Set as Set+import Data.Set(Set)  -------------------------------------------------------------------------- -- fixities@@ -168,23 +172,23 @@   -- k must be total   m >>= k  = joinRose (fmap k m) --- Execute the "IORose" bits of a rose tree, returning a tree+-- | Execute the "IORose" bits of a rose tree, returning a tree -- constructed by MkRose. reduceRose :: Rose Result -> IO (Rose Result) reduceRose r@(MkRose _ _) = return r reduceRose (IORose m) = m >>= reduceRose --- Apply a function to the outermost MkRose constructor of a rose tree.+-- | Apply a function to the outermost MkRose constructor of a rose tree. -- The function must be total! onRose :: (a -> [Rose a] -> Rose a) -> Rose a -> Rose a onRose f (MkRose x rs) = f x rs onRose f (IORose m) = IORose (fmap (onRose f) m) --- Wrap a rose tree in an exception handler.+-- | Wrap a rose tree in an exception handler. protectRose :: IO (Rose Result) -> IO (Rose Result) protectRose = protect (return . exception "Exception") --- Wrap all the Results in a rose tree in exception handlers.+-- | Wrap all the Results in a rose tree in exception handlers. protectResults :: Rose Result -> Rose Result protectResults = onRose $ \x rs ->   IORose $ do@@ -208,7 +212,8 @@   , 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-  , stamp        :: [(String,Int)]    -- ^ the collected values for this test case+  , 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   } @@ -220,7 +225,8 @@   , reason       = ""   , theException = Nothing   , abort        = False-  , stamp        = []+  , labels       = Map.empty+  , stamp        = Set.empty   , callbacks    = []   } @@ -364,17 +370,22 @@          -> prop -> Property classify b s = cover b 0 s --- | Checks that at least the given proportion of the test cases belong--- to the given class.+-- | 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. cover :: Testable prop =>          Bool   -- ^ @True@ if the test case belongs to the class.       -> Int    -- ^ The required percentage (0-100) of test cases.       -> String -- ^ Label for the test case class.       -> prop -> Property-cover True n s = n `seq` s `listSeq` (mapTotalResult $ \res -> res { stamp = (s,n) : stamp res })+cover x n s =+  x `seq` n `seq` s `listSeq`+  mapTotalResult $+    \res -> res {+      labels = Map.insertWith max s n (labels res),+      stamp = if x then Set.insert s (stamp res) else stamp res }   where [] `listSeq` z = z         (x:xs) `listSeq` z = x `seq` xs `listSeq` z-cover False _ _ = property  -- | Implication for properties: The resulting property holds if -- the first argument is 'False' (in which case the test case is discarded),@@ -440,20 +451,20 @@ conjoin ps =   MkProperty $   do roses <- mapM (fmap unProp . unProperty . property) ps-     return (MkProp (conj [] roses))+     return (MkProp (conj id roses))  where-  conj cbs [] =-    MkRose succeeded{callbacks = cbs} []+  conj k [] =+    MkRose (k succeeded) [] -  conj cbs (p : ps) = IORose $ do+  conj k (p : ps) = IORose $ do     rose@(MkRose result _) <- reduceRose p     case ok result of       _ | not (expect result) ->         return (return failed { reason = "expectFailure may not occur inside a conjunction" })-      Just True -> return (conj (cbs ++ callbacks result) ps)+      Just True -> return (conj (addLabels result . addCallbacks result . k) ps)       Just False -> return rose       Nothing -> do-        rose2@(MkRose result2 _) <- reduceRose (conj (cbs ++ callbacks result) ps)+        rose2@(MkRose result2 _) <- reduceRose (conj (addCallbacks result . k) ps)         return $           -- Nasty work to make sure we use the right callbacks           case ok result2 of@@ -461,6 +472,12 @@             Just False -> rose2             Nothing -> rose2 +  addCallbacks result r =+    r { callbacks = callbacks result ++ callbacks r }+  addLabels result r =+    r { labels = Map.unionWith max (labels result) (labels r),+        stamp = Set.union (stamp result) (stamp r) }+ -- | Disjunction: 'p1' '.||.' 'p2' passes unless 'p1' and 'p2' simultaneously fail. (.||.) :: (Testable prop1, Testable prop2) => prop1 -> prop2 -> Property p1 .||. p2 = disjoin [property p1, property p2]@@ -481,12 +498,25 @@          Just False -> do            result2 <- q            return $-             if expect result2 then-               case ok result2 of-                 Just True -> result2-                 Just False -> result1 >>> result2-                 Nothing -> result2-             else expectFailureError+             case ok result2 of+               _ | not (expect result2) -> expectFailureError+               Just True -> result2+               Just False ->+                 MkResult {+                   ok = Just False,+                   expect = True,+                   reason = sep (reason result1) (reason result2),+                   theException = theException result1 `mplus` theException result2,+                   -- The following three fields are not important because the+                   -- test case has failed anyway+                   abort = False,+                   labels = Map.empty,+                   stamp = Set.empty,+                   callbacks =+                     callbacks result1 +++                     [PostFinalFailure Counterexample $ \st _res -> putLine (terminal st) ""] +++                     callbacks result2 }+               Nothing -> result2          Nothing -> do            result2 <- q            return (case ok result2 of@@ -495,16 +525,9 @@                      _ -> result1)    expectFailureError = failed { reason = "expectFailure may not occur inside a disjunction" }-  result1 >>> result2 | not (expect result1 && expect result2) = expectFailureError-  result1 >>> result2 =-    result2-    { reason       = if null (reason result2) then reason result1 else reason result2-    , theException = if null (reason result2) then theException result1 else theException result2-    , stamp        = stamp result1 ++ stamp result2-    , callbacks    = callbacks result1 ++-                    [PostFinalFailure Counterexample $ \st _res -> putLine (terminal st) ""] ++-                    callbacks result2-    }+  sep [] s = s+  sep s [] = s+  sep s s' = s ++ ", " ++ s'  -- | Like '==', but prints a counterexample when it fails. infix 4 ===

@@ -3,6 +3,9 @@  import Test.QuickCheck.Text import Test.QuickCheck.Random+import qualified Data.Map as Map+import Data.Map(Map)+import Data.Set(Set)  -------------------------------------------------------------------------- -- State@@ -16,20 +19,21 @@   , maxSuccessTests           :: Int               -- ^ maximum number of successful tests needed   , 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+                                                   --   #tests and #discarded tests -                                                   -- dynamic-  , numSuccessTests           :: Int               -- ^ the current number of tests that have succeeded-  , numDiscardedTests         :: Int               -- ^ the current number of discarded tests-  , numRecentlyDiscardedTests :: Int               -- ^ the number of discarded tests since the last successful test-  , collected                 :: [[(String,Int)]]  -- ^ all labels that have been collected so far-  , expectedFailure           :: Bool              -- ^ indicates if the property is expected to fail-  , randomSeed                :: QCGen             -- ^ the current random seed+  -- dynamic+  , numSuccessTests           :: !Int              -- ^ the current number of tests that have succeeded+  , numDiscardedTests         :: !Int              -- ^ the current number of discarded tests+  , numRecentlyDiscardedTests :: !Int              -- ^ the number of discarded tests since the last successful test+  , labels                    :: !(Map String Int) -- ^ all labels that have been defined so far+  , collected                 :: ![Set String]     -- ^ all labels that have been collected so far+  , expectedFailure           :: !Bool             -- ^ indicates if the property is expected to fail+  , randomSeed                :: !QCGen            -- ^ the current random seed                                                     -- shrinking-  , numSuccessShrinks         :: Int               -- ^ number of successful shrinking steps so far-  , numTryShrinks             :: Int               -- ^ number of failed shrinking steps since the last successful shrink-  , numTotTryShrinks          :: Int               -- ^ total number of failed shrinking steps+  , numSuccessShrinks         :: !Int              -- ^ number of successful shrinking steps so far+  , numTryShrinks             :: !Int              -- ^ number of failed shrinking steps since the last successful shrink+  , numTotTryShrinks          :: !Int              -- ^ total number of failed shrinking steps   }  --------------------------------------------------------------------------

@@ -9,13 +9,16 @@ -- imports  import Test.QuickCheck.Gen-import Test.QuickCheck.Property hiding ( Result( reason, theException) )+import Test.QuickCheck.Property hiding ( Result( reason, theException, labels ) ) import qualified Test.QuickCheck.Property as P import Test.QuickCheck.Text-import Test.QuickCheck.State+import Test.QuickCheck.State hiding (labels)+import qualified Test.QuickCheck.State as S import Test.QuickCheck.Exception import Test.QuickCheck.Random import System.Random(split)+import qualified Data.Map as Map+import qualified Data.Set as Set  import Data.Char   ( isSpace@@ -76,6 +79,12 @@     , labels         :: [(String,Int)]    --   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+    , output         :: String            --   Printed output+    }  deriving ( Show )  -- | Check if the test run result was a success@@ -121,6 +130,7 @@                  , numSuccessTests           = 0                  , numDiscardedTests         = 0                  , numRecentlyDiscardedTests = 0+                 , S.labels                  = Map.empty                  , collected                 = []                  , expectedFailure           = False                  , randomSeed                = rnd@@ -173,31 +183,34 @@   | otherwise                                    = runATest st f  doneTesting :: State -> (QCGen -> Int -> Prop) -> IO Result-doneTesting st _f =-  do -- CALLBACK done_testing?-     if expectedFailure st then-       putPart (terminal st)-         ( "+++ OK, passed "-        ++ show (numSuccessTests st)-        ++ " tests"-         )-      else-       putPart (terminal st)-         ( bold ("*** Failed!")-        ++ " Passed "-        ++ show (numSuccessTests st)-        ++ " tests (expected failure)"-         )-     success st-     theOutput <- terminalOutput (terminal st)-     if expectedFailure st then-       return Success{ labels = summary st,-                       numTests = numSuccessTests st,-                       output = theOutput }-      else-       return NoExpectedFailure{ labels = summary st,-                                 numTests = numSuccessTests st,-                                 output = theOutput }+doneTesting st _f+  | not (expectedFailure st) = do+      putPart (terminal st)+        ( bold ("*** Failed!")+       ++ " Passed "+       ++ show (numSuccessTests st)+       ++ " tests (expected failure)"+        )+      finished NoExpectedFailure+  | insufficientCoverage st = do+      putPart (terminal st)+        ( bold ("*** Insufficient coverage after ")+       ++ show (numSuccessTests st)+       ++ " tests"+        )+      finished InsufficientCoverage+  | otherwise = do+      putPart (terminal st)+        ( "+++ OK, passed "+       ++ show (numSuccessTests st)+       ++ " tests"+        )+      finished Success+  where+    finished k = do+      success st+      theOutput <- terminalOutput (terminal st)+      return (k (numSuccessTests st) (summary st) theOutput)  giveUp :: State -> (QCGen -> Int -> Prop) -> IO Result giveUp st _f =@@ -228,10 +241,13 @@         )      let size = computeSize st (numSuccessTests st) (numRecentlyDiscardedTests st)      MkRose res ts <- protectRose (reduceRose (unProp (f rnd1 size)))-     callbackPostTest st res+     res <- callbackPostTest st res       let continue break st' | abort res = break st'                             | otherwise = test st'+         cons x xs+           | Set.null x = xs+           | otherwise = x:xs       case res of        MkResult{ok = Just True, stamp = stamp, expect = expect} -> -- successful test@@ -239,7 +255,8 @@               st{ numSuccessTests           = numSuccessTests st + 1                 , numRecentlyDiscardedTests = 0                 , randomSeed                = rnd2-                , collected                 = stamp : collected st+                , S.labels                  = Map.unionWith max (S.labels st) (P.labels res)+                , collected                 = stamp `cons` collected st                 , expectedFailure           = expect                 } f @@ -248,6 +265,7 @@               st{ numDiscardedTests         = numDiscardedTests st + 1                 , numRecentlyDiscardedTests = numRecentlyDiscardedTests st + 1                 , randomSeed                = rnd2+                , S.labels                  = Map.unionWith max (S.labels st) (P.labels res)                 , expectedFailure           = expect                 } f @@ -282,10 +300,9 @@            . map (\ss -> (head ss, (length ss * 100) `div` numSuccessTests st))            . group            . sort-           $ [ concat (intersperse ", " s')+           $ [ concat (intersperse ", " (Set.toList s))              | s <- collected st-             , let s' = [ t | (t,_) <- s ]-             , not (null s')+             , not (Set.null s)              ]  success :: State -> IO ()@@ -307,30 +324,28 @@             . sort             $ [ concat (intersperse ", " s')               | s <- collected st-              , let s' = [ t | (t,0) <- s ]+              , let s' = [ t | t <- Set.toList s, Map.lookup t (S.labels st) == Just 0 ]               , not (null s')               ] -  covers = [ ("only " ++ show occurP ++ "% " ++ fst (head lps) ++ "; not " ++ show reqP ++ "%")-           | lps <- groupBy first-                  . sort-                  $ [ lp-                    | lps <- collected st-                    , lp <- maxi lps-                    , snd lp > 0-                    ]-           , let occurP = (100 * length lps) `div` maxSuccessTests st-                 reqP   = maximum (map snd lps)-           , occurP < reqP+  covers = [ ("only " ++ show (labelPercentage l st) ++ "% " ++ l ++ ", not " ++ show reqP ++ "%")+           | (l, reqP) <- Map.toList (S.labels st)+           , labelPercentage l st < reqP            ] -  (x,_) `first` (y,_) = x == y+  showP p = (if p < 10 then " " else "") ++ show p ++ "% " -  maxi = map (\lps -> (fst (head lps), maximum (map snd lps)))-       . groupBy first-       . sort+labelPercentage :: String -> State -> Int+labelPercentage 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' ] -  showP p = (if p < 10 then " " else "") ++ show p ++ "% "+insufficientCoverage :: State -> Bool+insufficientCoverage st =+  or [ labelPercentage l st < reqP | (l, reqP) <- Map.toList (S.labels st) ]  -------------------------------------------------------------------------- -- main shrinking loop@@ -343,33 +358,38 @@ localMin st MkResult{P.theException = Just e} lastRes _   | isInterrupt e = localMinFound st lastRes localMin st res _ ts = do-  putTemp (terminal st)-    ( short 26 (oneLine (P.reason res))-   ++ " (after " ++ number (numSuccessTests st+1) "test"-   ++ concat [ " and "-            ++ show (numSuccessShrinks st)-            ++ concat [ "." ++ show (numTryShrinks st) | numTryShrinks st > 0 ]-            ++ " shrink"-            ++ (if numSuccessShrinks st == 1-                && numTryShrinks st == 0-                then "" else "s")-             | numSuccessShrinks st > 0 || numTryShrinks st > 0-             ]-   ++ ")..."-    )-  r <- tryEvaluate ts+  r <- tryEvaluateIO $+    putTemp (terminal st)+      ( short 26 (oneLine (P.reason res))+     ++ " (after " ++ number (numSuccessTests st+1) "test"+     ++ concat [ " and "+              ++ show (numSuccessShrinks st)+              ++ concat [ "." ++ show (numTryShrinks st) | numTryShrinks st > 0 ]+              ++ " shrink"+              ++ (if numSuccessShrinks st == 1+                  && numTryShrinks st == 0+                  then "" else "s")+               | numSuccessShrinks st > 0 || numTryShrinks st > 0+               ]+     ++ ")..."+      )   case r of     Left err ->-      localMinFound st-         (exception "Exception while generating shrink-list" err) { callbacks = callbacks res }-    Right ts' -> localMin' st res ts'+      localMinFound st (exception "Exception while printing status message" err) { callbacks = callbacks res }+    Right () -> do+      r <- tryEvaluate ts+      case r of+        Left err ->+          localMinFound st+            (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' st res [] = localMinFound st res localMin' st res (t:ts) =   do -- CALLBACK before_test     MkRose res' ts' <- protectRose (reduceRose t)-    callbackPostTest st res'+    res' <- callbackPostTest st res'     if ok res' == Just False       then localMin st{ numSuccessShrinks = numSuccessShrinks st + 1,                         numTryShrinks     = 0 } res' res ts'@@ -394,28 +414,27 @@            | msg <- lines (P.reason res)            ]      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)  -------------------------------------------------------------------------- -- callbacks -callbackPostTest :: State -> P.Result -> IO ()-callbackPostTest st res =-  sequence_ [ safely st (f st res) | PostTest _ f <- callbacks res ]+callbackPostTest :: State -> P.Result -> IO P.Result+callbackPostTest st res = protect (exception "Exception running callback") $ do+  sequence_ [ f st res | PostTest _ f <- callbacks res ]+  return res  callbackPostFinalFailure :: State -> P.Result -> IO ()-callbackPostFinalFailure st res =-  sequence_ [ safely st (f st res) | PostFinalFailure _ f <- callbacks res ]--safely :: State -> IO () -> IO ()-safely st x = do-  r <- tryEvaluateIO x-  case r of-    Left e ->-      putLine (terminal st)-        ("*** Exception in callback: " ++ show e)-    Right x ->-      return x+callbackPostFinalFailure st res = do+  x <- tryEvaluateIO $ sequence_ [ f st res | PostFinalFailure _ f <- callbacks res ]+  case x of+    Left err -> do+      putLine (terminal st) "*** Exception running callback: "+      tryEvaluateIO $ putLine (terminal st) (show err)+      return ()+    Right () -> return ()  -------------------------------------------------------------------------- -- the end.

@@ -85,15 +85,13 @@ -- putting strings  data Terminal-  = MkTerminal (IORef (IO ())) Output Output--data Output-  = Output (String -> IO ()) (IORef String)+  = MkTerminal (IORef String) (IORef Int) (String -> IO ()) (String -> IO ()) -newTerminal :: Output -> Output -> IO Terminal+newTerminal :: (String -> IO ()) -> (String -> IO ()) -> IO Terminal newTerminal out err =-  do ref <- newIORef (return ())-     return (MkTerminal ref out err)+  do res <- newIORef ""+     tmp <- newIORef 0+     return (MkTerminal res tmp out err)  withBuffering :: IO a -> IO a withBuffering action = do@@ -104,65 +102,39 @@   action `finally` hSetBuffering stderr mode  withStdioTerminal :: (Terminal -> IO a) -> IO a-withStdioTerminal action = do-  out <- output (handle stdout)-  err <- output (handle stderr)-  withBuffering (newTerminal out err >>= action)+withStdioTerminal action =+  withBuffering (newTerminal (handle stdout) (handle stderr) >>= action)  withNullTerminal :: (Terminal -> IO a) -> IO a-withNullTerminal action = do-  out <- output (const (return ()))-  err <- output (const (return ()))-  newTerminal out err >>= action+withNullTerminal action =+  newTerminal (const (return ())) (const (return ())) >>= action  terminalOutput :: Terminal -> IO String-terminalOutput (MkTerminal _ out _) = get out+terminalOutput (MkTerminal res _ _ _) = readIORef res  handle :: Handle -> String -> IO () handle h s = do   hPutStr h s   hFlush h -output :: (String -> IO ()) -> IO Output-output f = do-  r <- newIORef ""-  return (Output f r)--put :: Output -> String -> IO ()-put (Output f r) s = do-  f s-  modifyIORef r (++ s)--get :: Output -> IO String-get (Output _ r) = readIORef r- flush :: Terminal -> IO ()-flush (MkTerminal ref _ _) =-  do io <- readIORef ref-     writeIORef ref (return ())-     io--postpone :: Terminal -> IO () -> IO ()-postpone (MkTerminal ref _ _) io' =-  do io <- readIORef ref-     writeIORef ref (io >> io')+flush (MkTerminal _ tmp _ err) =+  do n <- readIORef tmp+     writeIORef tmp 0+     err (replicate n ' ' ++ replicate n '\b')  putPart, putTemp, putLine :: Terminal -> String -> IO ()-putPart tm@(MkTerminal _ out _) s =+putPart tm@(MkTerminal res _ out _) s =   do flush tm-     put out s+     out s+     modifyIORef res (++ s) -putTemp tm@(MkTerminal _ _ err) s =-  do flush tm-     put err (s ++ [ '\b' | _ <- s ])-     postpone tm $-       put err ( [ ' ' | _ <- s ]-              ++ [ '\b' | _ <- s ]-               )+putLine tm s = putPart tm (s ++ "\n") -putLine tm@(MkTerminal _ out _) s =+putTemp tm@(MkTerminal _ tmp _ err) s =   do flush tm-     put out (s ++ "\n")+     err (s ++ [ '\b' | _ <- s ])+     modifyIORef tmp (+ length s)  -------------------------------------------------------------------------- -- the end.

@@ -1,3 +1,24 @@+QuickCheck 2.8 (released 2015-03-18)+	* New features:+		* Support for GHC 7.10+		* Arbitrary instance for Natural+		* New generators shuffle and sublistOf+		* Support for generic coarbitrary+		* When using the cover combinator, insufficient coverage now+		  causes the property to fail++	* API changes:+		* Test.QuickCheck.Function: new pattern synonym Fn+		* genericShrink no longer requires Typeable+		* Result has a new constructor InsufficientCoverage+		* resize throws an error if the size is negative++	* Bug fixes:+		* Fix memory leaks+		* Exceptions thrown by callbacks now cause the test to fail+		* Fixed a bug where the cover combinator wouldn't give a+		  warning if coverage was 0%+ QuickCheck 2.7.3 (released 2014-03-24) 	* Add annotations for Safe Haskell. 

@@ -25,7 +25,7 @@   = Node a (Heap a) (Heap a)   | Empty  deriving ( Eq, Ord, Show )-  + empty :: Heap a empty = Empty @@ -53,13 +53,13 @@ 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) +  merging hs  = merging (sweep hs)    sweep []         = []   sweep [h]        = [h]@@ -124,7 +124,7 @@   h ==? xs && xs == sort xs  where   xs = toSortedList h-  + -------------------------------------------------------------------------- -- generators @@ -141,7 +141,7 @@                     where arbHeap2 = arbHeap (Just y) (n `div` 2))         | n > 0         ]-        + -------------------------------------------------------------------------- -- main