diff --git a/QuickCheck.cabal b/QuickCheck.cabal --- a/QuickCheck.cabal +++ b/QuickCheck.cabal @@ -1,5 +1,5 @@ Name: QuickCheck -Version: 2.10.1 +Version: 2.11 Cabal-Version: >= 1.8 Build-type: Simple License: BSD3 @@ -49,7 +49,7 @@ source-repository this type: git location: https://github.com/nick8325/quickcheck - tag: 2.10.1 + tag: 2.11 flag templateHaskell Description: Build Test.QuickCheck.All, which uses Template Haskell. @@ -118,7 +118,7 @@ if !impl(ghc) -- If your Haskell compiler can cope without some of these, please -- send a message to the QuickCheck mailing list! - cpp-options: -DNO_TIMEOUT -DNO_NEWTYPE_DERIVING -DNO_GENERICS -DNO_TEMPLATE_HASKELL -DNO_SAFE_HASKELL + cpp-options: -DNO_TIMEOUT -DNO_NEWTYPE_DERIVING -DNO_GENERICS -DNO_TEMPLATE_HASKELL -DNO_SAFE_HASKELL -DNO_TYPEABLE if !impl(hugs) && !impl(uhc) cpp-options: -DNO_ST_MONAD -DNO_MULTI_PARAM_TYPE_CLASSES diff --git a/Test/QuickCheck.hs b/Test/QuickCheck.hs --- a/Test/QuickCheck.hs +++ b/Test/QuickCheck.hs @@ -56,6 +56,7 @@ , quickCheckAll , verboseCheckAll , forAllProperties + , allProperties -- ** Testing polymorphic properties , polyQuickCheck , polyVerboseCheck @@ -106,6 +107,9 @@ , shrink2 -- ** Helper functions for implementing arbitrary + , applyArbitrary2 + , applyArbitrary3 + , applyArbitrary4 , arbitrarySizedIntegral , arbitrarySizedNatural , arbitrarySizedFractional @@ -142,6 +146,7 @@ , Fixed(..) , OrderedList(..) , NonEmptyList(..) + , InfiniteList(..) , Positive(..) , NonZero(..) , NonNegative(..) @@ -158,7 +163,7 @@ , PrintableString(..) -- ** Functions - , Fun + , Fun (..) , applyFun , applyFun2 , applyFun3 diff --git a/Test/QuickCheck/All.hs b/Test/QuickCheck/All.hs --- a/Test/QuickCheck/All.hs +++ b/Test/QuickCheck/All.hs @@ -11,6 +11,7 @@ quickCheckAll, verboseCheckAll, forAllProperties, + allProperties, -- ** Testing polymorphic properties polyQuickCheck, polyVerboseCheck, @@ -123,7 +124,16 @@ -- 'forAllProperties' has the same issue with scoping as 'quickCheckAll': -- see the note there about @return []@. forAllProperties :: Q Exp -- :: (Property -> IO Result) -> IO Bool -forAllProperties = do +forAllProperties = [| runQuickCheckAll $allProperties |] + +-- | List all properties in the current module. +-- +-- @$'allProperties'@ has type @[('String', 'Property')]@. +-- +-- 'allProperties' has the same issue with scoping as 'quickCheckAll': +-- see the note there about @return []@. +allProperties :: Q Exp +allProperties = do Loc { loc_filename = filename } <- location when (filename == "") $ error "don't run this interactively" ls <- runIO (fmap lines (readUTF8File filename)) @@ -140,7 +150,7 @@ if exists then sequence [ [| ($(stringE $ x ++ " from " ++ filename ++ ":" ++ show l), property $(monomorphic (mkName x))) |] ] else return [] - [| runQuickCheckAll $(fmap (ListE . concat) (mapM quickCheckOne idents)) |] + [| $(fmap (ListE . concat) (mapM quickCheckOne idents)) :: [(String, Property)] |] readUTF8File name = S.openFile name S.ReadMode >>= set_utf8_io_enc >>= @@ -169,7 +179,7 @@ -- and then execute @runTests@. -- -- Note: the bizarre @return []@ in the example above is needed on --- GHC 7.8; without it, 'quickCheckAll' will not be able to find +-- GHC 7.8 and later; without it, 'quickCheckAll' will not be able to find -- any of the properties. For the curious, the @return []@ is a -- Template Haskell splice that makes GHC insert the empty list -- of declarations at that point in the program; GHC typechecks diff --git a/Test/QuickCheck/Arbitrary.hs b/Test/QuickCheck/Arbitrary.hs --- a/Test/QuickCheck/Arbitrary.hs +++ b/Test/QuickCheck/Arbitrary.hs @@ -36,6 +36,9 @@ , shrink2 -- ** Helper functions for implementing arbitrary + , applyArbitrary2 + , applyArbitrary3 + , applyArbitrary4 , arbitrarySizedIntegral -- :: Integral a => Gen a , arbitrarySizedNatural -- :: Integral a => Gen a , arbitraryBoundedIntegral -- :: (Bounded a, Integral a) => Gen a @@ -180,7 +183,8 @@ -- -- 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. + -- or + -- packages. -- -- The -- goes into detail on how to write good generators. Make sure to look at it, @@ -972,6 +976,22 @@ -- ** Helper functions for implementing arbitrary + +-- | Apply a binary function to random arguments. +applyArbitrary2 :: (Arbitrary a, Arbitrary b) => (a -> b -> r) -> Gen r +applyArbitrary2 f = liftA2 f arbitrary arbitrary + +-- | Apply a ternary function to random arguments. +applyArbitrary3 + :: (Arbitrary a, Arbitrary b, Arbitrary c) + => (a -> b -> c -> r) -> Gen r +applyArbitrary3 f = liftA3 f arbitrary arbitrary arbitrary + +-- | Apply a function of arity 4 to random arguments. +applyArbitrary4 + :: (Arbitrary a, Arbitrary b, Arbitrary c, Arbitrary d) + => (a -> b -> c -> d -> r) -> Gen r +applyArbitrary4 f = applyArbitrary3 (uncurry f) -- | Generates an integral number. The number can be positive or negative -- and its maximum absolute value depends on the size parameter. diff --git a/Test/QuickCheck/Gen.hs b/Test/QuickCheck/Gen.hs --- a/Test/QuickCheck/Gen.hs +++ b/Test/QuickCheck/Gen.hs @@ -48,7 +48,7 @@ instance Applicative Gen where pure = return - (<*>) = ap + gf <*> gx = gf >>= \f -> fmap f gx instance Monad Gen where return x = diff --git a/Test/QuickCheck/Modifiers.hs b/Test/QuickCheck/Modifiers.hs --- a/Test/QuickCheck/Modifiers.hs +++ b/Test/QuickCheck/Modifiers.hs @@ -8,6 +8,9 @@ #ifndef NO_NEWTYPE_DERIVING {-# LANGUAGE GeneralizedNewtypeDeriving #-} #endif +#ifndef NO_TYPEABLE +{-# LANGUAGE DeriveDataTypeable #-} +#endif -- | Modifiers for test data. -- -- These types do things such as restricting the kind of test data that can be generated. @@ -45,6 +48,7 @@ , Fixed(..) , OrderedList(..) , NonEmptyList(..) + , InfiniteList(..) , Positive(..) , NonZero(..) , NonNegative(..) @@ -67,12 +71,17 @@ import Test.QuickCheck.Gen import Test.QuickCheck.Arbitrary +import Test.QuickCheck.Exception import Data.List ( sort ) import Data.Ix (Ix) +#ifndef NO_TYPEABLE +import Data.Typeable (Typeable) +#endif + -------------------------------------------------------------------------- -- | @Blind x@: as x, but x does not have to be in the 'Show' class. newtype Blind a = Blind {getBlind :: a} @@ -80,6 +89,9 @@ #ifndef NO_NEWTYPE_DERIVING , Num, Integral, Real, Enum #endif +#ifndef NO_TYPEABLE + , Typeable +#endif ) instance Functor Blind where @@ -100,6 +112,9 @@ #ifndef NO_NEWTYPE_DERIVING , Num, Integral, Real, Enum #endif +#ifndef NO_TYPEABLE + , Typeable +#endif ) instance Functor Fixed where @@ -113,7 +128,11 @@ -------------------------------------------------------------------------- -- | @Ordered xs@: guarantees that xs is ordered. newtype OrderedList a = Ordered {getOrdered :: [a]} - deriving ( Eq, Ord, Show, Read ) + deriving ( Eq, Ord, Show, Read +#ifndef NO_TYPEABLE + , Typeable +#endif + ) instance Functor OrderedList where fmap f (Ordered x) = Ordered (map f x) @@ -130,7 +149,11 @@ -------------------------------------------------------------------------- -- | @NonEmpty xs@: guarantees that xs is non-empty. newtype NonEmptyList a = NonEmpty {getNonEmpty :: [a]} - deriving ( Eq, Ord, Show, Read ) + deriving ( Eq, Ord, Show, Read +#ifndef NO_TYPEABLE + , Typeable +#endif + ) instance Functor NonEmptyList where fmap f (NonEmpty x) = NonEmpty (map f x) @@ -144,6 +167,61 @@ , not (null xs') ] +---------------------------------------------------------------------- +-- | @InfiniteList xs _@: guarantees that xs is an infinite list. +-- When a counterexample is found, only prints the prefix of xs +-- that was used by the program. +-- +-- Here is a contrived example property: +-- +-- > prop_take_10 :: InfiniteList Char -> Bool +-- > prop_take_10 (InfiniteList xs _) = +-- > or [ x == 'a' | x <- take 10 xs ] +-- +-- In the following counterexample, the list must start with @"bbbbbbbbbb"@ but +-- the remaining (infinite) part can contain anything: +-- +-- >>> quickCheck prop_take_10 +-- *** Failed! Falsifiable (after 1 test and 14 shrinks): +-- "bbbbbbbbbb" ++ ... +data InfiniteList a = + InfiniteList { + getInfiniteList :: [a], + infiniteListInternalData :: InfiniteListInternalData a } + +-- Uses a similar trick to Test.QuickCheck.Function: +-- the Arbitrary instance generates an infinite list, which is +-- reduced to a finite prefix by shrinking. We use discard to +-- check that nothing coming after the finite prefix is used +-- (see makeInfiniteList). +data InfiniteListInternalData a = Infinite [a] | FinitePrefix [a] + +infiniteListFromData :: InfiniteListInternalData a -> InfiniteList a +infiniteListFromData info@(Infinite xs) = InfiniteList xs info +infiniteListFromData info@(FinitePrefix xs) = + InfiniteList (xs ++ discard) info + +instance Show a => Show (InfiniteList a) where + showsPrec _ (InfiniteList _ (Infinite _)) = + ("" ++) + showsPrec n (InfiniteList _ (FinitePrefix xs)) = + (if n > 10 then ('(':) else id) . + showsPrec 0 xs . + (" ++ ..." ++) . + (if n > 10 then (')':) else id) + +instance Arbitrary a => Arbitrary (InfiniteList a) where + arbitrary = fmap infiniteListFromData arbitrary + shrink (InfiniteList _ info) = + map infiniteListFromData (shrink info) + +instance Arbitrary a => Arbitrary (InfiniteListInternalData a) where + arbitrary = fmap Infinite infiniteList + shrink (Infinite xs) = + [FinitePrefix (take n xs) | n <- map (2^) [0..]] + shrink (FinitePrefix xs) = + map FinitePrefix (shrink xs) + -------------------------------------------------------------------------- -- | @Positive x@: guarantees that @x \> 0@. newtype Positive a = Positive {getPositive :: a} @@ -151,6 +229,9 @@ #ifndef NO_NEWTYPE_DERIVING , Enum #endif +#ifndef NO_TYPEABLE + , Typeable +#endif ) instance Functor Positive where @@ -174,6 +255,9 @@ #ifndef NO_NEWTYPE_DERIVING , Enum #endif +#ifndef NO_TYPEABLE + , Typeable +#endif ) instance Functor NonZero where @@ -191,6 +275,9 @@ #ifndef NO_NEWTYPE_DERIVING , Enum #endif +#ifndef NO_TYPEABLE + , Typeable +#endif ) instance Functor NonNegative where @@ -220,6 +307,9 @@ #ifndef NO_NEWTYPE_DERIVING , Num, Integral, Real, Enum, Ix #endif +#ifndef NO_TYPEABLE + , Typeable +#endif ) instance Functor Large where @@ -237,6 +327,9 @@ #ifndef NO_NEWTYPE_DERIVING , Num, Integral, Real, Enum, Ix #endif +#ifndef NO_TYPEABLE + , Typeable +#endif ) instance Functor Small where @@ -253,6 +346,9 @@ #ifndef NO_NEWTYPE_DERIVING , Num, Integral, Real, Enum #endif +#ifndef NO_TYPEABLE + , Typeable +#endif ) instance Functor Shrink2 where @@ -349,7 +445,11 @@ -------------------------------------------------------------------------- -- | @ASCIIString@: generates an ASCII string. newtype ASCIIString = ASCIIString {getASCIIString :: String} - deriving ( Eq, Ord, Show, Read ) + deriving ( Eq, Ord, Show, Read +#ifndef NO_TYPEABLE + , Typeable +#endif + ) instance Arbitrary ASCIIString where arbitrary = ASCIIString `fmap` listOf arbitraryASCIIChar @@ -359,7 +459,11 @@ -- | @UnicodeString@: generates a unicode String. -- The string will not contain surrogate pairs. newtype UnicodeString = UnicodeString {getUnicodeString :: String} - deriving ( Eq, Ord, Show, Read ) + deriving ( Eq, Ord, Show, Read +#ifndef NO_TYPEABLE + , Typeable +#endif + ) instance Arbitrary UnicodeString where arbitrary = UnicodeString `fmap` listOf arbitraryUnicodeChar @@ -369,7 +473,11 @@ -- | @PrintableString@: generates a printable unicode String. -- The string will not contain surrogate pairs. newtype PrintableString = PrintableString {getPrintableString :: String} - deriving ( Eq, Ord, Show, Read ) + deriving ( Eq, Ord, Show, Read +#ifndef NO_TYPEABLE + , Typeable +#endif + ) instance Arbitrary PrintableString where arbitrary = PrintableString `fmap` listOf arbitraryPrintableChar diff --git a/Test/QuickCheck/Property.hs b/Test/QuickCheck/Property.hs --- a/Test/QuickCheck/Property.hs +++ b/Test/QuickCheck/Property.hs @@ -1,5 +1,8 @@ -- | Combinators for constructing properties. {-# LANGUAGE CPP #-} +#ifndef NO_TYPEABLE +{-# LANGUAGE DeriveDataTypeable #-} +#endif #ifndef NO_SAFE_HASKELL {-# LANGUAGE Safe #-} #endif @@ -28,6 +31,9 @@ #ifndef NO_DEEPSEQ import Control.DeepSeq #endif +#ifndef NO_TYPEABLE +import Data.Typeable (Typeable) +#endif -------------------------------------------------------------------------- -- fixities @@ -71,6 +77,9 @@ -- | The type of properties. newtype Property = MkProperty { unProperty :: Gen Prop } +#ifndef NO_TYPEABLE + deriving (Typeable) +#endif -- | The class of properties, i.e., types which QuickCheck knows how to test. -- Typically a property will be a function returning 'Bool' or 'Property'. @@ -617,7 +626,11 @@ infix 4 === (===) :: (Eq a, Show a) => a -> a -> Property x === y = - counterexample (show x ++ " /= " ++ show y) (x == y) + counterexample (show x ++ interpret res ++ show y) res + where + res = x == y + interpret True = " == " + interpret False = " /= " #ifndef NO_DEEPSEQ -- | Checks that a value is total, i.e., doesn't crash when evaluated. diff --git a/Test/QuickCheck/Test.hs b/Test/QuickCheck/Test.hs --- a/Test/QuickCheck/Test.hs +++ b/Test/QuickCheck/Test.hs @@ -304,10 +304,7 @@ } f MkResult{ok = Just False} -> -- failed test - do if expect res - then putPart (terminal st) (bold "*** Failed! ") - else putPart (terminal st) "+++ OK, failed as expected. " - (numShrinks, totFailed, lastFailed, res) <- foundFailure st res ts + do (numShrinks, totFailed, lastFailed, res) <- foundFailure st res ts theOutput <- terminalOutput (terminal st) if not (expect res) then return Success{ labels = summary st, @@ -330,6 +327,44 @@ where (rnd1,rnd2) = split (randomSeed st) +failureSummary :: State -> P.Result -> String +failureSummary st res = fst (failureSummaryAndReason st res) + +failureReason :: State -> P.Result -> [String] +failureReason st res = snd (failureSummaryAndReason st res) + +failureSummaryAndReason :: State -> P.Result -> (String, [String]) +failureSummaryAndReason st res = (summary, full) + where + summary = + header ++ + short 26 (oneLine reason ++ " ") ++ + count ++ "..." + + full = + (header ++ + (if isOneLine reason then reason ++ " " else "") ++ + count ++ ":"): + if isOneLine reason then [] else lines reason + + reason = P.reason res + + header = + if expect res then + bold "*** Failed! " + else "+++ OK, failed as expected. " + + count = + "(after " ++ number (numSuccessTests st+1) "test" ++ + concat [ + " and " ++ + show (numSuccessShrinks st) ++ + concat [ "." ++ show (numTryShrinks st) | numTryShrinks st > 0 ] ++ + " shrink" ++ + (if numSuccessShrinks st == 1 && numTryShrinks st == 0 then "" else "s") + | numSuccessShrinks st > 0 || numTryShrinks st > 0 ] ++ + ")" + summary :: State -> [(String, Double)] summary st = reverse . sortBy (comparing snd) @@ -408,20 +443,7 @@ localMinFound st res localMin st res _ ts = do r <- tryEvaluateIO $ - putTemp (terminal st) - ( short 26 (oneLine (P.reason res)) - ++ " (after " ++ number (numSuccessTests st+1) "test" - ++ concat [ " and " - ++ show (numSuccessShrinks st) - ++ concat [ "." ++ show (numTryShrinks st) | numTryShrinks st > 0 ] - ++ " shrink" - ++ (if numSuccessShrinks st == 1 - && numTryShrinks st == 0 - then "" else "s") - | numSuccessShrinks st > 0 || numTryShrinks st > 0 - ] - ++ ")..." - ) + putTemp (terminal st) (failureSummary st res) case r of Left err -> localMinFound st (exception "Exception while printing status message" err) { callbacks = callbacks res } @@ -447,21 +469,7 @@ localMinFound :: State -> P.Result -> IO (Int, Int, Int, P.Result) localMinFound st res = - do let report = concat [ - "(after " ++ number (numSuccessTests st+1) "test", - concat [ " and " ++ number (numSuccessShrinks st) "shrink" - | numSuccessShrinks st > 0 - ], - "): " - ] - if isOneLine (P.reason res) - then putLine (terminal st) (P.reason res ++ " " ++ report) - else do - putLine (terminal st) report - sequence_ - [ putLine (terminal st) msg - | msg <- lines (P.reason res) - ] + do sequence_ [ putLine (terminal st) msg | msg <- failureReason st res ] callbackPostFinalFailure st res -- NB no need to check if callbacks threw an exception because -- we are about to return to the user anyway diff --git a/changelog b/changelog --- a/changelog +++ b/changelog @@ -1,4 +1,19 @@ -QuickCheck 2.10.1 (release 2017-10-06) +QuickCheck 2.11 (released 2018-01-12) + * New features: + - InfiniteList modifier generates infinite lists and shows + only the relevant part. + - applyArbitrary2/3/4 for applying a function to random + arguments. + - Template Haskell function allProperties returns all + properties in a module. + + * Applicative Gen instances do less splitting. + * Property now has a Typeable instance. + * (===) now prints correct output when the property is true. + * Test.QuickCheck now exports Fun constructor. + * verboseCheck output is now slightly less confusing. + +QuickCheck 2.10.1 (released 2017-10-06) * Arbitrary instances for Foreign.C.Types are available in more GHC versions. * Fixed a bug where withMaxSuccess didn't adjust the allowed