summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorSimonMarlow <>2010-09-13 11:38:47 (GMT)
committerLuite Stegeman <luite@luite.com>2010-09-13 11:38:47 (GMT)
commit3406daeadeaf03adb7271b674316aed8e9c395b2 (patch)
tree711b4f5cecb7d7124714e7e56eb124432c55c1ca
parent0b73c34f30799bd7e7894da14186c8fac12f2a87 (diff)
version 1.2.0.11.2.0.1
-rw-r--r--Debug/QuickCheck.hs21
-rw-r--r--Debug/QuickCheck/Batch.hs21
-rw-r--r--Debug/QuickCheck/Poly.hs19
-rw-r--r--Debug/QuickCheck/Utils.hs21
-rw-r--r--LICENSE48
-rw-r--r--QuickCheck.cabal83
-rw-r--r--README26
-rw-r--r--Setup.hs6
-rw-r--r--Setup.lhs8
-rw-r--r--Test/QuickCheck.hs460
-rw-r--r--Test/QuickCheck/Arbitrary.hs536
-rw-r--r--Test/QuickCheck/Batch.hs269
-rw-r--r--Test/QuickCheck/Exception.hs72
-rw-r--r--Test/QuickCheck/Function.hs257
-rw-r--r--Test/QuickCheck/Gen.hs178
-rw-r--r--Test/QuickCheck/Modifiers.hs232
-rw-r--r--Test/QuickCheck/Monadic.hs85
-rw-r--r--Test/QuickCheck/Poly.hs160
-rw-r--r--Test/QuickCheck/Property.hs342
-rw-r--r--Test/QuickCheck/State.hs33
-rw-r--r--Test/QuickCheck/Test.hs366
-rw-r--r--Test/QuickCheck/Text.hs148
-rw-r--r--Test/QuickCheck/Utils.hs53
23 files changed, 901 insertions, 2543 deletions
diff --git a/Debug/QuickCheck.hs b/Debug/QuickCheck.hs
new file mode 100644
index 0000000..60cf61b
--- /dev/null
+++ b/Debug/QuickCheck.hs
@@ -0,0 +1,21 @@
+-----------------------------------------------------------------------------
+-- |
+-- 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
+
diff --git a/Debug/QuickCheck/Batch.hs b/Debug/QuickCheck/Batch.hs
new file mode 100644
index 0000000..6985402
--- /dev/null
+++ b/Debug/QuickCheck/Batch.hs
@@ -0,0 +1,21 @@
+-----------------------------------------------------------------------------
+-- |
+-- 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
+
diff --git a/Debug/QuickCheck/Poly.hs b/Debug/QuickCheck/Poly.hs
new file mode 100644
index 0000000..f01f2c7
--- /dev/null
+++ b/Debug/QuickCheck/Poly.hs
@@ -0,0 +1,19 @@
+-----------------------------------------------------------------------------
+-- |
+-- 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
+
diff --git a/Debug/QuickCheck/Utils.hs b/Debug/QuickCheck/Utils.hs
new file mode 100644
index 0000000..e9ee826
--- /dev/null
+++ b/Debug/QuickCheck/Utils.hs
@@ -0,0 +1,21 @@
+-----------------------------------------------------------------------------
+-- |
+-- 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
+
diff --git a/LICENSE b/LICENSE
index 5e89f2c..4ec14bf 100644
--- a/LICENSE
+++ b/LICENSE
@@ -1,27 +1,31 @@
-Copyright (c) 2000-2006, Koen Claessen
-Copyright (c) 2006, Bjorn Bringert
+The Glasgow Haskell Compiler License
+
+Copyright 2004, The University Court of the University of Glasgow.
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 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.
+- 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.
-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.
+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.
diff --git a/QuickCheck.cabal b/QuickCheck.cabal
index 1ee25ba..1881522 100644
--- a/QuickCheck.cabal
+++ b/QuickCheck.cabal
@@ -1,61 +1,44 @@
-Name: QuickCheck
-Version: 2.3
-Cabal-Version: >= 1.2
-Build-type: Simple
-License: BSD3
-License-file: LICENSE
-Extra-source-files: README
-Copyright: Koen Claessen <koen@chalmers.se>
-Author: Koen Claessen <koen@chalmers.se>
-Maintainer: QuickCheck developers <quickcheck@projects.haskell.org>
-Homepage: http://code.haskell.org/QuickCheck
-Category: Testing
-Synopsis: Automatic testing of Haskell programs
-Description:
- QuickCheck is a library for random testing of program properties.
- .
+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.
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 splitBase
- Description: Choose the new smaller, split-up base package.
-
-flag extensibleExceptions
- Description: Choose the even newer, even smaller, split-up base package.
+flag base3
+flag base4
library
- Build-depends: mtl
- if flag(extensibleExceptions)
- Build-depends: base >= 4 && < 5, random
- else
- if flag(splitBase)
- Build-depends: base >= 3 && < 4, random
+ 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
- if impl(ghc >= 6.7) && impl(ghc < 6.13)
- Build-depends: ghc
- if impl(ghc >= 6.9)
- Build-depends: extensible-exceptions
- Exposed-Modules:
- Test.QuickCheck,
- Test.QuickCheck.Arbitrary,
- Test.QuickCheck.Function,
- Test.QuickCheck.Gen,
- Test.QuickCheck.Monadic,
- Test.QuickCheck.Modifiers,
- Test.QuickCheck.Property,
- Test.QuickCheck.Test,
- Test.QuickCheck.Text,
- Test.QuickCheck.Poly,
- Test.QuickCheck.State
- Other-Modules:
- Test.QuickCheck.Exception
- GHC-options:
+ build-depends: base < 3
+ extensions: CPP
diff --git a/README b/README
deleted file mode 100644
index c991eb8..0000000
--- a/README
+++ /dev/null
@@ -1,26 +0,0 @@
-This is QuickCheck 2.1.1, a library for random testing of program properties.
-
-=== Installation ===
-
-Installation is done with Cabal:
-
-$ cabal install
-
-or, if you're missing the cabal command,
-
-$ runghc Setup.lhs configure
-$ runghc Setup.lhs build
-$ runghc Setup.lhs install
-
-=== Bugs ===
-
-Please report bugs to the QuickCheck mailing list at
-quickcheck@projects.haskell.org.
-
-=== Documentation ===
-
-$ runghc Setup.lhs haddock
-
-generates API documentation in dist/doc/html/index.html
-
-
diff --git a/Setup.hs b/Setup.hs
new file mode 100644
index 0000000..6fa548c
--- /dev/null
+++ b/Setup.hs
@@ -0,0 +1,6 @@
+module Main (main) where
+
+import Distribution.Simple
+
+main :: IO ()
+main = defaultMain
diff --git a/Setup.lhs b/Setup.lhs
deleted file mode 100644
index e2c31e7..0000000
--- a/Setup.lhs
+++ /dev/null
@@ -1,8 +0,0 @@
-#!/usr/bin/env runghc
-
-> module Main where
-
-> import Distribution.Simple
-
-> main :: IO ()
-> main = defaultMain
diff --git a/Test/QuickCheck.hs b/Test/QuickCheck.hs
index 0950630..1f8b3b9 100644
--- a/Test/QuickCheck.hs
+++ b/Test/QuickCheck.hs
@@ -1,105 +1,373 @@
+-----------------------------------------------------------------------------
+-- |
+-- 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
- (
- -- * 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'
-
- -- * Arbitrary and CoArbitrary classes.
- , Arbitrary(..)
- , CoArbitrary(..)
+ -- 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
- -- ** Helper functions for implementing arbitrary
- , arbitrarySizedIntegral
- , arbitrarySizedFractional
- , arbitrarySizedBoundedIntegral
- , arbitraryBoundedIntegral
- , arbitraryBoundedRandom
- -- ** Helper functions for implementing shrink
- , shrinkNothing
- , shrinkIntegral
- , shrinkRealFrac
- -- ** Helper functions for implementing coarbitrary
- , variant
- , (><)
- , coarbitraryIntegral
- , coarbitraryReal
- , coarbitraryShow
-
- -- ** Type-level modifiers for changing generator behavior
- , Blind(..)
- , Fixed(..)
- , OrderedList(..)
- , NonEmptyList(..)
- , Positive(..)
- , NonZero(..)
- , NonNegative(..)
- , Smart(..)
- , Shrink2(..)
- , Shrinking(..)
- , ShrinkState(..)
-
- -- * Properties
- , Property, Prop, Testable(..)
- -- ** Property combinators
- , mapSize
- , shrinking
- , (==>)
- , forAll
- , forAllShrink
- , (.&.)
- -- *** Handling failure
- , whenFail
- , whenFail'
- , expectFailure
- , within
- -- *** Test distribution
- , label
- , collect
- , classify
- , cover
+ -- generator combinators
+ , Gen -- :: * -> * ; Functor, Monad
- -- * Text formatting
- , Str(..)
- , ranges
+ , 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]
+
+ -- default generators
+ , Arbitrary(..) -- :: class
+ , rand -- :: Gen StdGen
+ , promote -- :: (a -> Gen b) -> Gen (a -> b)
+ , variant -- :: Int -> Gen a -> Gen a
+
+ -- testable
+ , Testable(..) -- :: class
+ , Property -- :: *
+
+ -- For writing your own driver
+ , Result(..) -- :: data
+ , generate -- :: Int -> StdGen -> Gen a -> a
+ , evaluate -- :: Testable a => a -> Gen Result
)
where
---------------------------------------------------------------------------
--- imports
+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)
-import Test.QuickCheck.Gen
-import Test.QuickCheck.Arbitrary
-import Test.QuickCheck.Modifiers
-import Test.QuickCheck.Property hiding ( Result(..) )
-import Test.QuickCheck.Test
-import Test.QuickCheck.Text
+ percentage n m = show ((100 * n) `div` m) ++ "%"
---------------------------------------------------------------------------
+--------------------------------------------------------------------
-- the end.
diff --git a/Test/QuickCheck/Arbitrary.hs b/Test/QuickCheck/Arbitrary.hs
deleted file mode 100644
index 31fd20a..0000000
--- a/Test/QuickCheck/Arbitrary.hs
+++ /dev/null
@@ -1,536 +0,0 @@
-module Test.QuickCheck.Arbitrary
- (
- -- * Arbitrary and CoArbitrary classes.
- Arbitrary(..)
- , CoArbitrary(..)
-
- -- ** Helper functions for implementing arbitrary
- , arbitrarySizedIntegral -- :: Num a => Gen a
- , arbitraryBoundedIntegral -- :: (Bounded a, Integral a) => Gen a
- , arbitrarySizedBoundedIntegral -- :: (Bounded a, Integral a) => Gen a
- , arbitrarySizedFractional -- :: Fractional a => Gen a
- , arbitraryBoundedRandom -- :: (Bounded a, Random a) => Gen a
- -- ** Helper functions for implementing shrink
- , shrinkNothing -- :: a -> [a]
- , shrinkList -- :: (a -> [a]) -> [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]
- )
- where
-
---------------------------------------------------------------------------
--- imports
-
-import Test.QuickCheck.Gen
-
-{-
-import Data.Generics
- ( (:*:)(..)
- , (:+:)(..)
- , Unit(..)
- )
--}
-
-import Data.Char
- ( chr
- , ord
- , isLower
- , isUpper
- , toLower
- , isDigit
- , isSpace
- )
-
-import Data.Ratio
- ( Ratio
- , (%)
- , numerator
- , denominator
- )
-
-import Data.Complex
- ( Complex((:+)) )
-
-import System.Random
- ( Random
- )
-
-import Data.List
- ( sort
- , nub
- )
-
-import Control.Monad
- ( liftM
- , liftM2
- , liftM3
- , liftM4
- , liftM5
- )
-
-import Data.Int(Int8, Int16, Int32, Int64)
-import Data.Word(Word, Word8, Word16, Word32, Word64)
-
---------------------------------------------------------------------------
--- ** 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)
- shrink True = [False]
- shrink False = []
-
-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 = shrinkList shrink xs
-
-shrinkList :: (a -> [a]) -> [a] -> [[a]]
-shrinkList shr xs0 = removeChunks xs0 ++ shrinkOne xs0
- where
- shrinkOne [] = []
- shrinkOne (x:xs) = [ x':xs | x' <- shr 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 ]
--}
-
-removeChunks :: [a] -> [[a]]
-removeChunks xs0 = remC (length xs0) xs0
- where
- remC 0 _ = []
- remC 1 _ = [[]]
- remC n xs = xs1
- : xs2
- : ( [ xs1' ++ xs2 | xs1' <- remC n1 xs1, not (null xs1') ]
- `ilv` [ xs1 ++ xs2' | xs2' <- remC n2 xs2, not (null xs2') ]
- )
- where
- n1 = n `div` 2
- xs1 = take n1 xs
- n2 = n - n1
- xs2 = drop n1 xs
-
- [] `ilv` bs = bs
- as `ilv` [] = as
- (a:as) `ilv` (b:bs) = a : b : (as `ilv` bs)
-
-instance (Integral a, Arbitrary a) => Arbitrary (Ratio a) where
- arbitrary = arbitrarySizedFractional
- shrink = shrinkRealFrac
-
-instance (RealFloat a, Arbitrary a) => Arbitrary (Complex a) where
- arbitrary = liftM2 (:+) arbitrary arbitrary
- shrink (x :+ y) = [ x' :+ y | x' <- shrink x ] ++
- [ x :+ y' | y' <- shrink y ]
-
-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 = arbitrarySizedBoundedIntegral
- shrink = shrinkIntegral
-
-instance Arbitrary Int8 where
- arbitrary = arbitrarySizedBoundedIntegral
- shrink = shrinkIntegral
-
-instance Arbitrary Int16 where
- arbitrary = arbitrarySizedBoundedIntegral
- shrink = shrinkIntegral
-
-instance Arbitrary Int32 where
- arbitrary = arbitrarySizedBoundedIntegral
- shrink = shrinkIntegral
-
-instance Arbitrary Int64 where
- arbitrary = arbitrarySizedBoundedIntegral
- shrink = shrinkIntegral
-
-instance Arbitrary Word where
- arbitrary = arbitrarySizedBoundedIntegral
- shrink = shrinkIntegral
-
-instance Arbitrary Word8 where
- arbitrary = arbitrarySizedBoundedIntegral
- shrink = shrinkIntegral
-
-instance Arbitrary Word16 where
- arbitrary = arbitrarySizedBoundedIntegral
- shrink = shrinkIntegral
-
-instance Arbitrary Word32 where
- arbitrary = arbitrarySizedBoundedIntegral
- shrink = shrinkIntegral
-
-instance Arbitrary Word64 where
- arbitrary = arbitrarySizedBoundedIntegral
- shrink = shrinkIntegral
-
-instance Arbitrary Char where
- arbitrary = chr `fmap` oneof [choose (0,127), choose (0,255)]
- shrink c = filter (<. c) $ nub
- $ ['a','b','c']
- ++ [ toLower c | isUpper c ]
- ++ ['A','B','C']
- ++ ['1','2','3']
- ++ [' ','\n']
- where
- a <. b = stamp a < stamp b
- stamp a = ( not (isLower a)
- , not (isUpper a)
- , not (isDigit a)
- , not (a==' ')
- , not (isSpace a)
- , a
- )
-
-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 uniformly from
--- the entire range of the type. You may want to use
--- 'arbitrarySizedBoundedIntegral' instead.
-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. The number is
--- chosen from the entire range of the type, but small numbers are
--- generated more often than big numbers. Inspired by demands from
--- Phil Wadler.
-arbitrarySizedBoundedIntegral :: (Bounded a, Integral a) => Gen a
-arbitrarySizedBoundedIntegral =
- sized $ \s ->
- do let mn = minBound
- mx = maxBound `asTypeOf` mn
- bits n | n `quot` 2 == 0 = 0
- | otherwise = 1 + bits (n `quot` 2)
- k = 2^(s*(bits mn `max` bits mx `max` 40) `div` 100)
- 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 > x
- ] ++
- [ x'
- | x' <- takeWhile (<< x) (0:[ x - i | i <- tail (iterate (`quot` 2) x) ])
- ]
- where
- -- a << b is "morally" abs a < abs b, but taking care of overflow.
- a << b = case (a >= 0, b >= 0) of
- (True, True) -> a < b
- (False, False) -> a > b
- (True, False) -> a + b < 0
- (False, True) -> a + b > 0
-
--- | Shrink a fraction.
-shrinkRealFrac :: RealFrac a => a -> [a]
-shrinkRealFrac x =
- nub $
- [ -x
- | x < 0
- ] ++
- [ x'
- | x' <- [fromInteger (truncate x)]
- , x' << x
- ]
- where
- a << b = abs a < abs b
-
---------------------------------------------------------------------------
--- ** 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 (RealFloat a, CoArbitrary a) => CoArbitrary (Complex a) where
- coarbitrary (x :+ y) = coarbitrary x >< coarbitrary y
-
-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 Int8 where
- coarbitrary = coarbitraryIntegral
-
-instance CoArbitrary Int16 where
- coarbitrary = coarbitraryIntegral
-
-instance CoArbitrary Int32 where
- coarbitrary = coarbitraryIntegral
-
-instance CoArbitrary Int64 where
- coarbitrary = coarbitraryIntegral
-
-instance CoArbitrary Word where
- coarbitrary = coarbitraryIntegral
-
-instance CoArbitrary Word8 where
- coarbitrary = coarbitraryIntegral
-
-instance CoArbitrary Word16 where
- coarbitrary = coarbitraryIntegral
-
-instance CoArbitrary Word32 where
- coarbitrary = coarbitraryIntegral
-
-instance CoArbitrary Word64 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
-
---------------------------------------------------------------------------
--- the end.
diff --git a/Test/QuickCheck/Batch.hs b/Test/QuickCheck/Batch.hs
new file mode 100644
index 0000000..e2f49ef
--- /dev/null
+++ b/Test/QuickCheck/Batch.hs
@@ -0,0 +1,269 @@
+{-# 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)
diff --git a/Test/QuickCheck/Exception.hs b/Test/QuickCheck/Exception.hs
deleted file mode 100644
index 548f933..0000000
--- a/Test/QuickCheck/Exception.hs
+++ /dev/null
@@ -1,72 +0,0 @@
-{-# LANGUAGE CPP #-}
-module Test.QuickCheck.Exception where
-
-#if !defined(__GLASGOW_HASKELL__) || (__GLASGOW_HASKELL__ < 609)
-#define OLD_EXCEPTIONS
-#endif
-
-#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 607
-#define GHC_INTERRUPT
-
-#if __GLASGOW_HASKELL__ < 613
-#define GHCI_INTERRUPTED_EXCEPTION
-#endif
-#endif
-
-#if defined OLD_EXCEPTIONS
-import Control.Exception(evaluate, try, Exception(..))
-#else
-import Control.Exception.Extensible(evaluate, try, SomeException(SomeException)
-#if defined(GHC_INTERRUPT)
- , AsyncException(UserInterrupt)
-#endif
- )
-#endif
-
-#if defined(GHC_INTERRUPT)
-#if defined(GHCI_INTERRUPTED_EXCEPTION)
-import Panic(GhcException(Interrupted))
-#endif
-import Data.Typeable
-#if defined(OLD_EXCEPTIONS)
-import Data.Dynamic
-#endif
-#endif
-
-#if defined(OLD_EXCEPTIONS)
-type AnException = Control.Exception.Exception
-#else
-type AnException = SomeException
-#endif
-
---------------------------------------------------------------------------
--- try evaluate
-
-tryEvaluate :: a -> IO (Either AnException a)
-tryEvaluate x = tryEvaluateIO (return x)
-
-tryEvaluateIO :: IO a -> IO (Either AnException a)
-tryEvaluateIO m = try (m >>= evaluate)
---tryEvaluateIO m = Right `fmap` m
-
--- Test if an exception was a ^C.
--- QuickCheck won't try to shrink an interrupted test case.
-isInterrupt :: AnException -> Bool
-
-#if defined(GHC_INTERRUPT)
-#if defined(OLD_EXCEPTIONS)
-isInterrupt (DynException e) = fromDynamic e == Just Interrupted
-isInterrupt _ = False
-#elif defined(GHCI_INTERRUPTED_EXCEPTION)
-isInterrupt (SomeException e) =
- cast e == Just Interrupted || cast e == Just UserInterrupt
-#else
-isInterrupt (SomeException e) = cast e == Just UserInterrupt
-#endif
-
-#else /* !defined(GHC_INTERRUPT) */
-isInterrupt _ = False
-#endif
-
---------------------------------------------------------------------------
--- the end.
diff --git a/Test/QuickCheck/Function.hs b/Test/QuickCheck/Function.hs
deleted file mode 100644
index a1affaf..0000000
--- a/Test/QuickCheck/Function.hs
+++ /dev/null
@@ -1,257 +0,0 @@
-{-# LANGUAGE TypeOperators, GADTs #-}
-module Test.QuickCheck.Function
- ( Fun(..)
- , apply
- , (:->)
- , FunArbitrary(..)
- , funArbitraryMap
- , funArbitraryShow
- )
- where
-
---------------------------------------------------------------------------
--- imports
-
-import Test.QuickCheck.Gen
-import Test.QuickCheck.Arbitrary
-import Test.QuickCheck.Property
-import Test.QuickCheck.Poly
-import Test.QuickCheck.Modifiers
-
-import Data.Char
-import Data.Word
-
---------------------------------------------------------------------------
--- concrete functions
-
--- the type of possibly partial concrete functions
-data a :-> c where
- Pair :: (a :-> (b :-> c)) -> ((a,b) :-> c)
- (:+:) :: (a :-> c) -> (b :-> c) -> (Either a b :-> c)
- Unit :: c -> (() :-> c)
- Nil :: a :-> c
- Table :: Eq a => [(a,c)] -> (a :-> c)
- Map :: (a -> b) -> (b -> a) -> (b :-> c) -> (a :-> c)
-
-instance Functor ((:->) a) where
- fmap f (Pair p) = Pair (fmap (fmap f) p)
- fmap f (p:+:q) = fmap f p :+: fmap f q
- fmap f (Unit c) = Unit (f c)
- fmap f Nil = Nil
- fmap f (Table xys) = Table [ (x,f y) | (x,y) <- xys ]
- fmap f (Map g h p) = Map g h (fmap f p)
-
-instance (Show a, Show b) => Show (a:->b) where
- -- only use this on finite functions
- show p =
- "{" ++ (case table p of
- [] -> ""
- (_,c):xcs -> concat [ show x ++ "->" ++ show c ++ ","
- | (x,c) <- xcs
- ]
- ++ "_->" ++ show c)
- ++ "}"
- where
- xcs = table p
-
--- turning a concrete function into an abstract function (with a default result)
-abstract :: (a :-> c) -> c -> (a -> c)
-abstract (Pair p) d (x,y) = abstract (fmap (\q -> abstract q d y) p) d x
-abstract (p :+: q) d exy = either (abstract p d) (abstract q d) exy
-abstract (Unit c) _ _ = c
-abstract Nil d _ = d
-abstract (Table xys) d x = head ([y | (x',y) <- xys, x == x'] ++ [d])
-abstract (Map g _ p) d x = abstract p d (g x)
-
--- generating a table from a concrete function
-table :: (a :-> c) -> [(a,c)]
-table (Pair p) = [ ((x,y),c) | (x,q) <- table p, (y,c) <- table q ]
-table (p :+: q) = [ (Left x, c) | (x,c) <- table p ]
- ++ [ (Right y,c) | (y,c) <- table q ]
-table (Unit c) = [ ((), c) ]
-table Nil = []
-table (Table xys) = xys
-table (Map _ h p) = [ (h x, c) | (x,c) <- table p ]
-
---------------------------------------------------------------------------
--- FunArbitrary
-
-class FunArbitrary a where
- funArbitrary :: Arbitrary c => Gen (a :-> c)
-
-instance (FunArbitrary a, Arbitrary c) => Arbitrary (a :-> c) where
- arbitrary = funArbitrary
- shrink = shrinkFun shrink
-
--- basic instances: pairs, sums, units
-
-instance (FunArbitrary a, FunArbitrary b) => FunArbitrary (a,b) where
- funArbitrary =
- do p <- funArbitrary
- return (Pair p)
-
-instance (FunArbitrary a, FunArbitrary b) => FunArbitrary (Either a b) where
- funArbitrary =
- do p <- funArbitrary
- q <- funArbitrary
- return (p :+: q)
-
-instance FunArbitrary () where
- funArbitrary =
- do c <- arbitrary
- return (Unit c)
-
-instance FunArbitrary Word8 where
- funArbitrary =
- do xys <- sequence [ do y <- arbitrary
- return (x,y)
- | x <- [0..255]
- ]
- return (Table xys)
-
--- other instances (using Map)
-
-funArbitraryMap :: (FunArbitrary a, Arbitrary c) => (b -> a) -> (a -> b) -> Gen (b :-> c)
-funArbitraryMap g h =
- do p <- funArbitrary
- return (Map g h p)
-
-funArbitraryShow :: (Show a, Read a, Arbitrary c) => Gen (a :-> c)
-funArbitraryShow = funArbitraryMap show read
-
-instance FunArbitrary a => FunArbitrary [a] where
- funArbitrary = funArbitraryMap g h
- where
- g [] = Left ()
- g (x:xs) = Right (x,xs)
-
- h (Left _) = []
- h (Right (x,xs)) = x:xs
-
-instance FunArbitrary a => FunArbitrary (Maybe a) where
- funArbitrary = funArbitraryMap g h
- where
- g Nothing = Left ()
- g (Just x) = Right x
-
- h (Left _) = Nothing
- h (Right x) = Just x
-
-instance FunArbitrary Bool where
- funArbitrary = funArbitraryMap g h
- where
- g False = Left ()
- g True = Right ()
-
- h (Left _) = False
- h (Right _) = True
-
-instance FunArbitrary Integer where
- funArbitrary = funArbitraryMap gInteger hInteger
- where
- gInteger n | n < 0 = Left (gNatural (abs n - 1))
- | otherwise = Right (gNatural n)
-
- hInteger (Left ws) = -(hNatural ws + 1)
- hInteger (Right ws) = hNatural ws
-
- gNatural 0 = []
- gNatural n = (fromIntegral (n `mod` 256) :: Word8) : gNatural (n `div` 256)
-
- hNatural [] = 0
- hNatural (w:ws) = fromIntegral w + 256 * hNatural ws
-
-instance FunArbitrary Int where
- funArbitrary = funArbitraryMap fromIntegral fromInteger
-
-instance FunArbitrary Char where
- funArbitrary = funArbitraryMap ord' chr'
- where
- ord' c = fromIntegral (ord c) :: Word8
- chr' n = chr (fromIntegral n)
-
--- poly instances
-
-instance FunArbitrary A where
- funArbitrary = funArbitraryMap unA A
-
-instance FunArbitrary B where
- funArbitrary = funArbitraryMap unB B
-
-instance FunArbitrary C where
- funArbitrary = funArbitraryMap unC C
-
-instance FunArbitrary OrdA where
- funArbitrary = funArbitraryMap unOrdA OrdA
-
-instance FunArbitrary OrdB where
- funArbitrary = funArbitraryMap unOrdB OrdB
-
-instance FunArbitrary OrdC where
- funArbitrary = funArbitraryMap unOrdC OrdC
-
---------------------------------------------------------------------------
--- shrinking
-
-shrinkFun :: (c -> [c]) -> (a :-> c) -> [a :-> c]
-shrinkFun shr (Pair p) =
- [ pair p' | p' <- shrinkFun (\q -> shrinkFun shr q) p ]
- where
- pair Nil = Nil
- pair p = Pair p
-
-shrinkFun shr (p :+: q) =
- [ p .+. Nil | not (isNil q) ] ++
- [ Nil .+. q | not (isNil p) ] ++
- [ p' .+. q | p' <- shrinkFun shr p ] ++
- [ p .+. q' | q' <- shrinkFun shr q ]
- where
- isNil Nil = True
- isNil _ = False
-
- Nil .+. Nil = Nil
- p .+. q = p :+: q
-
-shrinkFun shr (Unit c) =
- [ Nil ] ++
- [ Unit c' | c' <- shr c ]
-
-shrinkFun shr (Table xys) =
- [ table xys' | xys' <- shrinkList shrXy xys ]
- where
- shrXy (x,y) = [(x,y') | y' <- shr y]
-
- table [] = Nil
- table xys = Table xys
-
-shrinkFun shr Nil =
- []
-
-shrinkFun shr (Map g h p) =
- [ mapp g h p' | p' <- shrinkFun shr p ]
- where
- mapp g h Nil = Nil
- mapp g h p = Map g h p
-
---------------------------------------------------------------------------
--- the Fun modifier
-
-data Fun a b = Fun (a :-> b) (a -> b)
-
-fun :: (a :-> b) -> Fun a b
-fun p = Fun p (abstract p (snd (head (table p))))
-
-apply :: Fun a b -> (a -> b)
-apply (Fun _ f) = f
-
-instance (Show a, Show b) => Show (Fun a b) where
- show (Fun p _) = show p
-
-instance (FunArbitrary a, Arbitrary b) => Arbitrary (Fun a b) where
- arbitrary = fun `fmap` arbitrary
-
- shrink (Fun p _) =
- [ fun p' | p' <- shrink p, _:_ <- [table p'] ]
-
---------------------------------------------------------------------------
--- the end.
diff --git a/Test/QuickCheck/Gen.hs b/Test/QuickCheck/Gen.hs
deleted file mode 100644
index 947e68f..0000000
--- a/Test/QuickCheck/Gen.hs
+++ /dev/null
@@ -1,178 +0,0 @@
-module Test.QuickCheck.Gen where
-
---------------------------------------------------------------------------
--- imports
-
-import System.Random
- ( RandomGen(..)
- , Random(..)
- , StdGen
- , newStdGen
- )
-
-import Control.Monad
- ( liftM
- , ap
- )
-
-import Control.Applicative
- ( Applicative(..)
- )
-
-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 Applicative Gen where
- pure = return
- (<*>) = ap
-
-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 k0 (MkGen m) = MkGen (\r n -> m (var k0 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 monadic 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 rnd0 <- newStdGen
- let rnds rnd = rnd1 : rnds rnd2 where (rnd1,rnd2) = split rnd
- return [(m r n) | (r,n) <- rnds rnd0 `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 xs0 = choose (1, tot) >>= (`pick` xs0)
- where
- tot = sum (map fst xs0)
-
- 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.
diff --git a/Test/QuickCheck/Modifiers.hs b/Test/QuickCheck/Modifiers.hs
deleted file mode 100644
index 1c2fdd7..0000000
--- a/Test/QuickCheck/Modifiers.hs
+++ /dev/null
@@ -1,232 +0,0 @@
-{-# LANGUAGE MultiParamTypeClasses, GeneralizedNewtypeDeriving #-}
-module Test.QuickCheck.Modifiers
- (
- -- ** Type-level modifiers for changing generator behavior
- Blind(..)
- , Fixed(..)
- , OrderedList(..)
- , NonEmptyList(..)
- , Positive(..)
- , NonZero(..)
- , NonNegative(..)
- , Smart(..)
- , Shrink2(..)
- , Shrinking(..)
- , ShrinkState(..)
- )
- where
-
---------------------------------------------------------------------------
--- imports
-
-import Test.QuickCheck.Gen
-import Test.QuickCheck.Arbitrary
-
-import Data.List
- ( sort
- )
-
---------------------------------------------------------------------------
--- ** 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
- ]
-
---------------------------------------------------------------------------
--- | @Shrink2 x@: allows 2 shrinking steps at the same time when shrinking x
-newtype Shrink2 a = Shrink2 a
- deriving ( Eq, Ord, Num, Integral, Real, Enum, Show, Read )
-
-instance Arbitrary a => Arbitrary (Shrink2 a) where
- arbitrary =
- Shrink2 `fmap` arbitrary
-
- shrink (Shrink2 x) =
- [ Shrink2 y | y <- shrink_x ] ++
- [ Shrink2 z
- | y <- shrink_x
- , z <- shrink y
- ]
- where
- shrink_x = shrink x
-
---------------------------------------------------------------------------
--- | @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 j y | (j,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.
diff --git a/Test/QuickCheck/Monadic.hs b/Test/QuickCheck/Monadic.hs
deleted file mode 100644
index e862a1c..0000000
--- a/Test/QuickCheck/Monadic.hs
+++ /dev/null
@@ -1,85 +0,0 @@
-{-# LANGUAGE Rank2Types #-}
--- | Allows testing of monadic values.
-module Test.QuickCheck.Monadic where
-
---------------------------------------------------------------------------
--- imports
-
-import Test.QuickCheck.Gen
-import Test.QuickCheck.Property
-
-import Control.Monad
- ( liftM
- )
-
-import Control.Monad.ST
-
--- 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 = stop (failed { reason = s })
-
-stop :: (Testable prop, Monad m) => prop -> PropertyM m a
-stop p = MkPropertyM (\_k -> return (return (property p)))
-
--- should think about strictness/exceptions here
---assert :: Testable prop => prop -> PropertyM m ()
-assert :: Monad m => Bool -> PropertyM m ()
-assert True = return ()
-assert False = fail "Assertion failed"
-
--- should think about strictness/exceptions here
-pre :: Monad m => Bool -> PropertyM m ()
-pre True = return ()
-pre False = stop rejected
-
--- 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 runner m = property (fmap runner (monadic' m))
-
-monadic' :: Monad m => PropertyM m a -> Gen (m Property)
-monadic' (MkPropertyM m) = m (const (return (return (property True))))
-
-monadicIO :: PropertyM IO a -> Property
-monadicIO = monadic property
-
-monadicST :: (forall s. PropertyM (ST s) a) -> Property
-monadicST m = property (runSTGen (monadic' m))
-
-runSTGen :: (forall s. Gen (ST s a)) -> Gen a
-runSTGen g = MkGen $ \r n -> runST (unGen g r n)
-
---------------------------------------------------------------------------
--- the end.
diff --git a/Test/QuickCheck/Poly.hs b/Test/QuickCheck/Poly.hs
index 41a390c..d2fae68 100644
--- a/Test/QuickCheck/Poly.hs
+++ b/Test/QuickCheck/Poly.hs
@@ -1,110 +1,86 @@
-module Test.QuickCheck.Poly
- ( A(..), B(..), C(..)
- , OrdA(..), OrdB(..), OrdC(..)
- )
- where
-
---------------------------------------------------------------------------
--- imports
-
-import Test.QuickCheck.Arbitrary
-
---------------------------------------------------------------------------
--- polymorphic A, B, C (in Eq)
-
--- A
-
-newtype A = A{ unA :: Integer }
- deriving ( Eq )
-
-instance Show A where
- showsPrec n (A x) = showsPrec n x
-
-instance Arbitrary A where
- arbitrary = (A . (+1) . abs) `fmap` arbitrary
- shrink (A x) = [ A x' | x' <- shrink x, x' > 0 ]
-
-instance CoArbitrary A where
- coarbitrary = coarbitrary . unA
-
--- B
+-----------------------------------------------------------------------------
+-- |
+-- 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.
+--
+-----------------------------------------------------------------------------
-newtype B = B{ unB :: Integer }
- deriving ( Eq )
-
-instance Show B where
- showsPrec n (B x) = showsPrec n x
-
-instance Arbitrary B where
- arbitrary = (B . (+1) . abs) `fmap` arbitrary
- shrink (B x) = [ B x' | x' <- shrink x, x' > 0 ]
-
-instance CoArbitrary B where
- coarbitrary = coarbitrary . unB
-
--- C
-
-newtype C = C{ unC :: Integer }
- deriving ( Eq )
-
-instance Show C where
- showsPrec n (C x) = showsPrec n x
-
-instance Arbitrary C where
- arbitrary = (C . (+1) . 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)
+module Test.QuickCheck.Poly
+ ( ALPHA
+ , BETA
+ , GAMMA
+ , OrdALPHA
+ , OrdBETA
+ , OrdGAMMA
+ ) where
--- OrdA
+import Prelude
-newtype OrdA = OrdA{ unOrdA :: Integer }
- deriving ( Eq, Ord )
+import Test.QuickCheck
+import Test.QuickCheck.Utils
-instance Show OrdA where
- showsPrec n (OrdA x) = showsPrec n x
+{- 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)
+ -}
-instance Arbitrary OrdA where
- arbitrary = (OrdA . (+1) . abs) `fmap` arbitrary
- shrink (OrdA x) = [ OrdA x' | x' <- shrink x, x' > 0 ]
+newtype Poly a = Poly Int
-instance CoArbitrary OrdA where
- coarbitrary = coarbitrary . unOrdA
+instance Show (Poly a) where
+ show (Poly a) = "_" ++ show a
--- OrdB
+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)
-newtype OrdB = OrdB{ unOrdB :: Integer }
- deriving ( Eq, Ord )
+instance Eq a => Eq (Poly a) where
+ (Poly a) == (Poly b) = a == b
-instance Show OrdB where
- showsPrec n (OrdB x) = showsPrec n x
+instance Ord a => Ord (Poly a) where
+ (Poly a) `compare` (Poly b) = a `compare` b
-instance Arbitrary OrdB where
- arbitrary = (OrdB . (+1) . abs) `fmap` arbitrary
- shrink (OrdB x) = [ OrdB x' | x' <- shrink x, x' > 0 ]
+{-
+ - These are what we export, our pseudo-polymorphic instances.
+ -}
-instance CoArbitrary OrdB where
- coarbitrary = coarbitrary . unOrdB
+type ALPHA = Poly ALPHA_
+data ALPHA_ = ALPHA_ deriving (Eq)
--- OrdC
+type BETA = Poly BETA_
+data BETA_ = BETA_ deriving (Eq)
-newtype OrdC = OrdC{ unOrdC :: Integer }
- deriving ( Eq, Ord )
+type GAMMA = Poly GAMMA_
+data GAMMA_ = GAMMA_ deriving (Eq)
-instance Show OrdC where
- showsPrec n (OrdC x) = showsPrec n x
+type OrdALPHA = Poly OrdALPHA_
+data OrdALPHA_ = OrdALPHA_ deriving (Eq,Ord)
-instance Arbitrary OrdC where
- arbitrary = (OrdC . (+1) . abs) `fmap` arbitrary
- shrink (OrdC x) = [ OrdC x' | x' <- shrink x, x' > 0 ]
+type OrdBETA = Poly OrdBETA_
+data OrdBETA_ = OrdBETA_ deriving (Eq,Ord)
-instance CoArbitrary OrdC where
- coarbitrary = coarbitrary . unOrdC
+type OrdGAMMA = Poly OrdGAMMA_
+data OrdGAMMA_ = OrdGAMMA_ deriving (Eq,Ord)
---------------------------------------------------------------------------
--- the end.
+{-
+ - This is a condition on OrdALPHA, OrdBETA, etc, itself.
+ - It states that all OrdALPHA objects obey total ordering.
+ -}
+prop_OrdPOLY x y = isTotalOrder x y
+ where types = (x :: OrdALPHA, y :: OrdALPHA)
diff --git a/Test/QuickCheck/Property.hs b/Test/QuickCheck/Property.hs
deleted file mode 100644
index c0a381d..0000000
--- a/Test/QuickCheck/Property.hs
+++ /dev/null
@@ -1,342 +0,0 @@
-{-# LANGUAGE FlexibleInstances #-}
-module Test.QuickCheck.Property where
-
---------------------------------------------------------------------------
--- imports
-
-import Test.QuickCheck.Gen
-import Test.QuickCheck.Arbitrary
-import Test.QuickCheck.Text( showErr, putLine )
-import Test.QuickCheck.Exception
-import Test.QuickCheck.State
-
-import Control.Concurrent
- ( forkIO
- , threadDelay
- , killThread
- , newEmptyMVar
- , takeMVar
- , putMVar
- )
-
-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 . protectProp
-
-instance Testable prop => Testable (Gen prop) where
- property mp = do p <- mp; property p
-
-instance Testable prop => Testable (IO prop) where
- property = fmap (MkProp . IORose . fmap unProp) . promote . fmap property
-
-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) }
-
-protectProp :: Prop -> Prop
-protectProp (MkProp r) =
- MkProp . IORose $ do
- (x, rs) <- unpackRose r
- return (MkRose x rs)
-
--- ** type Rose
-
--- We never allow a rose tree to be _|_. This makes avoiding
--- exceptions easier.
--- This relies on the fact that the 'property' function never returns _|_.
-data Rose a = MkRose a [Rose a] | IORose (IO (Rose a))
-
-join :: Rose (Rose a) -> Rose a
-join (IORose rs) = IORose (fmap join rs)
-join (MkRose (IORose rm) rs) = IORose $ do r <- rm; return (join (MkRose r rs))
-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 (IORose rs) = IORose (fmap (fmap f) rs)
- 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)
-
-unpackRose :: Rose (IO Result) -> IO (IO Result, [Rose (IO Result)])
-unpackRose rose = either (\e -> (return (exception "Exception" e), [])) id
- `fmap` tryEvaluateIO (unpack rose)
- where unpack (MkRose x xs) = return (x, xs)
- unpack (IORose m) = m >>= unpack
-
--- ** 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
- , interrupted :: Bool -- ^ indicates if the test case was cancelled by pressing ^C
- , 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 = ""
- , interrupted = False
- , stamp = []
- , callbacks = []
- }
-
-exception :: String -> AnException -> Result
-exception msg err = failed{ reason = msg ++ ": '" ++ showErr err ++ "'",
- interrupted = isInterrupt err }
-
-protectResult :: IO Result -> IO Result
-protectResult m = either (exception "Exception") id `fmap` tryEvaluateIO (fmap force m)
- where force res = ok res == Just False `seq` res
-
-succeeded :: Result
-succeeded = result{ ok = Just True }
-
-failed :: Result
-failed = result{ ok = Just False }
-
-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 = property (MkProp (return m))
-
-mapResult :: Testable prop => (Result -> Result) -> prop -> Property
-mapResult f = mapIOResult (fmap f)
-
-mapIOResult :: Testable prop => (IO Result -> IO Result) -> prop -> Property
-mapIOResult f = mapRoseIOResult (fmap (f . protectResult))
-
--- f here has to be total.
-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 when you want to
--- override the default behavior.
-shrinking :: Testable prop =>
- (a -> [a]) -- ^ 'shrink'-like function.
- -> a -- ^ The original argument
- -> (a -> prop) -> Property
-shrinking shrinker x0 pf = fmap (MkProp . join . fmap unProp) (promote (props x0))
- where
- props x =
- MkRose (property (pf x)) [ props x' | x' <- shrinker x ]
-
--- | Disables shrinking for a property altogether.
-noShrinking :: Testable prop => prop -> Property
-noShrinking = mapRoseIOResult f
- where f (MkRose mres _ts) = MkRose mres []
- f (IORose rm) = IORose (fmap f rm)
-
--- | Adds a callback
-callback :: Testable prop => Callback -> prop -> Property
-callback cb = mapResult (\res -> res{ callbacks = cb : callbacks res })
-
--- | Prints a message to the terminal after the last failure of a property.
-whenFailPrint :: Testable prop => String -> prop -> Property
-whenFailPrint s =
- callback $ PostFinalFailure $ \st _res ->
- putLine (terminal st) s
-
--- | 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 = mapResult $ \res ->
- case b of
- True -> res{ stamp = (s,n) : stamp res }
- 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
-
--- | 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
-
- let waitAndFail =
- do put "Waiting ..."
- threadDelay n
- put "Done waiting!"
- putMVar resV (failed {reason = "Time out"})
-
- evalProp =
- do put "Evaluating Result ..."
- res <- protectResult ior
- put "Evaluating OK ..."
- putMVar resV res
-
- pid1 <- forkIO evalProp
- pid2 <- forkIO waitAndFail
-
- put "Blocking ..."
- res <- takeMVar resV
- put "Killing threads ..."
- killThread pid1
- killThread pid2
- 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 ->
- whenFailPrint (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 shrinker pf =
- gen >>= \x ->
- shrinking shrinker x $ \x' ->
- whenFailPrint (show x') $
- property (pf x')
-
-(.&.) :: (Testable prop1, Testable prop2) => prop1 -> prop2 -> Property
-p1 .&. p2 =
- arbitrary >>= \b ->
- whenFailPrint (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.
diff --git a/Test/QuickCheck/State.hs b/Test/QuickCheck/State.hs
deleted file mode 100644
index 237ecc9..0000000
--- a/Test/QuickCheck/State.hs
+++ /dev/null
@@ -1,33 +0,0 @@
-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
- , numSuccessShrinks :: Int -- ^ number of successful shrinking steps so far
- , numTryShrinks :: Int -- ^ number of failed shrinking steps since the last successful shrink
- }
-
---------------------------------------------------------------------------
--- the end.
diff --git a/Test/QuickCheck/Test.hs b/Test/QuickCheck/Test.hs
deleted file mode 100644
index ef38365..0000000
--- a/Test/QuickCheck/Test.hs
+++ /dev/null
@@ -1,366 +0,0 @@
-module Test.QuickCheck.Test where
-
---------------------------------------------------------------------------
--- imports
-
-import Test.QuickCheck.Gen
-import Test.QuickCheck.Property hiding ( Result( reason, interrupted ) )
-import qualified Test.QuickCheck.Property as P
-import Test.QuickCheck.Text
-import Test.QuickCheck.State
-import Test.QuickCheck.Exception
-import Data.IORef
-
-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
- , chatty :: Bool -- ^ whether to print anything
- }
- deriving ( Show, Read )
-
--- | Result represents the test result
-data Result
- = Success -- a successful test run
- { numTests :: Int -- ^ number of successful tests performed
- , labels :: [(String,Int)] -- ^ labels and frequencies found during all tests
- , output :: String -- ^ printed output
- }
- | GaveUp -- given up
- { numTests :: Int -- ^ number of successful tests performed
- , labels :: [(String,Int)] -- ^ labels and frequencies found during all tests
- , output :: String -- ^ printed output
- }
- | Failure -- failed test run
- { numTests :: Int -- ^ number of tests performed
- , numShrinks :: Int -- ^ number of successful shrinking steps performed
- , 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
- , output :: String -- ^ printed output
- }
- | NoExpectedFailure -- the expected failure did not happen
- { numTests :: Int -- ^ number of tests performed
- , labels :: [(String,Int)] -- ^ labels and frequencies found during all successful tests
- , output :: String -- ^ printed output
- }
- 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
- , chatty = True
--- 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 a p =
- do tm <- if chatty a then newStdioTerminal else newNullTerminal
- rnd <- case replay a of
- Nothing -> newStdGen
- Just (rnd,_) -> return rnd
- test MkState{ terminal = tm
- , maxSuccessTests = maxSuccess a
- , maxDiscardedTests = maxDiscard a
- , computeSize = case replay a of
- Nothing -> computeSize'
- Just (_,s) -> \_ _ -> s
- , numSuccessTests = 0
- , numDiscardedTests = 0
- , collected = []
- , expectedFailure = False
- , randomSeed = rnd
- , numSuccessShrinks = 0
- , numTryShrinks = 0
- } (unGen (property p))
- where computeSize' n d
- -- e.g. with maxSuccess = 250, maxSize = 100, goes like this:
- -- 0, 1, 2, ..., 99, 0, 1, 2, ..., 99, 0, 2, 4, ..., 98.
- | n `roundTo` maxSize a + maxSize a <= maxSuccess a ||
- n >= maxSuccess a ||
- maxSuccess a `mod` maxSize a == 0 = n `mod` maxSize a + d `div` 10
- | otherwise =
- (n `mod` maxSize a) * maxSize a `div` (maxSuccess a `mod` maxSize a) + d `div` 10
- n `roundTo` m = (n `div` m) * m
-
---------------------------------------------------------------------------
--- 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
- theOutput <- terminalOutput (terminal st)
- if expectedFailure st then
- return Success{ labels = summary st,
- numTests = numSuccessTests st,
- output = theOutput }
- else
- return NoExpectedFailure{ labels = summary st,
- numTests = numSuccessTests st,
- output = theOutput }
-
-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
- theOutput <- terminalOutput (terminal st)
- return GaveUp{ numTests = numSuccessTests st
- , labels = summary st
- , output = theOutput
- }
-
-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)
- (mres, ts) <- unpackRose (unProp (f rnd1 size))
- res <- mres
- 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"
- ++ ")..."
- )
- numShrinks <- foundFailure st res ts
- theOutput <- terminalOutput (terminal st)
- if not (expect res) then
- return Success{ labels = summary st,
- numTests = numSuccessTests st+1,
- output = theOutput }
- else
- return Failure{ usedSeed = randomSeed st -- correct! (this will be split first)
- , usedSize = size
- , numTests = numSuccessTests st+1
- , numShrinks = numShrinks
- , output = theOutput
- , 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 allLabels ++ 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
- allLabels = reverse
- . sort
- . map (\ss -> (showP ((length ss * 100) `div` numSuccessTests st) ++ head ss))
- . group
- . sort
- $ [ concat (intersperse ", " s')
- | s <- collected st
- , let s' = [ t | (t,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 ++ "% "
-
---------------------------------------------------------------------------
--- main shrinking loop
-
-foundFailure :: State -> P.Result -> [Rose (IO P.Result)] -> IO Int
-foundFailure st res ts =
- do localMin st{ numTryShrinks = 0 } res ts
-
-localMin :: State -> P.Result -> [Rose (IO P.Result)] -> IO Int
-localMin st res _ | P.interrupted res = localMinFound st res
-localMin st res ts = do
- r <- tryEvaluate ts
- case r of
- Left err ->
- localMinFound st
- (exception "Exception while generating shrink-list" err)
- Right ts' -> localMin' st res ts'
-
-localMin' :: State -> P.Result -> [Rose (IO P.Result)] -> IO Int
-localMin' st res [] = localMinFound st res
-localMin' st res (t:ts) =
- do -- CALLBACK before_test
- (mres', ts') <- unpackRose t
- res' <- mres'
- 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
-
-localMinFound :: State -> P.Result -> IO Int
-localMinFound 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
- return (numSuccessShrinks st)
-
---------------------------------------------------------------------------
--- 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.
diff --git a/Test/QuickCheck/Text.hs b/Test/QuickCheck/Text.hs
deleted file mode 100644
index d609e28..0000000
--- a/Test/QuickCheck/Text.hs
+++ /dev/null
@@ -1,148 +0,0 @@
-module Test.QuickCheck.Text
- ( Str(..)
- , ranges
-
- , number
- , short
- , showErr
- , bold
-
- , newTerminal
- , newStdioTerminal
- , newNullTerminal
- , terminalOutput
- , handle
- , Terminal
- , putTemp
- , putPart
- , putLine
- )
- where
-
---------------------------------------------------------------------------
--- imports
-
-import System.IO
- ( hFlush
- , hPutStr
- , stdout
- , stderr
- , Handle
- )
-
-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
-
-data Terminal
- = MkTerminal (IORef (IO ())) Output Output
-
-data Output
- = Output (String -> IO ()) (IORef String)
-
-newTerminal :: Output -> Output -> IO Terminal
-newTerminal out err =
- do ref <- newIORef (return ())
- return (MkTerminal ref out err)
-
-newStdioTerminal :: IO Terminal
-newStdioTerminal = do
- out <- output (handle stdout)
- err <- output (handle stderr)
- newTerminal out err
-
-newNullTerminal :: IO Terminal
-newNullTerminal = do
- out <- output (const (return ()))
- err <- output (const (return ()))
- newTerminal out err
-
-terminalOutput :: Terminal -> IO String
-terminalOutput (MkTerminal _ out _) = get out
-
-handle :: Handle -> String -> IO ()
-handle h s = do
- hPutStr h s
- hFlush h
-
-output :: (String -> IO ()) -> IO Output
-output f = do
- r <- newIORef ""
- return (Output f r)
-
-put :: Output -> String -> IO ()
-put (Output f r) s = do
- f s
- modifyIORef r (++ s)
-
-get :: Output -> IO String
-get (Output _ r) = readIORef r
-
-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@(MkTerminal _ out _) s =
- do flush tm
- put out s
-
-putTemp tm@(MkTerminal _ _ err) s =
- do flush tm
- put err s
- put err [ '\b' | _ <- s ]
- postpone tm $
- put err ( [ ' ' | _ <- s ]
- ++ [ '\b' | _ <- s ]
- )
-
-putLine tm@(MkTerminal _ out _) s =
- do flush tm
- put out s
- put out "\n"
-
---------------------------------------------------------------------------
--- the end.
diff --git a/Test/QuickCheck/Utils.hs b/Test/QuickCheck/Utils.hs
new file mode 100644
index 0000000..b43eea0
--- /dev/null
+++ b/Test/QuickCheck/Utils.hs
@@ -0,0 +1,53 @@
+-----------------------------------------------------------------------------
+-- |
+-- 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