diff --git a/QuickCheck.cabal b/QuickCheck.cabal --- a/QuickCheck.cabal +++ b/QuickCheck.cabal @@ -1,5 +1,5 @@ Name: QuickCheck -Version: 2.13.2 +Version: 2.14 Cabal-Version: >= 1.8 Build-type: Simple License: BSD3 @@ -56,7 +56,7 @@ source-repository this type: git location: https://github.com/nick8325/quickcheck - tag: 2.13.2 + tag: 2.14 flag templateHaskell Description: Build Test.QuickCheck.All, which uses Template Haskell. @@ -120,7 +120,7 @@ -- Use splitmix on newer GHCs. if impl(ghc >= 7.0) - Build-depends: splitmix >= 0.0.2 + Build-depends: splitmix >= 0.0.4 else cpp-options: -DNO_SPLITMIX @@ -134,7 +134,7 @@ if !impl(ghc) -- If your Haskell compiler can cope without some of these, please -- send a message to the QuickCheck mailing list! - cpp-options: -DNO_TIMEOUT -DNO_NEWTYPE_DERIVING -DNO_GENERICS -DNO_TEMPLATE_HASKELL -DNO_SAFE_HASKELL -DNO_TYPEABLE -DNO_GADTS + cpp-options: -DNO_TIMEOUT -DNO_NEWTYPE_DERIVING -DNO_GENERICS -DNO_TEMPLATE_HASKELL -DNO_SAFE_HASKELL -DNO_TYPEABLE -DNO_GADTS -DNO_EXTRA_METHODS_IN_APPLICATIVE if !impl(hugs) && !impl(uhc) cpp-options: -DNO_ST_MONAD -DNO_MULTI_PARAM_TYPE_CLASSES diff --git a/Test/QuickCheck.hs b/Test/QuickCheck.hs --- a/Test/QuickCheck.hs +++ b/Test/QuickCheck.hs @@ -95,6 +95,11 @@ , Gen -- ** Generator combinators , choose + , chooseInt + , chooseInteger + , chooseBoundedIntegral + , chooseEnum + , chooseAny , oneof , frequency , elements diff --git a/Test/QuickCheck/Arbitrary.hs b/Test/QuickCheck/Arbitrary.hs --- a/Test/QuickCheck/Arbitrary.hs +++ b/Test/QuickCheck/Arbitrary.hs @@ -55,6 +55,8 @@ , arbitraryPrintableChar -- :: Gen Char -- ** Helper functions for implementing shrink #ifndef NO_GENERICS + , RecursivelyShrink + , GSubterms , 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] @@ -157,6 +159,7 @@ import qualified Data.IntSet as IntSet import qualified Data.IntMap as IntMap import qualified Data.Sequence as Sequence +import Data.Bits import qualified Data.Monoid as Monoid @@ -412,7 +415,7 @@ arbitrary = return () instance Arbitrary Bool where - arbitrary = choose (False,True) + arbitrary = chooseEnum (False,True) shrink True = [False] shrink False = [] @@ -485,7 +488,11 @@ arbitrary = arbitrarySizedFractional shrink = shrinkRealFrac +#if defined(MIN_VERSION_base) && MIN_VERSION_base(4,4,0) +instance Arbitrary a => Arbitrary (Complex a) where +#else instance (RealFloat a, Arbitrary a) => Arbitrary (Complex a) where +#endif arbitrary = liftM2 (:+) arbitrary arbitrary shrink (x :+ y) = [ x' :+ y | x' <- shrink x ] ++ [ x :+ y' | y' <- shrink y ] @@ -634,7 +641,7 @@ shrink = shrinkIntegral instance Arbitrary Word where - arbitrary = arbitrarySizedIntegral + arbitrary = arbitrarySizedNatural shrink = shrinkIntegral instance Arbitrary Word8 where @@ -926,7 +933,7 @@ -- | Generates 'Version' with non-empty non-negative @versionBranch@, and empty @versionTags@ instance Arbitrary Version where arbitrary = sized $ \n -> - do k <- choose (0, log2 n) + do k <- chooseInt (0, log2 n) xs <- vectorOf (k+1) arbitrarySizedNatural return (Version xs []) where @@ -975,17 +982,17 @@ arbitrarySizedIntegral :: Integral a => Gen a arbitrarySizedIntegral = sized $ \n -> - inBounds fromInteger (choose (-toInteger n, toInteger n)) + inBounds fromIntegral (chooseInt (-n, 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 fromIntegral (chooseInt (0, n)) -inBounds :: Integral a => (Integer -> a) -> Gen Integer -> Gen a -inBounds fi g = fmap fi (g `suchThat` (\x -> toInteger (fi x) == x)) +inBounds :: Integral a => (Int -> a) -> Gen Int -> Gen a +inBounds fi g = fmap fi (g `suchThat` (\x -> toInteger x == toInteger (fi x))) -- | Generates a fractional number. The number can be positive or negative -- and its maximum absolute value depends on the size parameter. @@ -993,14 +1000,15 @@ arbitrarySizedFractional = sized $ \n -> let n' = toInteger n in - do b <- choose (1, precision) - a <- choose ((-n') * b, n' * b) + do b <- chooseInteger (1, precision) + a <- chooseInteger ((-n') * b, n' * b) return (fromRational (a % b)) where precision = 9999999999999 :: Integer -- Useful for getting at minBound and maxBound without having to -- fiddle around with asTypeOf. +{-# INLINE withBounds #-} withBounds :: Bounded a => (a -> a -> Gen a) -> Gen a withBounds k = k minBound maxBound @@ -1008,10 +1016,7 @@ -- the entire range of the type. You may want to use -- 'arbitrarySizedBoundedIntegral' instead. arbitraryBoundedIntegral :: (Bounded a, Integral a) => Gen a -arbitraryBoundedIntegral = - withBounds $ \mn mx -> - do n <- choose (toInteger mn, toInteger mx) - return (fromInteger n) +arbitraryBoundedIntegral = chooseBoundedIntegral (minBound, maxBound) -- | Generates an element of a bounded type. The element is -- chosen from the entire range of the type. @@ -1020,44 +1025,52 @@ -- | Generates an element of a bounded enumeration. arbitraryBoundedEnum :: (Bounded a, Enum a) => Gen a -arbitraryBoundedEnum = - withBounds $ \mn mx -> - do n <- choose (fromEnum mn, fromEnum mx) - return (toEnum n) +arbitraryBoundedEnum = chooseEnum (minBound, maxBound) -- | Generates an integral number from a bounded domain. The number is -- chosen from the entire range of the type, but small numbers are -- generated more often than big numbers. Inspired by demands from -- Phil Wadler. arbitrarySizedBoundedIntegral :: (Bounded a, Integral a) => Gen a +-- INLINEABLE so that this combinator gets specialised at each type, +-- which means that the constant 'bits' in the let-block below will +-- only be computed once. +{-# INLINEABLE arbitrarySizedBoundedIntegral #-} arbitrarySizedBoundedIntegral = withBounds $ \mn mx -> - sized $ \s -> - do let bits n | n == 0 = 0 - | otherwise = 1 + bits (n `quot` 2) - k = (toInteger s*(bits mn `max` bits mx `max` 40) `div` 80) - -- computes x `min` (2^k), but avoids computing 2^k - -- if it is too large - x `minexp` k - | bits x < k = x - | otherwise = x `min` (2^k) - -- x `max` (-2^k) - x `maxexpneg` k = -((-x) `minexp` k) - n <- choose (toInteger mn `maxexpneg` k, toInteger mx `minexp` k) - return (fromInteger n) + let ilog2 1 = 0 + ilog2 n | n > 0 = 1 + ilog2 (n `div` 2) + -- How many bits are needed to represent this type? + -- (This number is an upper bound, not exact.) + bits = ilog2 (toInteger mx - toInteger mn + 1) in + sized $ \k -> + let + -- Reach maximum size by k=80, or quicker for small integer types + power = ((bits `max` 40) * k) `div` 80 + + -- Bounds should be 2^power, but: + -- * clamp the result to minBound/maxBound + -- * clamp power to 'bits', in case k is a huge number + lo = toInteger mn `max` (-1 `shiftL` (power `min` bits)) + hi = toInteger mx `min` (1 `shiftL` (power `min` bits)) in + fmap fromInteger (chooseInteger (lo, hi)) + -- ** Generators for various kinds of character -- | Generates any Unicode character (but not a surrogate) arbitraryUnicodeChar :: Gen Char arbitraryUnicodeChar = - arbitraryBoundedEnum `suchThat` (not . isSurrogate) + arbitraryBoundedEnum `suchThat` isValidUnicode where - isSurrogate c = generalCategory c == Surrogate + isValidUnicode c = case generalCategory c of + Surrogate -> False + NotAssigned -> False + _ -> True -- | Generates a random ASCII character (0-127). arbitraryASCIIChar :: Gen Char -arbitraryASCIIChar = choose ('\0', '\127') +arbitraryASCIIChar = chooseEnum ('\0', '\127') -- | Generates a printable Unicode character. arbitraryPrintableChar :: Gen Char @@ -1131,7 +1144,7 @@ shrinkDecimal :: RealFrac a => a -> [a] shrinkDecimal x | not (x == x) = 0 : take 10 (iterate (*2) 0) -- NaN - | not (2*x+1>x) = 0 : takeWhile (abs x) = 0 : takeWhile ( CoArbitrary (Complex a) where +#else instance (RealFloat a, CoArbitrary a) => CoArbitrary (Complex a) where +#endif coarbitrary (x :+ y) = coarbitrary x . coarbitrary y instance (CoArbitrary a, CoArbitrary b) diff --git a/Test/QuickCheck/Function.hs b/Test/QuickCheck/Function.hs --- a/Test/QuickCheck/Function.hs +++ b/Test/QuickCheck/Function.hs @@ -49,6 +49,9 @@ , functionRealFrac , functionBoundedEnum , functionVoid + , functionMapWith + , functionEitherWith + , functionPairWith #if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 708 , pattern Fn , pattern Fn2 @@ -188,6 +191,7 @@ functionMap :: Function b => (a->b) -> (b->a) -> (a->c) -> (a:->c) functionMap = functionMapWith function +-- | @since 2.13.3 functionMapWith :: ((b->c) -> (b:->c)) -> (a->b) -> (b->a) -> (a->c) -> (a:->c) functionMapWith function g h f = Map g h (function (\b -> f (h b))) @@ -203,12 +207,14 @@ instance (Function a, Function b) => Function (a,b) where function = functionPairWith function function +-- | @since 2.13.3 functionPairWith :: ((a->b->c) -> (a:->(b->c))) -> ((b->c) -> (b:->c)) -> ((a,b)->c) -> ((a,b):->c) functionPairWith func1 func2 f = Pair (func2 `fmap` func1 (curry f)) instance (Function a, Function b) => Function (Either a b) where function = functionEitherWith function function +-- | @since 2.13.3 functionEitherWith :: ((a->c) -> (a:->c)) -> ((b->c) -> (b:->c)) -> (Either a b->c) -> (Either a b:->c) functionEitherWith func1 func2 f = func1 (f . Left) :+: func2 (f . Right) diff --git a/Test/QuickCheck/Gen.hs b/Test/QuickCheck/Gen.hs --- a/Test/QuickCheck/Gen.hs +++ b/Test/QuickCheck/Gen.hs @@ -35,6 +35,13 @@ import Data.List import Data.Ord import Data.Maybe +#ifndef NO_SPLITMIX +import System.Random.SplitMix(bitmaskWithRejection64', SMGen) +#endif +import Data.Word +import Data.Int +import Data.Bits +import Control.Applicative -------------------------------------------------------------------------- -- ** Generator type @@ -56,12 +63,18 @@ MkGen (\r n -> f (h r n)) instance Applicative Gen where - pure = return - gf <*> gx = gf >>= \f -> fmap f gx + pure x = + MkGen (\_ _ -> x) + (<*>) = ap +#ifndef NO_EXTRA_METHODS_IN_APPLICATIVE + -- We don't need to split the seed for these. + _ *> m = m + m <* _ = m +#endif + instance Monad Gen where - return x = - MkGen (\_ _ -> x) + return = pure MkGen m >>= k = MkGen (\r n -> @@ -71,6 +84,8 @@ in m' r2 n ) + (>>) = (*>) + instance MonadFix Gen where mfix f = MkGen $ \r n -> @@ -126,6 +141,8 @@ scale f g = sized (\n -> resize (f n) g) -- | Generates a random element in the given inclusive range. +-- For integral and enumerated types, the specialised variants of +-- 'choose' below run much quicker. choose :: Random a => (a,a) -> Gen a choose rng = MkGen (\r _ -> let (x,_) = randomR rng r in x) @@ -133,6 +150,77 @@ chooseAny :: Random a => Gen a chooseAny = MkGen (\r _ -> let (x,_) = random r in x) +-- | A fast implementation of 'choose' for enumerated types. +chooseEnum :: Enum a => (a, a) -> Gen a +chooseEnum (lo, hi) = + fmap toEnum (chooseInt (fromEnum lo, fromEnum hi)) + +-- | A fast implementation of 'choose' for 'Int'. +chooseInt :: (Int, Int) -> Gen Int +chooseInt = chooseBoundedIntegral + +-- Note about INLINEABLE: we specialise chooseBoundedIntegral +-- for each concrete type, so that all the bounds checks get +-- simplified away. +{-# INLINEABLE chooseBoundedIntegral #-} +-- | A fast implementation of 'choose' for bounded integral types. +chooseBoundedIntegral :: (Bounded a, Integral a) => (a, a) -> Gen a +chooseBoundedIntegral (lo, hi) +#ifndef NO_SPLITMIX + | toInteger mn >= toInteger (minBound :: Int64) && + toInteger mx <= toInteger (maxBound :: Int64) = + fmap fromIntegral (chooseInt64 (fromIntegral lo, fromIntegral hi)) + | toInteger mn >= toInteger (minBound :: Word64) && + toInteger mx <= toInteger (maxBound :: Word64) = + fmap fromIntegral (chooseWord64 (fromIntegral lo, fromIntegral hi)) +#endif + | otherwise = + fmap fromInteger (chooseInteger (toInteger lo, toInteger hi)) +#ifndef NO_SPLITMIX + where + mn = minBound `asTypeOf` lo + mx = maxBound `asTypeOf` hi +#endif + +-- | A fast implementation of 'choose' for 'Integer'. +chooseInteger :: (Integer, Integer) -> Gen Integer +#ifdef NO_SPLITMIX +chooseInteger = choose +#else +chooseInteger (lo, hi) + | lo >= toInteger (minBound :: Int64) && lo <= toInteger (maxBound :: Int64) && + hi >= toInteger (minBound :: Int64) && hi <= toInteger (maxBound :: Int64) = + fmap toInteger (chooseInt64 (fromInteger lo, fromInteger hi)) + | lo >= toInteger (minBound :: Word64) && lo <= toInteger (maxBound :: Word64) && + hi >= toInteger (minBound :: Word64) && hi <= toInteger (maxBound :: Word64) = + fmap toInteger (chooseWord64 (fromInteger lo, fromInteger hi)) + | otherwise = choose (lo, hi) + +chooseWord64 :: (Word64, Word64) -> Gen Word64 +chooseWord64 (lo, hi) + | lo <= hi = chooseWord64' (lo, hi) + | otherwise = chooseWord64' (hi, lo) + where + chooseWord64' :: (Word64, Word64) -> Gen Word64 + chooseWord64' (lo, hi) = + fmap (+ lo) (chooseUpTo (hi - lo)) + +chooseInt64 :: (Int64, Int64) -> Gen Int64 +chooseInt64 (lo, hi) + | lo <= hi = chooseInt64' (lo, hi) + | otherwise = chooseInt64' (hi, lo) + where + chooseInt64' :: (Int64, Int64) -> Gen Int64 + chooseInt64' (lo, hi) = do + w <- chooseUpTo (fromIntegral hi - fromIntegral lo) + return (fromIntegral (w + fromIntegral lo)) + +chooseUpTo :: Word64 -> Gen Word64 +chooseUpTo n = + MkGen $ \(QCGen g) _ -> + fst (bitmaskWithRejection64' n g) +#endif + -- | Run a generator. The size passed to the generator is always 30; -- if you want another size then you should explicitly use 'resize'. generate :: Gen a -> IO a @@ -183,7 +271,7 @@ -- must be non-empty. oneof :: [Gen a] -> Gen a oneof [] = error "QuickCheck.oneof used with empty list" -oneof gs = choose (0,length gs - 1) >>= (gs !!) +oneof gs = chooseInt (0,length gs - 1) >>= (gs !!) -- | Chooses one of the given generators, with a weighted random distribution. -- The input list must be non-empty. @@ -194,7 +282,7 @@ error "QuickCheck.frequency: negative weight" | all (== 0) (map fst xs) = error "QuickCheck.frequency: all weights were zero" -frequency xs0 = choose (1, tot) >>= (`pick` xs0) +frequency xs0 = chooseInt (1, tot) >>= (`pick` xs0) where tot = sum (map fst xs0) @@ -206,16 +294,16 @@ -- | Generates one of the given values. The input list must be non-empty. elements :: [a] -> Gen a elements [] = error "QuickCheck.elements used with empty list" -elements xs = (xs !!) `fmap` choose (0, length xs - 1) +elements xs = (xs !!) `fmap` chooseInt (0, length xs - 1) -- | Generates a random subsequence of the given list. sublistOf :: [a] -> Gen [a] -sublistOf xs = filterM (\_ -> choose (False, True)) xs +sublistOf xs = filterM (\_ -> chooseEnum (False, True)) xs -- | Generates a random permutation of the given list. shuffle :: [a] -> Gen [a] shuffle xs = do - ns <- vectorOf (length xs) (choose (minBound :: Int, maxBound)) + ns <- vectorOf (length xs) (chooseInt (minBound :: Int, maxBound)) return (map snd (sortBy (comparing fst) (zip ns xs))) -- | Takes a list of elements of increasing size, and chooses @@ -242,14 +330,14 @@ -- size parameter. listOf :: Gen a -> Gen [a] listOf gen = sized $ \n -> - do k <- choose (0,n) + do k <- chooseInt (0,n) vectorOf k gen -- | Generates a non-empty list of random length. The maximum length -- depends on the size parameter. listOf1 :: Gen a -> Gen [a] listOf1 gen = sized $ \n -> - do k <- choose (1,1 `max` n) + do k <- chooseInt (1,1 `max` n) vectorOf k gen -- | Generates a list of the given length. diff --git a/Test/QuickCheck/Property.hs b/Test/QuickCheck/Property.hs --- a/Test/QuickCheck/Property.hs +++ b/Test/QuickCheck/Property.hs @@ -780,7 +780,7 @@ timeoutResult return (MkRose res' (map f roses)) - timeoutResult = failed { reason = "Timeout" } + timeoutResult = failed { reason = "Timeout of " ++ show n ++ " microseconds exceeded." } #ifdef NO_TIMEOUT timeout _ = fmap Just #endif diff --git a/changelog b/changelog --- a/changelog +++ b/changelog @@ -1,3 +1,46 @@ +QuickCheck 2.14 (release 2020-03-28) + * QuickCheck is now much faster at generating test data! + As a result, many properties can now be tested a lot faster; + the examples distributed with QuickCheck run about twice as + fast as before, for example. Of course, your mileage may vary. + + The reason for this is that there are now specialised versions + of the 'choose' combinator for various types. These are: + chooseInt, chooseInteger, chooseBoundedIntegral, and chooseEnum. + These combinators are identical to 'choose' but much faster. + All QuickCheck combinators, with the exception of 'choose' + itself, use the new combinators behind the scenes. + + You should see a speedup without doing anything, but to get a + further speedup, consider replacing any uses of 'choose' in your + own generators with the new combinators. + + We are hoping that future releases of the 'random' library may + speed up 'choose', in which case these combinators may no longer + be needed. + + Thanks to Oleg Grenrus for suggesting to bypass 'choose' for + random number generation, and providing the appropriate + primitive in his 'splitmix' random number library. + + * Smaller changes and bugfixes: + - RecursivelyShrink and GSubterms are exported from + Test.QuickCheck.Test (thanks to Tom Mortiboy). + - Don't generate invalid unicode characters + (thanks to Boris Stepanov). + - When a call to 'within' fails, include the duration of the + timeout in the failure report (thanks to William Rusnack). + - In Gen, avoid splitting the seed in the implementation of + >>, *> and <- (thanks to David Feuer). + - Fix a couple of bugs with shrinking of floating-point + numbers. + - Export functionMapWith, functionEitherWith and + functionPairWith from Test.QuickCheck.Function + (thanks to Oleg Grenrus). + - Remove redundant RealFloat constraint from + Arbitrary/CoArbitrary instances for Complex + (thanks to Bodigrim). + QuickCheck 2.13.2 (released 2019-06-30) * Compatibility with GHC 8.8 (thanks to Bodigrim) * Improve error message when 'frequency' is used with only zero weights diff --git a/make-hugs b/make-hugs --- a/make-hugs +++ b/make-hugs @@ -9,7 +9,7 @@ -DNO_CTYPES_CONSTRUCTORS -DNO_FOREIGN_C_USECONDS -DNO_GENERICS \ -DNO_SAFE_HASKELL -DNO_POLYKINDS -DNO_MONADFAIL -DNO_TIMEOUT \ -DNO_NEWTYPE_DERIVING -DNO_TYPEABLE -DNO_GADTS -DNO_TRANSFORMERS \ - -DNO_DEEPSEQ \ + -DNO_DEEPSEQ -DNO_EXTRA_METHODS_IN_APPLICATIVE \ $i > quickcheck-hugs/$i done diff --git a/tests/Generators.hs b/tests/Generators.hs --- a/tests/Generators.hs +++ b/tests/Generators.hs @@ -182,6 +182,16 @@ prop_no_shrinking_loop_Version = noShrinkingLoop :: Path Version -> Bool prop_no_shrinking_loop_ExitCode = noShrinkingLoop :: Path ExitCode -> Bool +-- Check that shrinking a Double always produces a shrinking candidate. +prop_shrink_candidate_double :: Property +prop_shrink_candidate_double = + forAllShrink gen shrink $ \x -> + x > 0 ==> + not (null (shrink x)) + where + gen :: Gen Double + gen = oneof [arbitrary, fmap fromInteger arbitrary] + -- Bad shrink: infinite list -- -- remove unexpectedFailure in prop_B1, shrinking should not loop forever.