diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,7 +1,8 @@ -Copyright (c) 2000-2016, Koen Claessen +(The following is the 3-clause BSD license.) + +Copyright (c) 2000-2017, Koen Claessen Copyright (c) 2006-2008, Björn Bringert -Copyright (c) 2009-2016, Nick Smallbone -All rights reserved. +Copyright (c) 2009-2017, 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 --- a/QuickCheck.cabal +++ b/QuickCheck.cabal @@ -1,35 +1,47 @@ Name: QuickCheck -Version: 2.9.2 +Version: 2.10 Cabal-Version: >= 1.8 Build-type: Simple License: BSD3 License-file: LICENSE -Extra-source-files: README changelog -Copyright: 2000-2016 Koen Claessen, 2006-2008 Björn Bringert, 2009-2016 Nick Smallbone +Copyright: 2000-2017 Koen Claessen, 2006-2008 Björn Bringert, 2009-2017 Nick Smallbone Author: Koen Claessen -Maintainer: QuickCheck developers -Bug-reports: mailto:quickcheck@projects.haskell.org -Tested-with: GHC >= 7 +Maintainer: Nick Smallbone ; see also QuickCheck mailing list (https://groups.google.com/forum/#!forum/haskell-quickcheck) +Bug-reports: https://github.com/nick8325/quickcheck/issues +Tested-with: GHC == 7.0.4, GHC == 7.2.2, GHC >= 7.4 Homepage: https://github.com/nick8325/quickcheck Category: Testing Synopsis: Automatic testing of Haskell programs Description: QuickCheck is a library for random testing of program properties. . - The programmer provides a specification of the program, in - the form of properties which functions should satisfy, and - QuickCheck then tests that the properties hold in a large number - of randomly generated cases. + The programmer provides a specification of the program, in the form of + properties which functions should satisfy, and QuickCheck then tests that the + properties hold in a large number of randomly generated cases. . - Specifications are expressed in - Haskell, using combinators defined in the QuickCheck library. - QuickCheck provides combinators to define properties, observe - the distribution of test data, and define test - data generators. + Specifications are expressed in Haskell, using combinators defined in the + QuickCheck library. QuickCheck provides combinators to define properties, + observe the distribution of test data, and define test data generators. . - You can find a (slightly out-of-date but useful) manual at - . + The + explains how to write generators and properties; + it is out-of-date in some details but still full of useful advice. + . + A user of QuickCheck has written an unofficial, but detailed, tutorial which + you can find at + . +extra-source-files: + README + changelog + examples/Heap.hs + examples/Heap_Program.hs + examples/Heap_ProgramAlgebraic.hs + examples/Lambda.hs + examples/Merge.hs + examples/Set.hs + examples/Simple.hs + source-repository head type: git location: https://github.com/nick8325/quickcheck @@ -37,7 +49,7 @@ source-repository this type: git location: https://github.com/nick8325/quickcheck - tag: 2.9.2 + tag: 2.10 flag templateHaskell Description: Build Test.QuickCheck.All, which uses Template Haskell. @@ -65,9 +77,9 @@ -- GHC-specific modules. if impl(ghc) Exposed-Modules: Test.QuickCheck.Function - Build-depends: transformers >= 0.2 + Build-depends: transformers >= 0.3, deepseq else - cpp-options: -DNO_TRANSFORMERS + cpp-options: -DNO_TRANSFORMERS -DNO_DEEPSEQ if impl(ghc) && flag(templateHaskell) Build-depends: template-haskell >= 2.4 @@ -76,6 +88,9 @@ else cpp-options: -DNO_TEMPLATE_HASKELL + if !impl(ghc >= 7.4) + cpp-options: -DNO_CTYPES + -- The new generics appeared in GHC 7.2... if impl(ghc < 7.2) cpp-options: -DNO_GENERICS @@ -93,19 +108,11 @@ else cpp-options: -DNO_TF_RANDOM - if impl(ghc) - if impl(ghc < 7.10) - -- `Numeric.Natural` is available in base only since GHC 7.10 / base 4.8 - build-depends: nats>=1 - else - cpp-options: -DNO_NATURALS + if !impl(ghc >= 7.6) + cpp-options: -DNO_POLYKINDS - if impl(ghc) - -- 'Data.List.NonEmpty' is available in base only since GHC 8.0 / base 4.9 - if impl(ghc < 8.0) - build-depends: semigroups >=0.9 - else - cpp-options: -DNO_NONEMPTY + if !impl(ghc >= 8.0) + cpp-options: -DNO_MONADFAIL -- Switch off most optional features on non-GHC systems. if !impl(ghc) @@ -131,23 +138,16 @@ hs-source-dirs: examples main-is: Heap.hs - build-depends: - base, - containers, - QuickCheck == 2.9.2, - template-haskell >= 2.4, - test-framework >= 0.4 && < 0.9 - if flag(templateHaskell) - Buildable: True - else + build-depends: base, QuickCheck + if !flag(templateHaskell) Buildable: False Test-Suite test-quickcheck-gcoarbitrary type: exitcode-stdio-1.0 hs-source-dirs: tests main-is: GCoArbitraryExample.hs - build-depends: base, QuickCheck == 2.9.2 - if impl(ghc < 7.2) + build-depends: base, QuickCheck + if !impl(ghc >= 7.2) buildable: False if impl(ghc >= 7.2) && impl(ghc < 7.6) build-depends: ghc-prim @@ -156,7 +156,7 @@ type: exitcode-stdio-1.0 hs-source-dirs: tests main-is: Generators.hs - build-depends: base, QuickCheck == 2.9.2 + build-depends: base, QuickCheck if !flag(templateHaskell) Buildable: False @@ -164,8 +164,8 @@ type: exitcode-stdio-1.0 hs-source-dirs: tests main-is: GShrinkExample.hs - build-depends: base, QuickCheck == 2.9.2 - if impl(ghc < 7.2) + build-depends: base, QuickCheck + if !impl(ghc >= 7.2) buildable: False if impl(ghc >= 7.2) && impl(ghc < 7.6) build-depends: ghc-prim diff --git a/README b/README --- a/README +++ b/README @@ -4,11 +4,5 @@ $ cabal install -Please report bugs to the QuickCheck mailing list at -quickcheck@projects.haskell.org. - -If you get errors about Template Haskell, try - -$ cabal install -f-templateHaskell - -but please report this as a bug. +There is a Google group for user discussion and questions at +https://groups.google.com/forum/#!forum/haskell-quickcheck. diff --git a/Test/QuickCheck.hs b/Test/QuickCheck.hs --- a/Test/QuickCheck.hs +++ b/Test/QuickCheck.hs @@ -1,74 +1,42 @@ -{-| For further information see the . +{-| +The +gives detailed information about using QuickCheck effectively. -To use QuickCheck to check a property, first define a function -expressing that property (functions expressing properties under test -tend to be prefixed with @prop_@). Testing that @n + m = m + n@ holds -for @Integer@s one might write: +To start using QuickCheck, write down your property as a function returning @Bool@. +For example, to check that reversing a list twice gives back the same list you can write: @ import Test.QuickCheck -prop_commutativeAdd :: Integer -> Integer -> Bool -prop_commutativeAdd n m = n + m == m + n +prop_reverse :: [Int] -> Bool +prop_reverse xs = reverse (reverse xs) == xs @ -and testing: - ->>> quickCheck prop_commutativeAdd -+++ OK, passed 100 tests. - -which tests @prop_commutativeAdd@ on 100 random @(Integer, Integer)@ pairs. - -'verboseCheck' can be used to see the actual values generated: +You can then use QuickCheck to test @prop_reverse@ on 100 random lists: ->>> verboseCheck prop_commutativeAdd -Passed: -0 -0 - …98 tests omitted… -Passed: --68 -6 +>>> quickCheck prop_reverse +++ OK, passed 100 tests. -and if more than 100 tests are needed the number of tests can be -increased by updating the 'stdArgs' record: - ->>> quickCheckWith stdArgs { maxSuccess = 500 } prop_commutativeAdd -+++ OK, passed 500 tests. - -To let QuickCheck generate values of your own data type an 'Arbitrary' -instance must be defined: - -@ -data Point = MkPoint Int Int deriving Eq - -instance Arbitrary Point where - arbitrary = do - x <- 'arbitrary' - y <- arbitrary - return (MkPoint x y) - -swapPoint :: Point -> Point -swapPoint (MkPoint x y) = MkPoint y x - --- swapPoint . swapPoint = id -prop_swapInvolution point = swapPoint (swapPoint point) == point -@ +To run more tests you can use the 'withMaxSuccess' combinator: ->>> quickCheck prop_swapInvolution -+++ OK, passed 100 tests. +>>> quickCheck (withMaxSuccess 10000 prop_reverse) ++++ OK, passed 10000 tests. -See "Test.QuickCheck.Function" for generating random shrinkable, -showable functions used for testing higher-order functions and -"Test.QuickCheck.Monadic" for testing impure or monadic code -(e.g. effectful code in 'IO'). +To use QuickCheck on your own data types you will need to write 'Arbitrary' +instances for those types. See the + for +details about how to do that. +This module exports most of QuickCheck's functionality, but see also +"Test.QuickCheck.Monadic" which helps with testing impure or monadic code. -} {-# LANGUAGE CPP #-} #ifndef NO_SAFE_HASKELL {-# LANGUAGE Safe #-} #endif +#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 708 +{-# LANGUAGE PatternSynonyms #-} +#endif module Test.QuickCheck ( -- * Running tests @@ -103,9 +71,11 @@ , elements , growingElements , sized + , getSize , resize , scale , suchThat + , suchThatMap , suchThatMaybe , listOf , listOf1 @@ -127,6 +97,14 @@ , Arbitrary(..) , CoArbitrary(..) + -- ** Unary and Binary classes + , Arbitrary1(..) + , arbitrary1 + , shrink1 + , Arbitrary2(..) + , arbitrary2 + , shrink2 + -- ** Helper functions for implementing arbitrary , arbitrarySizedIntegral , arbitrarySizedNatural @@ -135,6 +113,9 @@ , arbitraryBoundedIntegral , arbitraryBoundedRandom , arbitraryBoundedEnum + , arbitraryUnicodeChar + , arbitraryASCIIChar + , arbitraryPrintableChar -- ** Helper functions for implementing shrink #ifndef NO_GENERICS , genericCoarbitrary @@ -144,6 +125,8 @@ #endif , shrinkNothing , shrinkList + , shrinkMap + , shrinkMapBy , shrinkIntegral , shrinkRealFrac -- ** Helper functions for implementing coarbitrary @@ -170,7 +153,23 @@ , Shrinking(..) , ShrinkState(..) #endif + , ASCIIString(..) + , UnicodeString(..) + , PrintableString(..) + -- ** Functions + , Fun + , applyFun + , applyFun2 + , applyFun3 +#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 708 + , pattern Fn + , pattern Fn2 + , pattern Fn3 +#endif + , Function (..) + , functionMap + -- * Properties , Property, Testable(..) -- ** Property combinators @@ -179,11 +178,15 @@ , shrinking , (==>) , (===) +#ifndef NO_DEEPSEQ + , total +#endif , ioProperty -- *** Controlling property execution , verbose , once , again + , withMaxSuccess , within , noShrinking -- *** Conjunction and disjunction @@ -218,8 +221,8 @@ import Test.QuickCheck.Modifiers import Test.QuickCheck.Property hiding ( Result(..) ) import Test.QuickCheck.Test -import Test.QuickCheck.Text import Test.QuickCheck.Exception +import Test.QuickCheck.Function #ifndef NO_TEMPLATE_HASKELL import Test.QuickCheck.All #endif diff --git a/Test/QuickCheck/Arbitrary.hs b/Test/QuickCheck/Arbitrary.hs --- a/Test/QuickCheck/Arbitrary.hs +++ b/Test/QuickCheck/Arbitrary.hs @@ -1,13 +1,20 @@ -- | Type classes for random generation of values. {-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleContexts #-} #ifndef NO_GENERICS {-# LANGUAGE DefaultSignatures, FlexibleContexts, TypeOperators #-} {-# LANGUAGE FlexibleInstances, KindSignatures, ScopedTypeVariables #-} {-# LANGUAGE MultiParamTypeClasses #-} -#if __GLASGOW_HASKELL__ < 710 +#if __GLASGOW_HASKELL__ >= 710 +#define OVERLAPPING_ {-# OVERLAPPING #-} +#else {-# LANGUAGE OverlappingInstances #-} +#define OVERLAPPING_ #endif #endif +#ifndef NO_POLYKINDS +{-# LANGUAGE PolyKinds #-} +#endif #ifndef NO_SAFE_HASKELL {-# LANGUAGE Safe #-} #endif @@ -17,6 +24,14 @@ Arbitrary(..) , CoArbitrary(..) + -- ** Unary and Binary classes + , Arbitrary1(..) + , arbitrary1 + , shrink1 + , Arbitrary2(..) + , arbitrary2 + , shrink2 + -- ** Helper functions for implementing arbitrary , arbitrarySizedIntegral -- :: Integral a => Gen a , arbitrarySizedNatural -- :: Integral a => Gen a @@ -25,6 +40,10 @@ , arbitrarySizedFractional -- :: Fractional a => Gen a , arbitraryBoundedRandom -- :: (Bounded a, Random a) => Gen a , arbitraryBoundedEnum -- :: (Bounded a, Enum a) => Gen a + -- ** Generators for various kinds of character + , arbitraryUnicodeChar -- :: Gen Char + , arbitraryASCIIChar -- :: Gen Char + , arbitraryPrintableChar -- :: Gen Char -- ** Helper functions for implementing shrink #ifndef NO_GENERICS , genericShrink -- :: (Generic a, Arbitrary a, RecursivelyShrink (Rep a), GSubterms (Rep a) a) => a -> [a] @@ -34,6 +53,8 @@ #endif , shrinkNothing -- :: a -> [a] , shrinkList -- :: (a -> [a]) -> [a] -> [[a]] + , shrinkMap -- :: Arbitrary a -> (a -> b) -> (b -> a) -> b -> [b] + , shrinkMapBy -- :: (a -> b) -> (b -> a) -> (a -> [a]) -> b -> [b] , shrinkIntegral -- :: Integral a => a -> [a] , shrinkRealFrac -- :: RealFrac a => a -> [a] -- ** Helper functions for implementing coarbitrary @@ -57,6 +78,7 @@ import Data.Foldable(toList) import System.Random(Random) import Test.QuickCheck.Gen +import Test.QuickCheck.Random import Test.QuickCheck.Gen.Unsafe {- @@ -68,13 +90,15 @@ -} import Data.Char - ( chr - , ord + ( ord , isLower , isUpper , toLower , isDigit , isSpace + , isPrint + , generalCategory + , GeneralCategory(..) ) #ifndef NO_FIXED @@ -84,10 +108,6 @@ ) #endif -#ifndef NO_NATURALS -import Numeric.Natural -#endif - import Data.Ratio ( Ratio , (%) @@ -103,11 +123,6 @@ , nub ) -#ifndef NO_NONEMPTY -import Data.List.NonEmpty (NonEmpty (..), nonEmpty) -import Data.Maybe (mapMaybe) -#endif - import Data.Version (Version (..)) import Control.Monad @@ -120,6 +135,10 @@ 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 @@ -136,25 +155,52 @@ #ifndef NO_TRANSFORMERS import Data.Functor.Identity import Data.Functor.Constant +import Data.Functor.Compose +import Data.Functor.Product #endif -------------------------------------------------------------------------- -- ** class Arbitrary -- | Random generation and shrinking of values. +-- +-- QuickCheck provides @Arbitrary@ instances for most types in @base@, +-- except those which incur extra dependencies. +-- For a wider range of @Arbitrary@ instances see the +-- +-- package. class Arbitrary a where -- | A generator for values of the given type. + -- + -- It is worth spending time thinking about what sort of test data + -- you want - good generators are often the difference between + -- finding bugs and not finding them. You can use 'sample', + -- 'label' and 'classify' to check the quality of your test data. + -- + -- There is no generic @arbitrary@ implementation included because we don't + -- know how to make a high-quality one. If you want one, consider using the + -- package. + -- + -- The + -- goes into detail on how to write good generators. Make sure to look at it, + -- especially if your type is recursive! arbitrary :: Gen a -- | Produces a (possibly) empty list of all the possible - -- immediate shrinks of the given value. The default implementation - -- returns the empty list, so will not try to shrink the value. + -- immediate shrinks of the given value. -- + -- The default implementation returns the empty list, so will not try to + -- shrink the value. If your data type has no special invariants, you can + -- enable shrinking by defining @shrink = 'genericShrink'@, but by customising + -- the behaviour of @shrink@ you can often get simpler counterexamples. + -- -- Most implementations of 'shrink' should try at least three things: -- -- 1. Shrink a term to any of its immediate subterms. + -- You can use 'subterms' to do this. -- -- 2. Recursively apply 'shrink' to all immediate subterms. + -- You can use 'recursivelyShrink' to do this. -- -- 3. Type-specific shrinkings such as replacing a constructor by a -- simpler constructor. @@ -188,8 +234,7 @@ -- the three is fully shrunk. -- -- There is a fair bit of boilerplate in the code above. - -- We can avoid it with the help of some generic functions; - -- note that these only work on GHC 7.2 and above. + -- We can avoid it with the help of some generic functions. -- The function 'genericShrink' tries shrinking a term to all of its -- subterms and, failing that, recursively shrinks the subterms. -- Using it, we can define 'shrink' as: @@ -214,6 +259,30 @@ shrink :: a -> [a] shrink _ = [] +-- | Lifting of the 'Arbitrary' class to unary type constructors. +class Arbitrary1 f where + liftArbitrary :: Gen a -> Gen (f a) + liftShrink :: (a -> [a]) -> f a -> [f a] + liftShrink _ _ = [] + +arbitrary1 :: (Arbitrary1 f, Arbitrary a) => Gen (f a) +arbitrary1 = liftArbitrary arbitrary + +shrink1 :: (Arbitrary1 f, Arbitrary a) => f a -> [f a] +shrink1 = liftShrink shrink + +-- | Lifting of the 'Arbitrary' class to binary type constructors. +class Arbitrary2 f where + liftArbitrary2 :: Gen a -> Gen b -> Gen (f a b) + liftShrink2 :: (a -> [a]) -> (b -> [b]) -> f a b -> [f a b] + liftShrink2 _ _ _ = [] + +arbitrary2 :: (Arbitrary2 f, Arbitrary a, Arbitrary b) => Gen (f a b) +arbitrary2 = liftArbitrary2 arbitrary arbitrary + +shrink2 :: (Arbitrary2 f, Arbitrary a, Arbitrary b) => f a b -> [f a b] +shrink2 = liftShrink2 shrink shrink + #ifndef NO_GENERICS -- | Shrink a term to any of its immediate subterms, -- and also recursively shrink all subterms. @@ -314,18 +383,21 @@ gSubtermsIncl (M1 x) = gSubtermsIncl x -- This is the important case: We've found a term of the same type. -instance {-# OVERLAPPING #-} GSubtermsIncl (K1 i a) a where +instance OVERLAPPING_ GSubtermsIncl (K1 i a) a where gSubtermsIncl (K1 x) = [x] -instance {-# OVERLAPPING #-} GSubtermsIncl (K1 i a) b where +instance OVERLAPPING_ GSubtermsIncl (K1 i a) b where gSubtermsIncl (K1 _) = [] #endif -- instances +instance (CoArbitrary a) => Arbitrary1 ((->) a) where + liftArbitrary arbB = promote (`coarbitrary` arbB) + instance (CoArbitrary a, Arbitrary b) => Arbitrary (a -> b) where - arbitrary = promote (`coarbitrary` arbitrary) + arbitrary = arbitrary1 instance Arbitrary () where arbitrary = return () @@ -341,27 +413,37 @@ shrink LT = [EQ] shrink EQ = [] +instance Arbitrary1 Maybe where + liftArbitrary arb = frequency [(1, return Nothing), (3, liftM Just arb)] + + liftShrink shr (Just x) = Nothing : [ Just x' | x' <- shr x ] + liftShrink _ Nothing = [] + instance Arbitrary a => Arbitrary (Maybe a) where - arbitrary = frequency [(1, return Nothing), (3, liftM Just arbitrary)] + arbitrary = arbitrary1 + shrink = shrink1 - shrink (Just x) = Nothing : [ Just x' | x' <- shrink x ] - shrink _ = [] +instance Arbitrary2 Either where + liftArbitrary2 arbA arbB = oneof [liftM Left arbA, liftM Right arbB] + liftShrink2 shrA _ (Left x) = [ Left x' | x' <- shrA x ] + liftShrink2 _ shrB (Right y) = [ Right y' | y' <- shrB y ] + +instance Arbitrary a => Arbitrary1 (Either a) where + liftArbitrary = liftArbitrary2 arbitrary + liftShrink = liftShrink2 shrink + instance (Arbitrary a, Arbitrary b) => Arbitrary (Either a b) where - arbitrary = oneof [liftM Left arbitrary, liftM Right arbitrary] + arbitrary = arbitrary2 + shrink = shrink2 - shrink (Left x) = [ Left x' | x' <- shrink x ] - shrink (Right y) = [ Right y' | y' <- shrink y ] +instance Arbitrary1 [] where + liftArbitrary = listOf + liftShrink = shrinkList instance Arbitrary a => Arbitrary [a] where - arbitrary = listOf arbitrary - shrink xs = shrinkList shrink xs - -#ifndef NO_NONEMPTY -instance Arbitrary a => Arbitrary (NonEmpty a) where - arbitrary = liftM2 (:|) arbitrary arbitrary - shrink (x :| xs) = mapMaybe nonEmpty . shrinkList shrink $ x : xs -#endif + arbitrary = arbitrary1 + shrink = shrink1 -- | Shrink a list of values given a shrinking function for individual values. shrinkList :: (a -> [a]) -> [a] -> [[a]] @@ -405,15 +487,20 @@ shrink = shrinkRealFrac #endif -instance (Arbitrary a, Arbitrary b) - => Arbitrary (a,b) - where - arbitrary = liftM2 (,) arbitrary arbitrary +instance Arbitrary2 (,) where + liftArbitrary2 = liftM2 (,) + liftShrink2 shrA shrB (x, y) = + [ (x', y) | x' <- shrA x ] + ++ [ (x, y') | y' <- shrB y ] - shrink (x, y) = - [ (x', y) | x' <- shrink x ] - ++ [ (x, y') | y' <- shrink y ] +instance (Arbitrary a) => Arbitrary1 ((,) a) where + liftArbitrary = liftArbitrary2 arbitrary + liftShrink = liftShrink2 shrink +instance (Arbitrary a, Arbitrary b) => Arbitrary (a,b) where + arbitrary = arbitrary2 + shrink = shrink2 + instance (Arbitrary a, Arbitrary b, Arbitrary c) => Arbitrary (a,b,c) where @@ -517,12 +604,6 @@ arbitrary = arbitrarySizedIntegral shrink = shrinkIntegral -#ifndef NO_NATURALS -instance Arbitrary Natural where - arbitrary = arbitrarySizedNatural - shrink = shrinkIntegral -#endif - instance Arbitrary Int where arbitrary = arbitrarySizedIntegral shrink = shrinkIntegral @@ -564,22 +645,26 @@ shrink = shrinkIntegral instance Arbitrary Char where - arbitrary = chr `fmap` oneof [choose (0,127), choose (0,255)] - shrink c = filter (<. c) $ nub + arbitrary = + frequency + [(3, arbitraryASCIIChar), + (1, arbitraryUnicodeChar)] + + shrink c = filter (<. c) $ nub $ ['a','b','c'] - ++ [ toLower c | isUpper c ] - ++ ['A','B','C'] - ++ ['1','2','3'] - ++ [' ','\n'] - where - a <. b = stamp a < stamp b - stamp a = ( (not (isLower a) - , not (isUpper a) - , not (isDigit a)) - , (not (a==' ') - , not (isSpace a) - , a) - ) + ++ [ toLower c | isUpper c ] + ++ ['A','B','C'] + ++ ['1','2','3'] + ++ [' ','\n'] + where + a <. b = stamp a < stamp b + stamp a = ( (not (isLower a) + , not (isUpper a) + , not (isDigit a)) + , (not (a==' ') + , not (isSpace a) + , a) + ) instance Arbitrary Float where arbitrary = arbitrarySizedFractional @@ -589,44 +674,199 @@ arbitrary = arbitrarySizedFractional shrink = shrinkRealFrac +#ifndef NO_CTYPES +instance Arbitrary CChar where + arbitrary = CChar <$> arbitrary + shrink (CChar x) = CChar <$> shrink x + +instance Arbitrary CSChar where + arbitrary = CSChar <$> arbitrary + shrink (CSChar x) = CSChar <$> shrink x + +instance Arbitrary CUChar where + arbitrary = CUChar <$> arbitrary + shrink (CUChar x) = CUChar <$> shrink x + +instance Arbitrary CShort where + arbitrary = CShort <$> arbitrary + shrink (CShort x) = CShort <$> shrink x + +instance Arbitrary CUShort where + arbitrary = CUShort <$> arbitrary + shrink (CUShort x) = CUShort <$> shrink x + +instance Arbitrary CInt where + arbitrary = CInt <$> arbitrary + shrink (CInt x) = CInt <$> shrink x + +instance Arbitrary CUInt where + arbitrary = CUInt <$> arbitrary + shrink (CUInt x) = CUInt <$> shrink x + +instance Arbitrary CLong where + arbitrary = CLong <$> arbitrary + shrink (CLong x) = CLong <$> shrink x + +instance Arbitrary CULong where + arbitrary = CULong <$> arbitrary + shrink (CULong x) = CULong <$> shrink x + +instance Arbitrary CPtrdiff where + arbitrary = CPtrdiff <$> arbitrary + shrink (CPtrdiff x) = CPtrdiff <$> shrink x + +instance Arbitrary CSize where + arbitrary = CSize <$> arbitrary + shrink (CSize x) = CSize <$> shrink x + +instance Arbitrary CWchar where + arbitrary = CWchar <$> arbitrary + shrink (CWchar x) = CWchar <$> shrink x + +instance Arbitrary CSigAtomic where + arbitrary = CSigAtomic <$> arbitrary + shrink (CSigAtomic x) = CSigAtomic <$> shrink x + +instance Arbitrary CLLong where + arbitrary = CLLong <$> arbitrary + shrink (CLLong x) = CLLong <$> shrink x + +instance Arbitrary CULLong where + arbitrary = CULLong <$> arbitrary + shrink (CULLong x) = CULLong <$> shrink x + +instance Arbitrary CIntPtr where + arbitrary = CIntPtr <$> arbitrary + shrink (CIntPtr x) = CIntPtr <$> shrink x + +instance Arbitrary CUIntPtr where + arbitrary = CUIntPtr <$> arbitrary + shrink (CUIntPtr x) = CUIntPtr <$> shrink x + +instance Arbitrary CIntMax where + arbitrary = CIntMax <$> arbitrary + shrink (CIntMax x) = CIntMax <$> shrink x + +instance Arbitrary CUIntMax where + arbitrary = CUIntMax <$> arbitrary + shrink (CUIntMax x) = CUIntMax <$> shrink x + +instance Arbitrary CClock where + arbitrary = CClock <$> arbitrary + shrink (CClock x) = CClock <$> shrink x + +instance Arbitrary CTime where + arbitrary = CTime <$> arbitrary + shrink (CTime x) = CTime <$> shrink x + +instance Arbitrary CUSeconds where + arbitrary = CUSeconds <$> arbitrary + shrink (CUSeconds x) = CUSeconds <$> shrink x + +instance Arbitrary CSUSeconds where + arbitrary = CSUSeconds <$> arbitrary + shrink (CSUSeconds x) = CSUSeconds <$> shrink x + +instance Arbitrary CFloat where + arbitrary = CFloat <$> arbitrary + shrink (CFloat x) = CFloat <$> shrink x + +instance Arbitrary CDouble where + arbitrary = CDouble <$> arbitrary + shrink (CDouble x) = CDouble <$> shrink x +#endif + -- Arbitrary instances for container types 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 instance (Ord k, Arbitrary k, Arbitrary v) => Arbitrary (Map.Map k v) where - arbitrary = fmap Map.fromList arbitrary - shrink = map Map.fromList . shrink . Map.toList + arbitrary = arbitrary1 + shrink = shrink1 instance Arbitrary IntSet.IntSet where arbitrary = fmap IntSet.fromList arbitrary shrink = map IntSet.fromList . shrink . IntSet.toList +instance Arbitrary1 IntMap.IntMap where + liftArbitrary = fmap IntMap.fromList . liftArbitrary . liftArbitrary + liftShrink shr = map IntMap.fromList . liftShrink (liftShrink shr) . IntMap.toList instance Arbitrary a => Arbitrary (IntMap.IntMap a) where - arbitrary = fmap IntMap.fromList arbitrary - shrink = map IntMap.fromList . shrink . IntMap.toList + arbitrary = arbitrary1 + shrink = shrink1 +instance Arbitrary1 Sequence.Seq where + liftArbitrary = fmap Sequence.fromList . liftArbitrary + liftShrink shr = map Sequence.fromList . liftShrink shr . toList instance Arbitrary a => Arbitrary (Sequence.Seq a) where - arbitrary = fmap Sequence.fromList arbitrary - shrink = map Sequence.fromList . shrink . toList + arbitrary = arbitrary1 + shrink = shrink1 -- Arbitrary instance for Ziplist +instance Arbitrary1 ZipList where + liftArbitrary = fmap ZipList . liftArbitrary + liftShrink shr = map ZipList . liftShrink shr . getZipList instance Arbitrary a => Arbitrary (ZipList a) where - arbitrary = fmap ZipList arbitrary - shrink = map ZipList . shrink . getZipList + arbitrary = arbitrary1 + shrink = shrink1 #ifndef NO_TRANSFORMERS -- Arbitrary instance for transformers' Functors +instance Arbitrary1 Identity where + liftArbitrary = fmap Identity + liftShrink shr = map Identity . shr . runIdentity instance Arbitrary a => Arbitrary (Identity a) where - arbitrary = fmap Identity arbitrary - shrink = map Identity . shrink . runIdentity + arbitrary = arbitrary1 + shrink = shrink1 +instance Arbitrary2 Constant where + liftArbitrary2 arbA _ = fmap Constant arbA + liftShrink2 shrA _ = fmap Constant . shrA . getConstant +instance Arbitrary a => Arbitrary1 (Constant a) where + liftArbitrary = liftArbitrary2 arbitrary + liftShrink = liftShrink2 shrink +-- Have to be defined explicitly, as Constant is kind polymorphic instance Arbitrary a => Arbitrary (Constant a b) where arbitrary = fmap Constant arbitrary shrink = map Constant . shrink . getConstant + +instance (Arbitrary1 f, Arbitrary1 g) => Arbitrary1 (Product f g) where + liftArbitrary arb = liftM2 Pair (liftArbitrary arb) (liftArbitrary arb) + liftShrink shr (Pair f g) = + [ Pair f' g | f' <- liftShrink shr f ] ++ + [ Pair f g' | g' <- liftShrink shr g ] +instance (Arbitrary1 f, Arbitrary1 g, Arbitrary a) => Arbitrary (Product f g a) where + arbitrary = arbitrary1 + shrink = shrink1 + +instance (Arbitrary1 f, Arbitrary1 g) => Arbitrary1 (Compose f g) where + liftArbitrary = fmap Compose . liftArbitrary . liftArbitrary + liftShrink shr = map Compose . liftShrink (liftShrink shr) . getCompose +instance (Arbitrary1 f, Arbitrary1 g, Arbitrary a) => Arbitrary (Compose f g a) where + arbitrary = arbitrary1 + shrink = shrink1 #endif -- Arbitrary instance for Const +instance Arbitrary2 Const where + liftArbitrary2 arbA _ = fmap Const arbA + liftShrink2 shrA _ = fmap Const . shrA . getConst +instance Arbitrary a => Arbitrary1 (Const a) where + liftArbitrary = liftArbitrary2 arbitrary + liftShrink = liftShrink2 shrink +-- Have to be defined explicitly, as Const is kind polymorphic instance Arbitrary a => Arbitrary (Const a b) where arbitrary = fmap Const arbitrary shrink = map Const . shrink . getConst +instance Arbitrary (m a) => Arbitrary (WrappedMonad m a) where + arbitrary = WrapMonad <$> arbitrary + shrink (WrapMonad a) = map WrapMonad (shrink a) + +instance Arbitrary (a b c) => Arbitrary (WrappedArrow a b c) where + arbitrary = WrapArrow <$> arbitrary + shrink (WrapArrow a) = map WrapArrow (shrink a) + -- Arbitrary instances for Monoid instance Arbitrary a => Arbitrary (Monoid.Dual a) where arbitrary = fmap Monoid.Dual arbitrary @@ -688,6 +928,17 @@ , all (>=0) xs' ] +instance Arbitrary QCGen where + arbitrary = MkGen (\g _ -> g) + +instance Arbitrary ExitCode where + arbitrary = frequency [(1, return ExitSuccess), (3, liftM ExitFailure arbitrary)] + + shrink (ExitFailure x) = ExitSuccess : [ ExitFailure x' | x' <- shrink x ] + shrink _ = [] + + + -- ** Helper functions for implementing arbitrary -- | Generates an integral number. The number can be positive or negative @@ -759,12 +1010,46 @@ n <- choose (toInteger mn `max` (-k), toInteger mx `min` k) return (fromInteger n) +-- ** Generators for various kinds of character + +-- | Generates any Unicode character (but not a surrogate) +arbitraryUnicodeChar :: Gen Char +arbitraryUnicodeChar = + arbitraryBoundedEnum `suchThat` (not . isSurrogate) + where + isSurrogate c = generalCategory c == Surrogate + +-- | Generates a random ASCII character (0-127). +arbitraryASCIIChar :: Gen Char +arbitraryASCIIChar = choose ('\0', '\127') + +-- | Generates a printable Unicode character. +arbitraryPrintableChar :: Gen Char +arbitraryPrintableChar = arbitrary `suchThat` isPrint + -- ** Helper functions for implementing shrink -- | Returns no shrinking alternatives. shrinkNothing :: a -> [a] shrinkNothing _ = [] +-- | Map a shrink function to another domain. This is handy if your data type +-- has special invariants, but is /almost/ isomorphic to some other type. +-- +-- @ +-- shrinkOrderedList :: (Ord a, Arbitrary a) => [a] -> [[a]] +-- shrinkOrderedList = shrinkMap sort id +-- +-- shrinkSet :: (Ord a, Arbitrary a) => Set a -> Set [a] +-- shrinkSet = shrinkMap fromList toList +-- @ +shrinkMap :: Arbitrary a => (a -> b) -> (b -> a) -> b -> [b] +shrinkMap f g = shrinkMapBy f g shrink + +-- | Non-overloaded version of `shrinkMap`. +shrinkMapBy :: (a -> b) -> (b -> a) -> (a -> [a]) -> b -> [b] +shrinkMapBy f g shr = map f . shr . g + -- | Shrink an integral number. shrinkIntegral :: Integral a => a -> [a] shrinkIntegral x = @@ -892,11 +1177,6 @@ coarbitrary [] = variant 0 coarbitrary (x:xs) = variant 1 . coarbitrary (x,xs) -#ifndef NO_NONEMPTY -instance CoArbitrary a => CoArbitrary (NonEmpty a) where - coarbitrary (x :| xs) = coarbitrary (x, xs) -#endif - instance (Integral a, CoArbitrary a) => CoArbitrary (Ratio a) where coarbitrary r = coarbitrary (numerator r,denominator r) @@ -943,11 +1223,6 @@ instance CoArbitrary Integer where coarbitrary = coarbitraryIntegral -#ifndef NO_NATURALS -instance CoArbitrary Natural where - coarbitrary = coarbitraryIntegral -#endif - instance CoArbitrary Int where coarbitrary = coarbitraryIntegral @@ -1084,7 +1359,7 @@ orderedList :: (Ord a, Arbitrary a) => Gen [a] orderedList = sort `fmap` arbitrary --- | Generate an infinite list. +-- | Generates an infinite list. infiniteList :: Arbitrary a => Gen [a] infiniteList = infiniteListOf arbitrary diff --git a/Test/QuickCheck/Exception.hs b/Test/QuickCheck/Exception.hs --- a/Test/QuickCheck/Exception.hs +++ b/Test/QuickCheck/Exception.hs @@ -56,7 +56,19 @@ tryEvaluate x = tryEvaluateIO (return x) tryEvaluateIO :: IO a -> IO (Either AnException a) -tryEvaluateIO m = E.try (m >>= E.evaluate) +tryEvaluateIO m = E.tryJust notAsync (m >>= E.evaluate) + where + notAsync :: E.SomeException -> Maybe AnException +#if MIN_VERSION_base(4,7,0) + notAsync e = case E.fromException e of + Just (E.SomeAsyncException _) -> Nothing + Nothing -> Just e +#else + notAsync e = case E.fromException e :: Maybe E.AsyncException of + Just _ -> Nothing + Nothing -> Just e +#endif + --tryEvaluateIO m = Right `fmap` m evaluate :: a -> IO a diff --git a/Test/QuickCheck/Function.hs b/Test/QuickCheck/Function.hs --- a/Test/QuickCheck/Function.hs +++ b/Test/QuickCheck/Function.hs @@ -1,13 +1,19 @@ {-# LANGUAGE TypeOperators, GADTs, CPP #-} - +#ifndef NO_SAFE_HASKELL +{-# LANGUAGE Safe #-} +#endif #if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 708 -{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE PatternSynonyms, ViewPatterns #-} #endif #ifndef NO_GENERICS {-# LANGUAGE DefaultSignatures, FlexibleContexts #-} #endif +#ifndef NO_POLYKINDS +{-# LANGUAGE PolyKinds #-} +#endif + -- | Generation of random shrinkable, showable functions. -- See the paper \"Shrinking and showing functions\" by Koen Claessen. -- @@ -28,7 +34,10 @@ -- See the @'Function' [a]@ instance for an example of the latter. module Test.QuickCheck.Function ( Fun(..) + , applyFun , apply + , applyFun2 + , applyFun3 , (:->) , Function(..) , functionMap @@ -38,6 +47,8 @@ , functionBoundedEnum #if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 708 , pattern Fn + , pattern Fn2 + , pattern Fn3 #endif ) where @@ -51,16 +62,13 @@ import Data.Char import Data.Word import Data.List( intersperse ) -import Data.Maybe( fromJust ) import Data.Ratio -import Control.Arrow( (&&&) ) import qualified Data.IntMap as IntMap import qualified Data.IntSet as IntSet import qualified Data.Map as Map import qualified Data.Set as Set import qualified Data.Sequence as Sequence import Data.Int -import Data.Word import Data.Complex import Data.Foldable(toList) @@ -68,14 +76,6 @@ import Data.Fixed #endif -#ifndef NO_NATURALS -import Numeric.Natural -#endif - -#ifndef NO_NONEMPTY -import Data.List.NonEmpty(NonEmpty(..)) -#endif - #ifndef NO_GENERICS import GHC.Generics hiding (C) #endif @@ -135,6 +135,12 @@ -------------------------------------------------------------------------- -- Function +-- | The class @Function a@ is used for random generation of showable +-- functions of type @a -> b@. +-- +-- There is a default implementation for 'function', which you can use +-- if your type has structural equality. Otherwise, you can normally +-- use 'functionMap' or 'functionShow'. class Function a where function :: (a->b) -> (a:->b) #ifndef NO_GENERICS @@ -250,6 +256,9 @@ instance Function Int where function = functionIntegral +instance Function Word where + function = functionIntegral + instance Function Char where function = functionMap ord chr @@ -272,14 +281,6 @@ h (Left True) = EQ h (Right _) = GT -#ifndef NO_NONEMPTY -instance Function a => Function (NonEmpty a) where - function = functionMap g h - where - g (x :| xs) = (x, xs) - h (x, xs) = x :| xs -#endif - instance (Integral a, Function a) => Function (Ratio a) where function = functionMap g h where @@ -312,11 +313,6 @@ instance Function a => Function (Sequence.Seq a) where function = functionMap toList Sequence.fromList -#ifndef NO_NATURALS -instance Function Natural where - function = functionIntegral -#endif - instance Function Int8 where function = functionBoundedEnum @@ -449,26 +445,77 @@ -------------------------------------------------------------------------- -- the Fun modifier -data Fun a b = Fun (a :-> b, b, Bool) (a -> b) +-- | Generation of random shrinkable, showable functions. +-- +-- To generate random values of type @'Fun' a b@, +-- you must have an instance @'Function' a@. +-- +-- See also 'applyFun', and 'Fn' with GHC >= 7.8. +data Fun a b = Fun (a :-> b, b, Shrunk) (a -> b) +data Shrunk = Shrunk | NotShrunk deriving Eq #if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 708 --- | A pattern for matching against the function only: +-- | A modifier for testing functions. -- -- > prop :: Fun String Integer -> Bool -- > prop (Fn f) = f "banana" == f "monkey" -- > || f "banana" == f "elephant" -pattern Fn f <- Fun _ f +#if __GLASGOW_HASKELL__ >= 800 +pattern Fn :: (a -> b) -> Fun a b #endif +pattern Fn f <- (applyFun -> f) +-- | A modifier for testing binary functions. +-- +-- > prop_zipWith :: Fun (Int, Bool) Char -> [Int] -> [Bool] -> Bool +-- > prop_zipWith (Fn2 f) xs ys = zipWith f xs ys == [ f x y | (x, y) <- zip xs ys] +#if __GLASGOW_HASKELL__ >= 800 +pattern Fn2 :: (a -> b -> c) -> Fun (a, b) c +#endif +pattern Fn2 f <- (applyFun2 -> f) + +-- | A modifier for testing ternary functions. +#if __GLASGOW_HASKELL__ >= 800 +pattern Fn3 :: (a -> b -> c -> d) -> Fun (a, b, c) d +#endif +pattern Fn3 f <- (applyFun3 -> f) +#endif + mkFun :: (a :-> b) -> b -> Fun a b -mkFun p d = Fun (p, d, False) (abstract p d) +mkFun p d = Fun (p, d, NotShrunk) (abstract p d) +-- | Alias to 'applyFun'. apply :: Fun a b -> (a -> b) -apply (Fun _ f) = f +apply = applyFun +-- | Extracts the value of a function. +-- +-- 'Fn' is the pattern equivalent of this function. +-- +-- > prop :: Fun String Integer -> Bool +-- > prop f = applyFun f "banana" == applyFun f "monkey" +-- > || applyFun f "banana" == applyFun f "elephant" +applyFun :: Fun a b -> (a -> b) +applyFun (Fun _ f) = f + +-- | Extracts the value of a binary function. +-- +-- 'Fn2' is the pattern equivalent of this function. +-- +-- > prop_zipWith :: Fun (Int, Bool) Char -> [Int] -> [Bool] -> Bool +-- > prop_zipWith f xs ys = zipWith (applyFun2 f) xs ys == [ applyFun2 f x y | (x, y) <- zip xs ys] +-- +applyFun2 :: Fun (a, b) c -> (a -> b -> c) +applyFun2 (Fun _ f) a b = f (a, b) + +-- | Extracts the value of a ternary function. 'Fn3' is the +-- pattern equivalent of this function. +applyFun3 :: Fun (a, b, c) d -> (a -> b -> c -> d) +applyFun3 (Fun _ f) a b c = f (a, b, c) + instance (Show a, Show b) => Show (Fun a b) where - show (Fun (_, _, False) _) = "" - show (Fun (p, d, True) _) = showFunction p (Just d) + show (Fun (_, _, NotShrunk) _) = "" + show (Fun (p, d, Shrunk) _) = showFunction p (Just d) instance (Function a, CoArbitrary a, Arbitrary b) => Arbitrary (Fun a b) where arbitrary = @@ -476,9 +523,9 @@ d <- arbitrary return (mkFun p d) - shrink (Fun (p, d, b) f) = + shrink (Fun (p, d, s) f) = [ mkFun p' d' | (p', d') <- shrink (p, d) ] ++ - [ Fun (p, d, True) f | not b ] + [ Fun (p, d, Shrunk) f | s == NotShrunk ] -------------------------------------------------------------------------- -- the end. diff --git a/Test/QuickCheck/Gen.hs b/Test/QuickCheck/Gen.hs --- a/Test/QuickCheck/Gen.hs +++ b/Test/QuickCheck/Gen.hs @@ -10,37 +10,33 @@ import System.Random ( Random - , StdGen , random , randomR , split - , newStdGen ) import Control.Monad - ( liftM - , ap + ( ap , replicateM , filterM ) import Control.Applicative - ( Applicative(..) - , (<$>) - ) - -import Control.Arrow - ( second - ) + ( Applicative(..) ) import Test.QuickCheck.Random import Data.List import Data.Ord +import Data.Maybe -------------------------------------------------------------------------- -- ** Generator type -- | A generator for values of type @a@. +-- +-- The third-party package +-- +-- provides a monad transformer version of @GenT@. 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'. @@ -60,9 +56,10 @@ MkGen m >>= k = MkGen (\r n -> - let (r1,r2) = split r - MkGen m' = k (m r1 n) - in m' r2 n + case split r of + (r1, r2) -> + let MkGen m' = k (m r1 n) + in m' r2 n ) -------------------------------------------------------------------------- @@ -73,9 +70,35 @@ variant k (MkGen g) = MkGen (\r n -> g (variantQCGen k r) n) -- | Used to construct generators that depend on the size parameter. +-- +-- For example, 'listOf', which uses the size parameter as an upper bound on +-- length of lists it generates, can be defined like this: +-- +-- > listOf :: Gen a -> Gen [a] +-- > listOf gen = sized $ \n -> +-- > do k <- choose (0,n) +-- > vectorOf k gen +-- +-- You can also do this using 'getSize'. sized :: (Int -> Gen a) -> Gen a sized f = MkGen (\r n -> let MkGen m = f n in m r n) +-- | Generates the size parameter. Used to construct generators that depend on +-- the size parameter. +-- +-- For example, 'listOf', which uses the size parameter as an upper bound on +-- length of lists it generates, can be defined like this: +-- +-- > listOf :: Gen a -> Gen [a] +-- > listOf gen = do +-- > n <- getSize +-- > k <- choose (0,n) +-- > vectorOf k gen +-- +-- You can also do this using 'sized'. +getSize :: Gen Int +getSize = sized pure + -- | Overrides the size parameter. Returns a generator which uses -- the given size instead of the runtime-size parameter. resize :: Int -> Gen a -> Gen a @@ -124,7 +147,14 @@ Just x -> return x Nothing -> sized (\n -> resize (n+1) (gen `suchThat` p)) +-- | Generates a value for which the given function returns a 'Just', and then +-- applies the function. +suchThatMap :: Gen a -> (a -> Maybe b) -> Gen b +gen `suchThatMap` f = + fmap fromJust $ fmap f gen `suchThat` isJust + -- | Tries to generate a value that satisfies a predicate. +-- If it fails to do so after enough attempts, returns @Nothing@. suchThatMaybe :: Gen a -> (a -> Bool) -> Gen (Maybe a) gen `suchThatMaybe` p = sized (try 0 . max 1) where diff --git a/Test/QuickCheck/Gen/Unsafe.hs b/Test/QuickCheck/Gen/Unsafe.hs --- a/Test/QuickCheck/Gen/Unsafe.hs +++ b/Test/QuickCheck/Gen/Unsafe.hs @@ -1,4 +1,7 @@ {-# LANGUAGE CPP #-} +#ifndef NO_SAFE_HASKELL +{-# LANGUAGE Safe #-} +#endif #ifndef NO_ST_MONAD {-# LANGUAGE Rank2Types #-} #endif diff --git a/Test/QuickCheck/Modifiers.hs b/Test/QuickCheck/Modifiers.hs --- a/Test/QuickCheck/Modifiers.hs +++ b/Test/QuickCheck/Modifiers.hs @@ -56,6 +56,9 @@ , Shrinking(..) , ShrinkState(..) #endif + , ASCIIString(..) + , UnicodeString(..) + , PrintableString(..) ) where @@ -68,6 +71,7 @@ import Data.List ( sort ) +import Data.Ix (Ix) -------------------------------------------------------------------------- -- | @Blind x@: as x, but x does not have to be in the 'Show' class. @@ -214,7 +218,7 @@ newtype Large a = Large {getLarge :: a} deriving ( Eq, Ord, Show, Read #ifndef NO_NEWTYPE_DERIVING - , Num, Integral, Real, Enum + , Num, Integral, Real, Enum, Ix #endif ) @@ -231,7 +235,7 @@ newtype Small a = Small {getSmall :: a} deriving ( Eq, Ord, Show, Read #ifndef NO_NEWTYPE_DERIVING - , Num, Integral, Real, Enum + , Num, Integral, Real, Enum, Ix #endif ) @@ -343,4 +347,32 @@ #endif /* NO_MULTI_PARAM_TYPE_CLASSES */ -------------------------------------------------------------------------- +-- | @ASCIIString@: generates an ASCII string. +newtype ASCIIString = ASCIIString {getASCIIString :: String} + deriving ( Eq, Ord, Show, Read ) + +instance Arbitrary ASCIIString where + arbitrary = ASCIIString `fmap` listOf arbitraryASCIIChar + shrink (ASCIIString xs) = ASCIIString `fmap` shrink xs + +-------------------------------------------------------------------------- +-- | @UnicodeString@: generates a unicode String. +-- The string will not contain surrogate pairs. +newtype UnicodeString = UnicodeString {getUnicodeString :: String} + deriving ( Eq, Ord, Show, Read ) + +instance Arbitrary UnicodeString where + arbitrary = UnicodeString `fmap` listOf arbitraryUnicodeChar + shrink (UnicodeString xs) = UnicodeString `fmap` shrink xs + +-------------------------------------------------------------------------- +-- | @PrintableString@: generates a printable unicode String. +-- The string will not contain surrogate pairs. +newtype PrintableString = PrintableString {getPrintableString :: String} + deriving ( Eq, Ord, Show, Read ) + +instance Arbitrary PrintableString where + arbitrary = PrintableString `fmap` listOf arbitraryPrintableChar + shrink (PrintableString xs) = PrintableString `fmap` shrink xs + -- the end. diff --git a/Test/QuickCheck/Monadic.hs b/Test/QuickCheck/Monadic.hs --- a/Test/QuickCheck/Monadic.hs +++ b/Test/QuickCheck/Monadic.hs @@ -1,4 +1,11 @@ {-# LANGUAGE CPP #-} +#ifndef NO_SAFE_HASKELL +#if !defined(NO_ST_MONAD) && !(MIN_VERSION_base(4,8,0)) +{-# LANGUAGE Trustworthy #-} +#else +{-# LANGUAGE Safe #-} +#endif +#endif #ifndef NO_ST_MONAD {-# LANGUAGE Rank2Types #-} #endif @@ -83,6 +90,10 @@ import Control.Monad.Trans.Class #endif +#ifndef NO_MONADFAIL +import qualified Control.Monad.Fail as Fail +#endif + -------------------------------------------------------------------------- -- type PropertyM @@ -95,18 +106,30 @@ newtype PropertyM m a = MkPropertyM { unPropertyM :: (a -> Gen (m Property)) -> Gen (m Property) } +bind :: PropertyM m a -> (a -> PropertyM m b) -> PropertyM m b +MkPropertyM m `bind` f = MkPropertyM (\k -> m (\a -> unPropertyM (f a) k)) + +fail_ :: Monad m => String -> PropertyM m a +fail_ s = stop (failed { reason = s }) + instance Functor (PropertyM m) where fmap f (MkPropertyM m) = MkPropertyM (\k -> m (k . f)) -instance Monad m => Applicative (PropertyM m) where - pure = return - (<*>) = liftM2 ($) +instance Applicative (PropertyM m) where + pure x = MkPropertyM (\k -> k x) + mf <*> mx = + mf `bind` \f -> mx `bind` \x -> pure (f x) instance Monad m => Monad (PropertyM m) where - return x = MkPropertyM (\k -> k x) - MkPropertyM m >>= f = MkPropertyM (\k -> m (\a -> unPropertyM (f a) k)) - fail s = stop (failed { reason = s }) + return = pure + (>>=) = bind + fail = fail_ +#ifndef NO_MONADFAIL +instance Monad m => Fail.MonadFail (PropertyM m) where + fail = fail_ +#endif + #ifndef NO_TRANSFORMERS instance MonadTrans PropertyM where lift = run @@ -201,11 +224,11 @@ -- run functions -monadic :: Monad m => (m Property -> Property) -> PropertyM m a -> Property +monadic :: (Testable a, Monad m) => (m Property -> Property) -> PropertyM m a -> Property monadic runner m = property (fmap runner (monadic' m)) -monadic' :: Monad m => PropertyM m a -> Gen (m Property) -monadic' (MkPropertyM m) = m (const (return (return (property True)))) +monadic' :: (Testable a, Monad m) => PropertyM m a -> Gen (m Property) +monadic' (MkPropertyM m) = m (\prop -> return (return (property prop))) -- | Runs the property monad for 'IO'-computations. -- @@ -221,7 +244,7 @@ -- >>> quickCheck prop_cat -- +++ OK, passed 100 tests. -- -monadicIO :: PropertyM IO a -> Property +monadicIO :: Testable a => PropertyM IO a -> Property monadicIO = monadic ioProperty #ifndef NO_ST_MONAD @@ -240,7 +263,7 @@ -- >>> quickCheck prop_sortST -- +++ OK, passed 100 tests. -- -monadicST :: (forall s. PropertyM (ST s) a) -> Property +monadicST :: Testable a => (forall s. PropertyM (ST s) a) -> Property monadicST m = property (runSTGen (monadic' m)) runSTGen :: (forall s. Gen (ST s a)) -> Gen a diff --git a/Test/QuickCheck/Poly.hs b/Test/QuickCheck/Poly.hs --- a/Test/QuickCheck/Poly.hs +++ b/Test/QuickCheck/Poly.hs @@ -1,6 +1,6 @@ {-# LANGUAGE CPP #-} -#ifndef NO_NEWTYPE_DERIVING -{-# LANGUAGE GeneralizedNewtypeDeriving #-} +#ifndef NO_SAFE_HASKELL +{-# LANGUAGE Safe #-} #endif -- | Types to help with testing polymorphic properties. -- @@ -75,12 +75,28 @@ -- OrdA newtype OrdA = OrdA{ unOrdA :: Integer } - deriving ( Eq, Ord -#ifndef NO_NEWTYPE_DERIVING - , Num -#endif - ) + deriving ( Eq, Ord ) +liftOrdA + :: (Integer -> Integer) + -> OrdA -> OrdA +liftOrdA f (OrdA x) = OrdA (f x) + +liftOrdA2 + :: (Integer -> Integer -> Integer) + -> OrdA -> OrdA -> OrdA +liftOrdA2 f (OrdA x) (OrdA y) = OrdA (f x y) + +instance Num OrdA where + (+) = liftOrdA2 (+) + (*) = liftOrdA2 (*) + (-) = liftOrdA2 (-) + negate = liftOrdA negate + abs = liftOrdA abs + signum = liftOrdA signum + fromInteger = OrdA . fromInteger + + instance Show OrdA where showsPrec n (OrdA x) = showsPrec n x @@ -94,12 +110,27 @@ -- OrdB newtype OrdB = OrdB{ unOrdB :: Integer } - deriving ( Eq, Ord -#ifndef NO_NEWTYPE_DERIVING - , Num -#endif - ) + deriving ( Eq, Ord ) +liftOrdB + :: (Integer -> Integer) + -> OrdB -> OrdB +liftOrdB f (OrdB x) = OrdB (f x) + +liftOrdB2 + :: (Integer -> Integer -> Integer) + -> OrdB -> OrdB -> OrdB +liftOrdB2 f (OrdB x) (OrdB y) = OrdB (f x y) + +instance Num OrdB where + (+) = liftOrdB2 (+) + (*) = liftOrdB2 (*) + (-) = liftOrdB2 (-) + negate = liftOrdB negate + abs = liftOrdB abs + signum = liftOrdB signum + fromInteger = OrdB . fromInteger + instance Show OrdB where showsPrec n (OrdB x) = showsPrec n x @@ -113,11 +144,26 @@ -- OrdC newtype OrdC = OrdC{ unOrdC :: Integer } - deriving ( Eq, Ord -#ifndef NO_NEWTYPE_DERIVING - , Num -#endif - ) + deriving ( Eq, Ord ) + +liftOrdC + :: (Integer -> Integer) + -> OrdC -> OrdC +liftOrdC f (OrdC x) = OrdC (f x) + +liftOrdC2 + :: (Integer -> Integer -> Integer) + -> OrdC -> OrdC -> OrdC +liftOrdC2 f (OrdC x) (OrdC y) = OrdC (f x y) + +instance Num OrdC where + (+) = liftOrdC2 (+) + (*) = liftOrdC2 (*) + (-) = liftOrdC2 (-) + negate = liftOrdC negate + abs = liftOrdC abs + signum = liftOrdC signum + fromInteger = OrdC . fromInteger instance Show OrdC where showsPrec n (OrdC x) = showsPrec n x diff --git a/Test/QuickCheck/Property.hs b/Test/QuickCheck/Property.hs --- a/Test/QuickCheck/Property.hs +++ b/Test/QuickCheck/Property.hs @@ -11,7 +11,7 @@ import Test.QuickCheck.Gen import Test.QuickCheck.Gen.Unsafe import Test.QuickCheck.Arbitrary -import Test.QuickCheck.Text( showErr, isOneLine, putLine ) +import Test.QuickCheck.Text( isOneLine, putLine ) import Test.QuickCheck.Exception import Test.QuickCheck.State hiding (labels) @@ -25,6 +25,9 @@ import Data.Map(Map) import qualified Data.Set as Set import Data.Set(Set) +#ifndef NO_DEEPSEQ +import Control.DeepSeq +#endif -------------------------------------------------------------------------- -- fixities @@ -69,7 +72,13 @@ -- | The type of properties. newtype Property = MkProperty { unProperty :: Gen Prop } --- | The class of things which can be tested, i.e. turned into a property. +-- | 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 @@ -81,6 +90,14 @@ instance Testable Discard where property _ = property rejected +-- This instance is here to make it easier to turn IO () into a Property. +instance Testable () where + property = property . liftUnit + where + -- N.B. the unit gets forced only inside 'property', + -- so that we turn exceptions into test failures + liftUnit () = succeeded + instance Testable Bool where property = property . liftBool @@ -94,26 +111,22 @@ property mp = MkProperty $ do p <- mp; unProperty (again p) instance Testable Property where - property = property . unProperty + property (MkProperty mp) = MkProperty $ do p <- mp; unProperty (property p) --- | Do I/O inside a property. This can obviously lead to unrepeatable --- testcases, so use with care. -{-# DEPRECATED morallyDubiousIOProperty "Use ioProperty instead" #-} +-- | Do I/O inside a property. +{-# DEPRECATED morallyDubiousIOProperty "Use 'ioProperty' instead" #-} morallyDubiousIOProperty :: Testable prop => IO prop -> Property -morallyDubiousIOProperty = ioProperty -- Silly names aren't all they're cracked up to be :) +morallyDubiousIOProperty = ioProperty --- | Do I/O inside a property. This can obviously lead to unrepeatable --- testcases, so use with care. --- --- For more advanced monadic testing you may want to look at --- "Test.QuickCheck.Monadic". +-- | Do I/O inside a property. -- --- Note that if you use 'ioProperty' on a property of type @IO Bool@, --- or more generally a property that does no quantification, the property --- will only be executed once. To test the property repeatedly you must --- use the 'again' combinator. +-- 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@. ioProperty :: Testable prop => IO prop -> Property -ioProperty = MkProperty . fmap (MkProp . ioRose . fmap unProp) . promote . fmap (unProperty . property) +ioProperty = + MkProperty . fmap (MkProp . ioRose . fmap unProp) . + promote . fmap (unProperty . noShrinking) instance (Arbitrary a, Show a, Testable prop) => Testable (a -> prop) where property f = forAllShrink arbitrary shrink f @@ -194,14 +207,16 @@ -- | The result of a single test. data Result = MkResult - { ok :: Maybe Bool -- ^ result of the test case; Nothing = discard - , expect :: Bool -- ^ indicates what the expected result of the property is - , reason :: String -- ^ a message indicating what went wrong - , theException :: Maybe AnException -- ^ the exception thrown, if any - , abort :: Bool -- ^ if True, the test should not be repeated - , labels :: Map String Int -- ^ all labels used by this property - , stamp :: Set String -- ^ the collected values for this test case - , callbacks :: [Callback] -- ^ the callbacks for this test case + { ok :: Maybe Bool -- ^ result of the test case; Nothing = discard + , expect :: Bool -- ^ indicates what the expected result of the property is + , reason :: String -- ^ a message indicating what went wrong + , theException :: Maybe AnException -- ^ the exception thrown, if any + , abort :: Bool -- ^ if True, the test should not be repeated + , maybeNumTests :: Maybe Int -- ^ stop after this many tests + , labels :: Map String Int -- ^ all labels used by this property + , stamp :: Set String -- ^ the collected labels for this test case + , callbacks :: [Callback] -- ^ the callbacks for this test case + , testCase :: [String] -- ^ the generated test case } exception :: String -> AnException -> Result @@ -226,14 +241,16 @@ where result = MkResult - { ok = undefined - , expect = True - , reason = "" - , theException = Nothing - , abort = True - , labels = Map.empty - , stamp = Set.empty - , callbacks = [] + { ok = undefined + , expect = True + , reason = "" + , theException = Nothing + , abort = True + , maybeNumTests = Nothing + , labels = Map.empty + , stamp = Set.empty + , callbacks = [] + , testCase = [] } -------------------------------------------------------------------------- @@ -263,8 +280,8 @@ mapSize :: Testable prop => (Int -> Int) -> prop -> Property mapSize f p = MkProperty (sized ((`resize` unProperty (property p)) . f)) --- | Shrinks the argument to property if it fails. Shrinking is done --- automatically for most types. This is only needed when you want to +-- | Shrinks the argument to a property if it fails. Shrinking is done +-- automatically for most types. This function is only needed when you want to -- override the default behavior. shrinking :: Testable prop => (a -> [a]) -- ^ 'shrink'-like function. @@ -283,18 +300,27 @@ callback :: Testable prop => Callback -> prop -> Property callback cb = mapTotalResult (\res -> res{ callbacks = cb : callbacks res }) --- | Adds the given string to the counterexample. +-- | Adds the given string to the counterexample if the property fails. counterexample :: Testable prop => String -> prop -> Property counterexample s = - callback $ PostFinalFailure Counterexample $ \st _res -> do - res <- tryEvaluateIO (putLine (terminal st) s) + mapTotalResult (\res -> res{ testCase = s:testCase res }) . + callback (PostFinalFailure Counterexample $ \st _res -> do + s <- showCounterexample s + putLine (terminal st) s) + +showCounterexample :: String -> IO String +showCounterexample s = do + let force [] = return () + force (x:xs) = x `seq` force xs + res <- tryEvaluateIO (force s) + return $ case res of Left err -> - putLine (terminal st) (formatException "Exception thrown while printing test case" err) + formatException "Exception thrown while showing test case" err Right () -> - return () + s --- | Adds the given string to the counterexample. +-- | Adds the given string to the counterexample if the property fails. {-# DEPRECATED printTestCase "Use counterexample instead" #-} printTestCase :: Testable prop => String -> prop -> Property printTestCase = counterexample @@ -321,7 +347,8 @@ verbose = mapResult (\res -> res { callbacks = newCallbacks (callbacks res) ++ callbacks res }) where newCallbacks cbs = PostTest Counterexample (\st res -> putLine (terminal st) (status res ++ ":")): - [ PostTest Counterexample f | PostFinalFailure Counterexample f <- cbs ] + [ PostTest Counterexample f | PostFinalFailure Counterexample f <- cbs ] ++ + [ PostTest Counterexample (\st res -> putLine (terminal st) "") ] status MkResult{ok = Just True} = "Passed" status MkResult{ok = Just False} = "Failed" status MkResult{ok = Nothing} = "Skipped (precondition false)" @@ -332,25 +359,79 @@ expectFailure = mapTotalResult (\res -> res{ expect = False }) -- | Modifies a property so that it only will be tested once. +-- Opposite of 'again'. once :: Testable prop => prop -> Property once = mapTotalResult (\res -> res{ abort = True }) --- | Undoes the effect of 'once'. +-- | Modifies a property so that it will be tested repeatedly. +-- Opposite of 'once'. again :: Testable prop => prop -> Property again = mapTotalResult (\res -> res{ abort = False }) +-- | Configures how many times a property will be tested. +-- +-- For example, +-- +-- > quickCheck (withMaxSuccess 1000 p) +-- +-- will test @p@ up to 1000 times. +withMaxSuccess :: Testable prop => Int -> prop -> Property +withMaxSuccess n = n `seq` mapTotalResult (\res -> res{ maybeNumTests = Just n }) + -- | Attaches a label to a property. This is used for reporting -- test case distribution. +-- +-- For example: +-- +-- > prop_reverse_reverse :: [Int] -> Property +-- > prop_reverse_reverse xs = +-- > label ("length of input is " ++ show (length xs)) $ +-- > reverse (reverse xs) === xs +-- +-- >>> quickCheck prop_reverse_reverse +-- +++ OK, passed 100 tests: +-- 7% length of input is 7 +-- 6% length of input is 3 +-- 5% length of input is 4 +-- 4% length of input is 6 +-- ... label :: Testable prop => String -> prop -> Property label s = classify True s --- | Labels a property with a value: +-- | Attaches a label to a property. This is used for reporting +-- test case distribution. -- -- > collect x = label (show x) +-- +-- For example: +-- +-- > prop_reverse_reverse :: [Int] -> Property +-- > prop_reverse_reverse xs = +-- > collect (length xs) $ +-- > reverse (reverse xs) === xs +-- +-- >>> quickCheck prop_reverse_reverse +-- +++ OK, passed 100 tests: +-- 7% 7 +-- 6% 3 +-- 5% 4 +-- 4% 6 +-- ... collect :: (Show a, Testable prop) => a -> prop -> Property collect x = label (show x) --- | Conditionally labels test case. +-- | Records how many test cases satisfy a given condition. +-- +-- For example: +-- +-- > prop_sorted_sort :: [Int] -> Property +-- > prop_sorted_sort xs = +-- > sorted xs ==> +-- > classify (length xs > 1) "non-trivial" $ +-- > sort xs === xs +-- +-- >>> quickCheck prop_sorted_sort +-- +++ OK, passed 100 tests (22% non-trivial). classify :: Testable prop => Bool -- ^ @True@ if the test case should be labelled. -> String -- ^ Label. @@ -360,6 +441,17 @@ -- | Checks that at least the given proportion of /successful/ test -- cases belong to the given class. Discarded tests (i.e. ones -- with a false precondition) do not affect coverage. +-- +-- For example: +-- +-- > prop_sorted_sort :: [Int] -> Property +-- > prop_sorted_sort xs = +-- > sorted xs ==> +-- > cover (length xs > 1) 50 "non-trivial" $ +-- > sort xs === xs +-- +-- >>> quickCheck prop_sorted_sort +-- *** Insufficient coverage after 100 tests (only 24% non-trivial, not 50%). cover :: Testable prop => Bool -- ^ @True@ if the test case belongs to the class. -> Int -- ^ The required percentage (0-100) of test cases. @@ -385,16 +477,16 @@ -- the given number of microseconds. within :: Testable prop => Int -> prop -> Property within n = mapRoseResult f - -- We rely on the fact that the property will catch the timeout - -- exception and turn it into a failed test case. where f rose = ioRose $ do - let m `orError` x = fmap (fromMaybe (error x)) m + let m `orError` x = fmap (fromMaybe x) m MkRose res roses <- timeout n (reduceRose rose) `orError` - "within: timeout exception not caught in Rose Result" + return timeoutResult res' <- timeout n (protectResult (return res)) `orError` - "within: timeout exception not caught in Result" + timeoutResult return (MkRose res' (map f roses)) + + timeoutResult = failed { reason = "Timeout" } #ifdef NO_TIMEOUT timeout _ = fmap Just #endif @@ -498,12 +590,16 @@ -- The following three fields are not important because the -- test case has failed anyway abort = False, + maybeNumTests = Nothing, labels = Map.empty, stamp = Set.empty, callbacks = callbacks result1 ++ [PostFinalFailure Counterexample $ \st _res -> putLine (terminal st) ""] ++ - callbacks result2 } + callbacks result2, + testCase = + testCase result1 ++ + testCase result2 } Nothing -> result2 Nothing -> do result2 <- q @@ -523,6 +619,11 @@ x === y = counterexample (show x ++ " /= " ++ show y) (x == y) +#ifndef NO_DEEPSEQ +-- | Checks that a value is total, i.e., doesn't crash when evaluated. +total :: NFData a => a -> Property +total x = property (rnf x) +#endif -------------------------------------------------------------------------- -- the end. diff --git a/Test/QuickCheck/Random.hs b/Test/QuickCheck/Random.hs --- a/Test/QuickCheck/Random.hs +++ b/Test/QuickCheck/Random.hs @@ -63,7 +63,7 @@ newtype QCGen = QCGen TheGen instance Show QCGen where - showsPrec n (QCGen g) = showsPrec n g + showsPrec n (QCGen g) s = showsPrec n g "" ++ s instance Read QCGen where readsPrec n xs = [(QCGen g, ys) | (g, ys) <- readsPrec n xs] diff --git a/Test/QuickCheck/State.hs b/Test/QuickCheck/State.hs --- a/Test/QuickCheck/State.hs +++ b/Test/QuickCheck/State.hs @@ -3,7 +3,6 @@ import Test.QuickCheck.Text import Test.QuickCheck.Random -import qualified Data.Map as Map import Data.Map(Map) import Data.Set(Set) @@ -20,6 +19,7 @@ , maxDiscardedTests :: Int -- ^ maximum number of tests that can be discarded , computeSize :: Int -> Int -> Int -- ^ how to compute the size of test cases from -- #tests and #discarded tests + , numTotMaxShrinks :: !Int -- ^ How many shrinks to try before giving up -- dynamic , numSuccessTests :: !Int -- ^ the current number of tests that have succeeded diff --git a/Test/QuickCheck/Test.hs b/Test/QuickCheck/Test.hs --- a/Test/QuickCheck/Test.hs +++ b/Test/QuickCheck/Test.hs @@ -34,10 +34,15 @@ import Data.List ( sort + , sortBy , group - , groupBy , intersperse ) + +import Data.Maybe(fromMaybe) +import Data.Ord(comparing) +import Text.Printf(printf) + -------------------------------------------------------------------------- -- quickCheck @@ -53,13 +58,18 @@ -- If you want to store a test case permanently you should save -- the test case itself. , maxSuccess :: Int - -- ^ Maximum number of successful tests before succeeding + -- ^ Maximum number of successful tests before succeeding. Testing stops + -- at the first failure. If all tests are passing and you want to run more tests, + -- increase this number. , maxDiscardRatio :: Int -- ^ Maximum number of discarded tests per successful test before giving up , maxSize :: Int -- ^ Size to use for the biggest test cases , chatty :: Bool -- ^ Whether to print anything + , maxShrinks :: Int + -- ^ Maximum number of shrinks to before giving up. Setting this to zero + -- turns shrinking off. } deriving ( Show, Read ) @@ -68,38 +78,39 @@ -- | A successful test run = Success { numTests :: Int -- ^ Number of tests performed - , labels :: [(String,Int)] -- ^ Labels and frequencies found during all successful tests + , labels :: [(String,Double)] -- ^ Labels and frequencies found during all successful tests , output :: String -- ^ Printed output } -- | Given up | GaveUp { numTests :: Int -- Number of tests performed - , labels :: [(String,Int)] -- Labels and frequencies found during all successful tests + , labels :: [(String,Double)] -- Labels and frequencies found during all successful tests , output :: String -- Printed output } -- | A failed test run | Failure - { numTests :: Int -- Number of tests performed - , numShrinks :: Int -- ^ Number of successful shrinking steps performed - , numShrinkTries :: Int -- ^ Number of unsuccessful shrinking steps performed - , numShrinkFinal :: Int -- ^ Number of unsuccessful shrinking steps performed since last successful shrink - , usedSeed :: QCGen -- ^ What seed was used - , usedSize :: Int -- ^ What was the test size - , reason :: String -- ^ Why did the property fail - , theException :: Maybe AnException -- ^ The exception the property threw, if any - , labels :: [(String,Int)] -- Labels and frequencies found during all successful tests - , output :: String -- Printed output + { numTests :: Int -- Number of tests performed + , numShrinks :: Int -- ^ Number of successful shrinking steps performed + , numShrinkTries :: Int -- ^ Number of unsuccessful shrinking steps performed + , numShrinkFinal :: Int -- ^ Number of unsuccessful shrinking steps performed since last successful shrink + , usedSeed :: QCGen -- ^ What seed was used + , usedSize :: Int -- ^ What was the test size + , reason :: String -- ^ Why did the property fail + , theException :: Maybe AnException -- ^ The exception the property threw, if any + , labels :: [(String,Double)] -- Labels and frequencies found during all successful tests + , output :: String -- Printed output + , failingTestCase :: [String] -- ^ The test case which provoked the failure } -- | A property that should have failed did not | NoExpectedFailure { numTests :: Int -- Number of tests performed - , labels :: [(String,Int)] -- Labels and frequencies found during all successful tests + , labels :: [(String,Double)] -- Labels and frequencies found during all successful tests , output :: String -- Printed output } -- | The tests passed but a use of 'cover' had insufficient coverage | InsufficientCoverage { numTests :: Int -- Number of tests performed - , labels :: [(String,Int)] -- Labels and frequencies found during all successful tests + , labels :: [(String,Double)] -- Labels and frequencies found during all successful tests , output :: String -- Printed output } deriving ( Show ) @@ -117,10 +128,13 @@ , maxDiscardRatio = 10 , maxSize = 100 , chatty = True --- noShrinking flag? + , maxShrinks = maxBound } -- | Tests a property and prints the results to 'stdout'. +-- +-- By default up to 100 tests are performed, which may not be enough +-- to find all bugs. To run more tests, use 'withMaxSuccess'. quickCheck :: Testable prop => prop -> IO () quickCheck p = quickCheckWith stdArgs p @@ -144,6 +158,7 @@ , computeSize = case replay a of Nothing -> computeSize' Just (_,s) -> computeSize' `at0` s + , numTotMaxShrinks = maxShrinks a , numSuccessTests = 0 , numDiscardedTests = 0 , numRecentlyDiscardedTests = 0 @@ -206,7 +221,7 @@ ++ " tests (expected failure)" ) finished NoExpectedFailure - | insufficientCoverage st = do + | not (null (insufficientlyCovered st)) = do putPart (terminal st) ( bold ("*** Insufficient coverage after ") ++ show (numSuccessTests st) @@ -264,20 +279,22 @@ | otherwise = x:xs case res of - MkResult{ok = Just True, stamp = stamp, expect = expect} -> -- successful test + MkResult{ok = Just True, stamp = stamp, expect = expect, maybeNumTests = mnt} -> -- successful test do continue doneTesting st{ numSuccessTests = numSuccessTests st + 1 , numRecentlyDiscardedTests = 0 + , maxSuccessTests = fromMaybe (maxSuccessTests st) mnt , randomSeed = rnd2 , S.labels = Map.unionWith max (S.labels st) (P.labels res) , collected = stamp `cons` collected st , expectedFailure = expect } f - MkResult{ok = Nothing, expect = expect} -> -- discarded test + MkResult{ok = Nothing, expect = expect, maybeNumTests = mnt} -> -- discarded test do continue giveUp st{ numDiscardedTests = numDiscardedTests st + 1 , numRecentlyDiscardedTests = numRecentlyDiscardedTests st + 1 + , maxSuccessTests = fromMaybe (maxSuccessTests st) mnt , randomSeed = rnd2 , S.labels = Map.unionWith max (S.labels st) (P.labels res) , expectedFailure = expect @@ -287,36 +304,40 @@ do if expect res then putPart (terminal st) (bold "*** Failed! ") else putPart (terminal st) "+++ OK, failed as expected. " - (numShrinks, totFailed, lastFailed) <- foundFailure st res ts + (numShrinks, totFailed, lastFailed, res) <- foundFailure st res ts theOutput <- terminalOutput (terminal st) if not (expect res) then return Success{ labels = summary st, numTests = numSuccessTests st+1, output = theOutput } - else - return Failure{ usedSeed = randomSeed st -- correct! (this will be split first) - , usedSize = size - , numTests = numSuccessTests st+1 - , numShrinks = numShrinks - , numShrinkTries = totFailed - , numShrinkFinal = lastFailed - , output = theOutput - , reason = P.reason res - , theException = P.theException res - , labels = summary st + else do + testCase <- mapM showCounterexample (P.testCase res) + return Failure{ usedSeed = randomSeed st -- correct! (this will be split first) + , usedSize = size + , numTests = numSuccessTests st+1 + , numShrinks = numShrinks + , numShrinkTries = totFailed + , numShrinkFinal = lastFailed + , output = theOutput + , reason = P.reason res + , theException = P.theException res + , labels = summary st + , failingTestCase = testCase } where (rnd1,rnd2) = split (randomSeed st) -summary :: State -> [(String,Int)] +summary :: State -> [(String, Double)] summary st = reverse - . sort - . map (\ss -> (head ss, (length ss * 100) `div` numSuccessTests st)) + . sortBy (comparing snd) + . map (\ss -> (head ss, fromIntegral (length ss) * 100 / fromIntegral (numSuccessTests st))) . group . sort - $ [ concat (intersperse ", " (Set.toList s)) + $ [ concat (intersperse ", " s') | s <- collected st - , not (Set.null s) + -- HACK: don't print out labels that were created by 'cover'. + , let s' = [ t | t <- Set.toList s, Map.lookup t (S.labels st) == Just 0 ] + , not (null s') ] success :: State -> IO () @@ -329,48 +350,59 @@ ++ ")." ) cases -> do putLine (terminal st) ":" - sequence_ [ putLine (terminal st) pt | pt <- cases ] + mapM_ (putLine $ terminal st) cases where - allLabels = reverse - . sort - . map (\ss -> (showP ((length ss * 100) `div` numSuccessTests st) ++ head ss)) - . group - . sort - $ [ concat (intersperse ", " s') - | s <- collected st - , let s' = [ t | t <- Set.toList s, Map.lookup t (S.labels st) == Just 0 ] - , not (null s') - ] + allLabels :: [String] + allLabels = map (formatLabel (numSuccessTests st) True) (summary st) - covers = [ ("only " ++ show (labelPercentage l st) ++ "% " ++ l ++ ", not " ++ show reqP ++ "%") - | (l, reqP) <- Map.toList (S.labels st) - , labelPercentage l st < reqP - ] + covers :: [String] + covers = [ ("only " ++ formatLabel (numSuccessTests st) False (l, p) ++ ", not " ++ show reqP ++ "%") + | (l, reqP, p) <- insufficientlyCovered st ] - showP p = (if p < 10 then " " else "") ++ show p ++ "% " +formatLabel :: Int -> Bool -> (String, Double) -> String +formatLabel n pad (x, p) = showP pad p ++ " " ++ x + where + showP :: Bool -> Double -> String + showP pad p = + (if pad && p < 10 then " " else "") ++ + printf "%.*f" places p ++ "%" -labelPercentage :: String -> State -> Int -labelPercentage l st = + -- Show no decimal places if <= 100 successful tests, + -- one decimal place if <= 1000 successful tests, + -- two decimal places if <= 10000 successful tests, and so on. + places :: Integer + places = + ceiling (logBase 10 (fromIntegral n) - 2 :: Double) `max` 0 + +labelCount :: String -> State -> Int +labelCount l st = -- XXX in case of a disjunction, a label can occur several times, -- need to think what to do there - (100 * occur) `div` maxSuccessTests st - where - occur = length [ l' | l' <- concat (map Set.toList (collected st)), l == l' ] + length [ l' | l' <- concat (map Set.toList (collected st)), l == l' ] -insufficientCoverage :: State -> Bool -insufficientCoverage st = - or [ labelPercentage l st < reqP | (l, reqP) <- Map.toList (S.labels st) ] +percentage :: Integral a => State -> a -> Double +percentage st n = + fromIntegral n * 100 / fromIntegral (numSuccessTests st) +insufficientlyCovered :: State -> [(String, Int, Double)] +insufficientlyCovered st = + [ (l, reqP, p) + | (l, reqP) <- Map.toList (S.labels st), + let p = percentage st (labelCount l st), + p < fromIntegral reqP ] + -------------------------------------------------------------------------- -- main shrinking loop -foundFailure :: State -> P.Result -> [Rose P.Result] -> IO (Int, Int, Int) +foundFailure :: State -> P.Result -> [Rose P.Result] -> IO (Int, Int, Int, P.Result) foundFailure st res ts = do localMin st{ numTryShrinks = 0 } res res ts -localMin :: State -> P.Result -> P.Result -> [Rose P.Result] -> IO (Int, Int, Int) -localMin st MkResult{P.theException = Just e} lastRes _ - | isInterrupt e = localMinFound st lastRes +localMin :: State -> P.Result -> P.Result -> [Rose P.Result] -> IO (Int, Int, Int, P.Result) +-- Don't try to shrink for too long +localMin st res _ ts + | numSuccessShrinks st + numTotTryShrinks st >= numTotMaxShrinks st = + localMinFound st res localMin st res _ ts = do r <- tryEvaluateIO $ putTemp (terminal st) @@ -398,7 +430,7 @@ (exception "Exception while generating shrink-list" err) { callbacks = callbacks res } Right ts' -> localMin' st res ts' -localMin' :: State -> P.Result -> [Rose P.Result] -> IO (Int, Int, Int) +localMin' :: State -> P.Result -> [Rose P.Result] -> IO (Int, Int, Int, P.Result) localMin' st res [] = localMinFound st res localMin' st res (t:ts) = do -- CALLBACK before_test @@ -410,7 +442,7 @@ else localMin st{ numTryShrinks = numTryShrinks st + 1, numTotTryShrinks = numTotTryShrinks st + 1 } res res ts -localMinFound :: State -> P.Result -> IO (Int, Int, Int) +localMinFound :: State -> P.Result -> IO (Int, Int, Int, P.Result) localMinFound st res = do let report = concat [ "(after " ++ number (numSuccessTests st+1) "test", @@ -430,7 +462,7 @@ callbackPostFinalFailure st res -- NB no need to check if callbacks threw an exception because -- we are about to return to the user anyway - return (numSuccessShrinks st, numTotTryShrinks st - numTryShrinks st, numTryShrinks st) + return (numSuccessShrinks st, numTotTryShrinks st - numTryShrinks st, numTryShrinks st, res) -------------------------------------------------------------------------- -- callbacks diff --git a/Test/QuickCheck/Text.hs b/Test/QuickCheck/Text.hs --- a/Test/QuickCheck/Text.hs +++ b/Test/QuickCheck/Text.hs @@ -25,7 +25,6 @@ -------------------------------------------------------------------------- -- imports -import Control.Applicative import System.IO ( hFlush , hPutStr diff --git a/changelog b/changelog --- a/changelog +++ b/changelog @@ -1,3 +1,71 @@ +QuickCheck 2.10 (released 2017-06-15) + * New combinators: + - withMaxSuccess sets the maximum number of test cases for a property. + - shrinkMap/shrinkMapBy are helpers for defining shrink functions. + - total checks that a value is non-crashing. + - suchThatMap is similar to 'suchThat' + but takes a Maybe-returning function instead of a predicate. + - getSize returns the current test case size. + + * Random strings and characters now include Unicode characters by + default. To generate only ASCII characters, use the new + ASCIIString modifier or arbitraryASCIIChar generator. + The following modifiers and generators also control the + kind of strings generated: UnicodeString, PrintableString, + arbitraryUnicodeChar, arbitraryPrintableChar. + + * QuickCheck no longer catches asynchronous exceptions, which + means that pressing ctrl-C will now cancel testing without + printing a counterexample. If you are debugging an infinite loop, + please use the 'timeout' combinator or 'verboseCheck' instead. + ('timeout' is better as it allows the counterexample to be + shrunk.) + + * Much of Test.QuickCheck.Function (showable random functions) + is now exported from Test.QuickCheck. + - Test.QuickCheck.Function now defines functions and + pattern synonyms which simplify testing functions of + more than one argument: apply2, apply3, Fn2, Fn3. + + * New typeclasses Arbitrary1 and Arbitrary2 which lift Arbitrary + to unary/binary type constructors, like in Data.Functor.Classes. + + * Some Arbitrary instances have been removed: NonEmpty, Natural. + This is because they resulted in a lot of extra dependencies. + You can now find them in the quickcheck-instances package. + Alternatively, use the NonEmptyList and NonNegative modifiers. + + * New Arbitrary instances for the following types: Proxy, ExitCode, + WrappedMonad, WrappedArrow, QCGen, and the types in + Foreign.C.Types and Data.Functor.{Product,Compose}. + Also a Function instance for Word. + + * The functions in Test.QuickCheck.Monadic which take an argument + of type PropertyM m a now expect that 'a' to be Testable, and test it. + To reduce breakage from this, () is now an instance of Testable which + always succeeds. + - PropertyM now has a MonadFail instance on recent GHCs. + Furthermore, the constraints on some instances were loosened. + + * Miscellaneous API changes: + - Result now returns the counterexample as a list of strings. + See the "failingTestCase" field. + - Args now has a `maxShrinks` argument, the maximum number of + shrinks to try before giving up shrinking. + - The 'labels' field of Result now encodes frequencies as Doubles + rather than Ints. + + * Bugfixes: + - 'Test.QuickCheck.Function', 'Test.QuickCheck.Poly', and + 'Test.QuickCheck.Monadic' are now Safe modules. + - Result.theException and Result.reason were taken from + the pre-shrunk counterexample, not the shrunk one. + - The Testable Property instance improperly used 'again'. + - Gen.>>= is strict in the result of split, fixing a space leak. + - within now gives a better error message on timeout + + * Some more examples and links have been added to the documentation. + QuickCheck 2.9.2 (released 2016-09-15) * Fix a bug where some properties were only being tested once * Make shrinking of floating-point values less aggressive diff --git a/examples/Heap.hs b/examples/Heap.hs --- a/examples/Heap.hs +++ b/examples/Heap.hs @@ -5,8 +5,6 @@ -- imports import Test.QuickCheck -import Test.QuickCheck.Text -import Test.QuickCheck.All import Data.List ( sort diff --git a/examples/Heap_Program.hs b/examples/Heap_Program.hs new file mode 100644 --- /dev/null +++ b/examples/Heap_Program.hs @@ -0,0 +1,197 @@ +{-# LANGUAGE ScopedTypeVariables, TemplateHaskell #-} +module Main where + +-------------------------------------------------------------------------- +-- imports + +import Test.QuickCheck +import Test.QuickCheck.Poly + +import Data.List + ( sort + , (\\) + ) + +import Control.Monad + ( liftM + , liftM2 + ) + +-------------------------------------------------------------------------- +-- skew heaps + +data Heap a + = Node a (Heap a) (Heap a) + | Nil + deriving ( Eq, Ord, Show ) + +empty :: Heap a +empty = Nil + +isEmpty :: Heap a -> Bool +isEmpty Nil = True +isEmpty _ = False + +unit :: a -> Heap a +unit x = Node x empty empty + +size :: Heap a -> Int +size Nil = 0 +size (Node _ h1 h2) = 1 + size h1 + size h2 + +insert :: Ord a => a -> Heap a -> Heap a +insert x h = unit x `merge` h + +removeMin :: Ord a => Heap a -> Maybe (a, Heap a) +removeMin Nil = Nothing +removeMin (Node x h1 h2) = Just (x, h1 `merge` h2) + +merge :: Ord a => Heap a -> Heap a -> Heap a +h1 `merge` Nil = h1 +Nil `merge` h2 = h2 +h1@(Node x h11 h12) `merge` h2@(Node y h21 h22) + | x <= y = Node x (h12 `merge` h2) h11 + | otherwise = Node y (h22 `merge` h1) h21 + +fromList :: Ord a => [a] -> Heap a +fromList xs = merging [ unit x | x <- xs ] + where + merging [] = empty + merging [h] = h + merging hs = merging (sweep hs) + + sweep [] = [] + sweep [h] = [h] + sweep (h1:h2:hs) = (h1 `merge` h2) : sweep hs + +toList :: Heap a -> [a] +toList h = toList' [h] + where + toList' [] = [] + toList' (Nil : hs) = toList' hs + toList' (Node x h1 h2 : hs) = x : toList' (h1:h2:hs) + +toSortedList :: Ord a => Heap a -> [a] +toSortedList Nil = [] +toSortedList (Node x h1 h2) = x : toList (h1 `merge` h2) + +-------------------------------------------------------------------------- +-- heap programs + +data HeapP a + = Empty + | Unit a + | Insert a (HeapP a) + | SafeRemoveMin (HeapP a) + | Merge (HeapP a) (HeapP a) + | FromList [a] + deriving (Show) + +heap :: Ord a => HeapP a -> Heap a +heap Empty = empty +heap (Unit x) = unit x +heap (Insert x p) = insert x (heap p) +heap (SafeRemoveMin p) = case removeMin (heap p) of + Nothing -> empty -- arbitrary choice + Just (_,h) -> h +heap (Merge p q) = heap p `merge` heap q +heap (FromList xs) = fromList xs + +instance Arbitrary a => Arbitrary (HeapP a) where + arbitrary = sized arbHeapP + where + arbHeapP s = + frequency + [ (1, do return Empty) + , (1, do x <- arbitrary + return (Unit x)) + , (s, do x <- arbitrary + p <- arbHeapP s1 + return (Insert x p)) + , (s, do p <- arbHeapP s1 + return (SafeRemoveMin p)) + , (s, do p <- arbHeapP s2 + q <- arbHeapP s2 + return (Merge p q)) + , (1, do xs <- arbitrary + return (FromList xs)) + ] + where + s1 = s-1 + s2 = s`div`2 + + + shrink (Unit x) = [ Unit x' | x' <- shrink x ] + shrink (FromList xs) = [ Unit x | x <- xs ] + ++ [ FromList xs' | xs' <- shrink xs ] + shrink (Insert x p) = [ p ] + ++ [ Insert x p' | p' <- shrink p ] + ++ [ Insert x' p | x' <- shrink x ] + shrink (SafeRemoveMin p) = [ p ] + ++ [ SafeRemoveMin p' | p' <- shrink p ] + shrink (Merge p q) = [ p, q ] + ++ [ Merge p' q | p' <- shrink p ] + ++ [ Merge p q' | q' <- shrink q ] + shrink _ = [] + +data HeapPP a = HeapPP (HeapP a) (Heap a) + deriving (Show) + +instance (Ord a, Arbitrary a) => Arbitrary (HeapPP a) where + arbitrary = + do p <- arbitrary + return (HeapPP p (heap p)) + + shrink (HeapPP p _) = + [ HeapPP p' (heap p') | p' <- shrink p ] + +-------------------------------------------------------------------------- +-- properties + +(==?) :: Heap OrdA -> [OrdA] -> Bool +h ==? xs = sort (toList h) == sort xs + +prop_Empty = + empty ==? [] + +prop_IsEmpty (HeapPP _ h) = + isEmpty h == null (toList h) + +prop_Unit x = + unit x ==? [x] + +prop_Size (HeapPP _ h) = + size h == length (toList h) + +prop_Insert x (HeapPP _ h) = + insert x h ==? (x : toList h) + +prop_RemoveMin (HeapPP _ h) = + cover (size h > 1) 80 "non-trivial" $ + case removeMin h of + Nothing -> h ==? [] + Just (x,h') -> x == minimum (toList h) && h' ==? (toList h \\ [x]) + +prop_Merge (HeapPP _ h1) (HeapPP _ h2) = + (h1 `merge` h2) ==? (toList h1 ++ toList h2) + +prop_FromList xs = + fromList xs ==? xs + +prop_ToSortedList (HeapPP _ h) = + h ==? xs && xs == sort xs + where + xs = toSortedList h + +-------------------------------------------------------------------------- +-- main + +return [] +main = $(quickCheckAll) + +-------------------------------------------------------------------------- +-- the end. + +-- toSortedList (Node x h1 h2) = x : toSortedList (h1 `merge` h2) + + diff --git a/examples/Heap_ProgramAlgebraic.hs b/examples/Heap_ProgramAlgebraic.hs new file mode 100644 --- /dev/null +++ b/examples/Heap_ProgramAlgebraic.hs @@ -0,0 +1,254 @@ +{-# LANGUAGE ScopedTypeVariables, TemplateHaskell, GADTs #-} +module Main where + +-------------------------------------------------------------------------- +-- imports + +import Test.QuickCheck +import Test.QuickCheck.Poly + +import Data.List + ( sort + , nub + , (\\) + ) + +import Data.Maybe + ( fromJust + ) + +import Control.Monad + ( liftM + , liftM2 + ) + +-------------------------------------------------------------------------- +-- skew heaps + +data Heap a + = Node a (Heap a) (Heap a) + | Nil + deriving ( Eq, Ord, Show ) + +empty :: Heap a +empty = Nil + +isEmpty :: Heap a -> Bool +isEmpty Nil = True +isEmpty _ = False + +unit :: a -> Heap a +unit x = Node x empty empty + +size :: Heap a -> Int +size Nil = 0 +size (Node _ h1 h2) = 1 + size h1 + size h2 + +insert :: Ord a => a -> Heap a -> Heap a +insert x h = unit x `merge` h + +removeMin :: Ord a => Heap a -> Maybe (a, Heap a) +removeMin Nil = Nothing +removeMin (Node x h1 h2) = Just (x, h1 `merge` h2) + +merge :: Ord a => Heap a -> Heap a -> Heap a +h1 `merge` Nil = h1 +Nil `merge` h2 = h2 +h1@(Node x h11 h12) `merge` h2@(Node y h21 h22) + | x <= y = Node x (h12 `merge` h2) h11 + | otherwise = Node y (h22 `merge` h1) h21 + +fromList :: Ord a => [a] -> Heap a +fromList xs = merging [ unit x | x <- xs ] [] + where + merging [] [] = empty + merging [p] [] = p + merging (p:q:ps) qs = merging ps ((p`merge`q):qs) + merging ps qs = merging (ps ++ reverse qs) [] + +toList :: Heap a -> [a] +toList h = toList' [h] + where + toList' [] = [] + toList' (Nil : hs) = toList' hs + toList' (Node x h1 h2 : hs) = x : toList' (h1:h2:hs) + +toSortedList :: Ord a => Heap a -> [a] +toSortedList Nil = [] +toSortedList (Node x h1 h2) = x : toSortedList (h1 `merge` h2) + +-------------------------------------------------------------------------- +-- heap programs + +data HeapP a + = Empty + | Unit a + | Insert a (HeapP a) + | SafeRemoveMin (HeapP a) + | Merge (HeapP a) (HeapP a) + | FromList [a] + deriving (Show) + +safeRemoveMin :: Ord a => Heap a -> Heap a +safeRemoveMin h = case removeMin h of + Nothing -> empty -- arbitrary choice + Just (_,h) -> h + +heap :: Ord a => HeapP a -> Heap a +heap Empty = empty +heap (Unit x) = unit x +heap (Insert x p) = insert x (heap p) +heap (SafeRemoveMin p) = safeRemoveMin (heap p) +heap (Merge p q) = heap p `merge` heap q +heap (FromList xs) = fromList xs + +instance (Ord a, Arbitrary a) => Arbitrary (HeapP a) where + arbitrary = sized arbHeapP + where + arbHeapP s = + frequency + [ (1, do return Empty) + , (1, do x <- arbitrary + return (Unit x)) + , (s, do x <- arbitrary + p <- arbHeapP s1 + return (Insert x p)) + , (s, do p <- arbHeapP s1 + return (SafeRemoveMin p)) + , (s, do p <- arbHeapP s2 + q <- arbHeapP s2 + return (Merge p q)) + , (1, do xs <- arbitrary + return (FromList xs)) + ] + where + s1 = s-1 + s2 = s`div`2 + + + shrink Empty = [] + shrink (Unit x) = [ Unit x' | x' <- shrink x ] + shrink (FromList xs) = [ Unit x | x <- xs ] + ++ [ FromList xs' | xs' <- shrink xs ] + shrink p = + [ FromList (toList (heap p)) ] ++ + case p of + Insert x p -> [ p ] + ++ [ Insert x p' | p' <- shrink p ] + ++ [ Insert x' p | x' <- shrink x ] + SafeRemoveMin p -> [ p ] + ++ [ SafeRemoveMin p' | p' <- shrink p ] + Merge p q -> [ p, q ] + ++ [ Merge p' q | p' <- shrink p ] + ++ [ Merge p q' | q' <- shrink q ] + +data HeapPP a = HeapPP (HeapP a) (Heap a) + deriving (Show) + +instance (Ord a, Arbitrary a) => Arbitrary (HeapPP a) where + arbitrary = + do p <- arbitrary + return (HeapPP p (heap p)) + + shrink (HeapPP p _) = + [ HeapPP p' (heap p') | p' <- shrink p ] + +-------------------------------------------------------------------------- +-- properties + +data Context a where + Context :: Eq b => (Heap a -> b) -> Context a + +instance (Ord a, Arbitrary a) => Arbitrary (Context a) where + arbitrary = + do f <- sized arbContext + let vec h = (size h, toSortedList h, isEmpty h) + return (Context (vec . f)) + where + arbContext s = + frequency + [ (1, do return id) + , (s, do x <- arbitrary + f <- arbContext (s-1) + return (insert x . f)) + , (s, do f <- arbContext (s-1) + return (safeRemoveMin . f)) + , (s, do HeapPP _ h <- arbitrary + f <- arbContext (s`div`2) + elements [ (h `merge`) . f, (`merge` h) . f ]) + ] + +instance Show (Context a) where + show _ = "*" + +(=~) :: Heap Char -> Heap Char -> Property +--h1 =~ h2 = sort (toList h1) == sort (toList h2) +--h1 =~ h2 = property (nub (sort (toList h1)) == nub (sort (toList h2))) -- bug! +h1 =~ h2 = property (\(Context c) -> c h1 == c h2) + +{- +The normal form is: + + insert x1 (insert x2 (... empty)...) + +where x1 <= x2 <= ... +-} + +-- heap creating operations + +prop_Unit x = + unit x =~ insert x empty + +prop_RemoveMin_Empty = + removeMin (empty :: Heap OrdA) == Nothing + +prop_RemoveMin_Insert1 x = + removeMin (insert x empty :: Heap OrdA) == Just (x, empty) + +prop_RemoveMin_Insert2 x y (HeapPP _ h) = + removeMin (insert x (insert y h)) ==~ + (insert (max x y) `maph` removeMin (insert (min x y) h)) + where + f `maph` Just (x,h) = Just (x, f h) + f `maph` Nothing = Nothing + + Nothing ==~ Nothing = property True + Just (x,h1) ==~ Just (y,h2) = x==y .&&. h1 =~ h2 + +prop_InsertSwap x y (HeapPP _ h) = + insert x (insert y h) =~ insert y (insert x h) + +prop_MergeInsertLeft x (HeapPP _ h1) (HeapPP _ h2) = + (insert x h1 `merge` h2) =~ insert x (h1 `merge` h2) + +prop_MergeInsertRight x (HeapPP _ h1) (HeapPP _ h2) = + (h1 `merge` insert x h2) =~ insert x (h1 `merge` h2) + +-- heap observing operations + +prop_Size_Empty = + size empty == 0 + +prop_Size_Insert x (HeapPP _ (h :: Heap OrdA)) = + size (insert x h) == 1 + size h + +prop_ToList_Empty = + toList empty == ([] :: [OrdA]) + +prop_ToList_Insert x (HeapPP _ (h :: Heap OrdA)) = + sort (toList (insert x h)) == sort (x : toList h) + +prop_ToSortedList (HeapPP _ (h :: Heap OrdA)) = + toSortedList h == sort (toList h) + +-------------------------------------------------------------------------- +-- main + +return [] +main = $(quickCheckAll) + +-------------------------------------------------------------------------- +-- the end. + + + diff --git a/examples/Lambda.hs b/examples/Lambda.hs new file mode 100644 --- /dev/null +++ b/examples/Lambda.hs @@ -0,0 +1,363 @@ +{-# LANGUAGE ScopedTypeVariables, TemplateHaskell #-} +module Main where + +-------------------------------------------------------------------------- +-- imports + +import Test.QuickCheck + +import Control.Monad + ( liftM + , liftM2 + ) + +import Data.Char + ( toUpper + ) + +import Data.Set (Set) +import qualified Data.Set as Set + +-------------------------------------------------------------------------- +-- types for lambda expressions + +-- variables + +newtype Var = MkVar String + deriving ( Eq, Ord ) + +instance Show Var where + show (MkVar s) = s + +varList :: [Var] +varList = [ MkVar s + | let vs = [ c:v | v <- "" : vs, c <- ['a'..'z'] ] + , s <- vs + ] + +instance Arbitrary Var where + arbitrary = growingElements [ MkVar [c] | c <- ['a'..'z'] ] + +-- constants + +newtype Con = MkCon String + deriving ( Eq, Ord ) + +instance Show Con where + show (MkCon s) = s + +instance Arbitrary Con where + arbitrary = growingElements [ MkCon [c] | c <- ['A'..'Z'] ] + +-- expressions + +data Exp + = Lam Var Exp + | App Exp Exp + | Var Var + | Con Con + deriving ( Eq, Ord ) + +instance Show Exp where + showsPrec n (Lam x t) = showParen (n>0) (showString "\\" . shows x . showString "." . shows t) + showsPrec n (App s t) = showParen (n>1) (showsPrec 1 s . showString " " . showsPrec 2 t) + showsPrec _ (Var x) = shows x + showsPrec _ (Con c) = shows c + +instance Arbitrary Exp where + arbitrary = sized arbExp + where + arbExp n = + frequency $ + [ (2, liftM Var arbitrary) + , (1, liftM Con arbitrary) + ] ++ + concat + [ [ (5, liftM2 Lam arbitrary arbExp1) + , (5, liftM2 App arbExp2 arbExp2) + ] + | n > 0 + ] + where + arbExp1 = arbExp (n-1) + arbExp2 = arbExp (n `div` 2) + + shrink (Lam x a) = [ a ] + ++ [ Lam x a' | a' <- shrink a ] + shrink (App a b) = [ a, b ] + ++ [ ab + | Lam x a' <- [a] + , let ab = subst x b a' + , length (show ab) < length (show (App a b)) + ] + ++ [ App a' b | a' <- shrink a ] + ++ [ App a b' | b' <- shrink b ] + shrink (Var x) = [Con (MkCon (map toUpper (show x)))] + shrink _ = [] + +-------------------------------------------------------------------------- +-- functions for lambda expressions + +free :: Exp -> Set Var +free (Lam x a) = Set.delete x (free a) +free (App a b) = free a `Set.union` free b +free (Var x) = Set.singleton x +free (Con _) = Set.empty + +subst :: Var -> Exp -> Exp -> Exp +subst x c (Var y) | x == y = c +subst x b (Lam y a) | x /= y = Lam y (subst x b a) +subst x c (App a b) = App (subst x c a) (subst x c b) +subst x c a = a + +fresh :: Var -> Set Var -> Var +fresh x ys = head (filter (`Set.notMember` ys) (x:varList)) + +rename :: Var -> Var -> Exp -> Exp +rename x y a | x == y = a + | otherwise = subst x (Var y) a + +-- different bugs: +--subst x b (Lam y a) | x /= y = Lam y (subst x b a) -- bug 1 +--subst x b (Lam y a) | x /= y = Lam y' (subst x b (rename y y' a)) where y':_ = (y:varList) \\ free b -- bug 2 +--subst x b (Lam y a) | x /= y = Lam y' (subst x b (rename y y' a)) where y' = (y:varList) \\ (x:free b) -- bug 3 +--subst x b (Lam y a) | x /= y = Lam y' (subst x b (rename y y' a)) where y' = fresh y (x:free b) -- bug 4 +--subst x c (Lam y a) | x /= y = Lam y' (subst x c (rename y y' a)) where y' = fresh y (x `insert` delete y (free a) `union` free c) + +-------------------------------------------------------------------------- +-- properties for substitutions + +showResult :: (Show a, Testable prop) => a -> (a -> prop) -> Property +showResult x f = + whenFail (putStrLn ("Result: " ++ show x)) $ + f x + +prop_SubstFreeNoVarCapture a x b = + showResult (subst x b a) $ \subst_x_b_a -> + x `Set.member` free_a ==> + free subst_x_b_a == (Set.delete x free_a `Set.union` free b) + where + free_a = free a + +prop_SubstNotFreeSame a x b = + showResult (subst x b a) $ \subst_x_b_a -> + x `Set.notMember` free a ==> + subst_x_b_a == a + +prop_SubstNotFreeSameVars a x b = + showResult (subst x b a) $ \subst_x_b_a -> + x `Set.notMember` free a ==> + free subst_x_b_a == free a + +main1 = + do quickCheck prop_SubstFreeNoVarCapture + quickCheck prop_SubstNotFreeSame + quickCheck prop_SubstNotFreeSameVars + +--expectFailure $ + + + + + + + + +-------------------------------------------------------------------------- +-- eval + +eval :: Exp -> Exp +eval (Var x) = error "eval: free variable" +eval (App a b) = + case eval a of + Lam x a' -> eval (subst x b a') + a' -> App a' (eval b) +eval a = a + +-------------------------------------------------------------------------- +-- closed lambda expressions + +newtype ClosedExp = Closed Exp deriving ( Show ) + +instance Arbitrary ClosedExp where + arbitrary = Closed `fmap` sized (arbExp []) + where + arbExp xs n = + frequency $ + [ (8, liftM Var (elements xs)) + | not (null xs) + ] ++ + [ (2, liftM Con arbitrary) + ] ++ + [ (20, do x <- arbitrary + t <- arbExp (x:xs) n' + return (Lam x t)) + | n > 0 || null xs + ] ++ + [ (20, liftM2 App (arbExp xs n2) (arbExp xs n2)) + | n > 0 + ] + where + n' = n-1 + n2 = n `div` 2 + + shrink (Closed a) = + [ Closed a' | a' <- shrink a, Set.null (free a') ] + +-------------------------------------------------------------------------- +-- properties for closed lambda expressions + +isValue :: Exp -> Bool +isValue (Var _) = False +isValue (App (Lam _ _) _) = False +isValue (App a b) = isValue a && isValue b +isValue _ = True + +prop_ClosedExpIsClosed (Closed a) = + Set.null (free a) + +prop_EvalProducesValue (Closed a) = + within 1000 $ + isValue (eval a) + +main2 = + do quickCheck prop_ClosedExpIsClosed + quickCheck prop_EvalProducesValue + +-- expectFailure $ + +-------------------------------------------------------------------------- +-- main + +main = + do main1 + main2 + +-------------------------------------------------------------------------- +-- the end. + +{- +instance Arbitrary Exp where + arbitrary = sized (arbExp []) + where + + arbitrary = repair [] `fmap` sized arbExp + where + arbExp n = + frequency $ + [ (1, liftM Var arbitrary) + ] ++ concat + [ [ (3, liftM2 Lam arbitrary (arbExp n')) + , (4, liftM2 App (arbExp n2) (arbExp n2)) + ] + | n > 0 + ] + where + n' = n-1 + n2 = n `div` 2 + + repair xs (Var x) + | x `elem` xs = Var x + | null xs = Lam x (Var x) + | otherwise = Var (xs !! (ord (last (show x)) `mod` length xs)) + repair xs (App a b) = App (repair xs a) (repair xs b) + repair xs (Lam x a) = Lam x (repair (x:xs) a) + + -- lots of clever shrinking added + shrinkRec (Lam x a) = [ a | x `notElem` free a ] + shrinkRec (App a b) = [ a, b ] + ++ [ red + | Lam x a' <- [a] + , let red = subst x b a' + , length (show red) < length (show (App a b)) + ] + shrinkRec (Var x) = [Con (MkCon (map toUpper (show x)))] + shrinkRec _ = [] + +-- types + +data Type + = Base Con + | Type :-> Type + deriving ( Eq, Show ) + +instance Arbitrary Type where + arbitrary = sized arbType + where + arbType n = + frequency $ + [ (1, liftM Base arbitrary) + ] ++ + [ (4, liftM2 (:->) arbType2 arbType2) + | n > 0 + ] + where + arbType2 = arbType (n `div` 2) + +newtype WellTypedExp = WellTyped Exp + deriving ( Eq, Show ) + +arbExpWithType n env t = + frequency $ + [ (2, liftM Var (elements xs)) + | let xs = [ x | (x,t') <- env, t == t' ] + , not (null xs) + ] ++ + [ (1, return (Con b)) + | Base b <- [t] + ] ++ + [ (if n > 0 then 5 else 1 + , do x <- arbitrary + b <- arbExpWithType n1 ((x,ta):[ xt | xt <- env, fst xt /= x ]) tb + return (Lam x b)) + | ta :-> tb <- [t] + ] ++ + [ (5, do tb <- arbitrary + a <- arbExpWithType n2 env (tb :-> t) + b <- arbExpWithType n2 env tb + return (App a b)) + | n > 0 + ] + where + n1 = n-1 + n2 = n `div` 2 + +instance Arbitrary WellTypedExp where + arbitrary = + do t <- arbitrary + e <- sized (\n -> arbExpWithType n [] t) + return (WellTyped e) + + shrink _ = [] + +newtype OpenExp = Open Exp + deriving ( Eq, Show ) + +instance Arbitrary OpenExp where + arbitrary = Open `fmap` sized arbExp + where + arbExp n = + frequency $ + [ (2, liftM Var arbitrary) + , (1, liftM Con arbitrary) + ] ++ + concat + [ [ (5, liftM2 Lam arbitrary arbExp1) + , (5, liftM2 App arbExp2 arbExp2) + ] + | n > 0 + ] + where + arbExp1 = arbExp (n-1) + arbExp2 = arbExp (n `div` 2) + + shrink (Open a) = map Open (shrink a) + +prop_EvalProducesValueWT (WellTyped a) = + isValue (eval a) + +-} + +x = MkVar "x" +y = MkVar "y" + diff --git a/examples/Merge.hs b/examples/Merge.hs new file mode 100644 --- /dev/null +++ b/examples/Merge.hs @@ -0,0 +1,116 @@ +{-# LANGUAGE ScopedTypeVariables, TemplateHaskell #-} +module Main where + +-------------------------------------------------------------------------- +-- imports + +import Test.QuickCheck + +import Data.List + ( sort + ) + +-------------------------------------------------------------------------- +-- merge sort + +msort :: Ord a => [a] -> [a] +msort xs = merging [ [x] | x <- xs ] + +merging :: Ord a => [[a]] -> [a] +merging [] = [] +merging [xs] = xs +merging xss = merging (sweep xss) + +sweep :: Ord a => [[a]] -> [[a]] +sweep [] = [] +sweep [xs] = [xs] +sweep (xs:ys:xss) = merge xs ys : sweep xss + +merge :: Ord a => [a] -> [a] -> [a] +merge xs [] = xs +merge [] ys = ys +merge (x:xs) (y:ys) + | x <= y = x : merge xs (y:ys) + | otherwise = y : merge (x:xs) ys + +-------------------------------------------------------------------------- +-- example properties + +ordered :: Ord a => [a] -> Bool +ordered [] = True +ordered [x] = True +ordered (x:y:xs) = x <= y && ordered (y:xs) + +prop_Merge xs (ys :: [Int]) = + ordered xs && ordered ys ==> + collect (length xs + length ys) $ + ordered (xs `merge` ys) + +-- collect (sort [length xs, length ys]) $ + + + + + + + + + + + + + + + + + + + +-------------------------------------------------------------------------- +-- quantificiation + +--prop_Merge (Ordered xs) (Ordered (ys :: [Int])) = +-- ordered (xs `merge` ys) + + + + + + + + + + + + + +-- classify (length xs `min` length ys >= 5) "not trivial" $ +-- cover (length xs `min` length ys >= 5) 70 "not trivial" $ + +{- + shrink (Ordered xs) = + [ Ordered xs' + | xs' <- shrink xs + , ordered xs' + ] +-} + +-------------------------------------------------------------------------- +-- merging + +prop_Merging (xss :: [OrderedList Int]) = + ordered (merging [ xs | Ordered xs <- xss ]) + + + + + + + +-- mapSize (`div` 2) $ \(xss :: [OrderedList Int]) -> + +return [] +main = $quickCheckAll + +-------------------------------------------------------------------------- +-- the end. diff --git a/examples/Set.hs b/examples/Set.hs new file mode 100644 --- /dev/null +++ b/examples/Set.hs @@ -0,0 +1,213 @@ +{-# LANGUAGE ScopedTypeVariables, TemplateHaskell #-} +module Main where + +-------------------------------------------------------------------------- +-- imports + +import Test.QuickCheck + +import Text.Show.Functions +import Data.List + ( sort + , group + , nub + , (\\) + ) + +import Control.Monad + ( liftM + , liftM2 + ) + +import Data.Maybe + +--import Text.Show.Functions + +-------------------------------------------------------------------------- +-- binary search trees + +data Set a + = Node a (Set a) (Set a) + | Empty + deriving ( Eq, Ord, Show ) + +empty :: Set a +empty = Empty + +isEmpty :: Set a -> Bool +isEmpty Empty = True +isEmpty _ = False + +unit :: a -> Set a +unit x = Node x empty empty + +size :: Set a -> Int +size Empty = 0 +size (Node _ s1 s2) = 1 + size s1 + size s2 + +insert :: Ord a => a -> Set a -> Set a +insert x s = s `union` unit x + +merge :: Set a -> Set a -> Set a +s `merge` Empty = s +s `merge` Node x Empty s2 = Node x s s2 +s `merge` Node x (Node y s11 s12) s2 = Node y s (Node x (s11 `merge` s12) s2) + +delete :: Ord a => a -> Set a -> Set a +delete x Empty = Empty +delete x (Node x' s1 s2) = + case x `compare` x' of + LT -> Node x' (delete x s1) s2 + EQ -> s1 `merge` s2 + GT -> Node x' s1 (delete x s2) + +union :: Ord a => Set a -> Set a -> Set a +{- +s1 `union` Empty = s1 +Empty `union` s2 = s2 +s1@(Node x s11 s12) `union` s2@(Node y s21 s22) = + case x `compare` y of + LT -> Node x s11 (s12 `union` Node y Empty s22) `union` s21 + EQ -> Node x (s11 `union` s21) (s12 `union` s22) + --GT -> s11 `union` Node y s21 (Node x Empty s12 `union` s22) + GT -> Node x (s11 `union` Node y s21 Empty) s12 `union` s22 +-} +s1 `union` Empty = s1 +Empty `union` s2 = s2 +Node x s11 s12 `union` s2 = Node x (s11 `union` s21) (s12 `union` s22) + where + (s21,s22) = split x s2 + +split :: Ord a => a -> Set a -> (Set a, Set a) +split x Empty = (Empty, Empty) +split x (Node y s1 s2) = + case x `compare` y of + LT -> (s11, Node y s12 s2) + EQ -> (s1, s2) + GT -> (Node y s1 s21, s22) + where + (s11,s12) = split x s1 + (s21,s22) = split x s2 + +mapp :: (a -> b) -> Set a -> Set b +mapp f Empty = Empty +mapp f (Node x s1 s2) = Node (f x) (mapp f s1) (mapp f s2) + +fromList :: Ord a => [a] -> Set a +--fromList xs = build [ (empty,x) | x <- sort xs ] +fromList xs = build [ (empty,head x) | x <- group (sort xs) ] + where + build [] = empty + build [(s,x)] = attach x s + build sxs = build (sweep sxs) + + sweep [] = [] + sweep [sx] = [sx] + sweep ((s1,x1):(s2,x2):sxs) = (Node x1 s1 s2,x2) : sweep sxs + + attach x Empty = unit x + attach x (Node y s1 s2) = Node y s1 (attach x s2) + +toList :: Set a -> [a] +toList s = toSortedList s + +toSortedList :: Set a -> [a] +toSortedList s = toList' s [] + where + toList' Empty xs = xs + toList' (Node x s1 s2) xs = toList' s1 (x : toList' s2 xs) + +-------------------------------------------------------------------------- +-- generators + +instance (Ord a, Arbitrary a) => Arbitrary (Set a) where + arbitrary = sized (arbSet Nothing Nothing) + where + arbSet mx my n = + frequency $ + [ (1, return Empty) ] ++ + [ (7, do mz <- arbitrary `suchThatMaybe` (isOK mx my) + case mz of + Nothing -> return Empty + Just z -> liftM2 (Node z) (arbSet mx mz n2) + (arbSet mz my n2) + where n2 = n `div` 2) + | n > 0 + ] + + isOK mx my z = + maybe True ( ShrinkSub (Set a) + +-------------------------------------------------------------------------- +-- properties + +(.<) :: Ord a => Set a -> a -> Bool +Empty .< x = True +Node y _ s .< x = y < x && s .< x + +(<.) :: Ord a => a -> Set a -> Bool +x <. Empty = True +x <. Node y _ s = x < y && x <. s + +(==?) :: Ord a => Set a -> [a] -> Bool +s ==? xs = invariant s && sort (toList s) == nub (sort xs) + +invariant :: Ord a => Set a -> Bool +invariant Empty = True +invariant (Node x s1 s2) = s1 .< x && x <. s2 && invariant s1 && invariant s2 + +prop_Invariant (s :: Set Int) = + invariant s + +prop_Empty = + empty ==? ([] :: [Int]) + +prop_Unit (x :: Int) = + unit x ==? [x] + +prop_Size (s :: Set Int) = + cover (size s >= 15) 60 "large" $ + size s == length (toList s) + +prop_Insert x (s :: Set Int) = + insert x s ==? (x : toList s) + +prop_Delete x (s :: Set Int) = + delete x s ==? (toList s \\ [x]) + +prop_Union s1 (s2 :: Set Int) = + (s1 `union` s2) ==? (toList s1 ++ toList s2) + +prop_Mapp (f :: Int -> Int) (s :: Set Int) = + expectFailure $ + whenFail (putStrLn ("Fun: " ++ show [ (x,f x) | x <- toList s])) $ + mapp f s ==? map f (toList s) + +prop_FromList (xs :: [Int]) = + fromList xs ==? xs + +prop_ToSortedList (s :: Set Int) = + s ==? xs && xs == sort xs + where + xs = toSortedList s + +-- whenFail (putStrLn ("Result: " ++ show (fromList xs))) $ + +prop_FromList' (xs :: [Int]) = + shrinking shrink xs $ \xs' -> + fromList xs ==? xs + +-------------------------------------------------------------------------- +-- main + +return [] +main = $quickCheckAll + +-------------------------------------------------------------------------- +-- the end. diff --git a/examples/Simple.hs b/examples/Simple.hs new file mode 100644 --- /dev/null +++ b/examples/Simple.hs @@ -0,0 +1,46 @@ +{-# LANGUAGE ScopedTypeVariables, TemplateHaskell #-} +module Main where + +-------------------------------------------------------------------------- +-- imports + +import Test.QuickCheck + +-------------------------------------------------------------------------- +-- example 1 + +allEqual x y z = x == y && y == z +allEqual' x y z = 2*x == y + z + +prop_SimonThompson x y (z :: Int) = + allEqual x y z == allEqual' x y z + +-------------------------------------------------------------------------- +-- example 2 + +prop_ReverseReverse :: Eq a => [a] -> Bool +prop_ReverseReverse xs = + reverse (reverse xs) == xs + +prop_Reverse xs = + reverse xs == xs + +-------------------------------------------------------------------------- +-- example 3 + +prop_Error (x,y) = + 2*x <= 5*y + +-------------------------------------------------------------------------- +-- main + +return [] +prop_conj = counterexample "Simon Thompson" $(monomorphic 'prop_SimonThompson) .&&. + counterexample "reverse" $(monomorphic 'prop_Reverse) +prop_disj = counterexample "reverse" $(monomorphic 'prop_Reverse) .||. + counterexample "Simon Thompson" $(monomorphic 'prop_SimonThompson) +return [] +main = $quickCheckAll + +-------------------------------------------------------------------------- +-- the end. diff --git a/tests/Generators.hs b/tests/Generators.hs --- a/tests/Generators.hs +++ b/tests/Generators.hs @@ -142,5 +142,17 @@ prop_reachesBound_Word32 = reachesBound :: Word32 -> Property prop_reachesBound_Word64 = reachesBound :: Word64 -> Property +-- Bad shrink: infinite list +-- +-- remove unexpectedFailure in prop_B1, shrinking should not loop forever. +data B1 = B1 Int deriving (Eq, Show) + +instance Arbitrary B1 where + arbitrary = fmap B1 arbitrary + shrink x = x : shrink x + +prop_B1 :: B1 -> Property +prop_B1 (B1 n) = expectFailure $ n === n + 1 + return [] -main = $quickCheckAll >>= print +main = $forAllProperties (quickCheckWithResult stdArgs { maxShrinks = 10000 }) >>= print