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