diff --git a/QuickCheck.cabal b/QuickCheck.cabal --- a/QuickCheck.cabal +++ b/QuickCheck.cabal @@ -1,5 +1,5 @@ Name: QuickCheck -Version: 2.14.3 +Version: 2.15 Cabal-Version: >= 1.10 Build-type: Simple License: BSD3 @@ -8,7 +8,15 @@ Author: Koen Claessen Maintainer: Nick Smallbone Bug-reports: https://github.com/nick8325/quickcheck/issues -Tested-with: GHC ==7.0.4 || ==7.2.2 || >= 7.4 +Tested-with: GHC == 7.0.4 || + == 7.2.2 || + == 7.4.1 || + == 7.4.2 || + == 7.6.3 || + == 7.8.4 || + == 7.10.3 || + == 8.0.2 || + >= 8.2.2 && < 9.10 Homepage: https://github.com/nick8325/quickcheck Category: Testing Synopsis: Automatic testing of Haskell programs @@ -57,7 +65,7 @@ source-repository this type: git location: https://github.com/nick8325/quickcheck - tag: 2.14.3 + tag: 2.15 flag templateHaskell Description: Build Test.QuickCheck.All, which uses Template Haskell. @@ -88,7 +96,7 @@ if impl(hugs) cpp-options: -DNO_SPLITMIX else - Build-depends: splitmix >= 0.1 && <0.2 + Build-depends: splitmix >= 0.1.0.2 && <0.2 -- Modules that are always built. Exposed-Modules: @@ -124,6 +132,9 @@ else cpp-options: -DNO_TEMPLATE_HASKELL + if !impl(ghc >= 8.0) + cpp-options: -DNO_CALLSTACK + if !impl(ghc >= 7.4) cpp-options: -DNO_CTYPES_CONSTRUCTORS -DNO_FOREIGN_C_USECONDS @@ -151,13 +162,16 @@ if !impl(ghc >= 8.0) cpp-options: -DNO_MONADFAIL + if impl(ghc >= 9.8) + ghc-options: -Wno-x-partial + -- Switch off most optional features on non-GHC systems. 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 - -DNO_EXTRA_METHODS_IN_APPLICATIVE -DOLD_RANDOM + -DNO_EXTRA_METHODS_IN_APPLICATIVE -DOLD_RANDOM -DNO_CALLSTACK if !impl(hugs) && !impl(uhc) cpp-options: -DNO_ST_MONAD -DNO_MULTI_PARAM_TYPE_CLASSES @@ -237,12 +251,30 @@ hs-source-dirs: tests main-is: Split.hs build-depends: base, QuickCheck + if impl(ghc >= 9.8) + ghc-options: -Wno-x-partial +Test-Suite test-quickcheck-strictness + type: exitcode-stdio-1.0 + Default-language: Haskell2010 + hs-source-dirs: tests + main-is: Strictness.hs + build-depends: base, QuickCheck, containers + if !flag(templateHaskell) || !impl(ghc >= 7.10) + buildable: False + Test-Suite test-quickcheck-misc type: exitcode-stdio-1.0 Default-language: Haskell2010 hs-source-dirs: tests main-is: Misc.hs - build-depends: base, QuickCheck + build-depends: base, QuickCheck, containers if !flag(templateHaskell) || !impl(ghc >= 7.10) buildable: False + +Test-Suite test-quickcheck-discard + type: exitcode-stdio-1.0 + Default-language: Haskell2010 + hs-source-dirs: tests + main-is: DiscardRatio.hs + build-depends: base, QuickCheck diff --git a/changelog b/changelog --- a/changelog +++ b/changelog @@ -1,3 +1,33 @@ +QuickCheck 2.15 + * BREAKING: properties without quantification are no longer implicitly + wrapped in once + * Add witness property modifier and witnesses field in result on + compilers that support Typeable to allow conveniently exposing + counterexamples + * Add assertException, assertExceptionIO, assertDeepException, and + assertDeepExceptionIO (thanks to Alexey Kuleshevich) + * Add withMaxSize, withMaxShrinks, and withMaxDiscardRatio combinators + * Add recheck + * Add HasCallStack to partial top-level functions + * Updated some documentation + * Fix overflow bug when calculating discard ratio + * Fix error printing bug when shrinks are discarded + * Fix withMaxSuccess not working when checkCoverage is turned on + * Fix a bug whereby an unfortunately timed discard could unduly fail a + property running with checkCoverage + * Fix Arbitrary intance for Map breaking invariants from + Data.Map.Strict (thanks to Neil Mayhew) + * Fix non-covered classes not showing up in output as 0% covered + * Fix Negative's Arbitrary instance discarding an unnecessary number + of generated values. + * Fix promote doing an unnecessary seed split + * Fix a bug whereby maxSuccess and discardRatio would interact poorly + to produce too few size increases. + * Fix a couple of underflow bugs in generators for Small Natural and + Ratio Natural + * Fix a bug whereby the internal DISCARDED exception would show up + user-side in sample + QuickCheck 2.14.3 (released 2023-05-31) * Add shrinkBoundedEnum (thanks to Jonathan Knowles) * Add discardAfter for discarding tests on timeout (thanks to Justus Sagemüller) diff --git a/examples/Heap.hs b/examples/Heap.hs --- a/examples/Heap.hs +++ b/examples/Heap.hs @@ -148,20 +148,17 @@ -------------------------------------------------------------------------- -- the end. -{- - shrink Empty = [] - shrink (Node x h1 h2) = - [ h1, h2 ] - ++ [ Node x h1' h2 | h1' <- shrink h1, x <=? h1' ] - ++ [ Node x h1 h2' | h2' <- shrink h2, x <=? h2' ] - ++ [ Node x' h1 h2 | x' <- shrink x, x' <=? h1, x' <=? h2 ] --} +-- shrink Empty = [] +-- shrink (Node x h1 h2) = +-- [ h1, h2 ] +-- ++ [ Node x h1' h2 | h1' <- shrink h1, x <=? h1' ] +-- ++ [ Node x h1 h2' | h2' <- shrink h2, x <=? h2' ] +-- ++ [ Node x' h1 h2 | x' <- shrink x, x' <=? h1, x' <=? h2 ] + -- toSortedList (Node x h1 h2) = x : toSortedList (h1 `merge` h2) -{- -prop_HeapIsNotSorted (h :: Heap Int) = - expectFailure $ - toList h == toSortedList h --} +-- prop_HeapIsNotSorted (h :: Heap Int) = +-- expectFailure $ +-- toList h == toSortedList h diff --git a/examples/Set.hs b/examples/Set.hs --- a/examples/Set.hs +++ b/examples/Set.hs @@ -21,8 +21,6 @@ import Data.Maybe ---import Text.Show.Functions - -------------------------------------------------------------------------- -- binary search trees @@ -142,8 +140,6 @@ shrink t@(Node x s1 s2) = [ s1, s2 ] ++ [ t' | x' <- shrink x, let t' = Node x' s1 s2, invariant t' ] --- instance (Ord a, ShrinkSub a) => ShrinkSub (Set a) - -------------------------------------------------------------------------- -- properties @@ -196,8 +192,6 @@ s ==? xs && xs == sort xs where xs = toSortedList s - --- whenFail (putStrLn ("Result: " ++ show (fromList xs))) $ prop_FromList' (xs :: [Int]) = shrinking shrink xs $ \xs' -> diff --git a/make-hugs b/make-hugs --- a/make-hugs +++ b/make-hugs @@ -18,7 +18,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_EXTRA_METHODS_IN_APPLICATIVE \ + -DNO_DEEPSEQ -DNO_EXTRA_METHODS_IN_APPLICATIVE -DNO_CALLSTACK \ "$src" > "$tgt" done diff --git a/src/Test/QuickCheck.hs b/src/Test/QuickCheck.hs --- a/src/Test/QuickCheck.hs +++ b/src/Test/QuickCheck.hs @@ -28,6 +28,39 @@ instances for those types. See the for details about how to do that. + +When testing fails @quickCheck@ will try to give you a minimal counterexample to +your property: +@ +import Test.QuickCheck + +prop_reverse_bad :: [Int] -> Bool +prop_reverse_bad xs = reverse xs == xs + +>>> quickCheck prop_reverse_bad +*** Failed! Falsified (after 3 tests and 3 shrinks): +[0,1] +@ + +However, beware because not all properties that ought to fail will fail when you expect +them to: + +@ +>>> quickCheck $ \ x y -> x == y ++++ Ok, passed 100 tests. +@ + +That's because GHCi will default any type variables in your property to '()', so in the example +above @quickCheck@ was really testing that '()' is equal to itself. To avoid this behaviour it +is best practise to monomorphise your polymorphic properties when testing: + +@ +>>> quickCheck $ \ x y -> (x :: Int) == y +*** Failed! Falsified (after 4 tests and 3 shrinks): +0 +1 +@ + -} {-# LANGUAGE CPP #-} #ifndef NO_SAFE_HASKELL @@ -45,6 +78,7 @@ , quickCheckWith , quickCheckWithResult , quickCheckResult + , recheck , isSuccess -- ** Running tests verbosely , verboseCheck @@ -271,6 +305,9 @@ , withMaxSuccess , within , discardAfter + , withDiscardRatio + , withMaxSize + , withMaxShrinks , once , again , mapSize @@ -281,6 +318,12 @@ , (.||.) , disjoin -- ** What to do on failure +#ifndef NO_TYPEABLE + , Witness(..) + , witness + , coerceWitness + , castWitness +#endif , counterexample , printTestCase , whenFail diff --git a/src/Test/QuickCheck/Arbitrary.hs b/src/Test/QuickCheck/Arbitrary.hs --- a/src/Test/QuickCheck/Arbitrary.hs +++ b/src/Test/QuickCheck/Arbitrary.hs @@ -165,9 +165,14 @@ #endif import qualified Data.Set as Set -import qualified Data.Map as Map import qualified Data.IntSet as IntSet +#if MIN_VERSION_containers(0,5,0) +import qualified Data.Map.Strict as Map +import qualified Data.IntMap.Strict as IntMap +#else +import qualified Data.Map as Map import qualified Data.IntMap as IntMap +#endif import qualified Data.Sequence as Sequence import qualified Data.Tree as Tree import Data.Bits @@ -409,7 +414,7 @@ instance OVERLAPPING_ GSubtermsIncl (K1 i a) a where gSubtermsIncl (K1 x) = [x] -instance OVERLAPPING_ GSubtermsIncl (K1 i a) b where +instance GSubtermsIncl (K1 i a) b where gSubtermsIncl (K1 _) = [] #endif @@ -496,8 +501,16 @@ -} instance Integral a => Arbitrary (Ratio a) where - arbitrary = arbitrarySizedFractional - shrink = shrinkRealFrac + arbitrary = sized $ \ n -> do + denom <- chooseInt (1, max 1 n) + let lb | isNonNegativeType fromI = 0 + | otherwise = (-n*denom) + -- NOTE: this is a trick to make sure we get around lack of scoped type + -- variables by pinning the result-type of fromIntegral. + fromI = fromIntegral + numer <- chooseInt (lb, n*denom) + pure $ fromI numer % fromI denom + shrink = shrinkRealFrac #if defined(MIN_VERSION_base) && MIN_VERSION_base(4,4,0) instance Arbitrary a => Arbitrary (Complex a) where @@ -852,27 +865,36 @@ shrink = shrinkDecimal -- Arbitrary instances for container types +-- | WARNING: Users working on the internals of the @Set@ type via e.g. @Data.Set.Internal@ +-- should be aware that this instance aims to give a good representation of @Set a@ +-- as mathematical sets but *does not* aim to provide a varied distribution over the +-- underlying representation. instance (Ord a, Arbitrary a) => Arbitrary (Set.Set a) where arbitrary = fmap Set.fromList arbitrary shrink = map Set.fromList . shrink . Set.toList instance (Ord k, Arbitrary k) => Arbitrary1 (Map.Map k) where liftArbitrary = fmap Map.fromList . liftArbitrary . liftArbitrary liftShrink shr = map Map.fromList . liftShrink (liftShrink shr) . Map.toList +-- | WARNING: The same warning as for @Arbitrary (Set a)@ applies here. instance (Ord k, Arbitrary k, Arbitrary v) => Arbitrary (Map.Map k v) where arbitrary = arbitrary1 shrink = shrink1 +-- | WARNING: The same warning as for @Arbitrary (Set a)@ applies here. instance Arbitrary IntSet.IntSet where arbitrary = fmap IntSet.fromList arbitrary shrink = map IntSet.fromList . shrink . IntSet.toList +-- | WARNING: The same warning as for @Arbitrary (Set a)@ applies here. instance Arbitrary1 IntMap.IntMap where liftArbitrary = fmap IntMap.fromList . liftArbitrary . liftArbitrary liftShrink shr = map IntMap.fromList . liftShrink (liftShrink shr) . IntMap.toList +-- | WARNING: The same warning as for @Arbitrary (Set a)@ applies here. instance Arbitrary a => Arbitrary (IntMap.IntMap a) where arbitrary = arbitrary1 shrink = shrink1 instance Arbitrary1 Sequence.Seq where liftArbitrary = fmap Sequence.fromList . liftArbitrary liftShrink shr = map Sequence.fromList . liftShrink shr . toList +-- | WARNING: The same warning as for @Arbitrary (Set a)@ applies here. instance Arbitrary a => Arbitrary (Sequence.Seq a) where arbitrary = arbitrary1 shrink = shrink1 @@ -1082,9 +1104,19 @@ -- | Generates an integral number. The number can be positive or negative -- and its maximum absolute value depends on the size parameter. arbitrarySizedIntegral :: Integral a => Gen a -arbitrarySizedIntegral = - sized $ \n -> - inBounds fromIntegral (chooseInt (-n, n)) +arbitrarySizedIntegral + | isNonNegativeType fromI = arbitrarySizedNatural + | otherwise = sized $ \n -> inBounds fromI (chooseInt (-n, n)) + where + -- NOTE: this is a trick to make sure we get around lack of scoped type + -- variables by pinning the result-type of fromIntegral. + fromI = fromIntegral + +isNonNegativeType :: Enum a => (Int -> a) -> Bool +isNonNegativeType fromI = + case enumFromThen (fromI 1) (fromI 0) of + [_, _] -> True + _ -> False -- | Generates a natural number. The number's maximum value depends on -- the size parameter. diff --git a/src/Test/QuickCheck/Exception.hs b/src/Test/QuickCheck/Exception.hs --- a/src/Test/QuickCheck/Exception.hs +++ b/src/Test/QuickCheck/Exception.hs @@ -75,8 +75,6 @@ notAsync e = Just e #endif ---tryEvaluateIO m = Right `fmap` m - evaluate :: a -> IO a evaluate = E.evaluate diff --git a/src/Test/QuickCheck/Features.hs b/src/Test/QuickCheck/Features.hs --- a/src/Test/QuickCheck/Features.hs +++ b/src/Test/QuickCheck/Features.hs @@ -28,7 +28,7 @@ f res = case ok res of Just True - | not (features (P.labels res) (Set.fromList (P.classes res)) `Set.isSubsetOf` feats) -> + | not (features (P.labels res) (Set.fromList (map fst $ filter snd $ P.classes res)) `Set.isSubsetOf` feats) -> res{ok = Just False, P.reason = "New feature found"} _ -> res @@ -49,7 +49,7 @@ -- > where count x xs = length (filter (== x) xs) -- -- 'labelledExamples' generates three example test cases, one for each label: --- +-- -- >>> labelledExamples prop_delete -- *** Found example of count x xs == 0 -- 0 @@ -100,7 +100,7 @@ mapM_ (putLine (terminal state)) (failingTestCase res) putStrLn "" loop (Set.union feats feats') - state{randomSeed = usedSeed res, computeSize = computeSize state `at0` usedSize res} + state{randomSeed = usedSeed res, replayStartSize = Just $ usedSize res} _ -> do out <- terminalOutput nullterm putStr out diff --git a/src/Test/QuickCheck/Gen.hs b/src/Test/QuickCheck/Gen.hs --- a/src/Test/QuickCheck/Gen.hs +++ b/src/Test/QuickCheck/Gen.hs @@ -15,6 +15,8 @@ -------------------------------------------------------------------------- -- imports +import Test.QuickCheck.Exception + import System.Random ( Random , random @@ -45,6 +47,12 @@ import Data.Int import Data.Bits import Control.Applicative +#ifndef NO_CALLSTACK +import GHC.Stack +#define WITHCALLSTACK(ty) HasCallStack => ty +#else +#define WITHCALLSTACK(ty) ty +#endif -------------------------------------------------------------------------- -- ** Generator type @@ -57,7 +65,7 @@ -- -- provide monad transformer versions of @Gen@. newtype Gen a = MkGen{ - unGen :: QCGen -> Int -> a -- ^ Run the generator on a particular seed. + unGen :: QCGen -> Int -> a -- ^ Run the generator on a particular seed and size. -- If you just want to get a random value out, consider using 'generate'. } @@ -134,7 +142,7 @@ -- | 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 :: WITHCALLSTACK(Int -> Gen a -> Gen a) resize n _ | n < 0 = error "Test.QuickCheck.resize: negative size" resize n (MkGen g) = MkGen (\r _ -> g r n) @@ -239,8 +247,14 @@ -- | Generates some example values and prints them to 'stdout'. sample :: Show a => Gen a -> IO () sample g = - do cases <- sample' g - mapM_ print cases + sequence_ [ do r <- newQCGen + munit <- tryEvaluateIO (print $ unGen g r n) + case munit of + Left e + | isDiscard e -> putStrLn "" + | otherwise -> error $ unlines $ "Uncaught exception in sample: " : map (" " ++) (lines $ show e) + Right () -> return () + | n <- [0,2..20] ] -------------------------------------------------------------------------- -- ** Floating point @@ -289,13 +303,13 @@ -- | Randomly uses one of the given generators. The input list -- must be non-empty. -oneof :: [Gen a] -> Gen a +oneof :: WITHCALLSTACK([Gen a] -> Gen a) oneof [] = error "QuickCheck.oneof used with empty list" 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. -frequency :: [(Int, Gen a)] -> Gen a +frequency :: WITHCALLSTACK([(Int, Gen a)] -> Gen a) frequency [] = error "QuickCheck.frequency used with empty list" frequency xs | any (< 0) (map fst xs) = @@ -312,7 +326,7 @@ pick _ _ = error "QuickCheck.pick used with empty list" -- | Generates one of the given values. The input list must be non-empty. -elements :: [a] -> Gen a +elements :: WITHCALLSTACK([a] -> Gen a) elements [] = error "QuickCheck.elements used with empty list" elements xs = (xs !!) `fmap` chooseInt (0, length xs - 1) @@ -330,7 +344,7 @@ -- among an initial segment of the list. The size of this initial -- segment increases with the size parameter. -- The input list must be non-empty. -growingElements :: [a] -> Gen a +growingElements :: WITHCALLSTACK([a] -> Gen a) growingElements [] = error "QuickCheck.growingElements used with empty list" growingElements xs = sized $ \n -> elements (take (1 `max` size n) xs) where diff --git a/src/Test/QuickCheck/Gen/Unsafe.hs b/src/Test/QuickCheck/Gen/Unsafe.hs --- a/src/Test/QuickCheck/Gen/Unsafe.hs +++ b/src/Test/QuickCheck/Gen/Unsafe.hs @@ -22,12 +22,11 @@ import Test.QuickCheck.Gen import Control.Monad +import Control.Applicative -- | Promotes a monadic generator to a generator of monadic values. promote :: Monad m => m (Gen a) -> Gen (m a) -promote m = do - eval <- delay - return (liftM eval m) +promote m = flip liftM m <$> delay -- | Randomly generates a function of type @'Gen' a -> a@, which -- you can then use to evaluate generators. Mostly useful in diff --git a/src/Test/QuickCheck/Modifiers.hs b/src/Test/QuickCheck/Modifiers.hs --- a/src/Test/QuickCheck/Modifiers.hs +++ b/src/Test/QuickCheck/Modifiers.hs @@ -283,7 +283,7 @@ fmap f (Negative x) = Negative (f x) instance (Num a, Ord a, Arbitrary a) => Arbitrary (Negative a) where - arbitrary = fmap Negative (arbitrary `suchThat` (< 0)) + arbitrary = fmap Negative (fmap (negate . abs) arbitrary `suchThat` (< 0)) shrink (Negative x) = [ Negative x' | x' <- shrink x , x' < 0 ] -------------------------------------------------------------------------- diff --git a/src/Test/QuickCheck/Monadic.hs b/src/Test/QuickCheck/Monadic.hs --- a/src/Test/QuickCheck/Monadic.hs +++ b/src/Test/QuickCheck/Monadic.hs @@ -72,6 +72,17 @@ , monadicST , runSTGen #endif + + -- * Exceptions + +#ifndef NO_EXCEPTIONS + , assertException + , assertExceptionIO +#ifndef NO_DEEPSEQ + , assertDeepException + , assertDeepExceptionIO +#endif +#endif ) where -------------------------------------------------------------------------- @@ -95,6 +106,13 @@ import qualified Control.Monad.Fail as Fail #endif +#ifndef NO_DEEPSEQ +import Control.DeepSeq +#endif + +#ifndef NO_EXCEPTIONS +import qualified Control.Exception as E +#endif -------------------------------------------------------------------------- -- type PropertyM @@ -296,6 +314,61 @@ runSTGen f = do Capture eval <- capture return (runST (eval f)) +#endif + +-- Exceptions + + +#ifndef NO_EXCEPTIONS + +-- | Evaluate the value to Weak Head Normal Form (WHNF) and fail if it does not result in +-- an expected exception being thrown. +assertException :: + E.Exception exc + => (exc -> Bool) -- ^ Return `True` if that is the exception that was expected + -> a -- ^ Value that should result in an exception, when evaluated to WHNF + -> Property +assertException isExc value = assertExceptionIO isExc (return value) + + +-- | Make sure that a specific exception is thrown during an IO action. The result is +-- evaluated to WHNF. +assertExceptionIO :: + E.Exception exc + => (exc -> Bool) -- ^ Return `True` if that is the exception that was expected + -> IO a -- ^ An action that should throw the expected exception + -> Property +assertExceptionIO isExc action = + monadicIO $ do + hasFailed <- + run + (E.catch + (do res <- action + res `seq` return False) + (return . isExc)) + assert hasFailed + +#ifndef NO_DEEPSEQ + +-- | Same as `assertException`, but evaluate the value to Normal Form (NF) and fail if it +-- does not result in an expected exception being thrown. +assertDeepException :: + (NFData a, E.Exception exc) + => (exc -> Bool) -- ^ Return True if that is the exception that was expected + -> a -- ^ Value that should result in an exception, when fully evaluated to NF + -> Property +assertDeepException isExc value = assertException isExc (rnf value) + +-- | Make sure that a specific exception is thrown during an IO action. The result is +-- evaluated to NF. +assertDeepExceptionIO :: + (NFData a, E.Exception exc) + => (exc -> Bool) -- ^ Return True if that is the exception that was expected + -> IO a -- ^ An action that should throw the expected exception + -> Property +assertDeepExceptionIO isExc action = assertExceptionIO isExc (fmap rnf action) + +#endif #endif -------------------------------------------------------------------------- diff --git a/src/Test/QuickCheck/Property.hs b/src/Test/QuickCheck/Property.hs --- a/src/Test/QuickCheck/Property.hs +++ b/src/Test/QuickCheck/Property.hs @@ -3,6 +3,7 @@ {-# LANGUAGE CPP #-} #ifndef NO_TYPEABLE {-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE ExistentialQuantification #-} #endif #ifndef NO_SAFE_HASKELL {-# LANGUAGE Safe #-} @@ -33,7 +34,7 @@ import Control.DeepSeq #endif #ifndef NO_TYPEABLE -import Data.Typeable (Typeable) +import Data.Typeable (Typeable, cast) #endif import Data.Maybe @@ -85,11 +86,6 @@ -- | The class of properties, i.e., types which QuickCheck knows how to test. -- Typically a property will be a function returning 'Bool' or 'Property'. --- --- If a property does no quantification, i.e. has no --- parameters and doesn't use 'forAll', it will only be tested once. --- This may not be what you want if your property is an @IO Bool@. --- You can change this behaviour using the 'again' combinator. class Testable prop where -- | Convert the thing to a property. property :: prop -> Property @@ -142,7 +138,7 @@ property p = MkProperty . return . protectProp $ p instance Testable prop => Testable (Gen prop) where - property mp = MkProperty $ do p <- mp; unProperty (again p) + property mp = MkProperty $ do p <- mp; unProperty (property p) instance Testable Property where property (MkProperty mp) = MkProperty (fmap protectProp mp) @@ -157,9 +153,6 @@ -- Warning: any random values generated inside of the argument to @ioProperty@ -- will not currently be shrunk. For best results, generate all random values -- before calling @ioProperty@, or use 'idempotentIOProperty' if that is safe. --- --- Note: if your property does no quantification, it will only be tested once. --- To test it repeatedly, use 'again'. ioProperty :: Testable prop => IO prop -> Property ioProperty prop = idempotentIOProperty (fmap noShrinking prop) @@ -262,35 +255,61 @@ data CallbackKind = Counterexample -- ^ Affected by the 'verbose' combinator | NotCounterexample -- ^ Not affected by the 'verbose' combinator +#ifndef NO_TYPEABLE +data Witness = forall a. (Typeable a, Show a) => Wit a + +instance Show Witness where + show (Wit a) = show a + +coerceWitness :: Typeable a => Witness -> a +coerceWitness (Wit a) = case cast a of + Nothing -> error $ "Can't coerceWitness " ++ show a + Just a -> a + +castWitness :: Typeable a => Witness -> Maybe a +castWitness (Wit a) = cast a + +#define WITNESSES(a) , theWitnesses a +#else +#define WITNESSES(a) +#endif + -- | The result of a single test. data Result = MkResult - { ok :: Maybe Bool + { ok :: Maybe Bool -- ^ result of the test case; Nothing = discard - , expect :: Bool + , expect :: Bool -- ^ indicates what the expected result of the property is - , reason :: String + , reason :: String -- ^ a message indicating what went wrong - , theException :: Maybe AnException + , theException :: Maybe AnException -- ^ the exception thrown, if any - , abort :: Bool + , abort :: Bool -- ^ if True, the test should not be repeated - , maybeNumTests :: Maybe Int + , maybeNumTests :: Maybe Int -- ^ stop after this many tests - , maybeCheckCoverage :: Maybe Confidence + , maybeCheckCoverage :: Maybe Confidence -- ^ required coverage confidence - , labels :: [String] + , maybeDiscardedRatio :: Maybe Int + -- ^ maximum number of discarded tests per successful test + , maybeMaxShrinks :: Maybe Int + -- ^ maximum number of shrinks + , maybeMaxTestSize :: Maybe Int + -- ^ maximum test size + , labels :: [String] -- ^ test case labels - , classes :: [String] + , classes :: [(String, Bool)] -- ^ test case classes - , tables :: [(String, String)] + , tables :: [(String, String)] -- ^ test case tables - , requiredCoverage :: [(Maybe String, String, Double)] + , requiredCoverage :: [(Maybe String, String, Double)] -- ^ required coverage - , callbacks :: [Callback] + , callbacks :: [Callback] -- ^ the callbacks for this test case - , testCase :: [String] + , testCase :: [String] -- ^ the generated test case + WITNESSES(:: [Witness]) } exception :: String -> AnException -> Result @@ -315,19 +334,23 @@ where result = MkResult - { ok = undefined - , expect = True - , reason = "" - , theException = Nothing - , abort = True - , maybeNumTests = Nothing - , maybeCheckCoverage = Nothing - , labels = [] - , classes = [] - , tables = [] - , requiredCoverage = [] - , callbacks = [] - , testCase = [] + { ok = undefined + , expect = True + , reason = "" + , theException = Nothing + , abort = False + , maybeNumTests = Nothing + , maybeCheckCoverage = Nothing + , maybeDiscardedRatio = Nothing + , maybeMaxShrinks = Nothing + , maybeMaxTestSize = Nothing + , labels = [] + , classes = [] + , tables = [] + , requiredCoverage = [] + , callbacks = [] + , testCase = [] + WITNESSES(= []) } -------------------------------------------------------------------------- @@ -477,6 +500,47 @@ withMaxSuccess :: Testable prop => Int -> prop -> Property withMaxSuccess n = n `seq` mapTotalResult (\res -> res{ maybeNumTests = Just n }) +-- | Configures how many times a property is allowed to be discarded before failing. +-- +-- For example, +-- +-- > quickCheck (withDiscardRatio 10 p) +-- +-- will allow @p@ to fail up to 10 times per successful test. +withDiscardRatio :: Testable prop => Int -> prop -> Property +withDiscardRatio n = n `seq` mapTotalResult (\res -> res{ maybeDiscardedRatio = Just n }) + +-- | Configure the maximum number of times a property will be shrunk. +-- +-- For example, +-- +-- > quickCheck (withMaxShrinks 100 p) +-- +-- will cause @p@ to only attempt 100 shrinks on failure. +withMaxShrinks :: Testable prop => Int -> prop -> Property +withMaxShrinks n = n `seq` mapTotalResult (\res -> res{ maybeMaxShrinks = Just n }) + +-- | Configure the maximum size a property will be tested at. +withMaxSize :: Testable prop => Int -> prop -> Property +withMaxSize n = n `seq` mapTotalResult (\res -> res{ maybeMaxTestSize = Just n }) + +#ifndef NO_TYPEABLE +-- | Return a value in the 'witnesses' field of the 'Result' returned by 'quickCheckResult'. Witnesses +-- are returned outer-most first. +-- +-- In ghci, for example: +-- +-- >>> [Wit x] <- fmap witnesses . quickCheckResult $ \ x -> witness x $ x == (0 :: Int) +-- *** Failed! Falsified (after 2 tests): +-- 1 +-- >>> x +-- 1 +-- >>> :t x +-- x :: Int +witness :: (Typeable a, Show a, Testable prop) => a -> prop -> Property +witness a = a `seq` mapTotalResult (\res -> res{ theWitnesses = Wit a : theWitnesses res }) +#endif + -- | Check that all coverage requirements defined by 'cover' and 'coverTable' -- are met, using a statistically sound test, and fail if they are not met. -- @@ -591,13 +655,12 @@ Bool -- ^ @True@ if the test case should be labelled. -> String -- ^ Label. -> prop -> Property -classify False _ = property -classify True s = +classify b s = #ifndef NO_DEEPSEQ s `deepseq` #endif mapTotalResult $ - \res -> res { classes = s:classes res } + \res -> res { classes = (s, b):classes res } -- | Checks that at least the given proportion of /successful/ test -- cases belong to the given class. Discarded tests (i.e. ones @@ -705,7 +768,8 @@ -- | Checks that the values in a given 'table' appear a certain proportion of -- the time. A call to 'coverTable' @table@ @[(x1, p1), ..., (xn, pn)]@ asserts -- that of the values in @table@, @x1@ should appear at least @p1@ percent of --- the time, @x2@ at least @p2@ percent of the time, and so on. +-- the time that @table@ appears, @x2@ at least @p2@ percent of the time that +-- @table@ appears, and so on. -- -- __Note:__ If the coverage check fails, QuickCheck prints out a warning, but -- the property does /not/ fail. To make the property fail, use 'checkCoverage'. @@ -839,7 +903,6 @@ :: Testable prop => Gen a -> (a -> [a]) -> (a -> prop) -> Property forAllShrinkBlind gen shrinker pf = - again $ MkProperty $ gen >>= \x -> unProperty $ @@ -850,7 +913,6 @@ -- makes 100 random choices. (.&.) :: (Testable prop1, Testable prop2) => prop1 -> prop2 -> Property p1 .&. p2 = - again $ MkProperty $ arbitrary >>= \b -> unProperty $ @@ -864,7 +926,6 @@ -- | Take the conjunction of several properties. conjoin :: Testable prop => [prop] -> Property conjoin ps = - again $ MkProperty $ do roses <- mapM (fmap unProp . unProperty . property) ps return (MkProp (conj id roses)) @@ -903,7 +964,6 @@ -- | Take the disjunction of several properties. disjoin :: Testable prop => [prop] -> Property disjoin ps = - again $ MkProperty $ do roses <- mapM (fmap unProp . unProperty . property) ps return (MkProp (foldr disj (MkRose failed []) roses)) @@ -930,6 +990,9 @@ abort = False, maybeNumTests = Nothing, maybeCheckCoverage = Nothing, + maybeDiscardedRatio = Nothing, + maybeMaxShrinks = Nothing, + maybeMaxTestSize = Nothing, labels = [], classes = [], tables = [], @@ -940,7 +1003,9 @@ callbacks result2, testCase = testCase result1 ++ - testCase result2 } + testCase result2 + WITNESSES(= theWitnesses result1 ++ theWitnesses result2) + } Nothing -> result2 -- The "obvious" semantics of .||. has: -- discard .||. true = true diff --git a/src/Test/QuickCheck/State.hs b/src/Test/QuickCheck/State.hs --- a/src/Test/QuickCheck/State.hs +++ b/src/Test/QuickCheck/State.hs @@ -25,12 +25,14 @@ , maxDiscardedRatio :: Int -- ^ maximum number of discarded tests per successful test , coverageConfidence :: Maybe Confidence - -- ^ required coverage confidence - , 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 + , replayStartSize :: Maybe Int + -- ^ Size to start at when replaying + , maxTestSize :: !Int + -- ^ Maximum size of test -- dynamic , numSuccessTests :: !Int @@ -69,7 +71,7 @@ -- If the coverage requirement is met, and the certainty parameter is @n@, -- then you should get a false positive at most one in @n@ runs of QuickCheck. -- The default value is @10^9@. - -- + -- -- Lower values will speed up 'checkCoverage' at the cost of false -- positives. -- diff --git a/src/Test/QuickCheck/Test.hs b/src/Test/QuickCheck/Test.hs --- a/src/Test/QuickCheck/Test.hs +++ b/src/Test/QuickCheck/Test.hs @@ -12,6 +12,7 @@ -------------------------------------------------------------------------- -- imports +import Control.Applicative import Test.QuickCheck.Gen import Test.QuickCheck.Property hiding ( Result( reason, theException, labels, classes, tables ), (.&.) ) import qualified Test.QuickCheck.Property as P @@ -50,6 +51,7 @@ import Text.Printf(printf) import Control.Monad import Data.Bits +import Data.Maybe #ifndef NO_TYPEABLE import Data.Typeable (Typeable) @@ -80,7 +82,7 @@ , chatty :: Bool -- ^ Whether to print anything , maxShrinks :: Int - -- ^ Maximum number of shrinks to before giving up. Setting this to zero + -- ^ Maximum number of shrinks to do before giving up. Setting this to zero -- turns shrinking off. } deriving ( Show, Read @@ -142,6 +144,10 @@ -- ^ The test case's labels (see 'label') , failingClasses :: Set String -- ^ The test case's classes (see 'classify') +#ifndef NO_TYPEABLE + , witnesses :: [Witness] + -- ^ The existentially quantified witnesses provided by 'witness' +#endif } -- | A property that should have failed did not | NoExpectedFailure @@ -197,6 +203,11 @@ quickCheckWithResult a p = withState a (\s -> test s (property p)) +-- | Re-run a property with the seed and size that failed in a run of 'quickCheckResult'. +recheck :: Testable prop => Result -> prop -> IO () +recheck res@Failure{} = quickCheckWith stdArgs{ replay = Just (usedSeed res, usedSize res)} . once +recheck _ = error "Can only recheck tests that failed with a counterexample." + withState :: Args -> (State -> IO a) -> IO a withState a test = (if chatty a then withStdioTerminal else withNullTerminal) $ \tm -> do rnd <- case replay a of @@ -206,9 +217,8 @@ , maxSuccessTests = maxSuccess a , coverageConfidence = Nothing , maxDiscardedRatio = maxDiscardRatio a - , computeSize = case replay a of - Nothing -> computeSize' - Just (_,s) -> computeSize' `at0` s + , replayStartSize = snd <$> replay a + , maxTestSize = maxSize a , numTotMaxShrinks = maxShrinks a , numSuccessTests = 0 , numDiscardedTests = 0 @@ -223,18 +233,31 @@ , numTryShrinks = 0 , numTotTryShrinks = 0 } - where computeSize' n d - -- e.g. with maxSuccess = 250, maxSize = 100, goes like this: - -- 0, 1, 2, ..., 99, 0, 1, 2, ..., 99, 0, 2, 4, ..., 98. - | n `roundTo` maxSize a + maxSize a <= maxSuccess a || - n >= maxSuccess a || - maxSuccess a `mod` maxSize a == 0 = (n `mod` maxSize a + d `div` 10) `min` maxSize a - | otherwise = - ((n `mod` maxSize a) * maxSize a `div` (maxSuccess a `mod` maxSize a) + d `div` 10) `min` maxSize a - n `roundTo` m = (n `div` m) * m - at0 f s 0 0 = s - at0 f s n d = f n d +computeSize :: State -> Int +computeSize MkState{replayStartSize = Just s,numSuccessTests = 0,numRecentlyDiscardedTests=0} = s +-- NOTE: Beware that changing this means you also have to change `prop_discardCoverage` as that currently relies +-- on the sequence produced by this function. +computeSize MkState{maxSuccessTests = ms, maxTestSize = mts, maxDiscardedRatio = md,numSuccessTests=n,numRecentlyDiscardedTests=d} + -- e.g. with maxSuccess = 250, maxSize = 100, goes like this: + -- 0, 1, 2, ..., 99, 0, 1, 2, ..., 99, 0, 2, 4, ..., 98. + | n `roundTo` mts + mts <= ms || + n >= ms || + ms `mod` mts == 0 = (n `mod` mts + d `div` dDenom) `min` mts + | otherwise = + ((n `mod` mts) * mts `div` (ms `mod` mts) + d `div` dDenom) `min` mts + where + -- The inverse of the rate at which we increase size as a function of discarded tests + -- if the discard ratio is high we can afford this to be slow, but if the discard ratio + -- is low we risk bowing out too early + dDenom + | md > 0 = (ms * md `div` 3) `clamp` (1, 10) + | otherwise = 1 -- Doesn't matter because there will be no discards allowed + n `roundTo` m = (n `div` m) * m + +clamp :: Ord a => a -> (a, a) -> a +clamp x (l, h) = max l (min x h) + -- | Tests a property and prints the results and all test cases generated to 'stdout'. -- This is just a convenience function that means the same as @'quickCheck' . 'verbose'@. -- @@ -275,14 +298,69 @@ -- main test loop test :: State -> Property -> IO Result -test st f - | numSuccessTests st >= maxSuccessTests st && isNothing (coverageConfidence st) = - doneTesting st f - | numDiscardedTests st >= maxDiscardedRatio st * max (numSuccessTests st) (maxSuccessTests st) = - giveUp st f - | otherwise = - runATest st f +test st prop + | finishedSuccessfully st = doneTesting st prop + | finishedInsufficientCoverage st = failCoverage st prop + | tooManyDiscards st = giveUp st prop + | otherwise = runATest st prop +finishedSuccessfully :: State -> Bool +finishedSuccessfully st + | checkingCoverage st = + and [ timeToCheckCoverage st + , coverageKnownSufficient st + , numSuccessTests st >= maxSuccessTests st + ] + | otherwise = numSuccessTests st >= maxSuccessTests st + +finishedInsufficientCoverage :: State -> Bool +finishedInsufficientCoverage st = + and [ checkingCoverage st + , timeToCheckCoverage st + , coverageKnownInsufficient st + ] + +tooManyDiscards :: State -> Bool +tooManyDiscards st + | maxDiscardedRatio st > 0 = numDiscardedTests st `div` maxDiscardedRatio st >= max (numSuccessTests st) (maxSuccessTests st) + | otherwise = numDiscardedTests st > 0 + +checkingCoverage :: State -> Bool +checkingCoverage st = isJust (coverageConfidence st) + +timeToCheckCoverage :: State -> Bool +timeToCheckCoverage st + -- This is the time when we would normally finish testing, so lets check + -- it now to see if we can finish testing already + | numSuccessTests st == maxSuccessTests st && numRecentlyDiscardedTests st == 0 = True + -- We are on test 100 * 2^k for k > 0 + | otherwise = + and [ numSuccessTests st > 0 + , numSuccessTests st `mod` 100 == 0 + , powerOfTwo (numSuccessTests st `div` 100) + ] + where powerOfTwo n = n .&. (n - 1) == 0 + +coverageKnownSufficient :: State -> Bool +coverageKnownSufficient st@MkState{coverageConfidence=Just confidence} = + and [ sufficientlyCovered confidence tot n p | (_, _, tot, n, p) <- allCoverage st ] +coverageKnownSufficient _ = True + +coverageKnownInsufficient :: State -> Bool +coverageKnownInsufficient st@MkState{coverageConfidence=Just confidence} = + or [ insufficientlyCovered (Just (certainty confidence)) tot n p + | (_, _, tot, n, p) <- allCoverage st ] +coverageKnownInsufficient _ = False + +failCoverage :: State -> Property -> IO Result +failCoverage st prop = + -- The last test wasn't actually successful, as the coverage failed + -- also this prevents an off-by-one error in the printing + runATest st{numSuccessTests = numSuccessTests st - 1} + $ foldr counterexample (property failed{P.reason = "Insufficient coverage"}) + (paragraphs [theLabels, theTables]) + where (theLabels, theTables) = labelsAndTables st + doneTesting :: State -> Property -> IO Result doneTesting st _f | expected st == False = do @@ -332,70 +410,77 @@ ] runATest :: State -> Property -> IO Result -runATest st f = +runATest st prop = do -- CALLBACK before_test putTemp (terminal st) ( "(" ++ showTestCount st ++ ")" ) - let powerOfTwo n = n .&. (n - 1) == 0 - let f_or_cov = - case coverageConfidence st of - Just confidence | (1 + numSuccessTests st) `mod` 100 == 0 && powerOfTwo ((1 + numSuccessTests st) `div` 100) -> - addCoverageCheck confidence st f - _ -> f - let size = computeSize st (numSuccessTests st) (numRecentlyDiscardedTests st) - MkRose res ts <- protectRose (reduceRose (unProp (unGen (unProperty f_or_cov) rnd1 size))) + + let size = computeSize st + + MkRose res ts <- protectRose (reduceRose (unProp (unGen (unProperty prop) rnd1 size))) res <- callbackPostTest st res - let continue break st' | abort res = break st' - | otherwise = test st' + let continue break st' + | abort res = break $ updateState st' + | otherwise = test $ updateState st' - let st' = st{ coverageConfidence = maybeCheckCoverage res `mplus` coverageConfidence st - , maxSuccessTests = fromMaybe (maxSuccessTests st) (maybeNumTests res) - , S.labels = Map.insertWith (+) (P.labels res) 1 (S.labels st) - , S.classes = Map.unionWith (+) (S.classes st) (Map.fromList (zip (P.classes res) (repeat 1))) - , S.tables = - foldr (\(tab, x) -> Map.insertWith (Map.unionWith (+)) tab (Map.singleton x 1)) - (S.tables st) (P.tables res) - , S.requiredCoverage = - foldr (\(key, value, p) -> Map.insertWith max (key, value) p) - (S.requiredCoverage st) (P.requiredCoverage res) - , expected = expect res } + updateState st0 = addNewOptions $ st0{ randomSeed = rnd2 } + addNewOptions st0 = st0{ maxSuccessTests = fromMaybe (maxSuccessTests st0) (maybeNumTests res) + , maxDiscardedRatio = fromMaybe (maxDiscardedRatio st0) (maybeDiscardedRatio res) + , numTotMaxShrinks = fromMaybe (numTotMaxShrinks st0) (maybeMaxShrinks res) + , maxTestSize = fromMaybe (maxTestSize st0) (maybeMaxTestSize res) + , expected = expect res + } + + addCoverageInfo st0 = + st0{ coverageConfidence = maybeCheckCoverage res `mplus` coverageConfidence st0 + , S.labels = Map.insertWith (+) (P.labels res) 1 (S.labels st0) + , S.classes = Map.unionWith (+) (S.classes st0) + (Map.fromList [ (s, if b then 1 else 0) | (s, b) <- P.classes res ]) + , S.tables = + foldr (\(tab, x) -> Map.insertWith (Map.unionWith (+)) tab (Map.singleton x 1)) + (S.tables st0) (P.tables res) + , S.requiredCoverage = + foldr (\(key, value, p) -> Map.insertWith max (key, value) p) + (S.requiredCoverage st0) (P.requiredCoverage res) + } + + stC = addCoverageInfo st + case res of MkResult{ok = Just True} -> -- successful test do continue doneTesting - st'{ numSuccessTests = numSuccessTests st' + 1 + stC{ numSuccessTests = numSuccessTests st + 1 , numRecentlyDiscardedTests = 0 - , randomSeed = rnd2 - } f + } prop - MkResult{ok = Nothing, expect = expect, maybeNumTests = mnt, maybeCheckCoverage = mcc} -> -- discarded test + MkResult{ok = Nothing} -> -- discarded test do continue giveUp -- Don't add coverage info from this test - st{ numDiscardedTests = numDiscardedTests st' + 1 - , numRecentlyDiscardedTests = numRecentlyDiscardedTests st' + 1 - , randomSeed = rnd2 - } f + st{ numDiscardedTests = numDiscardedTests st + 1 + , numRecentlyDiscardedTests = numRecentlyDiscardedTests st + 1 + } prop MkResult{ok = Just False} -> -- failed test - do (numShrinks, totFailed, lastFailed, res) <- foundFailure st' res ts - theOutput <- terminalOutput (terminal st') + do (numShrinks, totFailed, lastFailed, res) <- foundFailure (addNewOptions stC) res ts + theOutput <- terminalOutput (terminal stC) if not (expect res) then - return Success{ labels = S.labels st', - classes = S.classes st', - tables = S.tables st', - numTests = numSuccessTests st'+1, - numDiscarded = numDiscardedTests st', + return Success{ labels = S.labels stC, + classes = S.classes stC, + tables = S.tables stC, + numTests = numSuccessTests stC+1, + numDiscarded = numDiscardedTests stC, output = theOutput } else do testCase <- mapM showCounterexample (P.testCase res) - return Failure{ usedSeed = randomSeed st' -- correct! (this will be split first) + return Failure{ usedSeed = randomSeed stC -- correct! (this will be split first) , usedSize = size - , numTests = numSuccessTests st'+1 - , numDiscarded = numDiscardedTests st' + , numTests = numSuccessTests stC + 1 + , numDiscarded = numDiscardedTests stC , numShrinks = numShrinks , numShrinkTries = totFailed , numShrinkFinal = lastFailed @@ -404,7 +489,10 @@ , theException = P.theException res , failingTestCase = testCase , failingLabels = P.labels res - , failingClasses = Set.fromList (P.classes res) + , failingClasses = Set.fromList (map fst $ filter snd $ P.classes res) +#ifndef NO_TYPEABLE + , witnesses = theWitnesses res +#endif } where (rnd1,rnd2) = split (randomSeed st) @@ -524,7 +612,9 @@ Right () -> do r <- tryEvaluate ts case r of - Left err -> + Left err + | isDiscard err -> localMinFound st res + | otherwise -> localMinFound st (exception "Exception while generating shrink-list" err) { callbacks = callbacks res } Right ts' -> localMin' st res ts' @@ -664,18 +754,6 @@ p_low = 0.02425 p_high = 1 - p_low -addCoverageCheck :: Confidence -> State -> Property -> Property -addCoverageCheck confidence st prop - | and [ sufficientlyCovered confidence tot n p - | (_, _, tot, n, p) <- allCoverage st ] = - -- Note: run prop once more so that we get labels for this test case run - once prop - | or [ insufficientlyCovered (Just (certainty confidence)) tot n p - | (_, _, tot, n, p) <- allCoverage st ] = - let (theLabels, theTables) = labelsAndTables st in - foldr counterexample (property failed{P.reason = "Insufficient coverage"}) - (paragraphs [theLabels, theTables]) - | otherwise = prop allCoverage :: State -> [(Maybe String, String, Int, Int, Double)] allCoverage st = diff --git a/test-hugs b/test-hugs --- a/test-hugs +++ b/test-hugs @@ -19,8 +19,11 @@ dotest() { echo "$2" | hugs -98 -Pquickcheck-hugs: -p'> ' "$1" | tee hugs.output - grep "$3" hugs.output || die + grep -q "$3" hugs.output || die } # Simple tests dotest Test.QuickCheck 'quickCheck $ \xs -> reverse (reverse xs) === (xs :: [Int])' "OK, passed 100 tests." +dotest Test.QuickCheck 'quickCheck $ \xs -> reverse xs === (xs :: [Int])' "\[0,1\]" +echo +echo 'All tests passed!' diff --git a/tests/DiscardRatio.hs b/tests/DiscardRatio.hs new file mode 100644 --- /dev/null +++ b/tests/DiscardRatio.hs @@ -0,0 +1,51 @@ +module Main where + +import Control.Monad +import System.Exit +import Test.QuickCheck + +assert :: String -> Bool -> IO () +assert s False = do + putStrLn $ s ++ " failed!" + exitFailure +assert _ _ = return () + +quickCheckYesWith, quickCheckNoWith :: Testable p => Args -> p -> IO () +quickCheckYesWith args p = do + res <- quickCheckWithResult args p + unless (isSuccess res) exitFailure +quickCheckNoWith args p = do + res <- quickCheckWithResult args p + when (isSuccess res) exitFailure +quickCheckYes, quickCheckNo :: Testable p => p -> IO () +quickCheckYes = quickCheckYesWith stdArgs +quickCheckNo = quickCheckNoWith stdArgs + +check :: Result -> Int -> Int -> IO () +check res n d = do + quickCheckYes $ once $ n === numTests res + quickCheckYes $ once $ d === numDiscarded res + +main :: IO () +main = do + putStrLn "Expecting gave up after 200 tries: False ==> True" + res <- quickCheckResult $ withDiscardRatio 2 $ False ==> True + check res 0 200 + res <- quickCheckWithResult stdArgs{maxDiscardRatio = 2} $ False ==> True + check res 0 200 + + putStrLn "\nExpecting success after 100 tests: x == x" + res <- quickCheckResult $ withDiscardRatio 2 $ \ x -> (x :: Int) == x + check res 100 0 + res <- quickCheckWithResult stdArgs{maxDiscardRatio = 2} $ \ x -> (x :: Int) == x + check res 100 0 + + -- The real ratio is 20, if 1 works or 40 doesn't it's + -- probably because we broke something! + let p50 = forAll (choose (1, 1000)) $ \ x -> (x :: Int) < 50 ==> True + putStrLn "\nExpecting failure (discard ratio 1): x < 50 ==> True" + quickCheckNo $ withDiscardRatio 1 p50 + quickCheckNoWith stdArgs{maxDiscardRatio = 1} p50 + putStrLn "\nExpecting success (discard ratio 40): x < 50 ==> True" + quickCheckYes $ withDiscardRatio 40 p50 + quickCheckYesWith stdArgs{maxDiscardRatio = 40} p50 diff --git a/tests/Misc.hs b/tests/Misc.hs --- a/tests/Misc.hs +++ b/tests/Misc.hs @@ -3,6 +3,8 @@ {-# LANGUAGE TemplateHaskell #-} import Test.QuickCheck import Test.QuickCheck.Random +import Data.Map +import Control.Monad prop_verbose :: Blind (Int -> Int -> Bool) -> Property prop_verbose (Blind p) = @@ -20,7 +22,29 @@ let [x, y, z] = failingTestCase res return (not (p (read x) (read y) (read z))) +prop_maxSize :: Property +prop_maxSize = withMaxSize 10 (forAll (arbitrary :: Gen Int) $ \ x -> abs x < 10) + +prop_cover :: Property +prop_cover = withMaxSuccess 1000 + $ checkCoverage + $ forAll (arbitrary :: Gen Int) + $ \ x -> cover 5 (x > 0) "positive" True + +-- Issue #382 +prop_discardCoverage :: Property +prop_discardCoverage = checkCoverage $ forAll (sized $ \ n -> pure n) $ \ x -> cover 10 True "label" $ x /= 99 ==> True + return [] main = do True <- $quickCheckAll - return () + Success{classes=cls} <- quickCheckResult $ classify False "A" $ classify True "B" True + [("A",0),("B",100)] <- return $ toList cls + Success{numTests=1000} <- quickCheckResult prop_cover + forM_ [const discard, const [discard], \ x -> discard : shrink x] $ \ shr -> do + Failure{reason="Falsified"} <- quickCheckResult $ forAllShrink arbitrary shr (odd :: Int -> Bool) + return () + -- These shouldn't crash + sample (discard :: Gen Int) + sample (oneof [discard, return 1] :: Gen Int) + sample (oneof [return (1, discard), return (1, 1)] :: Gen (Int, Int)) diff --git a/tests/Strictness.hs b/tests/Strictness.hs new file mode 100644 --- /dev/null +++ b/tests/Strictness.hs @@ -0,0 +1,42 @@ +-- Strictness tests. + +{-# LANGUAGE CPP, TemplateHaskell #-} +import Test.QuickCheck + +import Control.Exception (Exception (..), throw) + +#if MIN_VERSION_containers(0,5,0) +import Control.Exception (evaluate, try) +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as Map +#endif + +data Thunk + +instance Arbitrary Thunk where + arbitrary = throw ThunkError + +instance Show Thunk where + show _ = "Thunk" + +data ThunkError = ThunkError deriving Show + +instance Exception ThunkError + +prop_strictMap :: Property +#if MIN_VERSION_containers(0,5,0) +prop_strictMap = again . ioProperty $ do + m <- generate arbitrary + result <- try $ evaluate m :: IO (Either ThunkError (Map Int Thunk)) + pure $ case result of + Right _ | not (Map.null m) -> counterexample ("Thunks in Map: " ++ show m) False + _ -> property True +#else +prop_strictMap = once $ property True +#endif + +return [] +main :: IO () +main = do + True <- $quickCheckAll + return ()