summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorNickSmallbone <>2019-03-25 23:07:00 (GMT)
committerhdiff <hdiff@hdiff.luite.com>2019-03-25 23:07:00 (GMT)
commit8d60e20c1b2ad194b1c5b68d37e7d38da90b5d6b (patch)
treef5c21e8a2ea5eaeced54d1a126ed768cf8e7b1c2
parent0e23c672ed55615abee79deb62b6ebe53110bde9 (diff)
version 2.132.13
-rw-r--r--LICENSE4
-rw-r--r--QuickCheck.cabal39
-rw-r--r--[-rwxr-xr-x]README3
-rwxr-xr-x[-rw-r--r--]Setup.lhs0
-rw-r--r--Test/QuickCheck.hs8
-rw-r--r--Test/QuickCheck/Exception.hs6
-rw-r--r--Test/QuickCheck/Features.hs2
-rw-r--r--Test/QuickCheck/Function.hs2
-rw-r--r--Test/QuickCheck/Gen.hs8
-rw-r--r--Test/QuickCheck/Modifiers.hs67
-rw-r--r--Test/QuickCheck/Property.hs39
-rw-r--r--Test/QuickCheck/Random.hs137
-rw-r--r--Test/QuickCheck/Test.hs105
-rw-r--r--Test/QuickCheck/Text.hs4
-rw-r--r--[-rwxr-xr-x]changelog20
-rw-r--r--[-rwxr-xr-x]examples/Heap.hs0
-rw-r--r--[-rwxr-xr-x]examples/Heap_Program.hs0
-rw-r--r--[-rwxr-xr-x]examples/Heap_ProgramAlgebraic.hs0
-rw-r--r--[-rwxr-xr-x]examples/Lambda.hs0
-rw-r--r--[-rwxr-xr-x]examples/Merge.hs0
-rw-r--r--[-rwxr-xr-x]examples/Set.hs0
-rw-r--r--[-rwxr-xr-x]examples/Simple.hs0
-rwxr-xr-xmake-hugs18
-rw-r--r--tests/Generators.hs42
-rw-r--r--tests/Split.hs28
25 files changed, 367 insertions, 165 deletions
diff --git a/LICENSE b/LICENSE
index 2e2d4b5..8b0fdbf 100644
--- a/LICENSE
+++ b/LICENSE
@@ -1,8 +1,8 @@
(The following is the 3-clause BSD license.)
-Copyright (c) 2000-2018, Koen Claessen
+Copyright (c) 2000-2019, Koen Claessen
Copyright (c) 2006-2008, Björn Bringert
-Copyright (c) 2009-2018, Nick Smallbone
+Copyright (c) 2009-2019, Nick Smallbone
Redistribution and use in source and binary forms, with or without
modification, are permitted provided that the following conditions are met:
diff --git a/QuickCheck.cabal b/QuickCheck.cabal
index 4ed7b40..288fd85 100644
--- a/QuickCheck.cabal
+++ b/QuickCheck.cabal
@@ -1,10 +1,10 @@
Name: QuickCheck
-Version: 2.12.6.1
+Version: 2.13
Cabal-Version: >= 1.8
Build-type: Simple
License: BSD3
License-file: LICENSE
-Copyright: 2000-2018 Koen Claessen, 2006-2008 Björn Bringert, 2009-2018 Nick Smallbone
+Copyright: 2000-2019 Koen Claessen, 2006-2008 Björn Bringert, 2009-2019 Nick Smallbone
Author: Koen Claessen <koen@chalmers.se>
Maintainer: Nick Smallbone <nick@smallbone.se>
Bug-reports: https://github.com/nick8325/quickcheck/issues
@@ -33,7 +33,7 @@ Description:
* <https://begriffs.com/posts/2017-01-14-design-use-quickcheck.html>,
a detailed tutorial written by a user of QuickCheck.
.
- The <http://hackage.haskell.org/package/quickcheck-instances quickcheck-instances>
+ The <https://hackage.haskell.org/package/quickcheck-instances quickcheck-instances>
companion package provides instances for types in Haskell Platform packages
at the cost of additional dependencies.
@@ -47,6 +47,7 @@ extra-source-files:
examples/Merge.hs
examples/Set.hs
examples/Simple.hs
+ make-hugs
source-repository head
type: git
@@ -55,14 +56,14 @@ source-repository head
source-repository this
type: git
location: https://github.com/nick8325/quickcheck
- tag: 2.12.6.1
+ tag: 2.13
flag templateHaskell
Description: Build Test.QuickCheck.All, which uses Template Haskell.
Default: True
library
- Build-depends: base >=4.3 && <5, random, containers, erf >= 2
+ Build-depends: base >=4.3 && <5, random, containers
-- Modules that are always built.
Exposed-Modules:
@@ -84,7 +85,7 @@ library
-- GHC-specific modules.
if impl(ghc)
Exposed-Modules: Test.QuickCheck.Function
- Build-depends: transformers >= 0.3, deepseq
+ Build-depends: transformers >= 0.3, deepseq >= 1.1.0.0
else
cpp-options: -DNO_TRANSFORMERS -DNO_DEEPSEQ
@@ -109,11 +110,11 @@ library
if impl (ghc < 7.4)
cpp-options: -DNO_SAFE_HASKELL
- -- Use tf-random on newer GHCs.
- if impl(ghc)
- Build-depends: tf-random >= 0.4
+ -- Use splitmix on newer GHCs.
+ if impl(ghc >= 7.0)
+ Build-depends: splitmix >= 0.0.2
else
- cpp-options: -DNO_TF_RANDOM
+ cpp-options: -DNO_SPLITMIX
if !impl(ghc >= 7.6)
cpp-options: -DNO_POLYKINDS
@@ -125,7 +126,7 @@ library
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
+ cpp-options: -DNO_TIMEOUT -DNO_NEWTYPE_DERIVING -DNO_GENERICS -DNO_TEMPLATE_HASKELL -DNO_SAFE_HASKELL -DNO_TYPEABLE -DNO_GADTS
if !impl(hugs) && !impl(uhc)
cpp-options: -DNO_ST_MONAD -DNO_MULTI_PARAM_TYPE_CLASSES
@@ -154,7 +155,7 @@ Test-Suite test-quickcheck-gcoarbitrary
hs-source-dirs: tests
main-is: GCoArbitraryExample.hs
build-depends: base, QuickCheck
- if !impl(ghc >= 7.2)
+ if !flag(templateHaskell) || !impl(ghc >= 7.2)
buildable: False
if impl(ghc >= 7.2) && impl(ghc < 7.6)
build-depends: ghc-prim
@@ -172,7 +173,7 @@ Test-Suite test-quickcheck-gshrink
hs-source-dirs: tests
main-is: GShrinkExample.hs
build-depends: base, QuickCheck
- if !impl(ghc >= 7.2)
+ if !flag(templateHaskell) || !impl(ghc >= 7.2)
buildable: False
if impl(ghc >= 7.2) && impl(ghc < 7.6)
build-depends: ghc-prim
@@ -181,8 +182,8 @@ Test-Suite test-quickcheck-terminal
type: exitcode-stdio-1.0
hs-source-dirs: tests
main-is: Terminal.hs
- build-depends: base, process, deepseq, QuickCheck
- if !impl(ghc >= 7.10)
+ build-depends: base, process, deepseq >= 1.1.0.0, QuickCheck
+ if !flag(templateHaskell) || !impl(ghc >= 7.10)
buildable: False
Test-Suite test-quickcheck-monadfix
@@ -190,5 +191,11 @@ Test-Suite test-quickcheck-monadfix
hs-source-dirs: tests
main-is: MonadFix.hs
build-depends: base, QuickCheck
- if !impl(ghc >= 7.10)
+ if !flag(templateHaskell) || !impl(ghc >= 7.10)
buildable: False
+
+Test-Suite test-quickcheck-split
+ type: exitcode-stdio-1.0
+ hs-source-dirs: tests
+ main-is: Split.hs
+ build-depends: base, QuickCheck
diff --git a/README b/README
index 832eebc..df2766b 100755..100644
--- a/README
+++ b/README
@@ -8,3 +8,6 @@ The quickcheck-instances [1] companion package provides instances for types in
Haskell Platform packages at the cost of additional dependencies.
[1]: http://hackage.haskell.org/package/quickcheck-instances
+
+The make-hugs scripts makes a Hugs-compatible version of QuickCheck.
+It may also be useful for other non-GHC implementations.
diff --git a/Setup.lhs b/Setup.lhs
index e2c31e7..e2c31e7 100644..100755
--- a/Setup.lhs
+++ b/Setup.lhs
diff --git a/Test/QuickCheck.hs b/Test/QuickCheck.hs
index a44ce95..7c75f63 100644
--- a/Test/QuickCheck.hs
+++ b/Test/QuickCheck.hs
@@ -136,6 +136,7 @@ module Test.QuickCheck
, sample
, sample'
+#ifndef NO_GADTS
-- * The 'Function' typeclass: generation of random shrinkable, showable functions
-- | Example of use:
@@ -145,7 +146,7 @@ module Test.QuickCheck
-- >>> prop (Fun _ f) = f "monkey" == f "banana" || f "banana" == f "elephant"
-- >>> :}
-- >>> quickCheck prop
- -- *** Failed! Falsifiable (after 3 tests and 134 shrinks):
+ -- *** Failed! Falsified (after 3 tests and 134 shrinks):
-- {"elephant"->1, "monkey"->1, _->0}
--
-- To generate random values of type @'Fun' a b@,
@@ -170,6 +171,7 @@ module Test.QuickCheck
, functionIntegral
, functionRealFrac
, functionBoundedEnum
+#endif
-- * The 'CoArbitrary' typeclass: generation of functions the old-fashioned way
, CoArbitrary(..)
@@ -220,8 +222,10 @@ module Test.QuickCheck
, InfiniteList(..)
, SortedList(..)
, Positive(..)
+ , Negative(..)
, NonZero(..)
, NonNegative(..)
+ , NonPositive(..)
, Large(..)
, Small(..)
, Smart(..)
@@ -303,7 +307,9 @@ import Test.QuickCheck.Modifiers
import Test.QuickCheck.Property hiding ( Result(..) )
import Test.QuickCheck.Test
import Test.QuickCheck.Exception
+#ifndef NO_GADTS
import Test.QuickCheck.Function
+#endif
import Test.QuickCheck.Features
import Test.QuickCheck.State
#ifndef NO_TEMPLATE_HASKELL
diff --git a/Test/QuickCheck/Exception.hs b/Test/QuickCheck/Exception.hs
index b9cdaad..f8b34de 100644
--- a/Test/QuickCheck/Exception.hs
+++ b/Test/QuickCheck/Exception.hs
@@ -59,15 +59,17 @@ tryEvaluate x = tryEvaluateIO (return x)
tryEvaluateIO :: IO a -> IO (Either AnException a)
tryEvaluateIO m = E.tryJust notAsync (m >>= E.evaluate)
where
- notAsync :: E.SomeException -> Maybe AnException
+ notAsync :: AnException -> Maybe AnException
#if MIN_VERSION_base(4,7,0)
notAsync e = case E.fromException e of
Just (E.SomeAsyncException _) -> Nothing
Nothing -> Just e
-#else
+#elif !defined(OLD_EXCEPTIONS)
notAsync e = case E.fromException e :: Maybe E.AsyncException of
Just _ -> Nothing
Nothing -> Just e
+#else
+ notAsync e = Just e
#endif
--tryEvaluateIO m = Right `fmap` m
diff --git a/Test/QuickCheck/Features.hs b/Test/QuickCheck/Features.hs
index b81d5b5..b2bbf5c 100644
--- a/Test/QuickCheck/Features.hs
+++ b/Test/QuickCheck/Features.hs
@@ -92,7 +92,7 @@ labelledExamplesWithResult args prop =
Failure{reason = "New feature found"} -> do
putLine (terminal state) $
"*** Found example of " ++
- intercalate ", " (Set.toList (feats' Set.\\ feats))
+ concat (intersperse ", " (Set.toList (feats' Set.\\ feats)))
mapM_ (putLine (terminal state)) (failingTestCase res)
putStrLn ""
loop (Set.union feats feats')
diff --git a/Test/QuickCheck/Function.hs b/Test/QuickCheck/Function.hs
index 4b410b4..85e629b 100644
--- a/Test/QuickCheck/Function.hs
+++ b/Test/QuickCheck/Function.hs
@@ -27,7 +27,7 @@
-- >>> prop (Fun _ f) = f "monkey" == f "banana" || f "banana" == f "elephant"
-- >>> :}
-- >>> quickCheck prop
--- *** Failed! Falsifiable (after 3 tests and 134 shrinks):
+-- *** Failed! Falsified (after 3 tests and 134 shrinks):
-- {"elephant"->1, "monkey"->1, _->0}
--
-- To generate random values of type @'Fun' a b@,
diff --git a/Test/QuickCheck/Gen.hs b/Test/QuickCheck/Gen.hs
index d97dda1..33eea41 100644
--- a/Test/QuickCheck/Gen.hs
+++ b/Test/QuickCheck/Gen.hs
@@ -41,9 +41,11 @@ import Data.Maybe
-- | A generator for values of type @a@.
--
--- The third-party package
+-- The third-party packages
-- <http://hackage.haskell.org/package/QuickCheck-GenT QuickCheck-GenT>
--- provides a monad transformer version of @GenT@.
+-- and
+-- <http://hackage.haskell.org/package/quickcheck-transformer quickcheck-transformer>
+-- provide monad transformer versions of @Gen@.
newtype Gen a = MkGen{
unGen :: QCGen -> Int -> a -- ^ Run the generator on a particular seed.
-- If you just want to get a random value out, consider using 'generate'.
@@ -80,7 +82,7 @@ instance MonadFix Gen where
-- | Modifies a generator using an integer seed.
variant :: Integral n => n -> Gen a -> Gen a
-variant k (MkGen g) = MkGen (\r n -> g (variantQCGen k r) n)
+variant k (MkGen g) = MkGen (\r n -> g (integerVariant (toInteger k) $! r) n)
-- | Used to construct generators that depend on the size parameter.
--
diff --git a/Test/QuickCheck/Modifiers.hs b/Test/QuickCheck/Modifiers.hs
index ec08748..62f71c5 100644
--- a/Test/QuickCheck/Modifiers.hs
+++ b/Test/QuickCheck/Modifiers.hs
@@ -54,8 +54,10 @@ module Test.QuickCheck.Modifiers
, InfiniteList(..)
, SortedList(..)
, Positive(..)
+ , Negative(..)
, NonZero(..)
, NonNegative(..)
+ , NonPositive(..)
, Large(..)
, Small(..)
, Smart(..)
@@ -186,7 +188,7 @@ instance Arbitrary a => Arbitrary (NonEmptyList a) where
-- the remaining (infinite) part can contain anything:
--
-- >>> quickCheck prop_take_10
--- *** Failed! Falsifiable (after 1 test and 14 shrinks):
+-- *** Failed! Falsified (after 1 test and 14 shrinks):
-- "bbbbbbbbbb" ++ ...
data InfiniteList a =
InfiniteList {
@@ -262,15 +264,27 @@ instance Functor Positive where
fmap f (Positive x) = Positive (f x)
instance (Num a, Ord a, Arbitrary a) => Arbitrary (Positive a) where
- arbitrary =
- ((Positive . abs) `fmap` (arbitrary `suchThat` (/= 0))) `suchThat` gt0
- where gt0 (Positive x) = x > 0
+ arbitrary = fmap Positive (fmap abs arbitrary `suchThat` (> 0))
+ shrink (Positive x) = [ Positive x' | x' <- shrink x , x' > 0 ]
- shrink (Positive x) =
- [ Positive x'
- | x' <- shrink x
- , x' > 0
- ]
+--------------------------------------------------------------------------
+-- | @Negative x@: guarantees that @x \< 0@.
+newtype Negative a = Negative {getNegative :: a}
+ deriving ( Eq, Ord, Show, Read
+#ifndef NO_NEWTYPE_DERIVING
+ , Enum
+#endif
+#ifndef NO_TYPEABLE
+ , Typeable
+#endif
+ )
+
+instance Functor Negative where
+ fmap f (Negative x) = Negative (f x)
+
+instance (Num a, Ord a, Arbitrary a) => Arbitrary (Negative a) where
+ arbitrary = fmap Negative (arbitrary `suchThat` (< 0))
+ shrink (Negative x) = [ Negative x' | x' <- shrink x , x' < 0 ]
--------------------------------------------------------------------------
-- | @NonZero x@: guarantees that @x \/= 0@.
@@ -308,20 +322,27 @@ instance Functor NonNegative where
fmap f (NonNegative x) = NonNegative (f x)
instance (Num a, Ord a, Arbitrary a) => Arbitrary (NonNegative a) where
- arbitrary =
- (frequency
- -- why is this distrbution like this?
- [ (5, (NonNegative . abs) `fmap` arbitrary)
- , (1, return (NonNegative 0))
- ]
- ) `suchThat` ge0
- where ge0 (NonNegative x) = x >= 0
-
- shrink (NonNegative x) =
- [ NonNegative x'
- | x' <- shrink x
- , x' >= 0
- ]
+ arbitrary = fmap NonNegative (fmap abs arbitrary `suchThat` (>= 0))
+ shrink (NonNegative x) = [ NonNegative x' | x' <- shrink x , x' >= 0 ]
+
+--------------------------------------------------------------------------
+-- | @NonPositive x@: guarantees that @x \<= 0@.
+newtype NonPositive a = NonPositive {getNonPositive :: a}
+ deriving ( Eq, Ord, Show, Read
+#ifndef NO_NEWTYPE_DERIVING
+ , Enum
+#endif
+#ifndef NO_TYPEABLE
+ , Typeable
+#endif
+ )
+
+instance Functor NonPositive where
+ fmap f (NonPositive x) = NonPositive (f x)
+
+instance (Num a, Ord a, Arbitrary a) => Arbitrary (NonPositive a) where
+ arbitrary = fmap NonPositive (arbitrary `suchThat` (<= 0))
+ shrink (NonPositive x) = [ NonPositive x' | x' <- shrink x , x' <= 0 ]
--------------------------------------------------------------------------
-- | @Large x@: by default, QuickCheck generates 'Int's drawn from a small
diff --git a/Test/QuickCheck/Property.hs b/Test/QuickCheck/Property.hs
index f99d49a..caeb785 100644
--- a/Test/QuickCheck/Property.hs
+++ b/Test/QuickCheck/Property.hs
@@ -94,6 +94,15 @@ class Testable prop where
-- | Convert the thing to a property.
property :: prop -> Property
+ -- | Optional; used internally in order to improve shrinking.
+ -- @propertyForAll gen shr shw f@ is normally equivalent to
+ -- @'forAllShrinkShow' gen shr shw f@.
+ -- The 'Testable' instance for functions defines
+ -- @propertyForAll@ in a way that improves shrinking.
+ propertyForAllShrinkShow :: Show a => Gen a -> (a -> [a]) -> (a -> String) -> (a -> prop) -> Property
+ propertyForAllShrinkShow gen shr f =
+ forAllShrinkShow gen shr f
+
-- | If a property returns 'Discard', the current test case is discarded,
-- the same as if a precondition was false.
--
@@ -115,6 +124,13 @@ instance Testable () where
-- so that we turn exceptions into test failures
liftUnit () = succeeded
+instance Testable prop => Testable (Maybe prop) where
+ property = property . liftMaybe
+ where
+ -- See comment for liftUnit above
+ liftMaybe Nothing = property Discard
+ liftMaybe (Just prop) = property prop
+
instance Testable Bool where
property = property . liftBool
@@ -157,7 +173,16 @@ idempotentIOProperty =
promote . fmap (unProperty . property)
instance (Arbitrary a, Show a, Testable prop) => Testable (a -> prop) where
- property f = forAllShrink arbitrary shrink f
+ property f =
+ propertyForAllShrinkShow arbitrary shrink show f
+ propertyForAllShrinkShow gen shr shw f =
+ -- gen :: Gen b, shr :: b -> [b], f :: b -> a -> prop
+ -- Idea: Generate and shrink (b, a) as a pair
+ propertyForAllShrinkShow
+ (liftM2 (,) gen arbitrary)
+ (liftShrink2 shr shrink)
+ (\(x, y) -> shw x ++ "\n" ++ show y)
+ (uncurry f)
-- ** Exception handling
protect :: (AnException -> a) -> IO a -> IO a
@@ -305,7 +330,7 @@ succeeded, failed, rejected :: Result
liftBool :: Bool -> Result
liftBool True = succeeded
-liftBool False = failed { reason = "Falsifiable" }
+liftBool False = failed { reason = "Falsified" }
mapResult :: Testable prop => (Result -> Result) -> prop -> Property
mapResult f = mapRoseResult (protectResults . fmap f)
@@ -505,7 +530,9 @@ stdConfidence =
-- not what you want, use 'tabulate'.
label :: Testable prop => String -> prop -> Property
label s =
+#ifndef NO_DEEPSEQ
s `deepseq`
+#endif
mapTotalResult $
\res -> res { labels = s:labels res }
@@ -553,7 +580,9 @@ classify :: Testable prop =>
-> prop -> Property
classify False _ = property
classify True s =
+#ifndef NO_DEEPSEQ
s `deepseq`
+#endif
mapTotalResult $
\res -> res { classes = s:classes res }
@@ -654,7 +683,9 @@ cover p x s = mapTotalResult f . classify x s
-- 16% LogOut
tabulate :: Testable prop => String -> [String] -> prop -> Property
tabulate key values =
+#ifndef NO_DEEPSEQ
key `deepseq` values `deepseq`
+#endif
mapTotalResult $
\res -> res { tables = [(key, value) | value <- values] ++ tables res }
@@ -704,7 +735,9 @@ tabulate key values =
coverTable :: Testable prop =>
String -> [(String, Double)] -> prop -> Property
coverTable table xs =
- tables `deepseq` xs `deepseq`
+#ifndef NO_DEEPSEQ
+ table `deepseq` xs `deepseq`
+#endif
mapTotalResult $
\res -> res { requiredCoverage = ys ++ requiredCoverage res }
where
diff --git a/Test/QuickCheck/Random.hs b/Test/QuickCheck/Random.hs
index e81b26e..aac4a09 100644
--- a/Test/QuickCheck/Random.hs
+++ b/Test/QuickCheck/Random.hs
@@ -6,65 +6,23 @@
#endif
module Test.QuickCheck.Random where
-#ifndef NO_TF_RANDOM
import System.Random
-import System.Random.TF
-import System.Random.TF.Gen(splitn)
-import Data.Word
-import Data.Bits
-
-#define TheGen TFGen
-
-newTheGen :: IO TFGen
-newTheGen = newTFGen
-
-bits, mask, doneBit :: Integral a => a
-bits = 14
-mask = 0x3fff
-doneBit = 0x4000
-
-chip :: Bool -> Word32 -> TFGen -> TFGen
-chip done n g = splitn g (bits+1) (if done then m .|. doneBit else m)
- where
- m = n .&. mask
-
-chop :: Integer -> Integer
-chop n = n `shiftR` bits
-
-stop :: Integral a => a -> Bool
-stop n = n <= mask
-
-mkTheGen :: Int -> TFGen
-mkTheGen = mkTFGen
-
-#else
-import System.Random
-
-#define TheGen StdGen
-
-newTheGen :: IO StdGen
-newTheGen = newStdGen
-
-mkTheGen :: Int -> StdGen
-mkTheGen = mkStdGen
-
-chip :: Bool -> Int -> StdGen -> StdGen
-chip finished n = boolVariant finished . boolVariant (even n)
-
-chop :: Integer -> Integer
-chop n = n `div` 2
-
-stop :: Integral a => a -> Bool
-stop n = n <= 1
+#ifndef NO_SPLITMIX
+import System.Random.SplitMix
#endif
+import Data.Bits
-- | The "standard" QuickCheck random number generator.
--- A wrapper around either 'TFGen' on GHC, or 'StdGen'
+-- A wrapper around either 'SMGen' on GHC, or 'StdGen'
-- on other Haskell systems.
-newtype QCGen = QCGen TheGen
+#ifdef NO_SPLITMIX
+newtype QCGen = QCGen StdGen
+#else
+newtype QCGen = QCGen SMGen
+#endif
instance Show QCGen where
- showsPrec n (QCGen g) s = showsPrec n g "" ++ s
+ showsPrec n (QCGen g) s = showsPrec n g s
instance Read QCGen where
readsPrec n xs = [(QCGen g, ys) | (g, ys) <- readsPrec n xs]
@@ -78,32 +36,55 @@ instance RandomGen QCGen where
(x, g') -> (x, QCGen g')
newQCGen :: IO QCGen
-newQCGen = fmap QCGen newTheGen
+#ifdef NO_SPLITMIX
+newQCGen = fmap QCGen newStdGen
+#else
+newQCGen = fmap QCGen newSMGen
+#endif
mkQCGen :: Int -> QCGen
-mkQCGen n = QCGen (mkTheGen n)
-
-bigNatVariant :: Integer -> TheGen -> TheGen
-bigNatVariant n g
- | g `seq` stop n = chip True (fromInteger n) g
- | otherwise = (bigNatVariant $! chop n) $! chip False (fromInteger n) g
-
-{-# INLINE natVariant #-}
-natVariant :: Integral a => a -> TheGen -> TheGen
-natVariant n g
- | g `seq` stop n = chip True (fromIntegral n) g
- | otherwise = bigNatVariant (toInteger n) g
-
-{-# INLINE variantTheGen #-}
-variantTheGen :: Integral a => a -> TheGen -> TheGen
-variantTheGen n g
- | n >= 1 = natVariant (n-1) (boolVariant False g)
- | n == 0 = natVariant (0 `asTypeOf` n) (boolVariant True g)
- | otherwise = bigNatVariant (negate (toInteger n)) (boolVariant True g)
-
-boolVariant :: Bool -> TheGen -> TheGen
-boolVariant False = fst . split
-boolVariant True = snd . split
+#ifdef NO_SPLITMIX
+mkQCGen n = QCGen (mkStdGen n)
+#else
+mkQCGen n = QCGen (mkSMGen (fromIntegral n))
+#endif
-variantQCGen :: Integral a => a -> QCGen -> QCGen
-variantQCGen n (QCGen g) = QCGen (variantTheGen n g)
+-- Parameterised in order to make this code testable.
+class Splittable a where
+ left, right :: a -> a
+
+instance Splittable QCGen where
+ left = fst . split
+ right = snd . split
+
+-- The logic behind 'variant'. Given a random number seed, and an integer, uses
+-- splitting to transform the seed according to the integer. We use a
+-- prefix-free code so that calls to integerVariant n g for different values of
+-- n are guaranteed to return independent seeds.
+{-# INLINE integerVariant #-}
+integerVariant :: Splittable a => Integer -> a -> a
+integerVariant n g
+ -- Use one bit to encode the sign, then use Elias gamma coding
+ -- (https://en.wikipedia.org/wiki/Elias_gamma_coding) to do the rest.
+ -- Actually, the first bit encodes whether n >= 1 or not;
+ -- this has the advantage that both 0 and 1 get short codes.
+ | n >= 1 = gamma n $! left g
+ | otherwise = gamma (1-n) $! right g
+ where
+ gamma n =
+ encode k . zeroes k
+ where
+ k = ilog2 n
+
+ encode (-1) g = g
+ encode k g
+ | testBit n k =
+ encode (k-1) $! right g
+ | otherwise =
+ encode (k-1) $! left g
+
+ zeroes 0 g = g
+ zeroes k g = zeroes (k-1) $! left g
+
+ ilog2 1 = 0
+ ilog2 n = 1 + ilog2 (n `div` 2)
diff --git a/Test/QuickCheck/Test.hs b/Test/QuickCheck/Test.hs
index 19d4fc9..8dd6417 100644
--- a/Test/QuickCheck/Test.hs
+++ b/Test/QuickCheck/Test.hs
@@ -1,6 +1,9 @@
{-# OPTIONS_HADDOCK hide #-}
-- | The main test loop.
{-# LANGUAGE CPP #-}
+#ifndef NO_TYPEABLE
+{-# LANGUAGE DeriveDataTypeable #-}
+#endif
#ifndef NO_SAFE_HASKELL
{-# LANGUAGE Trustworthy #-}
#endif
@@ -17,7 +20,6 @@ import Test.QuickCheck.State hiding (labels, classes, tables, requiredCoverage)
import qualified Test.QuickCheck.State as S
import Test.QuickCheck.Exception
import Test.QuickCheck.Random
-import Data.Number.Erf(invnormcdf)
import System.Random(split)
#if defined(MIN_VERSION_containers)
#if MIN_VERSION_containers(0,5,0)
@@ -41,16 +43,18 @@ import Data.List
, sortBy
, group
, intersperse
- , intercalate
)
import Data.Maybe(fromMaybe, isNothing, catMaybes)
import Data.Ord(comparing)
import Text.Printf(printf)
-import Data.Either(lefts, rights)
import Control.Monad
import Data.Bits
+#ifndef NO_TYPEABLE
+import Data.Typeable (Typeable)
+#endif
+
--------------------------------------------------------------------------
-- quickCheck
@@ -79,7 +83,11 @@ data Args
-- ^ Maximum number of shrinks to before giving up. Setting this to zero
-- turns shrinking off.
}
- deriving ( Show, Read )
+ deriving ( Show, Read
+#ifndef NO_TYPEABLE
+ , Typeable
+#endif
+ )
-- | Result represents the test result
data Result
@@ -167,6 +175,12 @@ stdArgs = Args
--
-- By default up to 100 tests are performed, which may not be enough
-- to find all bugs. To run more tests, use 'withMaxSuccess'.
+--
+-- If you want to get the counterexample as a Haskell value,
+-- rather than just printing it, try the
+-- <http://hackage.haskell.org/package/quickcheck-with-counterexamples quickcheck-with-counterexamples>
+-- package.
+
quickCheck :: Testable prop => prop -> IO ()
quickCheck p = quickCheckWith stdArgs p
@@ -390,16 +404,16 @@ failureSummaryAndReason st res = (summary, full)
where
summary =
header ++
- short 26 (oneLine reason ++ " ") ++
+ short 26 (oneLine theReason ++ " ") ++
count True ++ "..."
full =
(header ++
- (if isOneLine reason then reason ++ " " else "") ++
+ (if isOneLine theReason then theReason ++ " " else "") ++
count False ++ ":"):
- if isOneLine reason then [] else lines reason
+ if isOneLine theReason then [] else lines theReason
- reason = P.reason res
+ theReason = P.reason res
header =
if expect res then
@@ -433,10 +447,10 @@ success st = do
(":":short, long)
labelsAndTables :: State -> ([String], [String])
-labelsAndTables st = (labels, tables)
+labelsAndTables st = (theLabels, theTables)
where
- labels :: [String]
- labels =
+ theLabels :: [String]
+ theLabels =
paragraphs $
[ showTable (numSuccessTests st) Nothing m
| m <- S.classes st:Map.elems numberedLabels ]
@@ -448,8 +462,8 @@ labelsAndTables st = (labels, tables)
| (labels, n) <- Map.toList (S.labels st),
(i, l) <- zip [0..] labels ]
- tables :: [String]
- tables =
+ theTables :: [String]
+ theTables =
paragraphs $
[ showTable (sum (Map.elems m)) (Just table) m
| (table, m) <- Map.toList (S.tables st) ] ++
@@ -573,6 +587,67 @@ wilsonLow k n a = wilson k n (invnormcdf (a/2))
wilsonHigh :: Integer -> Integer -> Double -> Double
wilsonHigh k n a = wilson k n (invnormcdf (1-a/2))
+-- Algorithm taken from
+-- https://web.archive.org/web/20151110174102/http://home.online.no/~pjacklam/notes/invnorm/
+-- Accurate to about one part in 10^9.
+--
+-- The 'erf' package uses the same algorithm, but with an extra step
+-- to get a fully accurate result, which we skip because it requires
+-- the 'erfc' function.
+invnormcdf :: Double -> Double
+invnormcdf p
+ | p < 0 = 0/0
+ | p > 1 = 0/0
+ | p == 0 = -1/0
+ | p == 1 = 1/0
+ | p < p_low =
+ let
+ q = sqrt(-2*log(p))
+ in
+ (((((c1*q+c2)*q+c3)*q+c4)*q+c5)*q+c6) /
+ ((((d1*q+d2)*q+d3)*q+d4)*q+1)
+ | p <= p_high =
+ let
+ q = p - 0.5
+ r = q*q
+ in
+ (((((a1*r+a2)*r+a3)*r+a4)*r+a5)*r+a6)*q /
+ (((((b1*r+b2)*r+b3)*r+b4)*r+b5)*r+1)
+ | otherwise =
+ let
+ q = sqrt(-2*log(1-p))
+ in
+ -(((((c1*q+c2)*q+c3)*q+c4)*q+c5)*q+c6) /
+ ((((d1*q+d2)*q+d3)*q+d4)*q+1)
+ where
+ a1 = -3.969683028665376e+01
+ a2 = 2.209460984245205e+02
+ a3 = -2.759285104469687e+02
+ a4 = 1.383577518672690e+02
+ a5 = -3.066479806614716e+01
+ a6 = 2.506628277459239e+00
+
+ b1 = -5.447609879822406e+01
+ b2 = 1.615858368580409e+02
+ b3 = -1.556989798598866e+02
+ b4 = 6.680131188771972e+01
+ b5 = -1.328068155288572e+01
+
+ c1 = -7.784894002430293e-03
+ c2 = -3.223964580411365e-01
+ c3 = -2.400758277161838e+00
+ c4 = -2.549732539343734e+00
+ c5 = 4.374664141464968e+00
+ c6 = 2.938163982698783e+00
+
+ d1 = 7.784695709041462e-03
+ d2 = 3.224671290700398e-01
+ d3 = 2.445134137142996e+00
+ d4 = 3.754408661907416e+00
+
+ p_low = 0.02425
+ p_high = 1 - p_low
+
addCoverageCheck :: Confidence -> State -> Property -> Property
addCoverageCheck confidence st prop
| and [ sufficientlyCovered confidence tot n p
@@ -581,9 +656,9 @@ addCoverageCheck confidence st prop
once prop
| or [ insufficientlyCovered (Just (certainty confidence)) tot n p
| (_, _, tot, n, p) <- allCoverage st ] =
- let (labels, tables) = labelsAndTables st in
+ let (theLabels, theTables) = labelsAndTables st in
foldr counterexample (property failed{P.reason = "Insufficient coverage"})
- (paragraphs [labels, tables])
+ (paragraphs [theLabels, theTables])
| otherwise = prop
allCoverage :: State -> [(Maybe String, String, Int, Int, Double)]
diff --git a/Test/QuickCheck/Text.hs b/Test/QuickCheck/Text.hs
index 32c8a36..115cfa9 100644
--- a/Test/QuickCheck/Text.hs
+++ b/Test/QuickCheck/Text.hs
@@ -125,7 +125,7 @@ flattenRows rows = map row rows
cols = transpose rows
widths = map (maximum . map (length . text)) cols
- row cells = intercalate " " (zipWith cell widths cells)
+ row cells = concat (intersperse " " (zipWith cell widths cells))
cell n (LJust xs) = ljust n xs
cell n (RJust xs) = rjust n xs
cell n (Centred xs) = centre n xs
@@ -149,7 +149,7 @@ drawTable headers table =
border x y xs = [x, y] ++ centre width xs ++ [y, x]
paragraphs :: [[String]] -> [String]
-paragraphs = intercalate [""] . filter (not . null)
+paragraphs = concat . intersperse [""] . filter (not . null)
bold :: String -> String
-- not portable:
diff --git a/changelog b/changelog
index fe315cb..0f8cb15 100755..100644
--- a/changelog
+++ b/changelog
@@ -1,3 +1,23 @@
+QuickCheck 2.13 (released 2019-03-26)
+ * Properties with multiple arguments now shrink better.
+ Previously, the first argument was shrunk, then the second, and
+ so on. Now, the arguments are shrunk as a whole, so shrink steps
+ for different arguments can be interleaved.
+
+ * New features:
+ - New modifiers Negative and NonPositive
+ - A Testable instance for Maybe prop (where Nothing means 'discard
+ the test case')
+ * Dependencies on C code removed:
+ - Use splitmix instead of tf-random for random number generation
+ - Remove dependency on 'erf' package
+ * Small changes:
+ - Say 'Falsified' instead of 'Falsifiable' when a property fails
+ * Compatibility improvements:
+ - Explicitly derive instance Typeable Args
+ - Lower bound on deepseq
+ - A script for building Hugs packages
+
QuickCheck 2.12.6 (released 2018-10-02)
* Make arbitrarySizedBoundedIntegral handle huge sizes correctly.
* Add changelog for QuickCheck 2.12.5 :)
diff --git a/examples/Heap.hs b/examples/Heap.hs
index c3900a9..c3900a9 100755..100644
--- a/examples/Heap.hs
+++ b/examples/Heap.hs
diff --git a/examples/Heap_Program.hs b/examples/Heap_Program.hs
index d9db2de..d9db2de 100755..100644
--- a/examples/Heap_Program.hs
+++ b/examples/Heap_Program.hs
diff --git a/examples/Heap_ProgramAlgebraic.hs b/examples/Heap_ProgramAlgebraic.hs
index bfa9626..bfa9626 100755..100644
--- a/examples/Heap_ProgramAlgebraic.hs
+++ b/examples/Heap_ProgramAlgebraic.hs
diff --git a/examples/Lambda.hs b/examples/Lambda.hs
index 42aac86..42aac86 100755..100644
--- a/examples/Lambda.hs
+++ b/examples/Lambda.hs
diff --git a/examples/Merge.hs b/examples/Merge.hs
index 8b1d2dd..8b1d2dd 100755..100644
--- a/examples/Merge.hs
+++ b/examples/Merge.hs
diff --git a/examples/Set.hs b/examples/Set.hs
index 6e0a966..6e0a966 100755..100644
--- a/examples/Set.hs
+++ b/examples/Set.hs
diff --git a/examples/Simple.hs b/examples/Simple.hs
index b173df6..b173df6 100755..100644
--- a/examples/Simple.hs
+++ b/examples/Simple.hs
diff --git a/make-hugs b/make-hugs
new file mode 100755
index 0000000..67b9d07
--- /dev/null
+++ b/make-hugs
@@ -0,0 +1,18 @@
+#!/bin/bash
+cd $(dirname $0)
+for i in $(find Test -name '*.hs'); do
+ mkdir -p quickcheck-hugs/$(dirname $i)
+ # If you want to switch on and off other features, look in
+ # QuickCheck.cabal to see what's available, or submit a patch
+ # adding a new -DNO_... flag.
+ cpphs --noline -DNO_SPLITMIX -DNO_TEMPLATE_HASKELL \
+ -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 \
+ $i > quickcheck-hugs/$i
+done
+
+echo "A Hugs-compatible version of QuickCheck is now"
+echo "available in the quickcheck-hugs directory."
+echo "Load it with hugs -98."
diff --git a/tests/Generators.hs b/tests/Generators.hs
index 749968a..5174c9e 100644
--- a/tests/Generators.hs
+++ b/tests/Generators.hs
@@ -105,8 +105,8 @@ pathInt, somePathInt ::
Arbitrary (f (Extremal Word16)), Show (f (Extremal Word16)),
Arbitrary (f (Extremal Word32)), Show (f (Extremal Word32)),
Arbitrary (f (Extremal Word64)), Show (f (Extremal Word64))) =>
- (forall a. f a -> a) -> (forall a. Integral a => a -> Bool) -> Property
-pathInt f p =
+ Bool -> (forall a. f a -> a) -> (forall a. Integral a => a -> Bool) -> Property
+pathInt word f p =
conjoin
[counterexample "Int" (path ((p :: Int -> Bool) . getExtremal . f)),
counterexample "Integer" (path ((p :: Integer -> Bool) . f)),
@@ -114,22 +114,28 @@ pathInt f p =
counterexample "Int16" (path ((p :: Int16 -> Bool) . getExtremal . f)),
counterexample "Int32" (path ((p :: Int32 -> Bool) . getExtremal . f)),
counterexample "Int64" (path ((p :: Int64 -> Bool) . getExtremal . f)),
- counterexample "Word" (path ((p :: Word -> Bool) . getExtremal . f)),
- counterexample "Word8" (path ((p :: Word8 -> Bool) . getExtremal . f)),
- counterexample "Word16" (path ((p :: Word16 -> Bool) . getExtremal . f)),
- counterexample "Word32" (path ((p :: Word32 -> Bool) . getExtremal . f)),
- counterexample "Word64" (path ((p :: Word64 -> Bool) . getExtremal . f))]
-somePathInt f p = expectFailure (pathInt f (not . p))
-
-prop_positive = pathInt getPositive (> 0)
-prop_positive_bound = somePathInt getPositive (== 1)
-
-prop_nonzero = pathInt getNonZero (/= 0)
-prop_nonzero_bound_1 = somePathInt getNonZero (== 1)
-prop_nonzero_bound_2 = somePathInt getNonZero (== -1)
-
-prop_nonnegative = pathInt getNonNegative (>= 0)
-prop_nonnegative_bound = somePathInt getNonNegative (== 0)
+ counterexample "Word" (not word .||. path ((p :: Word -> Bool) . getExtremal . f)),
+ counterexample "Word8" (not word .||. path ((p :: Word8 -> Bool) . getExtremal . f)),
+ counterexample "Word16" (not word .||. path ((p :: Word16 -> Bool) . getExtremal . f)),
+ counterexample "Word32" (not word .||. path ((p :: Word32 -> Bool) . getExtremal . f)),
+ counterexample "Word64" (not word .||. path ((p :: Word64 -> Bool) . getExtremal . f))]
+somePathInt word f p = expectFailure (pathInt word f (not . p))
+
+prop_positive = pathInt True getPositive (> 0)
+prop_positive_bound = somePathInt True getPositive (== 1)
+
+prop_nonzero = pathInt True getNonZero (/= 0)
+prop_nonzero_bound_1 = somePathInt True getNonZero (== 1)
+prop_nonzero_bound_2 = somePathInt True getNonZero (== -1)
+
+prop_nonnegative = pathInt True getNonNegative (>= 0)
+prop_nonnegative_bound = somePathInt True getNonNegative (== 0)
+
+prop_negative = pathInt False getNegative (< 0)
+prop_negative_bound = somePathInt False getNegative (== -1)
+
+prop_nonpositive = pathInt True getNonPositive (<= 0)
+prop_nonpositive_bound = somePathInt True getNonPositive (== 0)
reachesBound :: (Bounded a, Integral a, Arbitrary a) =>
a -> Property
diff --git a/tests/Split.hs b/tests/Split.hs
new file mode 100644
index 0000000..d89b6a1
--- /dev/null
+++ b/tests/Split.hs
@@ -0,0 +1,28 @@
+import Test.QuickCheck
+import Test.QuickCheck.Random
+import Data.List
+
+-- This type allows us to run integerVariant and get a list of bits out.
+newtype Splits = Splits { unSplits :: [Bool] } deriving (Eq, Ord, Show)
+
+instance Splittable Splits where
+ left (Splits xs) = Splits (xs ++ [False])
+ right (Splits xs) = Splits (xs ++ [True])
+
+-- Check that integerVariant gives a prefix-free code,
+-- i.e., if m /= n then integerVariant m is not a prefix of integerVariant n.
+prop_split_prefix :: Property
+prop_split_prefix =
+ once $ forAllShrink (return [-10000..10000]) shrink $ \ns ->
+ map head (group (sort ns)) == sort ns ==> -- no duplicates
+ let
+ codes :: [Splits]
+ codes = sort [integerVariant n (Splits []) | n <- ns]
+
+ ok (Splits xs) (Splits ys) = not (xs `isPrefixOf` ys)
+ in
+ -- After sorting, any prefix will end up immediately before
+ -- one of its suffixes
+ and (zipWith ok codes (drop 1 codes))
+
+main = do Success{} <- quickCheckResult prop_split_prefix; return ()