QuickCheck 1.2.0.1 → 2.1
raw patch · 21 files changed
+2191/−901 lines, 21 filesdep +mtldep ~basesetup-changednew-uploader
Dependencies added: mtl
Dependency ranges changed: base
Files
- Debug/QuickCheck.hs +0/−21
- Debug/QuickCheck/Batch.hs +0/−21
- Debug/QuickCheck/Poly.hs +0/−19
- Debug/QuickCheck/Utils.hs +0/−21
- LICENSE +22/−26
- QuickCheck.cabal +39/−34
- Setup.hs +0/−6
- Setup.lhs +8/−0
- Test/QuickCheck.hs +92/−363
- Test/QuickCheck/Arbitrary.hs +613/−0
- Test/QuickCheck/Batch.hs +0/−269
- Test/QuickCheck/Exception.hs +20/−0
- Test/QuickCheck/Function.hs +139/−0
- Test/QuickCheck/Gen.hs +169/−0
- Test/QuickCheck/Monadic.hs +148/−0
- Test/QuickCheck/Poly.hs +92/−68
- Test/QuickCheck/Property.hs +346/−0
- Test/QuickCheck/State.hs +34/−0
- Test/QuickCheck/Test.hs +355/−0
- Test/QuickCheck/Text.hs +114/−0
- Test/QuickCheck/Utils.hs +0/−53
− Debug/QuickCheck.hs
@@ -1,21 +0,0 @@--------------------------------------------------------------------------------- |--- Module : Debug.QuickCheck--- Copyright : (c) Koen Claessen, John Hughes 2001--- License : BSD-style (see the file libraries/base/LICENSE)--- --- Maintainer : libraries@haskell.org--- Stability : deprecated--- Portability : portable------ implementation moved to Test.QuickCheck--------------------------------------------------------------------------------module Debug.QuickCheck-{-# DEPRECATED "Use module Test.QuickCheck instead" #-}- ( module Test.QuickCheck- )- where--import Test.QuickCheck-
− Debug/QuickCheck/Batch.hs
@@ -1,21 +0,0 @@--------------------------------------------------------------------------------- |--- Module : Debug.QuickCheck.Batch--- Copyright : (c) Andy Gill 2001--- License : BSD-style (see the file libraries/base/LICENSE)--- --- Maintainer : libraries@haskell.org--- Stability : deprecated--- Portability : non-portable (uses Control.Exception, Control.Concurrent)------ This is a batch driver for running QuickCheck (GHC only).-----------------------------------------------------------------------------------module Debug.QuickCheck.Batch-{-# DEPRECATED "Use module Test.QuickCheck.Batch instead" #-}- ( module Test.QuickCheck.Batch- ) where--import Test.QuickCheck.Batch-
− Debug/QuickCheck/Poly.hs
@@ -1,19 +0,0 @@--------------------------------------------------------------------------------- |--- Module : Debug.QuickCheck.Poly--- Copyright : (c) Andy Gill 2001--- License : BSD-style (see the file libraries/base/LICENSE)--- --- Maintainer : libraries@haskell.org--- Stability : deprecated--- Portability : portable-----------------------------------------------------------------------------------module Debug.QuickCheck.Poly-{-# DEPRECATED "Use module Test.QuickCheck.Poly instead" #-}- ( module Test.QuickCheck.Poly- ) where--import Test.QuickCheck.Poly-
− Debug/QuickCheck/Utils.hs
@@ -1,21 +0,0 @@--------------------------------------------------------------------------------- |--- Module : Debug.QuickCheck.Utils--- Copyright : (c) Andy Gill 2001--- License : BSD-style (see the file libraries/base/LICENSE)--- --- Maintainer : libraries@haskell.org--- Stability : deprecated--- Portability : portable------ These are some general purpose utilities for use with QuickCheck.-----------------------------------------------------------------------------------module Debug.QuickCheck.Utils-{-# DEPRECATED "Use module Test.QuickCheck.Utils instead" #-}- ( module Test.QuickCheck.Utils- ) where--import Test.QuickCheck.Utils-
LICENSE view
@@ -1,31 +1,27 @@-The Glasgow Haskell Compiler License--Copyright 2004, The University Court of the University of Glasgow. +Copyright (c) 2000-2006, Koen Claessen+Copyright (c) 2006, Bjorn Bringert All rights reserved. -Redistribution and use in source and binary forms, with or without+Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: -- Redistributions of source code must retain the above copyright notice,-this list of conditions and the following disclaimer.- -- Redistributions in binary form must reproduce the above copyright notice,-this list of conditions and the following disclaimer in the documentation-and/or other materials provided with the distribution.- -- Neither name of the University nor the names of its contributors may be-used to endorse or promote products derived from this software without-specific prior written permission. +- Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer.+- Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution.+- Neither the names of the copyright owners nor the names of the + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. -THIS SOFTWARE IS PROVIDED BY THE UNIVERSITY COURT OF THE UNIVERSITY OF-GLASGOW AND THE CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES,-INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND-FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE-UNIVERSITY COURT OF THE UNIVERSITY OF GLASGOW OR THE CONTRIBUTORS BE LIABLE-FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL-DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR-SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER-CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT-LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY-OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH-DAMAGE.+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
QuickCheck.cabal view
@@ -1,44 +1,49 @@-name: QuickCheck-version: 1.2.0.1-license: BSD3-license-file: LICENSE-author: Koen Classen and John Hughes-maintainer: libraries@haskell.org-category: Testing-homepage: http://www.math.chalmers.se/~rjmh/QuickCheck/-synopsis: Automatic testing of Haskell programs-description:- A library for testing Haskell programs automatically.+Name: QuickCheck+Version: 2.1+Cabal-Version: >= 1.2+Build-type: Simple+License: BSD3+License-file: LICENSE+Copyright: Koen Claessen <koen@cs.chalmers.se>+Author: Koen Claessen <koen@cs.chalmers.se>+Maintainer: Koen Claessen <koen@cs.chalmers.se>+Homepage: http://www.haskell.org/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. Specifications are expressed in+ 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.-build-type: Simple-cabal-version: >=1.2 -flag base3-flag base4+flag splitBase+ Description: Choose the new smaller, split-up base package. library- exposed-modules:- Debug.QuickCheck.Batch,- Debug.QuickCheck.Poly,- Debug.QuickCheck.Utils,- Debug.QuickCheck,- Test.QuickCheck.Batch,- Test.QuickCheck.Poly,- Test.QuickCheck.Utils,- Test.QuickCheck- if flag(base3)- build-depends: base >= 3 && < 4, random- else - if flag(base4)- build-depends: base >= 4 && < 5, random- cpp-options: -DBASE4=1- else- build-depends: base < 3- extensions: CPP+ Build-depends: mtl+ if flag(splitBase)+ Build-depends: base >= 3, random+ else+ Build-depends: base < 3+ Exposed-Modules:+ Test.QuickCheck,+ Test.QuickCheck.Arbitrary,+ Test.QuickCheck.Function,+ Test.QuickCheck.Gen,+ Test.QuickCheck.Monadic,+ Test.QuickCheck.Property,+ Test.QuickCheck.Test,+ Test.QuickCheck.Text,+ Test.QuickCheck.Poly,+ Test.QuickCheck.State+ Other-Modules:+ Test.QuickCheck.Exception+ GHC-options:
− Setup.hs
@@ -1,6 +0,0 @@-module Main (main) where--import Distribution.Simple--main :: IO ()-main = defaultMain
+ Setup.lhs view
@@ -0,0 +1,8 @@+#!/usr/bin/env runghc++> module Main where++> import Distribution.Simple++> main :: IO ()+> main = defaultMain
Test/QuickCheck.hs view
@@ -1,373 +1,102 @@--------------------------------------------------------------------------------- |--- Module : Test.QuickCheck--- Copyright : (c) Koen Claessen, John Hughes 2001--- License : BSD-style (see the file libraries/base/LICENSE)--- --- Maintainer : libraries@haskell.org--- Stability : experimental--- Portability : portable------ QuickCheck v.0.2--- DRAFT implementation; last update 000104.--- Koen Claessen, John Hughes.--- This file represents work in progress, and might change at a later date.---------------------------------------------------------------------------------- module Test.QuickCheck- -- testing functions- ( quickCheck -- :: prop -> IO ()- , verboseCheck -- :: prop -> IO ()- , test -- :: prop -> IO () -- = quickCheck- - , Config(..) -- :: *- , defaultConfig -- :: Config- , check -- :: Config -> prop -> IO ()- - -- property combinators- , forAll -- :: Gen a -> (a -> prop) -> prop- , (==>) -- :: Bool -> prop -> prop- - -- gathering test-case information- , label -- :: String -> prop -> prop- , collect -- :: Show a => a -> prop -> prop- , classify -- :: Bool -> String -> prop -> prop- , trivial -- :: Bool -> prop -> prop- - -- generator combinators- , Gen -- :: * -> * ; Functor, Monad- - , elements -- :: [a] -> Gen a- , two -- :: Gen a -> Gen (a,a)- , three -- :: Gen a -> Gen (a,a,a)- , four -- :: Gen a -> Gen (a,a,a,a)- - , sized -- :: (Int -> Gen a) -> Gen a- , resize -- :: Int -> Gen a -> Gen a- , choose -- :: Random a => (a, a) -> Gen a- , oneof -- :: [Gen a] -> Gen a- , frequency -- :: [(Int, Gen a)] -> Gen a- - , vector -- :: Arbitrary a => Int -> Gen [a]+ ( + -- * Running tests+ quickCheck+ , Args(..), Result(..)+ , stdArgs+ , quickCheckWith+ , quickCheckWithResult+ , quickCheckResult+ + -- * Random generation+ , Gen+ -- ** Generator combinators+ , sized+ , resize+ , choose+ , promote+ , suchThat+ , suchThatMaybe+ , oneof+ , frequency+ , elements+ , growingElements+ , listOf+ , listOf1+ , vectorOf+ -- ** Generators which use Arbitrary+ , vector+ , orderedList+ -- ** Generator debugging+ , sample+ , sample' - -- default generators- , Arbitrary(..) -- :: class- , rand -- :: Gen StdGen- , promote -- :: (a -> Gen b) -> Gen (a -> b)- , variant -- :: Int -> Gen a -> Gen a+ -- * Arbitrary and CoArbitrary classes.+ , Arbitrary(..)+ , CoArbitrary(..)+ + -- ** Helper functions for implementing arbitrary+ , arbitrarySizedIntegral+ , arbitrarySizedFractional+ , arbitraryBoundedIntegral+ , arbitraryBoundedRandom+ -- ** Helper functions for implementing shrink+ , shrinkNothing+ , shrinkIntegral+ , shrinkRealFrac+ -- ** Helper functions for implementing coarbitrary+ , variant+ , (><)+ , coarbitraryIntegral+ , coarbitraryReal+ , coarbitraryShow - -- testable- , Testable(..) -- :: class- , Property -- :: *+ -- ** Type-level modifiers for changing generator behavior+ , Blind(..)+ , Fixed(..)+ , OrderedList(..)+ , NonEmptyList(..)+ , Positive(..)+ , NonZero(..)+ , NonNegative(..)+ , Smart(..)+ , Shrinking(..)+ , ShrinkState(..) - -- For writing your own driver- , Result(..) -- :: data- , generate -- :: Int -> StdGen -> Gen a -> a- , evaluate -- :: Testable a => a -> Gen Result+ -- * Properties+ , Property, Prop, Testable(..)+ -- ** Property combinators+ , mapSize+ , shrinking+ , (==>)+ , forAll+ , forAllShrink+ , (.&.)+ -- *** Handling failure+ , whenFail+ , whenFail'+ , expectFailure+ , within+ -- *** Test distribution+ , label+ , collect+ , classify+ , cover+ + -- * Text formatting+ , Str(..)+ , ranges ) where -import Prelude--import System.Random-import Data.List( group, sort, intersperse )-import Control.Monad( liftM2, liftM3, liftM4 )--infixr 0 ==>-infix 1 `classify`------------------------------------------------------------------------- Generator--newtype Gen a- = Gen (Int -> StdGen -> a)--sized :: (Int -> Gen a) -> Gen a-sized fgen = Gen (\n r -> let Gen m = fgen n in m n r)--resize :: Int -> Gen a -> Gen a-resize n (Gen m) = Gen (\_ r -> m n r)--rand :: Gen StdGen-rand = Gen (\n r -> r)--promote :: (a -> Gen b) -> Gen (a -> b)-promote f = Gen (\n r -> \a -> let Gen m = f a in m n r)--variant :: Int -> Gen a -> Gen a-variant v (Gen m) = Gen (\n r -> m n (rands r v))- where- rands r0 0 = r0- rands r0 n = let (r1,r2) = split r0- (n',s) = n `quotRem` 2- in case s of- 0 -> rands r1 n'- _ -> rands r2 n'--generate :: Int -> StdGen -> Gen a -> a-generate n rnd (Gen m) = m size rnd'- where- (size, rnd') = randomR (0, n) rnd--instance Functor Gen where- fmap f m = m >>= return . f--instance Monad Gen where- return a = Gen (\n r -> a)- Gen m >>= k =- Gen (\n r0 -> let (r1,r2) = split r0- Gen m' = k (m n r1)- in m' n r2)---- derived--choose :: Random a => (a, a) -> Gen a-choose bounds = (fst . randomR bounds) `fmap` rand--elements :: [a] -> Gen a-elements xs = (xs !!) `fmap` choose (0, length xs - 1)--vector :: Arbitrary a => Int -> Gen [a]-vector n = sequence [ arbitrary | i <- [1..n] ]--oneof :: [Gen a] -> Gen a-oneof gens = elements gens >>= id--frequency :: [(Int, Gen a)] -> Gen a-frequency xs = choose (1, tot) >>= (`pick` xs)- where- tot = sum (map fst xs)-- pick n ((k,x):xs)- | n <= k = x- | otherwise = pick (n-k) xs---- general monadic--two :: Monad m => m a -> m (a, a)-two m = liftM2 (,) m m--three :: Monad m => m a -> m (a, a, a)-three m = liftM3 (,,) m m m--four :: Monad m => m a -> m (a, a, a, a)-four m = liftM4 (,,,) m m m m------------------------------------------------------------------------- Arbitrary--class Arbitrary a where- arbitrary :: Gen a- coarbitrary :: a -> Gen b -> Gen b--instance Arbitrary () where- arbitrary = return ()- coarbitrary _ = variant 0--instance Arbitrary Bool where- arbitrary = elements [True, False]- coarbitrary b = if b then variant 0 else variant 1--instance Arbitrary Int where- arbitrary = sized $ \n -> choose (-n,n)- coarbitrary n = variant (if n >= 0 then 2*n else 2*(-n) + 1)--instance Arbitrary Integer where- arbitrary = sized $ \n -> choose (-fromIntegral n,fromIntegral n)- coarbitrary n = variant (fromInteger (if n >= 0 then 2*n else 2*(-n) + 1))--instance Arbitrary Float where- arbitrary = liftM3 fraction arbitrary arbitrary arbitrary - coarbitrary x = coarbitrary (decodeFloat x)--instance Arbitrary Double where- arbitrary = liftM3 fraction arbitrary arbitrary arbitrary - coarbitrary x = coarbitrary (decodeFloat x)--fraction a b c = fromInteger a + (fromInteger b / (abs (fromInteger c) + 1))--instance (Arbitrary a, Arbitrary b) => Arbitrary (a, b) where- arbitrary = liftM2 (,) arbitrary arbitrary- coarbitrary (a, b) = coarbitrary a . coarbitrary b--instance (Arbitrary a, Arbitrary b, Arbitrary c) => Arbitrary (a, b, c) where- arbitrary = liftM3 (,,) arbitrary arbitrary arbitrary- coarbitrary (a, b, c) = coarbitrary a . coarbitrary b . coarbitrary c--instance (Arbitrary a, Arbitrary b, Arbitrary c, Arbitrary d)- => Arbitrary (a, b, c, d)- where- arbitrary = liftM4 (,,,) arbitrary arbitrary arbitrary arbitrary- coarbitrary (a, b, c, d) =- coarbitrary a . coarbitrary b . coarbitrary c . coarbitrary d--instance (Arbitrary a) => Arbitrary (Maybe a) where- arbitrary = sized arbMaybe- where- arbMaybe 0 = return Nothing- arbMaybe n = fmap Just (resize (n-1) arbitrary)- coarbitrary Nothing = variant 0- coarbitrary (Just x) = variant 1 . coarbitrary x--instance (Arbitrary a, Arbitrary b) => Arbitrary (Either a b) where- arbitrary = oneof [fmap Left arbitrary, fmap Right arbitrary]- coarbitrary (Left x) = variant 0 . coarbitrary x- coarbitrary (Right x) = variant 1 . coarbitrary x--instance Arbitrary a => Arbitrary [a] where- arbitrary = sized (\n -> choose (0,n) >>= vector)- coarbitrary [] = variant 0- coarbitrary (a:as) = coarbitrary a . variant 1 . coarbitrary as--instance (Arbitrary a, Arbitrary b) => Arbitrary (a -> b) where- arbitrary = promote (`coarbitrary` arbitrary)- coarbitrary f gen = arbitrary >>= ((`coarbitrary` gen) . f)------------------------------------------------------------------------- Testable--data Result- = Result { ok :: Maybe Bool, stamp :: [String], arguments :: [String] }--nothing :: Result-nothing = Result{ ok = Nothing, stamp = [], arguments = [] }--newtype Property- = Prop (Gen Result)--result :: Result -> Property-result res = Prop (return res)--evaluate :: Testable a => a -> Gen Result-evaluate a = gen where Prop gen = property a--class Testable a where- property :: a -> Property--instance Testable () where- property _ = result nothing--instance Testable Bool where- property b = result (nothing{ ok = Just b })--instance Testable Result where- property res = result res--instance Testable Property where- property prop = prop--instance (Arbitrary a, Show a, Testable b) => Testable (a -> b) where- property f = forAll arbitrary f--forAll :: (Show a, Testable b) => Gen a -> (a -> b) -> Property-forAll gen body = Prop $- do a <- gen- res <- evaluate (body a)- return (argument a res)- where- argument a res = res{ arguments = show a : arguments res }--(==>) :: Testable a => Bool -> a -> Property-True ==> a = property a-False ==> a = property ()--label :: Testable a => String -> a -> Property-label s a = Prop (add `fmap` evaluate a)- where- add res = res{ stamp = s : stamp res }--classify :: Testable a => Bool -> String -> a -> Property-classify True name = label name-classify False _ = property--trivial :: Testable a => Bool -> a -> Property-trivial = (`classify` "trivial")--collect :: (Show a, Testable b) => a -> b -> Property-collect v = label (show v)------------------------------------------------------------------------- Testing--data Config = Config- { configMaxTest :: Int- , configMaxFail :: Int- , configSize :: Int -> Int- , configEvery :: Int -> [String] -> String- }--quick :: Config-quick = Config- { configMaxTest = 100- , configMaxFail = 1000- , configSize = (+ 3) . (`div` 2)- , configEvery = \n args -> let s = show n in s ++ [ '\b' | _ <- s ]- }- -verbose :: Config-verbose = quick- { configEvery = \n args -> show n ++ ":\n" ++ unlines args- }--defaultConfig :: Config-defaultConfig = quick--test, quickCheck, verboseCheck :: Testable a => a -> IO ()-test = check quick-quickCheck = check quick-verboseCheck = check verbose- -check :: Testable a => Config -> a -> IO ()-check config a =- do rnd <- newStdGen- tests config (evaluate a) rnd 0 0 []--tests :: Config -> Gen Result -> StdGen -> Int -> Int -> [[String]] -> IO () -tests config gen rnd0 ntest nfail stamps- | ntest == configMaxTest config = do done "OK, passed" ntest stamps- | nfail == configMaxFail config = do done "Arguments exhausted after" ntest stamps- | otherwise =- do putStr (configEvery config ntest (arguments result))- case ok result of- Nothing ->- tests config gen rnd1 ntest (nfail+1) stamps- Just True ->- tests config gen rnd1 (ntest+1) nfail (stamp result:stamps)- Just False ->- putStr ( "Falsifiable, after "- ++ show ntest- ++ " tests:\n"- ++ unlines (arguments result)- )- where- result = generate (configSize config ntest) rnd2 gen- (rnd1,rnd2) = split rnd0--done :: String -> Int -> [[String]] -> IO ()-done mesg ntest stamps =- do putStr ( mesg ++ " " ++ show ntest ++ " tests" ++ table )- where- table = display- . map entry- . reverse- . sort- . map pairLength- . group- . sort- . filter (not . null)- $ stamps-- display [] = ".\n"- display [x] = " (" ++ x ++ ").\n"- display xs = ".\n" ++ unlines (map (++ ".") xs)-- pairLength xss@(xs:_) = (length xss, xs)- entry (n, xs) = percentage n ntest- ++ " "- ++ concat (intersperse ", " xs)+--------------------------------------------------------------------------+-- imports - percentage n m = show ((100 * n) `div` m) ++ "%"+import Test.QuickCheck.Gen+import Test.QuickCheck.Arbitrary+import Test.QuickCheck.Property hiding ( Result(..) )+import Test.QuickCheck.Test+import Test.QuickCheck.Text ---------------------------------------------------------------------+-------------------------------------------------------------------------- -- the end.
+ Test/QuickCheck/Arbitrary.hs view
@@ -0,0 +1,613 @@+{-# OPTIONS -fglasgow-exts #-}+module Test.QuickCheck.Arbitrary+ ( + -- * Arbitrary and CoArbitrary classes.+ Arbitrary(..)+ , CoArbitrary(..)+ + -- ** Helper functions for implementing arbitrary+ , arbitrarySizedIntegral -- :: Num a => Gen a+ , arbitrarySizedFractional -- :: Fractional a => Gen a+ , arbitraryBoundedIntegral -- :: (Bounded a, Integral a) => Gen a+ , arbitraryBoundedRandom -- :: (Bounded a, Random a) => Gen a+ -- ** Helper functions for implementing shrink+ , shrinkNothing -- :: a -> [a]+ , shrinkIntegral -- :: Integral a => a -> [a]+ , shrinkRealFrac -- :: RealFrac a => a -> [a]+ -- ** Helper functions for implementing coarbitrary+ , (><)+ , coarbitraryIntegral -- :: Integral a => a -> Gen b -> Gen b+ , coarbitraryReal -- :: Real a => a -> Gen b -> Gen b+ , coarbitraryShow -- :: Show a => a -> Gen b -> Gen b+ + -- ** Generators which use arbitrary+ , vector -- :: Arbitrary a => Int -> Gen [a]+ , orderedList -- :: (Ord a, Arbitrary a) => Gen [a]++ -- ** Type-level modifiers for changing generator behavior+ , Blind(..)+ , Fixed(..)+ , OrderedList(..)+ , NonEmptyList(..)+ , Positive(..)+ , NonZero(..)+ , NonNegative(..)+ , Smart(..)+ , Shrinking(..)+ , ShrinkState(..)+ )+ where++--------------------------------------------------------------------------+-- imports++import Test.QuickCheck.Gen++{-+import Data.Generics+ ( (:*:)(..)+ , (:+:)(..)+ , Unit(..)+ )+-}++import Data.Char+ ( chr+ , ord+ , isLower+ )++import Data.Ratio+ ( Ratio+ , (%)+ , numerator+ , denominator+ )++import System.Random+ ( Random+ )++import Data.List+ ( sort+ , nub+ )++import Control.Monad+ ( liftM+ , liftM2+ , liftM3+ , liftM4+ , liftM5+ )++--------------------------------------------------------------------------+-- ** class Arbitrary++-- | Random generation and shrinking of values.+class Arbitrary a where+ -- | A generator for values of the given type.+ arbitrary :: Gen a+ arbitrary = error "no default generator"+ + -- | Produces a (possibly) empty list of all the possible+ -- immediate shrinks of the given value.+ shrink :: a -> [a]+ shrink _ = []++-- instances++instance (CoArbitrary a, Arbitrary b) => Arbitrary (a -> b) where+ arbitrary = promote (`coarbitrary` arbitrary)++instance Arbitrary () where+ arbitrary = return ()++instance Arbitrary Bool where+ arbitrary = choose (False,True)++instance Arbitrary a => Arbitrary (Maybe a) where+ arbitrary = frequency [(1, return Nothing), (3, liftM Just arbitrary)]+ + shrink (Just x) = Nothing : [ Just x' | x' <- shrink x ]+ shrink _ = []++instance (Arbitrary a, Arbitrary b) => Arbitrary (Either a b) where+ arbitrary = oneof [liftM Left arbitrary, liftM Right arbitrary]+ + shrink (Left x) = [ Left x' | x' <- shrink x ]+ shrink (Right y) = [ Right y' | y' <- shrink y ]+ +instance Arbitrary a => Arbitrary [a] where+ arbitrary = sized $ \n ->+ do k <- choose (0,n)+ sequence [ arbitrary | _ <- [1..k] ]++ shrink xs = removeChunks xs+ ++ shrinkOne xs+ where+ removeChunks xs = rem (length xs) xs+ where+ rem 0 _ = []+ rem 1 _ = [[]]+ rem n xs = xs1+ : xs2+ : ( [ xs1' ++ xs2 | xs1' <- rem n1 xs1, not (null xs1') ]+ `ilv` [ xs1 ++ xs2' | xs2' <- rem n2 xs2, not (null xs2') ]+ )+ where+ n1 = n `div` 2+ xs1 = take n1 xs+ n2 = n - n1+ xs2 = drop n1 xs+ + [] `ilv` ys = ys+ xs `ilv` [] = xs+ (x:xs) `ilv` (y:ys) = x : y : (xs `ilv` ys)+ + shrinkOne [] = []+ shrinkOne (x:xs) = [ x':xs | x' <- shrink x ]+ ++ [ x:xs' | xs' <- shrinkOne xs ] ++{-+ -- "standard" definition for lists:+ shrink [] = []+ shrink (x:xs) = [ xs ]+ ++ [ x:xs' | xs' <- shrink xs ]+ ++ [ x':xs | x' <- shrink x ]+-}++instance (Integral a, Arbitrary a) => Arbitrary (Ratio a) where+ arbitrary = arbitrarySizedFractional+ shrink = shrinkRealFrac++instance (Arbitrary a, Arbitrary b)+ => Arbitrary (a,b)+ where+ arbitrary = liftM2 (,) arbitrary arbitrary+ + shrink (x,y) = [ (x',y) | x' <- shrink x ]+ ++ [ (x,y') | y' <- shrink y ]+ +instance (Arbitrary a, Arbitrary b, Arbitrary c)+ => Arbitrary (a,b,c)+ where+ arbitrary = liftM3 (,,) arbitrary arbitrary arbitrary+ + shrink (x,y,z) = [ (x',y,z) | x' <- shrink x ]+ ++ [ (x,y',z) | y' <- shrink y ]+ ++ [ (x,y,z') | z' <- shrink z ]+ +instance (Arbitrary a, Arbitrary b, Arbitrary c, Arbitrary d)+ => Arbitrary (a,b,c,d)+ where+ arbitrary = liftM4 (,,,) arbitrary arbitrary arbitrary arbitrary+ + shrink (w,x,y,z) = [ (w',x,y,z) | w' <- shrink w ]+ ++ [ (w,x',y,z) | x' <- shrink x ]+ ++ [ (w,x,y',z) | y' <- shrink y ]+ ++ [ (w,x,y,z') | z' <- shrink z ]+ +instance (Arbitrary a, Arbitrary b, Arbitrary c, Arbitrary d, Arbitrary e)+ => Arbitrary (a,b,c,d,e)+ where+ arbitrary = liftM5 (,,,,) arbitrary arbitrary arbitrary arbitrary arbitrary+ + shrink (v,w,x,y,z) = [ (v',w,x,y,z) | v' <- shrink v ]+ ++ [ (v,w',x,y,z) | w' <- shrink w ]+ ++ [ (v,w,x',y,z) | x' <- shrink x ]+ ++ [ (v,w,x,y',z) | y' <- shrink y ]+ ++ [ (v,w,x,y,z') | z' <- shrink z ]+ +-- typical instance for primitive (numerical) types++instance Arbitrary Integer where+ arbitrary = arbitrarySizedIntegral+ shrink = shrinkIntegral++instance Arbitrary Int where+ --arbitrary = arbitrarySizedIntegral+ arbitrary = arbitrarySizedBoundedInt+ shrink = shrinkIntegral++instance Arbitrary Char where+ arbitrary = chr `fmap` oneof [choose (0,127), choose (0,255)]+ shrink c = [ c' | c' <- ['a','b','c'], c' < c || not (isLower c) ]++instance Arbitrary Float where+ arbitrary = arbitrarySizedFractional+ shrink = shrinkRealFrac++instance Arbitrary Double where+ arbitrary = arbitrarySizedFractional+ shrink = shrinkRealFrac++-- ** Helper functions for implementing arbitrary++-- | Generates an integral number. The number can be positive or negative+-- and its maximum absolute value depends on the size parameter.+arbitrarySizedIntegral :: Num a => Gen a+arbitrarySizedIntegral =+ sized $ \n ->+ let n' = toInteger n in+ fmap fromInteger (choose (-n', n'))++-- | Generates a fractional number. The number can be positive or negative+-- and its maximum absolute value depends on the size parameter.+arbitrarySizedFractional :: Fractional a => Gen a+arbitrarySizedFractional =+ sized $ \n ->+ let n' = toInteger n in+ do a <- choose ((-n') * precision, n' * precision)+ b <- choose (1, precision)+ return (fromRational (a % b))+ where+ precision = 9999999999999 :: Integer++-- | Generates an integral number. The number is chosen from the entire+-- range of the type.+arbitraryBoundedIntegral :: (Bounded a, Integral a) => Gen a+arbitraryBoundedIntegral =+ do let mn = minBound+ mx = maxBound `asTypeOf` mn+ n <- choose (toInteger mn, toInteger mx)+ return (fromInteger n `asTypeOf` mn)++-- | Generates an element of a bounded type. The element is+-- chosen from the entire range of the type.+arbitraryBoundedRandom :: (Bounded a, Random a) => Gen a+arbitraryBoundedRandom = choose (minBound,maxBound)++-- | Generates an integral number from a bounded domain.+-- Inspired by demands from Phil Wadler.+arbitrarySizedBoundedInt :: Gen Int+arbitrarySizedBoundedInt =+ sized $ \s ->+ do let mn = minBound+ mx = maxBound `asTypeOf` mn+ k = 2^(s*2 `div` 5)+ n <- choose (toInteger mn `max` (-k), toInteger mx `min` k)+ return (fromInteger n `asTypeOf` mn)++-- ** Helper functions for implementing shrink++-- | Returns no shrinking alternatives. +shrinkNothing :: a -> [a]+shrinkNothing _ = []++-- | Shrink an integral number.+shrinkIntegral :: Integral a => a -> [a]+shrinkIntegral x = + nub $+ [ -x+ | x < 0+ ] +++ [ x'+ | x' <- takeWhile (<< x) (0:[ x - i | i <- tail (iterate (`quot` 2) x) ])+ ]+ where+ x << y = abs x < abs y++-- | Shrink a fraction.+shrinkRealFrac :: RealFrac a => a -> [a]+shrinkRealFrac x =+ nub $+ [ -x+ | x < 0+ ] +++ [ x'+ | x' <- [fromInteger (truncate x)]+ , x' << x+ ]+ where+ x << y = abs x < abs y++--------------------------------------------------------------------------+-- ** CoArbitrary++-- | Used for random generation of functions.+class CoArbitrary a where+ -- | Used to generate a function of type @a -> c@. The implementation+ -- should use the first argument to perturb the random generator+ -- given as the second argument. the returned generator + -- is then used to generate the function result.+ -- You can often use 'variant' and '><' to implement + -- 'coarbitrary'.+ coarbitrary :: a -> Gen c -> Gen c++{-+ -- GHC definition:+ coarbitrary{| Unit |} Unit = id+ coarbitrary{| a :*: b |} (x :*: y) = coarbitrary x >< coarbitrary y+ coarbitrary{| a :+: b |} (Inl x) = variant 0 . coarbitrary x+ coarbitrary{| a :+: b |} (Inr y) = variant (-1) . coarbitrary y+-}++-- | Combine two generator perturbing functions, for example the +-- results of calls to 'variant' or 'coarbitrary'.+(><) :: (Gen a -> Gen a) -> (Gen a -> Gen a) -> (Gen a -> Gen a) +(><) f g gen =+ do n <- arbitrary+ (g . variant (n :: Int) . f) gen ++-- for the sake of non-GHC compilers, I have added definitions+-- for coarbitrary here.++instance (Arbitrary a, CoArbitrary b) => CoArbitrary (a -> b) where+ coarbitrary f gen =+ do xs <- arbitrary+ coarbitrary (map f xs) gen+ +instance CoArbitrary () where+ coarbitrary _ = id++instance CoArbitrary Bool where+ coarbitrary False = variant 0+ coarbitrary True = variant (-1)++instance CoArbitrary a => CoArbitrary (Maybe a) where+ coarbitrary Nothing = variant 0+ coarbitrary (Just x) = variant (-1) . coarbitrary x++instance (CoArbitrary a, CoArbitrary b) => CoArbitrary (Either a b) where+ coarbitrary (Left x) = variant 0 . coarbitrary x+ coarbitrary (Right y) = variant (-1) . coarbitrary y+ +instance CoArbitrary a => CoArbitrary [a] where+ coarbitrary [] = variant 0+ coarbitrary (x:xs) = variant (-1) . coarbitrary (x,xs)++instance (Integral a, CoArbitrary a) => CoArbitrary (Ratio a) where+ coarbitrary r = coarbitrary (numerator r,denominator r)++instance (CoArbitrary a, CoArbitrary b)+ => CoArbitrary (a,b)+ where+ coarbitrary (x,y) = coarbitrary x+ >< coarbitrary y+ +instance (CoArbitrary a, CoArbitrary b, CoArbitrary c)+ => CoArbitrary (a,b,c)+ where+ coarbitrary (x,y,z) = coarbitrary x+ >< coarbitrary y+ >< coarbitrary z+ +instance (CoArbitrary a, CoArbitrary b, CoArbitrary c, CoArbitrary d)+ => CoArbitrary (a,b,c,d)+ where+ coarbitrary (x,y,z,v) = coarbitrary x+ >< coarbitrary y+ >< coarbitrary z+ >< coarbitrary v+ +instance (CoArbitrary a, CoArbitrary b, CoArbitrary c, CoArbitrary d, CoArbitrary e)+ => CoArbitrary (a,b,c,d,e)+ where+ coarbitrary (x,y,z,v,w) = coarbitrary x+ >< coarbitrary y+ >< coarbitrary z+ >< coarbitrary v+ >< coarbitrary w+ +-- typical instance for primitive (numerical) types++instance CoArbitrary Integer where+ coarbitrary = coarbitraryIntegral++instance CoArbitrary Int where+ coarbitrary = coarbitraryIntegral++instance CoArbitrary Char where+ coarbitrary = coarbitrary . ord++instance CoArbitrary Float where+ coarbitrary = coarbitraryReal++instance CoArbitrary Double where+ coarbitrary = coarbitraryReal++-- ** Helpers for implementing coarbitrary++-- | A 'coarbitrary' implementation for integral numbers.+coarbitraryIntegral :: Integral a => a -> Gen b -> Gen b+coarbitraryIntegral = variant++-- | A 'coarbitrary' implementation for real numbers.+coarbitraryReal :: Real a => a -> Gen b -> Gen b+coarbitraryReal x = coarbitrary (toRational x)++-- | 'coarbitrary' helper for lazy people :-).+coarbitraryShow :: Show a => a -> Gen b -> Gen b+coarbitraryShow x = coarbitrary (show x)++--------------------------------------------------------------------------+-- ** arbitrary generators++-- these are here and not in Gen because of the Arbitrary class constraint++-- | Generates a list of a given length.+vector :: Arbitrary a => Int -> Gen [a]+vector k = vectorOf k arbitrary++-- | Generates an ordered list of a given length.+orderedList :: (Ord a, Arbitrary a) => Gen [a]+orderedList = sort `fmap` arbitrary++--------------------------------------------------------------------------+-- ** arbitrary modifiers++-- These datatypes are mainly here to *pattern match* on in properties.+-- This is a stylistic alternative to using explicit quantification.+-- In other words, they should not be replaced by type synonyms, and their+-- constructors should be exported.++-- Examples:+{-+prop_TakeDropWhile (Blind p) (xs :: [A]) = -- because functions cannot be shown+ takeWhile p xs ++ dropWhile p xs == xs++prop_TakeDrop (NonNegative n) (xs :: [A]) = -- (BTW, also works for negative n)+ take n xs ++ drop n xs == xs++prop_Cycle (NonNegative n) (NonEmpty (xs :: [A])) = -- cycle does not work for empty lists+ take n (cycle xs) == take n (xs ++ cycle xs)++prop_Sort (Ordered (xs :: [OrdA])) = -- instead of "forAll orderedList"+ sort xs == xs+-}++-- | @Blind x@: as x, but x does not have to be in the 'Show' class.+newtype Blind a = Blind a+ deriving ( Eq, Ord, Num, Integral, Real, Enum )++instance Show (Blind a) where+ show _ = "(*)"++instance Arbitrary a => Arbitrary (Blind a) where+ arbitrary = Blind `fmap` arbitrary++ shrink (Blind x) = [ Blind x' | x' <- shrink x ]++-- | @Fixed x@: as x, but will not be shrunk.+newtype Fixed a = Fixed a+ deriving ( Eq, Ord, Num, Integral, Real, Enum, Show, Read )++instance Arbitrary a => Arbitrary (Fixed a) where+ arbitrary = Fixed `fmap` arbitrary+ + -- no shrink function++-- | @Ordered xs@: guarantees that xs is ordered.+newtype OrderedList a = Ordered [a]+ deriving ( Eq, Ord, Show, Read )++instance (Ord a, Arbitrary a) => Arbitrary (OrderedList a) where+ arbitrary = Ordered `fmap` orderedList++ shrink (Ordered xs) =+ [ Ordered xs'+ | xs' <- shrink xs+ , sort xs' == xs'+ ]++-- | @NonEmpty xs@: guarantees that xs is non-empty.+newtype NonEmptyList a = NonEmpty [a]+ deriving ( Eq, Ord, Show, Read )++instance Arbitrary a => Arbitrary (NonEmptyList a) where+ arbitrary = NonEmpty `fmap` (arbitrary `suchThat` (not . null))++ shrink (NonEmpty xs) =+ [ NonEmpty xs'+ | xs' <- shrink xs+ , not (null xs')+ ]++-- | @Positive x@: guarantees that @x \> 0@.+newtype Positive a = Positive a+ deriving ( Eq, Ord, Num, Integral, Real, Enum, Show, Read )++instance (Num a, Ord a, Arbitrary a) => Arbitrary (Positive a) where+ arbitrary =+ (Positive . abs) `fmap` (arbitrary `suchThat` (/= 0))++ shrink (Positive x) =+ [ Positive x'+ | x' <- shrink x+ , x' > 0+ ]++-- | @NonZero x@: guarantees that @x \/= 0@.+newtype NonZero a = NonZero a+ deriving ( Eq, Ord, Num, Integral, Real, Enum, Show, Read )++instance (Num a, Ord a, Arbitrary a) => Arbitrary (NonZero a) where+ arbitrary = fmap NonZero $ arbitrary `suchThat` (/= 0)++ shrink (NonZero x) = [ NonZero x' | x' <- shrink x, x' /= 0 ]++-- | @NonNegative x@: guarantees that @x \>= 0@.+newtype NonNegative a = NonNegative a+ deriving ( Eq, Ord, Num, Integral, Real, Enum, Show, Read )++instance (Num a, Ord a, Arbitrary a) => Arbitrary (NonNegative a) where+ arbitrary =+ frequency+ -- why is this distrbution like this?+ [ (5, (NonNegative . abs) `fmap` arbitrary)+ , (1, return 0)+ ]++ shrink (NonNegative x) =+ [ NonNegative x'+ | x' <- shrink x+ , x' >= 0+ ]++-- | @Smart _ x@: tries a different order when shrinking.+data Smart a =+ Smart Int a++instance Show a => Show (Smart a) where+ showsPrec n (Smart _ x) = showsPrec n x++instance Arbitrary a => Arbitrary (Smart a) where+ arbitrary =+ do x <- arbitrary+ return (Smart 0 x)++ shrink (Smart i x) = take i' ys `ilv` drop i' ys+ where+ ys = [ Smart i y | (i,y) <- [0..] `zip` shrink x ]+ i' = 0 `max` (i-2)++ [] `ilv` bs = bs+ as `ilv` [] = as+ (a:as) `ilv` (b:bs) = a : b : (as `ilv` bs)+ +{-+ shrink (Smart i x) = part0 ++ part2 ++ part1+ where+ ys = [ Smart i y | (i,y) <- [0..] `zip` shrink x ]+ i' = 0 `max` (i-2)+ k = i `div` 10+ + part0 = take k ys+ part1 = take (i'-k) (drop k ys)+ part2 = drop i' ys+-}++ -- drop a (drop b xs) == drop (a+b) xs | a,b >= 0+ -- take a (take b xs) == take (a `min` b) xs+ -- take a xs ++ drop a xs == xs+ + -- take k ys ++ take (i'-k) (drop k ys) ++ drop i' ys+ -- == take k ys ++ take (i'-k) (drop k ys) ++ drop (i'-k) (drop k ys)+ -- == take k ys ++ take (i'-k) (drop k ys) ++ drop (i'-k) (drop k ys)+ -- == take k ys ++ drop k ys+ -- == ys++-- | @Shrinking _ x@: allows for maintaining a state during shrinking.+data Shrinking s a =+ Shrinking s a++class ShrinkState s a where+ shrinkInit :: a -> s+ shrinkState :: a -> s -> [(a,s)]++instance Show a => Show (Shrinking s a) where+ showsPrec n (Shrinking _ x) = showsPrec n x++instance (Arbitrary a, ShrinkState s a) => Arbitrary (Shrinking s a) where+ arbitrary =+ do x <- arbitrary+ return (Shrinking (shrinkInit x) x)++ shrink (Shrinking s x) =+ [ Shrinking s' x'+ | (x',s') <- shrinkState x s+ ]++--------------------------------------------------------------------------+-- the end.
− Test/QuickCheck/Batch.hs
@@ -1,269 +0,0 @@-{-# OPTIONS_GHC -cpp #-}--------------------------------------------------------------------------------- |--- Module : Test.QuickCheck.Batch--- Copyright : (c) Andy Gill 2001--- License : BSD-style (see the file libraries/base/LICENSE)--- --- Maintainer : libraries@haskell.org--- Stability : experimental--- Portability : non-portable (uses Control.Exception, Control.Concurrent)------ A batch driver for running QuickCheck.------ /Note:/ in GHC only, it is possible to place a time limit on each test,--- to ensure that testing terminates.-----------------------------------------------------------------------------------{-- - Here is the key for reading the output.- - . = test successful- - ? = every example passed, but quickcheck did not find enough good examples- - * = test aborted for some reason (out-of-time, bottom, etc)- - # = test failed outright- - - - We also provide the dangerous "isBottom".- -- - Here is is an example of use for sorting:- - - - testOptions :: TestOptions- - testOptions = TestOptions - - { no_of_tests = 100 -- number of tests to run- - , length_of_tests = 1 -- 1 second max per check- - -- where a check == n tests- - , debug_tests = False -- True => debugging info- - }- - - - prop_sort1 xs = sort xs == sortBy compare xs- - where types = (xs :: [OrdALPHA])- - prop_sort2 xs = - - (not (null xs)) ==>- - (head (sort xs) == minimum xs)- - where types = (xs :: [OrdALPHA])- - prop_sort3 xs = (not (null xs)) ==>- - last (sort xs) == maximum xs- - where types = (xs :: [OrdALPHA])- - prop_sort4 xs ys =- - (not (null xs)) ==>- - (not (null ys)) ==>- - (head (sort (xs ++ ys)) == min (minimum xs) (minimum ys))- - where types = (xs :: [OrdALPHA], ys :: [OrdALPHA])- - prop_sort6 xs ys =- - (not (null xs)) ==>- - (not (null ys)) ==>- - (last (sort (xs ++ ys)) == max (maximum xs) (maximum ys))- - where types = (xs :: [OrdALPHA], ys :: [OrdALPHA])- - prop_sort5 xs ys =- - (not (null xs)) ==>- - (not (null ys)) ==>- - (head (sort (xs ++ ys)) == max (maximum xs) (maximum ys))- - where types = (xs :: [OrdALPHA], ys :: [OrdALPHA])- - - - test_sort = runTests "sort" testOptions- - [ run prop_sort1- - , run prop_sort2- - , run prop_sort3- - , run prop_sort4- - , run prop_sort5- - ]- - - - When run, this gives- - Main> test_sort- - sort : .....- - - - You would tie together all the test_* functions- - into one test_everything, on a per module basis.- -- -}--#if defined(__NHC__) && __NHC__ > 120-#define BASE4 1-#endif--module Test.QuickCheck.Batch- ( run -- :: Testable a => a -> TestOptions -> IO TestResult- , runTests -- :: String -> TestOptions -> - -- [TestOptions -> IO TestResult] -> IO ()- , defOpt -- :: TestOptions- , TestOptions (..)- , TestResult (..)- , isBottom -- :: a -> Bool- , bottom -- :: a {- _|_ -}- ) where--import Prelude--import System.Random-#ifdef __GLASGOW_HASKELL__-import Control.Concurrent-#endif-import Control.Exception hiding (catch, evaluate)-#if BASE4-import qualified Control.Exception as Exception-#else-import qualified Control.Exception as Exception (catch, evaluate)-#endif-import Test.QuickCheck-import System.IO.Unsafe--data TestOptions = TestOptions {- no_of_tests :: Int, -- ^ number of tests to run.- length_of_tests :: Int, -- ^ time limit for test, in seconds.- -- If zero, no time limit.- -- /Note:/ only GHC supports time limits.- debug_tests :: Bool }--defOpt :: TestOptions-defOpt = TestOptions - { no_of_tests = 100- , length_of_tests = 1- , debug_tests = False- }--data TestResult = TestOk String Int [[String]]- | TestExausted String Int [[String]]- | TestFailed [String] Int-#if BASE4- | TestAborted SomeException-#else- | TestAborted Exception-#endif--tests :: Config -> Gen Result -> StdGen -> Int -> Int -> [[String]] - -> IO TestResult-tests config gen rnd0 ntest nfail stamps- | ntest == configMaxTest config = return (TestOk "OK, passed" ntest stamps)- | nfail == configMaxFail config = return (TestExausted "Arguments exhausted after"- ntest stamps)- | otherwise =- do (if not (null txt) then putStr txt else return ())- case ok result of- Nothing ->- tests config gen rnd1 ntest (nfail+1) stamps- Just True ->- tests config gen rnd1 (ntest+1) nfail (stamp result:stamps)- Just False ->- do return (TestFailed (arguments result) ntest)- where- txt = configEvery config ntest (arguments result)- result = generate (configSize config ntest) rnd2 gen- (rnd1,rnd2) = split rnd0--batch n v = Config- { configMaxTest = n- , configMaxFail = n * 10- , configSize = (+ 3) . (`div` 2)- , configEvery = \n args -> if v then show n ++ ":\n" ++ unlines args else ""- }---- | Run the test.--- Here we use the same random number each time,--- so we get reproducable results!-run :: Testable a => a -> TestOptions -> IO TestResult-run a TestOptions { no_of_tests = n, length_of_tests = len, debug_tests = debug } =-#ifdef __GLASGOW_HASKELL__- do me <- myThreadId- ready <- newEmptyMVar- r <- if len == 0- then try theTest- else try (do- -- This waits a bit, then raises an exception in its parent,- -- saying, right, you've had long enough!- watcher <- forkIO (Exception.catch- (do threadDelay (len * 1000 * 1000)- takeMVar ready- throwTo me NonTermination- return ())-#if BASE4- (\ e -> case e of- Exception.ThreadKilled -> return ()- _ -> throw e))-#else- (\ _ -> return ()))-#endif- -- Tell the watcher we are starting...- putMVar ready ()- -- This is cheating, because possibly some of the internal message- -- inside "r" might be _|_, but anyway....- r <- theTest- -- Now, we turn off the watcher.- -- Ignored if the watcher is already dead, - -- (unless some unlucky thread picks up the same name)- killThread watcher- return r)- case r of- Right r -> return r- Left e -> return (TestAborted e)-#else- Exception.catch theTest $ \ e -> return (TestAborted e)-#endif- where- theTest = tests (batch n debug) (evaluate a) (mkStdGen 0) 0 0 [] ---- | Prints a one line summary of various tests with common theme-runTests :: String -> TestOptions -> [TestOptions -> IO TestResult] -> IO ()-runTests name scale actions =- do putStr (rjustify 25 name ++ " : ")- f <- tr 1 actions [] 0- mapM fa f- return ()- where- rjustify n s = replicate (max 0 (n - length s)) ' ' ++ s-- tr n [] xs c = do- putStr (rjustify (max 0 (35-n)) " (" ++ show c ++ ")\n")- return xs- tr n (action:actions) others c = - do r <- action scale- case r of- (TestOk _ m _) - -> do { putStr "." ;- tr (n+1) actions others (c+m) }- (TestExausted s m ss) -- -> do { putStr "?" ;- tr (n+1) actions others (c+m) }- (TestAborted e) - -> do { putStr "*" ;- tr (n+1) actions others c }- (TestFailed f num)- -> do { putStr "#" ;- tr (n+1) actions ((f,n,num):others) (c+num) }-- fa :: ([String],Int,Int) -> IO ()- fa (f,n,no) = - do putStr "\n"- putStr (" ** test " - ++ show (n :: Int)- ++ " of "- ++ name- ++ " failed with the binding(s)\n")- sequence_ [putStr (" ** " ++ v ++ "\n")- | v <- f ]- putStr "\n"--bottom :: a-bottom = error "_|_"---- | Look out behind you! These can be misused badly.--- However, in the context of a batch tester, can also be very useful.------ Examples of use of bottom and isBottom:------ > {- test for abort -}--- > prop_head2 = isBottom (head [])--- > {- test for strictness -}--- > prop_head3 = isBottom (head bottom)--isBottom :: a -> Bool-isBottom a = unsafePerformIO (do- a' <- try (Exception.evaluate a)- case a' of-#if BASE4- Left e -> let _ = e :: SomeException -- XXX Euch, want pattern sigs- in return True-#else- Left _ -> return True-#endif- Right _ -> return False)
+ Test/QuickCheck/Exception.hs view
@@ -0,0 +1,20 @@+module Test.QuickCheck.Exception where++import Control.Exception+ ( evaluate+ , try+ , Exception+ )++--------------------------------------------------------------------------+-- try evaluate++tryEvaluate :: a -> IO (Either Exception a)+tryEvaluate x = tryEvaluateIO (return x)++tryEvaluateIO :: IO a -> IO (Either Exception a)+tryEvaluateIO m = try (m >>= evaluate)+--tryEvaluateIO m = Right `fmap` m++--------------------------------------------------------------------------+-- the end.
+ Test/QuickCheck/Function.hs view
@@ -0,0 +1,139 @@+-- | Uses magic to show and shrink functions.+module Test.QuickCheck.Function+ -- * \"Magic\" functions+ ( Function(..)+ , function+ + -- * Generating monotonic functions+ , MonotonicFunction(..)+ , StrictlyMonotonicFunction(..)+ )+ where++--------------------------------------------------------------------------+-- imports++import Test.QuickCheck.Gen+import Test.QuickCheck.Arbitrary+import Test.QuickCheck.Property++import Data.IORef+import Data.List++import System.IO.Unsafe+ ( unsafePerformIO -- this is used for the magic+ )++--------------------------------------------------------------------------+-- | Functions from @a@ to @b@ which keep track of arguments+-- that they are applied to. This allows showing function tables+-- and shrinking functions.+data Function a b = Function (FunctionTable a b) (a -> b)++newtype FunctionTable a b = MkTable (IORef [(a,b)])++function :: (a -> b) -> Function a b+function f =+ unsafePerformIO $+ do ref <- newIORef []+ return $ Function (MkTable ref) $ \x ->+ unsafePerformIO $+ let y = f x in+ do tab <- readIORef ref+ writeIORef ref ((x,y):tab)+ return y++getFunction :: Function a b -> (a -> b)+getFunction (Function _ f) = f++getTable :: Function a b -> IO [(a,b)]+getTable (Function (MkTable ref) _) =+ do xys <- readIORef ref+ return (reverse xys)++showTable :: (Show a, Show b) => [(a,b)] -> String+showTable xys =+ "{"+ ++ concat (intersperse ", " (tabulate (reverse xys)))+ ++ "}"+ where+ tabulate = map (\((x,y):_) -> x ++ " -> " ++ y)+ . groupBy (\(x1,_) (x2,_) -> x1 == x2)+ . sortBy (\(x1,_) (x2,_) -> x1 `compare` x2)+ . map (\(x,y) -> (show x, show y))++instance (Show a, Show b) => Show (Function a b) where+ show fun =+ unsafePerformIO $+ do xys <- getTable fun+ return (showTable xys)++instance (Eq a, CoArbitrary a, Arbitrary b) => Arbitrary (Function a b) where+ arbitrary =+ function `fmap` arbitrary++ shrink fun@(Function _ f) =+ unsafePerformIO $+ do xys <- getTable fun+ return [ function (update x y' f)+ | (x,y) <- xys+ , y' <- shrink y+ ]+ where+ update x' y' f x+ | x == x' = y'+ | otherwise = f x++--------------------------------------------------------------------------+-- monotonicity++-- | Monotonic fun: guarantees that fun is monotonic.+newtype MonotonicFunction = Monotonic (Function Int Int)+ deriving ( Show )++instance Arbitrary MonotonicFunction where+ arbitrary = Monotonic `fmap` arbMonotonicFunction (\(NonNegative x) -> x)++-- | StrictlyMonotonic fun: guarantees that fun is strictly monotonic.+newtype StrictlyMonotonicFunction = StrictlyMonotonic (Function Int Int)+ deriving ( Show )++instance Arbitrary StrictlyMonotonicFunction where+ arbitrary = StrictlyMonotonic `fmap` arbMonotonicFunction (\(NonZero (NonNegative x)) -> x)++-- helper functions++arbMonotonicFunction :: Arbitrary a => (a -> Int) -> Gen (Function Int Int)+arbMonotonicFunction val =+ do ups <- arbIncSeq+ downs <- arbIncSeq+ y0 <- arbitrary+ return $ function $ \x ->+ case x of+ 0 -> y0+ _ | x > 0 -> y0 + (ups !! (x-1))+ | otherwise -> y0 - (downs !! (-x-1))+ where+ arbIncSeq =+ do as <- sequence [ arbitrary | _ <- [1..] ]+ let sums s (x:xs) = s `seq` (s : sums (val x+s) xs)+ return (tail (sums 0 as))++--------------------------------------------------------------------------+-- properties++prop_Monotonic x y (Monotonic (Function _ f)) =+ x <= y ==>+ f x <= f y++prop_StrictlyMonotonic x y (StrictlyMonotonic (Function _ f)) =+ x < y ==>+ f x < f y++prop_StrictlyMonotonic_Wrong x y (Monotonic (Function _ f)) =+ expectFailure $+ x < y ==>+ f x < f y++--------------------------------------------------------------------------+-- the end.
+ Test/QuickCheck/Gen.hs view
@@ -0,0 +1,169 @@+module Test.QuickCheck.Gen where++--------------------------------------------------------------------------+-- imports++import System.Random+ ( RandomGen(..)+ , Random(..)+ , StdGen+ , newStdGen+ )++import Control.Monad+ ( liftM+ )++import Control.Monad.Reader()+ -- needed for "instance Monad (a ->)"+ + -- 2005-09-16:+ -- GHC gives a warning for this. I reported this as a bug. /Koen++-- * Test case generation++--------------------------------------------------------------------------+-- ** Generator type++newtype Gen a = MkGen{ unGen :: StdGen -> Int -> a }++instance Functor Gen where+ fmap f (MkGen h) =+ MkGen (\r n -> f (h r n))++instance Monad Gen where+ return x =+ MkGen (\_ _ -> x)+ + MkGen m >>= k =+ MkGen (\r n ->+ let (r1,r2) = split r+ MkGen m' = k (m r1 n)+ in m' r2 n+ )++--------------------------------------------------------------------------+-- ** Primitive generator combinators++-- | Modifies a generator using an integer seed.+variant :: Integral n => n -> Gen a -> Gen a+variant k (MkGen m) = MkGen (\r n -> m (var k r) n)+ where+ var k = (if k == k' then id else var k')+ . (if even k then fst else snd)+ . split+ where+ k' = k `div` 2++-- | Used to construct generators that depend on the size parameter.+sized :: (Int -> Gen a) -> Gen a+sized f = MkGen (\r n -> let MkGen m = f n in m r n)++-- | Overrides the size parameter. Returns a generator which uses+-- the given size instead of the runtime-size parameter.+resize :: Int -> Gen a -> Gen a+resize n (MkGen m) = MkGen (\r _ -> m r n)++-- | Generates a random element in the given inclusive range.+choose :: Random a => (a,a) -> Gen a+choose rng = MkGen (\r _ -> let (x,_) = randomR rng r in x)++-- | Promotes a generator to a generator of monadic values.+promote :: Monad m => m (Gen a) -> Gen (m a)+promote m = MkGen (\r n -> liftM (\(MkGen m') -> m' r n) m)++-- | Generates some example values.+sample' :: Gen a -> IO [a]+sample' (MkGen m) =+ do rnd <- newStdGen+ let rnds rnd = rnd1 : rnds rnd2 where (rnd1,rnd2) = split rnd+ return [(m r n) | (r,n) <- rnds rnd `zip` [0,2..20] ]++-- | Generates some example values and prints them to 'stdout'.+sample :: Show a => Gen a -> IO ()+sample g = + do cases <- sample' g+ sequence_ (map print cases)++--------------------------------------------------------------------------+-- ** Common generator combinators++-- | Generates a value that satisfies a predicate.+suchThat :: Gen a -> (a -> Bool) -> Gen a+gen `suchThat` p =+ do mx <- gen `suchThatMaybe` p+ case mx of+ Just x -> return x+ Nothing -> sized (\n -> resize (n+1) (gen `suchThat` p))++-- | Tries to generate a value that satisfies a predicate.+suchThatMaybe :: Gen a -> (a -> Bool) -> Gen (Maybe a)+gen `suchThatMaybe` p = sized (try 0 . max 1) + where+ try _ 0 = return Nothing+ try k n = do x <- resize (2*k+n) gen+ if p x then return (Just x) else try (k+1) (n-1)++-- | Randomly uses one of the given generators. The input list+-- must be non-empty.+oneof :: [Gen a] -> Gen a+oneof [] = error "QuickCheck.oneof used with empty list"+oneof gs = choose (0,length gs - 1) >>= (gs !!)++-- | Chooses one of the given generators, with a weighted random distribution.+-- The input list must be non-empty.+frequency :: [(Int, Gen a)] -> Gen a+frequency [] = error "QuickCheck.frequency used with empty list"+frequency xs = choose (1, tot) >>= (`pick` xs)+ where+ tot = sum (map fst xs)++ pick n ((k,x):xs)+ | n <= k = x+ | otherwise = pick (n-k) xs+ pick _ _ = error "QuickCheck.pick used with empty list"++-- | Generates one of the given values. The input list must be non-empty.+elements :: [a] -> Gen a+elements [] = error "QuickCheck.elements used with empty list"+elements xs = (xs !!) `fmap` choose (0, length xs - 1)++-- | Takes a list of elements of increasing size, and chooses+-- among an initial segment of the list. The size of this initial+-- segment increases with the size parameter.+-- The input list must be non-empty.+growingElements :: [a] -> Gen a+growingElements [] = error "QuickCheck.growingElements used with empty list"+growingElements xs = sized $ \n -> elements (take (1 `max` size n) xs)+ where+ k = length xs+ mx = 100+ log' = round . log . fromIntegral+ size n = (log' n + 1) * k `div` log' mx++{- WAS: +growingElements xs = sized $ \n -> elements (take (1 `max` (n * k `div` 100)) xs)+ where+ k = length xs+-}++-- | Generates a list of random length. The maximum length depends on the+-- size parameter.+listOf :: Gen a -> Gen [a]+listOf gen = sized $ \n ->+ do k <- choose (0,n)+ vectorOf k gen++-- | Generates a non-empty list of random length. The maximum length +-- depends on the size parameter.+listOf1 :: Gen a -> Gen [a]+listOf1 gen = sized $ \n ->+ do k <- choose (1,1 `max` n)+ vectorOf k gen++-- | Generates a list of the given length.+vectorOf :: Int -> Gen a -> Gen [a]+vectorOf k gen = sequence [ gen | _ <- [1..k] ]++--------------------------------------------------------------------------+-- the end.
+ Test/QuickCheck/Monadic.hs view
@@ -0,0 +1,148 @@+{-# OPTIONS_GHC -fglasgow-exts #-}++-- | Allows testing of monadic values.+module Test.QuickCheck.Monadic where++--------------------------------------------------------------------------+-- imports++import Test.QuickCheck.Gen+import Test.QuickCheck.Property+import Test.QuickCheck.Arbitrary++import Control.Monad+ ( liftM+ )++import Control.Monad.ST++import System.IO.Unsafe+ ( unsafePerformIO+ )++-- instance of monad transformer?++--------------------------------------------------------------------------+-- type PropertyM++newtype PropertyM m a =+ MkPropertyM { unPropertyM :: (a -> Gen (m Property)) -> Gen (m Property) }++instance Functor (PropertyM m) where+ fmap f (MkPropertyM m) = MkPropertyM (\k -> m (k . f))++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 = MkPropertyM (\k -> return (return (property result)))+ where+ result = failed{ reason = s }++-- should think about strictness/exceptions here+--assert :: Testable prop => prop -> PropertyM m ()+assert :: Monad m => Bool -> PropertyM m ()+assert b = MkPropertyM $ \k ->+ if b+ then k ()+ else return (return (property False))++{-+let Prop p = property a in Monadic $ \k ->+ do r <- p+ case ok r of+ Just True -> do m <- k ()+ return (do p' <- m+ return (r &&& p'))+ _ -> return (return (property r))+-}++-- should think about strictness/exceptions here+pre :: Monad m => Bool -> PropertyM m ()+pre b = MkPropertyM $ \k ->+ if b+ then k ()+ else return (return (property ()))++-- should be called lift?+run :: Monad m => m a -> PropertyM m a+run m = MkPropertyM (liftM (m >>=) . promote)++pick :: (Monad m, Show a) => Gen a -> PropertyM m a+pick gen = MkPropertyM $ \k ->+ do a <- gen+ mp <- k a+ return (do p <- mp+ return (forAll (return a) (const p)))++wp :: Monad m => m a -> (a -> PropertyM m b) -> PropertyM m b+wp m k = run m >>= k++forAllM :: (Monad m, Show a) => Gen a -> (a -> PropertyM m b) -> PropertyM m b+forAllM gen k = pick gen >>= k++monitor :: Monad m => (Property -> Property) -> PropertyM m ()+monitor f = MkPropertyM (\k -> (f `liftM`) `fmap` (k ()))++-- run functions++monadic :: Monad m => (m Property -> Property) -> PropertyM m a -> Property+monadic run (MkPropertyM m) =+ do mp <- m (const (return (return (property True))))+ run mp++{-+monadicIO :: Monad m => (m Property -> IO Property) -> PropertyM m a -> IO Property+monadicIO run (MkPropertyM m) =+ do mp <- m (const (return (return (property True))))+ run mp+-}++-- Can't make this work in any other way... :-(+monadicIO :: PropertyM IO a -> Property+monadicIO (MkPropertyM m) =+ property $+ unsafePerformIO `fmap`+ m (const (return (return (property True))))++newtype IdM m s a = MkIdM { unIdM :: m s a }++data MonadS' m+ = MkMonadS+ { ret :: forall a s . a -> m s a+ , bin :: forall a b s . m s a -> (a -> m s b) -> m s b+ }++--grab () = MkMonadS return (>>=)++class MonadS m where+ return' :: a -> m s a+ bind' :: m s a -> (a -> m s b) -> m s b++instance MonadS m => Monad (IdM m s) where+ return = MkIdM . return'+ MkIdM m >>= k = MkIdM (m `bind'` (unIdM . k))++{-+monadicS :: MonadS m => ((forall s . m s Property) -> Property) -> (forall s . PropertyM (m s) a) -> Property+monadicS run mp = MkGen $ \r n ->+ let MkGen g' = run (let MkPropertyM f = mp' + MkGen g = f (const (return (return (property True))))+ in unIdM (g r n))+ in g' undefined undefined+ where+ mp' = MkPropertyM (\k -> fmap MkIdM (unPropertyM mp (\a -> fmap unIdM (k a))))+-}++{-++-- does not compile with GHC 6.6+imperative :: (forall s. PropertyM (ST s) a) -> Property+imperative m = MkGen $ \r n ->+ let MkPropertyM f = m+ MkGen g = f (const (return (return (property True))))+ MkGen q = runST (g r n)+ in q undefined undefined+-}++--------------------------------------------------------------------------+-- the end.
Test/QuickCheck/Poly.hs view
@@ -1,86 +1,110 @@--------------------------------------------------------------------------------- |--- Module : Test.QuickCheck.Poly--- Copyright : (c) Andy Gill 2001--- License : BSD-style (see the file libraries/base/LICENSE)--- --- Maintainer : libraries@haskell.org--- Stability : experimental--- Portability : portable------ This is an attempt to emulate polymorphic types for the --- purposes of testing by using abstract monomorphic types.--- --- It is likely that future versions of QuickCheck will--- include some polymorphic emulation testing facility,--- but this module can be used for now.---------------------------------------------------------------------------------- module Test.QuickCheck.Poly- ( ALPHA- , BETA- , GAMMA- , OrdALPHA- , OrdBETA- , OrdGAMMA- ) where+ ( A, B, C+ , OrdA, OrdB, OrdC+ )+ where -import Prelude+--------------------------------------------------------------------------+-- imports -import Test.QuickCheck-import Test.QuickCheck.Utils+import Test.QuickCheck.Arbitrary -{- This is the basic pseudo-polymorphic object.- - The idea is you can't cheat, and use the integer- - directly, but need to use the abstraction.- - - - We use phantom types (ref: Domain Specific Embedded Compilers,- - Daan Leijen & Erik Meijer, 2nd Conference of Domain Specific- - Languages, Austin, TX, 1999)- -}+--------------------------------------------------------------------------+-- polymorphic A, B, C (in Eq) -newtype Poly a = Poly Int+-- A -instance Show (Poly a) where- show (Poly a) = "_" ++ show a+newtype A = A{ unA :: Integer }+ deriving ( Eq ) -instance Arbitrary (Poly a) where- arbitrary = sized $ \n -> (choose (1,n) >>= return . Poly)- coarbitrary (Poly n) = variant (if n >= 0 then 2*n else 2*(-n) + 1)+instance Show A where+ showsPrec n (A x) = showsPrec n x -instance Eq a => Eq (Poly a) where- (Poly a) == (Poly b) = a == b+instance Arbitrary A where+ arbitrary = (A . abs) `fmap` arbitrary+ shrink (A x) = [ A x' | x' <- shrink x, x >= 0 ] -instance Ord a => Ord (Poly a) where- (Poly a) `compare` (Poly b) = a `compare` b+instance CoArbitrary A where+ coarbitrary = coarbitrary . unA -{-- - These are what we export, our pseudo-polymorphic instances.- -}+-- B -type ALPHA = Poly ALPHA_-data ALPHA_ = ALPHA_ deriving (Eq)+newtype B = B{ unB :: Integer }+ deriving ( Eq ) -type BETA = Poly BETA_-data BETA_ = BETA_ deriving (Eq)+instance Show B where+ showsPrec n (B x) = showsPrec n x -type GAMMA = Poly GAMMA_-data GAMMA_ = GAMMA_ deriving (Eq)+instance Arbitrary B where+ arbitrary = (B . abs) `fmap` arbitrary+ shrink (B x) = [ B x' | x' <- shrink x, x >= 0 ] -type OrdALPHA = Poly OrdALPHA_-data OrdALPHA_ = OrdALPHA_ deriving (Eq,Ord)+instance CoArbitrary B where+ coarbitrary = coarbitrary . unB -type OrdBETA = Poly OrdBETA_-data OrdBETA_ = OrdBETA_ deriving (Eq,Ord)+-- C -type OrdGAMMA = Poly OrdGAMMA_-data OrdGAMMA_ = OrdGAMMA_ deriving (Eq,Ord)+newtype C = C{ unC :: Integer }+ deriving ( Eq ) -{-- - This is a condition on OrdALPHA, OrdBETA, etc, itself.- - It states that all OrdALPHA objects obey total ordering.- -}+instance Show C where+ showsPrec n (C x) = showsPrec n x -prop_OrdPOLY x y = isTotalOrder x y- where types = (x :: OrdALPHA, y :: OrdALPHA)+instance Arbitrary C where+ arbitrary = (C . abs) `fmap` arbitrary+ shrink (C x) = [ C x' | x' <- shrink x, x >= 0 ]++instance CoArbitrary C where+ coarbitrary = coarbitrary . unC++--------------------------------------------------------------------------+-- polymorphic OrdA, OrdB, OrdC (in Eq, Ord)++-- OrdA++newtype OrdA = OrdA{ unOrdA :: Integer }+ deriving ( Eq, Ord )++instance Show OrdA where+ showsPrec n (OrdA x) = showsPrec n x++instance Arbitrary OrdA where+ arbitrary = (OrdA . abs) `fmap` arbitrary+ shrink (OrdA x) = [ OrdA x' | x' <- shrink x, x >= 0 ]++instance CoArbitrary OrdA where+ coarbitrary = coarbitrary . unOrdA++-- OrdB++newtype OrdB = OrdB{ unOrdB :: Integer }+ deriving ( Eq, Ord )++instance Show OrdB where+ showsPrec n (OrdB x) = showsPrec n x++instance Arbitrary OrdB where+ arbitrary = (OrdB . abs) `fmap` arbitrary+ shrink (OrdB x) = [ OrdB x' | x' <- shrink x, x >= 0 ]++instance CoArbitrary OrdB where+ coarbitrary = coarbitrary . unOrdB++-- OrdC++newtype OrdC = OrdC{ unOrdC :: Integer }+ deriving ( Eq, Ord )++instance Show OrdC where+ showsPrec n (OrdC x) = showsPrec n x++instance Arbitrary OrdC where+ arbitrary = (OrdC . abs) `fmap` arbitrary+ shrink (OrdC x) = [ OrdC x' | x' <- shrink x, x >= 0 ]++instance CoArbitrary OrdC where+ coarbitrary = coarbitrary . unOrdC++--------------------------------------------------------------------------+-- the end.+
+ Test/QuickCheck/Property.hs view
@@ -0,0 +1,346 @@+module Test.QuickCheck.Property where++--------------------------------------------------------------------------+-- imports++import Test.QuickCheck.Gen+import Test.QuickCheck.Arbitrary+import Test.QuickCheck.Text( showErr )+import Test.QuickCheck.Exception+import Test.QuickCheck.State++import Control.Concurrent+ ( forkIO+ , threadDelay+ , killThread+ , newEmptyMVar+ , takeMVar+ , putMVar+ )++import Data.IORef++import System.IO+ ( hFlush+ , stdout+ )++--------------------------------------------------------------------------+-- fixeties++infixr 0 ==>+infixr 1 .&.+-- infixr 1 .&&.++--------------------------------------------------------------------------+-- * Property and Testable types++type Property = Gen Prop++-- | The class of things which can be tested, i.e. turned into a property.+class Testable prop where+ property :: prop -> Property++instance Testable () where+ property _ = property rejected++instance Testable Bool where+ property = property . liftBool++instance Testable Result where+ property = return . MkProp . return . return++instance Testable Prop where+ property = return++instance Testable prop => Testable (Gen prop) where+ property mp = do p <- mp; property p++instance (Arbitrary a, Show a, Testable prop) => Testable (a -> prop) where+ property f = forAllShrink arbitrary shrink f++--------------------------------------------------------------------------+-- ** Type Prop++-- is this the right level to be abstract at?++newtype Prop = MkProp{ unProp :: Rose (IO Result) }++-- ** type Rose++data Rose a = MkRose a [Rose a]++join :: Rose (Rose a) -> Rose a+join (MkRose ~(MkRose x ts) tts) =+ -- first shrinks outer quantification; makes most sense+ MkRose x (map join tts ++ ts)+ -- first shrinks inner quantification+ --MkRose x (ts ++ map join tts)++instance Functor Rose where+ fmap f ~(MkRose x rs) = MkRose (f x) [ fmap f r | r <- rs ]++instance Monad Rose where+ return x = MkRose x []+ m >>= k = join (fmap k m)++-- ** Result type++-- | Different kinds of callbacks+data Callback+ = PostTest (State -> Result -> IO ()) -- ^ Called just after a test+ | PostFinalFailure (State -> Result -> IO ()) -- ^ Called with the final failing test-case++-- | 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+ , stamp :: [(String,Int)] -- ^ the collected values for this test case+ , callbacks :: [Callback] -- ^ the callbacks for this test case+ }++result :: Result+result =+ MkResult+ { ok = undefined+ , expect = True+ , reason = ""+ , stamp = []+ , callbacks = []+ }++failed :: Result+failed = result{ ok = Just False }++exception :: Show a => a -> Result+exception err = failed{ reason = "Exception: '" ++ showErr err ++ "'" }++succeeded :: Result +succeeded = result{ ok = Just True }++rejected :: Result+rejected = result{ ok = Nothing }++--------------------------------------------------------------------------+-- ** Lifting and mapping functions++liftBool :: Bool -> Property+liftBool b = liftResult $+ result+ { ok = Just b+ , reason = if b then "" else "Falsifiable"+ }++liftResult :: Result -> Property+liftResult r = liftIOResult (return r)++liftIOResult :: IO Result -> Property+liftIOResult m = liftRoseIOResult (return (wrap m))+ where+ wrap m = either exception id `fmap` tryEvaluateIO m++liftRoseIOResult :: Rose (IO Result) -> Property+liftRoseIOResult t = return (MkProp t)++mapResult :: Testable prop => (Result -> Result) -> prop -> Property+mapResult f = mapIOResult (>>= wrap f)+ where+ wrap f res =+ do mres <- tryEvaluate res+ return $ f $ case mres of+ Left err -> exception err+ Right res -> res+ +mapIOResult :: Testable prop => (IO Result -> IO Result) -> prop -> Property+mapIOResult f = mapRoseIOResult (fmap (f . wrap))+ where+ wrap iores =+ do miores <- tryEvaluate iores+ case miores of+ Left err -> return (exception err)+ Right iores -> iores++mapRoseIOResult :: Testable prop => (Rose (IO Result) -> Rose (IO Result)) -> prop -> Property+mapRoseIOResult f = mapProp (\(MkProp t) -> MkProp (f t))++mapProp :: Testable prop => (Prop -> Prop) -> prop -> Property+mapProp f = fmap f . property ++--------------------------------------------------------------------------+-- ** Property combinators++-- | Changes the maximum test case size for a property.+mapSize :: Testable prop => (Int -> Int) -> prop -> Property+mapSize f p = sized ((`resize` property p) . f)++-- | Shrinks the argument to property if it fails. Shrinking is done+-- automatically for most types. This is only needed weh you want to+-- override the default behavior.+shrinking :: Testable prop =>+ (a -> [a]) -- ^ 'shrink'-like function.+ -> a -- ^ The original argument+ -> (a -> prop) -> Property+shrinking shrink x pf = fmap (MkProp . join . fmap unProp) (promote (props x))+ where+ props x =+ MkRose (property (pf x)) [ props x' | x' <- shrink x ]++-- | Adds a callback+callback :: Testable prop => Callback -> prop -> Property+callback cb = mapResult (\res -> res{ callbacks = cb : callbacks res })++-- | Performs an 'IO' action after the last failure of a property.+whenFail :: Testable prop => IO () -> prop -> Property+whenFail m =+ callback $ PostFinalFailure $ \st res ->+ m++-- | Performs an 'IO' action every time a property fails. Thus,+-- if shrinking is done, this can be used to keep track of the +-- failures along the way.+whenFail' :: Testable prop => IO () -> prop -> Property+whenFail' m =+ callback $ PostTest $ \st res ->+ if ok res == Just False+ then m+ else return ()++-- | Modifies a property so that it is expected to fail for some test cases.+expectFailure :: Testable prop => prop -> Property+expectFailure = mapResult (\res -> res{ expect = False })++-- | Attaches a label to a property. This is used for reporting+-- test case distribution.+label :: Testable prop => String -> prop -> Property+label s = classify True s++-- | Labels a property with a value:+--+-- > collect x = label (show x)+collect :: (Show a, Testable prop) => a -> prop -> Property+collect x = label (show x)++-- | Conditionally labels test case.+classify :: Testable prop => + Bool -- ^ @True@ if the test case should be labelled.+ -> String -- ^ Label.+ -> prop -> Property+classify b s = cover b 0 s++-- | Checks that at least the given proportion of the test cases belong+-- to the given class.+cover :: Testable prop => + Bool -- ^ @True@ if the test case belongs to the class.+ -> Int -- ^ The required percentage (0-100) of test cases.+ -> String -- ^ Label for the test case class.+ -> prop -> Property+cover b n s = mapIOResult $ \ior ->+ do eeb <- tryEvaluate b+ res <- ior+ return $+ case eeb of+ Left err -> res{ ok = Just False+ , reason = "Exception: '" ++ showErr err ++ "'"+ }+ Right True -> res{ stamp = (s,n) : stamp res }+ Right False -> res++-- | Implication for properties: The resulting property holds if+-- the first argument is 'False', or if the given property holds.+(==>) :: Testable prop => Bool -> prop -> Property+False ==> _ = property ()+True ==> p = property p++-- INVESTIGATE: does not work+-- NOTE: n is in microseconds+-- | Considers a property failed if it does not complete within+-- the given number of microseconds.+within :: Testable prop => Int -> prop -> Property+within n = mapIOResult race+ where+ race ior =+ do put "Race starts ..."+ resV <- newEmptyMVar+ pidV <- newEmptyMVar+ partResV <- newIORef failed+ + let waitAndFail =+ do put "Waiting ..."+ threadDelay n+ put "Done waiting!"+ partRes <- readIORef partResV+ putMVar resV $+ partRes+ { ok = Just False+ , reason = "Time out"+ }+ + evalProp =+ do put "Evaluating Result ..."+ res <- ior+ writeIORef partResV res+ put "Evaluating OK ..."+ mok <- tryEvaluate (ok res == Just False)+ case mok of+ Left err -> do put "Exception!"+ putMVar resV $+ res+ { ok = Just False+ , reason = "Exception: '" ++ showErr err ++ "'"+ } + Right _ -> do put "Done!"+ putMVar resV res+ + -- used "mfix" here before but got non-termination problems+ pid1 <- forkIO $ do pid2 <- takeMVar pidV+ evalProp+ killThread pid2+ pid2 <- forkIO $ do waitAndFail+ killThread pid1+ putMVar pidV pid2++ put "Blocking ..."+ res <- takeMVar resV+ put ("Got Result: " ++ show (ok res))+ return res+ ++ put s | True = do return ()+ | otherwise = do putStrLn s+ hFlush stdout++-- | Explicit universal quantification: uses an explicitly given+-- test case generator.+forAll :: (Show a, Testable prop)+ => Gen a -> (a -> prop) -> Property+forAll gen pf =+ gen >>= \x ->+ whenFail (putStrLn (show x)) $+ property (pf x)++-- | Like 'forAll', but tries to shrink the argument for failing test cases.+forAllShrink :: (Show a, Testable prop)+ => Gen a -> (a -> [a]) -> (a -> prop) -> Property+forAllShrink gen shrink pf =+ gen >>= \x ->+ shrinking shrink x $ \x' ->+ whenFail (putStrLn (show x')) $+ property (pf x')++(.&.) :: (Testable prop1, Testable prop2) => prop1 -> prop2 -> Property+p1 .&. p2 =+ arbitrary >>= \b ->+ whenFail (putStrLn (if b then "LHS" else "RHS")) $+ if b then property p1 else property p2++{-+-- TODO++(.&&.) :: (Testable prop1, Testable prop2) => prop1 -> prop2 -> Property+p1 .&&. p2 = error "not implemented yet"+-}++--------------------------------------------------------------------------+-- the end.
+ Test/QuickCheck/State.hs view
@@ -0,0 +1,34 @@+module Test.QuickCheck.State where++import Test.QuickCheck.Text+import System.Random( StdGen )++--------------------------------------------------------------------------+-- State++-- | State represents QuickCheck's internal state while testing a property.+-- | The state is made visible to callback functions.+data State+ = MkState+ -- static+ { terminal :: Terminal -- ^ the current terminal+ , maxSuccessTests :: Int -- ^ maximum number of successful tests needed+ , 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+ + -- dynamic+ , numSuccessTests :: Int -- ^ the current number of tests that have succeeded+ , numDiscardedTests :: Int -- ^ the current number of discarded tests+ , collected :: [[(String,Int)]] -- ^ all labels that have been collected so far+ , expectedFailure :: Bool -- ^ indicates if the property is expected to fail+ , randomSeed :: StdGen -- ^ the current random seed+ + -- shrinking+ , isShrinking :: Bool -- ^ are we in a shrinking phase?+ , numSuccessShrinks :: Int -- ^ number of successful shrinking steps so far+ , numTryShrinks :: Int -- ^ number of failed shrinking steps since the last successful shrink+ }++--------------------------------------------------------------------------+-- the end.
+ Test/QuickCheck/Test.hs view
@@ -0,0 +1,355 @@+module Test.QuickCheck.Test where++--------------------------------------------------------------------------+-- imports++import Test.QuickCheck.Gen+import Test.QuickCheck.Property hiding ( Result( reason ) )+import qualified Test.QuickCheck.Property as P+import Test.QuickCheck.Text+import Test.QuickCheck.State+import Test.QuickCheck.Exception++import System.Random+ ( RandomGen(..)+ , newStdGen+ , StdGen+ )++import Data.Char+ ( isSpace+ )++import Data.List+ ( sort+ , group+ , groupBy+ , intersperse+ )++--------------------------------------------------------------------------+-- quickCheck++-- * Running tests++-- | Args specifies arguments to the QuickCheck driver+data Args+ = Args+ { replay :: Maybe (StdGen,Int) -- ^ should we replay a previous test?+ , maxSuccess :: Int -- ^ maximum number of successful tests before succeeding+ , maxDiscard :: Int -- ^ maximum number of discarded tests before giving up+ , maxSize :: Int -- ^ size to use for the biggest test cases+ }+ deriving ( Show, Read )++-- | Result represents the test result+data Result+ = Success -- a successful test run+ { labels :: [(String,Int)] -- ^ labels and frequencies found during all tests+ }+ | GaveUp -- given up+ { numTests :: Int -- ^ number of successful tests performed+ , labels :: [(String,Int)] -- ^ labels and frequencies found during all tests+ }+ | Failure -- failed test run+ { usedSeed :: StdGen -- ^ what seed was used+ , usedSize :: Int -- ^ what was the test size+ , reason :: String -- ^ what was the reason+ , labels :: [(String,Int)] -- ^ labels and frequencies found during all successful tests+ }+ | NoExpectedFailure -- the expected failure did not happen+ { labels :: [(String,Int)] -- ^ labels and frequencies found during all successful tests+ }+ deriving ( Show, Read )++-- | isSuccess checks if the test run result was a success+isSuccess :: Result -> Bool+isSuccess Success{} = True+isSuccess _ = False++-- | stdArgs are the default test arguments used+stdArgs :: Args+stdArgs = Args+ { replay = Nothing+ , maxSuccess = 100+ , maxDiscard = 500+ , maxSize = 100+-- noShrinking flag?+ }++-- | Tests a property and prints the results to 'stdout'.+quickCheck :: Testable prop => prop -> IO ()+quickCheck p = quickCheckWith stdArgs p++-- | Tests a property, using test arguments, and prints the results to 'stdout'.+quickCheckWith :: Testable prop => Args -> prop -> IO ()+quickCheckWith args p = quickCheckWithResult args p >> return ()++-- | Tests a property, produces a test result, and prints the results to 'stdout'.+quickCheckResult :: Testable prop => prop -> IO Result+quickCheckResult p = quickCheckWithResult stdArgs p++-- | Tests a property, using test arguments, produces a test result, and prints the results to 'stdout'.+quickCheckWithResult :: Testable prop => Args -> prop -> IO Result+quickCheckWithResult args p =+ do tm <- newTerminal+ rnd <- case replay args of+ Nothing -> newStdGen+ Just (rnd,_) -> return rnd+ test MkState{ terminal = tm+ , maxSuccessTests = maxSuccess args+ , maxDiscardedTests = maxDiscard args+ , computeSize = case replay args of+ Nothing -> \n d -> (n * maxSize args)+ `div` maxSuccess args+ + (d `div` 10)+ Just (_,s) -> \_ _ -> s+ , numSuccessTests = 0+ , numDiscardedTests = 0+ , collected = []+ , expectedFailure = False+ , randomSeed = rnd+ , isShrinking = False+ , numSuccessShrinks = 0+ , numTryShrinks = 0+ } (unGen (property p))++--------------------------------------------------------------------------+-- main test loop++test :: State -> (StdGen -> Int -> Prop) -> IO Result+test st f+ | numSuccessTests st >= maxSuccessTests st = doneTesting st f+ | numDiscardedTests st >= maxDiscardedTests st = giveUp st f+ | otherwise = runATest st f++doneTesting :: State -> (StdGen -> Int -> Prop) -> IO Result+doneTesting st f =+ do -- CALLBACK done_testing?+ if expectedFailure st then+ putPart (terminal st)+ ( "+++ OK, passed "+ ++ show (numSuccessTests st)+ ++ " tests"+ )+ else+ putPart (terminal st)+ ( bold ("*** Failed!")+ ++ " Passed "+ ++ show (numSuccessTests st)+ ++ " tests (expected failure)"+ )+ success st+ if expectedFailure st then+ return Success{ labels = summary st }+ else+ return NoExpectedFailure{ labels = summary st }+ +giveUp :: State -> (StdGen -> Int -> Prop) -> IO Result+giveUp st f =+ do -- CALLBACK gave_up?+ putPart (terminal st)+ ( bold ("*** Gave up!")+ ++ " Passed only "+ ++ show (numSuccessTests st)+ ++ " tests"+ )+ success st+ return GaveUp{ numTests = numSuccessTests st+ , labels = summary st+ }++runATest :: State -> (StdGen -> Int -> Prop) -> IO Result+runATest st f =+ do -- CALLBACK before_test+ putTemp (terminal st)+ ( "("+ ++ number (numSuccessTests st) "test"+ ++ concat [ "; " ++ show (numDiscardedTests st) ++ " discarded"+ | numDiscardedTests st > 0+ ]+ ++ ")"+ )+ let size = computeSize st (numSuccessTests st) (numDiscardedTests st)+ (res, ts) <- run (unProp (f rnd1 size))+ callbackPostTest st res+ + case ok res of+ Just True -> -- successful test+ do test st{ numSuccessTests = numSuccessTests st + 1+ , randomSeed = rnd2+ , collected = stamp res : collected st+ , expectedFailure = expect res+ } f+ + Nothing -> -- discarded test+ do test st{ numDiscardedTests = numDiscardedTests st + 1+ , randomSeed = rnd2+ , expectedFailure = expect res+ } f+ + Just False -> -- failed test+ do if expect res+ then putPart (terminal st) (bold "*** Failed! ")+ else putPart (terminal st) "+++ OK, failed as expected. "+ putTemp (terminal st)+ ( short 30 (P.reason res)+ ++ " (after "+ ++ number (numSuccessTests st+1) "test"+ ++ ")..."+ )+ foundFailure st res ts+ if not (expect res) then+ return Success{ labels = summary st }+ else+ return Failure{ usedSeed = randomSeed st -- correct! (this will be split first)+ , usedSize = size+ , reason = P.reason res+ , labels = summary st+ }+ where+ (rnd1,rnd2) = split (randomSeed st)++summary :: State -> [(String,Int)]+summary st = reverse+ . sort+ . map (\ss -> (head ss, (length ss * 100) `div` numSuccessTests st))+ . group+ . sort+ $ [ concat (intersperse ", " s')+ | s <- collected st+ , let s' = [ t | (t,_) <- s ]+ , not (null s')+ ]++success :: State -> IO ()+success st =+ case labels ++ covers of+ [] -> do putLine (terminal st) "."+ [pt] -> do putLine (terminal st)+ ( " ("+ ++ dropWhile isSpace pt+ ++ ")."+ )+ cases -> do putLine (terminal st) ":"+ sequence_ [ putLine (terminal st) pt | pt <- cases ]+ where+ labels = 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,0) <- s ]+ , not (null s')+ ]+ + covers = [ ("only " ++ show occurP ++ "% " ++ fst (head lps) ++ "; not " ++ show reqP ++ "%")+ | lps <- groupBy first+ . sort+ $ [ lp+ | lps <- collected st+ , lp <- maxi lps+ , snd lp > 0+ ]+ , let occurP = (100 * length lps) `div` maxSuccessTests st+ reqP = maximum (map snd lps)+ , occurP < reqP+ ]+ + (x,_) `first` (y,_) = x == y ++ maxi = map (\lps -> (fst (head lps), maximum (map snd lps)))+ . groupBy first+ . sort++ showP p = (if p < 10 then " " else "") ++ show p ++ "% "++-- this was there to take care of exceptions, but it does not seem to be+-- needed anymore?+run rose =+ do MkRose mres ts <- return rose `orElseErr` ("rose", errRose)+ res <- mres `orElseErr` ("mres", errResult failed)+ res <- return (strictOk res) `orElseErr` ("ok", errResult res{ ok = Just False })+ ts <- repairList ts+ return (res, ts)+ where+ errRose err = MkRose (return (errResult failed err)) []+ errResult res err = res{ P.reason = "Exception: '" ++ showErr err ++ "'" }++ m `orElseErr` (s,f) = -- either f id `fmap` try m+ do eex <- tryEvaluateIO m+ case eex of+ Left err -> do --putStrLn ("EX: [" ++ s ++ "]")+ return s -- to make warning go away+ return (f err)+ Right x -> do return x+ + strictOk res =+ (ok res == Just False) `seq` res+ + repairList xs =+ return xs+ {-+ unsafeInterleaveIO $+ do eexs <- tryEvaluate xs+ case eexs of+ Right (x:xs) -> do xs' <- repairList xs; return (x:xs')+ _ -> do return []+ -}+ +--------------------------------------------------------------------------+-- main shrinking loop++foundFailure :: State -> P.Result -> [Rose (IO P.Result)] -> IO ()+foundFailure st res ts =+ do localMin st{ numTryShrinks = 0, isShrinking = True } res ts++localMin :: State -> P.Result -> [Rose (IO P.Result)] -> IO ()+localMin st res [] =+ do putLine (terminal st)+ ( P.reason res+ ++ " (after " ++ number (numSuccessTests st+1) "test"+ ++ concat [ " and " ++ number (numSuccessShrinks st) "shrink"+ | numSuccessShrinks st > 0+ ]+ ++ "): "+ )+ callbackPostFinalFailure st res++localMin st res (t : ts) =+ do -- CALLBACK before_test+ (res',ts') <- run t+ putTemp (terminal st)+ ( short 35 (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+ ]+ ++ ")..."+ )+ callbackPostTest st res'+ if ok res' == Just False+ then foundFailure st{ numSuccessShrinks = numSuccessShrinks st + 1 } res' ts'+ else localMin st{ numTryShrinks = numTryShrinks st + 1 } res ts++--------------------------------------------------------------------------+-- callbacks++callbackPostTest :: State -> P.Result -> IO ()+callbackPostTest st res =+ sequence_ [ f st res | PostTest f <- callbacks res ]++callbackPostFinalFailure :: State -> P.Result -> IO ()+callbackPostFinalFailure st res =+ sequence_ [ f st res | PostFinalFailure f <- callbacks res ]++--------------------------------------------------------------------------+-- the end.
+ Test/QuickCheck/Text.hs view
@@ -0,0 +1,114 @@+module Test.QuickCheck.Text+ ( Str(..)+ , ranges+ + , number+ , short+ , showErr+ , bold+ + , newTerminal+ , Terminal+ , putTemp+ , putPart+ , putLine+ )+ where++--------------------------------------------------------------------------+-- imports++import System.IO+ ( hFlush+ , hPutStr+ , stdout+ , stderr+ )++import Data.IORef++--------------------------------------------------------------------------+-- literal string++newtype Str = MkStr String++instance Show Str where+ show (MkStr s) = s++ranges :: Integral a => a -> a -> Str+ranges k n = MkStr (show n' ++ " -- " ++ show (n'+k-1))+ where+ n' = k * (n `div` k)++--------------------------------------------------------------------------+-- formatting++number :: Int -> String -> String+number n s = show n ++ " " ++ s ++ if n == 1 then "" else "s"++short :: Int -> String -> String+short n s+ | n < k = take (n-2-i) s ++ ".." ++ drop (k-i) s+ | otherwise = s+ where+ k = length s+ i = if n >= 5 then 3 else 0++showErr :: Show a => a -> String+showErr = unwords . words . show++bold :: String -> String+-- not portable:+--bold s = "\ESC[1m" ++ s ++ "\ESC[0m"+bold s = s -- for now++--------------------------------------------------------------------------+-- putting strings++newtype Terminal+ = MkTerminal (IORef (IO ()))++newTerminal :: IO Terminal+newTerminal =+ do hFlush stdout+ hFlush stderr+ ref <- newIORef (return ())+ return (MkTerminal ref)++flush :: Terminal -> IO ()+flush (MkTerminal ref) =+ do io <- readIORef ref+ writeIORef ref (return ())+ io++postpone :: Terminal -> IO () -> IO ()+postpone (MkTerminal ref) io' =+ do io <- readIORef ref+ writeIORef ref (io >> io')++putPart, putTemp, putLine :: Terminal -> String -> IO ()+putPart tm s =+ do flush tm+ putStr s+ hFlush stdout+ +putTemp tm s =+ do flush tm+ hPutStr h s+ hPutStr h [ '\b' | _ <- s ]+ hFlush h+ postpone tm $+ do hPutStr h ( [ ' ' | _ <- s ]+ ++ [ '\b' | _ <- s ]+ )+ where+ --h = stdout+ h = stderr+ +putLine tm s =+ do flush tm+ putStrLn s+ hFlush stdout ++--------------------------------------------------------------------------+-- the end.
− Test/QuickCheck/Utils.hs
@@ -1,53 +0,0 @@--------------------------------------------------------------------------------- |--- Module : Test.QuickCheck.Utils--- Copyright : (c) Andy Gill 2001--- License : BSD-style (see the file libraries/base/LICENSE)--- --- Maintainer : libraries@haskell.org--- Stability : experimental--- Portability : portable------ These are some general purpose utilities for use with QuickCheck.-----------------------------------------------------------------------------------module Test.QuickCheck.Utils- ( isAssociativeBy- , isAssociative- , isCommutableBy- , isCommutable- , isTotalOrder- ) where--import Prelude--import Test.QuickCheck--isAssociativeBy :: (Show a,Testable prop) - => (a -> a -> prop) -> Gen a -> (a -> a -> a) -> Property-isAssociativeBy (===) src (**) = - forAll src $ \ a ->- forAll src $ \ b ->- forAll src $ \ c ->- ((a ** b) ** c) === (a ** (b ** c))--isAssociative :: (Arbitrary a,Show a,Eq a) => (a -> a -> a) -> Property-isAssociative = isAssociativeBy (==) arbitrary--isCommutableBy :: (Show a,Testable prop) - => (b -> b -> prop) -> Gen a -> (a -> a -> b) -> Property-isCommutableBy (===) src (**) =- forAll src $ \ a ->- forAll src $ \ b ->- (a ** b) === (b ** a)--isCommutable :: (Arbitrary a,Show a,Eq b) => (a -> a -> b) -> Property-isCommutable = isCommutableBy (==) arbitrary--isTotalOrder :: (Arbitrary a,Show a,Ord a) => a -> a -> Property-isTotalOrder x y = - classify (x > y) "less than" $- classify (x == y) "equals" $- classify (x < y) "greater than" $- x < y || x == y || x > y