diff --git a/QuickCheck.cabal b/QuickCheck.cabal --- a/QuickCheck.cabal +++ b/QuickCheck.cabal @@ -1,5 +1,5 @@ Name: QuickCheck -Version: 2.10.0.1 +Version: 2.10.1 Cabal-Version: >= 1.8 Build-type: Simple License: BSD3 @@ -49,7 +49,7 @@ source-repository this type: git location: https://github.com/nick8325/quickcheck - tag: 2.10.0.1 + tag: 2.10.1 flag templateHaskell Description: Build Test.QuickCheck.All, which uses Template Haskell. @@ -88,8 +88,8 @@ else cpp-options: -DNO_TEMPLATE_HASKELL - if !impl(ghc >= 7.4) - cpp-options: -DNO_CTYPES + if !impl(ghc >= 7.2) + cpp-options: -DNO_FOREIGN_C_USECONDS -- The new generics appeared in GHC 7.2... if impl(ghc < 7.2) diff --git a/Test/QuickCheck/Arbitrary.hs b/Test/QuickCheck/Arbitrary.hs --- a/Test/QuickCheck/Arbitrary.hs +++ b/Test/QuickCheck/Arbitrary.hs @@ -16,8 +16,11 @@ {-# LANGUAGE PolyKinds #-} #endif #ifndef NO_SAFE_HASKELL -{-# LANGUAGE Safe #-} +{-# LANGUAGE Trustworthy #-} #endif +#ifndef NO_NEWTYPE_DERIVING +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +#endif module Test.QuickCheck.Arbitrary ( -- * Arbitrary and CoArbitrary classes @@ -136,9 +139,7 @@ import Data.Int(Int8, Int16, Int32, Int64) import Data.Word(Word, Word8, Word16, Word32, Word64) import System.Exit (ExitCode(..)) -#ifndef NO_CTYPES import Foreign.C.Types -#endif #ifndef NO_GENERICS import GHC.Generics @@ -674,107 +675,138 @@ arbitrary = arbitrarySizedFractional shrink = shrinkRealFrac -#ifndef NO_CTYPES instance Arbitrary CChar where - arbitrary = CChar <$> arbitrary - shrink (CChar x) = CChar <$> shrink x + arbitrary = arbitrarySizedBoundedIntegral + shrink = shrinkIntegral instance Arbitrary CSChar where - arbitrary = CSChar <$> arbitrary - shrink (CSChar x) = CSChar <$> shrink x + arbitrary = arbitrarySizedBoundedIntegral + shrink = shrinkIntegral instance Arbitrary CUChar where - arbitrary = CUChar <$> arbitrary - shrink (CUChar x) = CUChar <$> shrink x + arbitrary = arbitrarySizedBoundedIntegral + shrink = shrinkIntegral instance Arbitrary CShort where - arbitrary = CShort <$> arbitrary - shrink (CShort x) = CShort <$> shrink x + arbitrary = arbitrarySizedBoundedIntegral + shrink = shrinkIntegral instance Arbitrary CUShort where - arbitrary = CUShort <$> arbitrary - shrink (CUShort x) = CUShort <$> shrink x + arbitrary = arbitrarySizedBoundedIntegral + shrink = shrinkIntegral instance Arbitrary CInt where - arbitrary = CInt <$> arbitrary - shrink (CInt x) = CInt <$> shrink x + arbitrary = arbitrarySizedBoundedIntegral + shrink = shrinkIntegral instance Arbitrary CUInt where - arbitrary = CUInt <$> arbitrary - shrink (CUInt x) = CUInt <$> shrink x + arbitrary = arbitrarySizedBoundedIntegral + shrink = shrinkIntegral instance Arbitrary CLong where - arbitrary = CLong <$> arbitrary - shrink (CLong x) = CLong <$> shrink x + arbitrary = arbitrarySizedBoundedIntegral + shrink = shrinkIntegral instance Arbitrary CULong where - arbitrary = CULong <$> arbitrary - shrink (CULong x) = CULong <$> shrink x + arbitrary = arbitrarySizedBoundedIntegral + shrink = shrinkIntegral instance Arbitrary CPtrdiff where - arbitrary = CPtrdiff <$> arbitrary - shrink (CPtrdiff x) = CPtrdiff <$> shrink x + arbitrary = arbitrarySizedBoundedIntegral + shrink = shrinkIntegral instance Arbitrary CSize where - arbitrary = CSize <$> arbitrary - shrink (CSize x) = CSize <$> shrink x + arbitrary = arbitrarySizedBoundedIntegral + shrink = shrinkIntegral instance Arbitrary CWchar where - arbitrary = CWchar <$> arbitrary - shrink (CWchar x) = CWchar <$> shrink x + arbitrary = arbitrarySizedBoundedIntegral + shrink = shrinkIntegral instance Arbitrary CSigAtomic where - arbitrary = CSigAtomic <$> arbitrary - shrink (CSigAtomic x) = CSigAtomic <$> shrink x + arbitrary = arbitrarySizedBoundedIntegral + shrink = shrinkIntegral instance Arbitrary CLLong where - arbitrary = CLLong <$> arbitrary - shrink (CLLong x) = CLLong <$> shrink x + arbitrary = arbitrarySizedBoundedIntegral + shrink = shrinkIntegral instance Arbitrary CULLong where - arbitrary = CULLong <$> arbitrary - shrink (CULLong x) = CULLong <$> shrink x + arbitrary = arbitrarySizedBoundedIntegral + shrink = shrinkIntegral instance Arbitrary CIntPtr where - arbitrary = CIntPtr <$> arbitrary - shrink (CIntPtr x) = CIntPtr <$> shrink x + arbitrary = arbitrarySizedBoundedIntegral + shrink = shrinkIntegral instance Arbitrary CUIntPtr where - arbitrary = CUIntPtr <$> arbitrary - shrink (CUIntPtr x) = CUIntPtr <$> shrink x + arbitrary = arbitrarySizedBoundedIntegral + shrink = shrinkIntegral instance Arbitrary CIntMax where - arbitrary = CIntMax <$> arbitrary - shrink (CIntMax x) = CIntMax <$> shrink x + arbitrary = arbitrarySizedBoundedIntegral + shrink = shrinkIntegral instance Arbitrary CUIntMax where - arbitrary = CUIntMax <$> arbitrary - shrink (CUIntMax x) = CUIntMax <$> shrink x + arbitrary = arbitrarySizedBoundedIntegral + shrink = shrinkIntegral +#ifndef NO_NEWTYPE_DERIVING +-- The following four types have no Bounded instance, +-- so we fake it by discovering the bounds at runtime. instance Arbitrary CClock where - arbitrary = CClock <$> arbitrary - shrink (CClock x) = CClock <$> shrink x + arbitrary = fmap unBounds arbitrary + shrink = shrinkMap unBounds Bounds instance Arbitrary CTime where - arbitrary = CTime <$> arbitrary - shrink (CTime x) = CTime <$> shrink x + arbitrary = fmap unBounds arbitrary + shrink = shrinkMap unBounds Bounds +#ifndef NO_FOREIGN_C_USECONDS instance Arbitrary CUSeconds where - arbitrary = CUSeconds <$> arbitrary - shrink (CUSeconds x) = CUSeconds <$> shrink x + arbitrary = fmap unBounds arbitrary + shrink = shrinkMap unBounds Bounds instance Arbitrary CSUSeconds where - arbitrary = CSUSeconds <$> arbitrary - shrink (CSUSeconds x) = CSUSeconds <$> shrink x + arbitrary = fmap unBounds arbitrary + shrink = shrinkMap unBounds Bounds +#endif +newtype Bounds a = Bounds { unBounds :: a } + deriving (Eq, Ord, Num, Enum, Real, Show) + +instance (Ord a, Num a) => Bounded (Bounds a) where + -- assume max has all 1s in binary expansion + maxBound = maximum (nubIterate (\x -> 2*x+1) 1) + -- assume min has a leading 1 and rest 0s in binary expansion (or is 0) + minBound = minimum (0:nubIterate (*2) 1) + +instance (Num a, Real a, Enum a) => Integral (Bounds a) where + toInteger = fromIntegral . fromEnum + x `quotRem` y = + let (z, w) = toInteger x `quotRem` toInteger y in + (fromInteger z, fromInteger w) + +instance (Ord a, Num a, Real a, Enum a) => Arbitrary (Bounds a) where + arbitrary = arbitrarySizedBoundedIntegral + shrink = shrinkIntegral + +-- Like iterate, but stop when you reach an existing value. +nubIterate :: Eq a => (a -> a) -> a -> [a] +nubIterate f x = iter [] x + where + iter xs x + | x `elem` xs = [] + | otherwise = x:iter (x:xs) (f x) +#endif + instance Arbitrary CFloat where - arbitrary = CFloat <$> arbitrary - shrink (CFloat x) = CFloat <$> shrink x + arbitrary = arbitrarySizedFractional + shrink = shrinkRealFrac instance Arbitrary CDouble where - arbitrary = CDouble <$> arbitrary - shrink (CDouble x) = CDouble <$> shrink x -#endif + arbitrary = arbitrarySizedFractional + shrink = shrinkRealFrac -- Arbitrary instances for container types instance (Ord a, Arbitrary a) => Arbitrary (Set.Set a) where diff --git a/Test/QuickCheck/State.hs b/Test/QuickCheck/State.hs --- a/Test/QuickCheck/State.hs +++ b/Test/QuickCheck/State.hs @@ -16,7 +16,7 @@ -- static { terminal :: Terminal -- ^ the current terminal , maxSuccessTests :: Int -- ^ maximum number of successful tests needed - , maxDiscardedTests :: Int -- ^ maximum number of tests that can be discarded + , maxDiscardedRatio :: Int -- ^ maximum number of discarded tests per successful test , computeSize :: Int -> Int -> Int -- ^ how to compute the size of test cases from -- #tests and #discarded tests , numTotMaxShrinks :: !Int -- ^ How many shrinks to try before giving up diff --git a/Test/QuickCheck/Test.hs b/Test/QuickCheck/Test.hs --- a/Test/QuickCheck/Test.hs +++ b/Test/QuickCheck/Test.hs @@ -154,7 +154,7 @@ Just (rnd,_) -> return rnd test MkState{ terminal = tm , maxSuccessTests = maxSuccess a - , maxDiscardedTests = maxDiscardRatio a * maxSuccess a + , maxDiscardedRatio = maxDiscardRatio a , computeSize = case replay a of Nothing -> computeSize' Just (_,s) -> computeSize' `at0` s @@ -207,9 +207,12 @@ test :: State -> (QCGen -> Int -> Prop) -> IO Result test st f - | numSuccessTests st >= maxSuccessTests st = doneTesting st f - | numDiscardedTests st >= maxDiscardedTests st = giveUp st f - | otherwise = runATest st f + | numSuccessTests st >= maxSuccessTests st = + doneTesting st f + | numDiscardedTests st >= maxDiscardedRatio st * maxSuccessTests st = + giveUp st f + | otherwise = + runATest st f doneTesting :: State -> (QCGen -> Int -> Prop) -> IO Result doneTesting st _f diff --git a/Test/QuickCheck/Text.hs b/Test/QuickCheck/Text.hs --- a/Test/QuickCheck/Text.hs +++ b/Test/QuickCheck/Text.hs @@ -85,11 +85,11 @@ -- putting strings data Terminal - = MkTerminal (IORef String) (IORef Int) (String -> IO ()) (String -> IO ()) + = MkTerminal (IORef ShowS) (IORef Int) (String -> IO ()) (String -> IO ()) newTerminal :: (String -> IO ()) -> (String -> IO ()) -> IO Terminal newTerminal out err = - do res <- newIORef "" + do res <- newIORef (showString "") tmp <- newIORef 0 return (MkTerminal res tmp out err) @@ -112,7 +112,7 @@ newTerminal (const (return ())) (const (return ())) >>= action terminalOutput :: Terminal -> IO String -terminalOutput (MkTerminal res _ _ _) = readIORef res +terminalOutput (MkTerminal res _ _ _) = fmap ($ "") (readIORef res) handle :: Handle -> String -> IO () handle h s = do @@ -130,7 +130,7 @@ do flush tm force s out s - modifyIORef res (++ s) + modifyIORef res (. showString s) where force :: [a] -> IO () force = evaluate . seqList diff --git a/changelog b/changelog --- a/changelog +++ b/changelog @@ -1,3 +1,10 @@ +QuickCheck 2.10.1 (release 2017-10-06) + * Arbitrary instances for Foreign.C.Types are available in more + GHC versions. + * Fixed a bug where withMaxSuccess didn't adjust the allowed + number of discarded tests. + * Remove quadratic behaviour in terminal output. + QuickCheck 2.10 (released 2017-06-15) * New combinators: - withMaxSuccess sets the maximum number of test cases for a property.