diff --git a/Debug/QuickCheck.hs b/Debug/QuickCheck.hs new file mode 100644 --- /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 --- /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 --- /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 --- /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 new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,31 @@ +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 +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. + +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 new file mode 100644 --- /dev/null +++ b/QuickCheck.cabal @@ -0,0 +1,30 @@ +name: QuickCheck +version: 1.0 +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 + 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. +exposed-modules: + Debug.QuickCheck.Batch, + Debug.QuickCheck.Poly, + Debug.QuickCheck.Utils, + Debug.QuickCheck, + Test.QuickCheck.Batch, + Test.QuickCheck.Poly, + Test.QuickCheck.Utils, + Test.QuickCheck +build-depends: base +extensions: CPP diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/Test/QuickCheck.hs b/Test/QuickCheck.hs new file mode 100644 --- /dev/null +++ b/Test/QuickCheck.hs @@ -0,0 +1,355 @@ +----------------------------------------------------------------------------- +-- | +-- 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] + + -- 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 + +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+1))) + where + rands r0 = r1 : rands r2 where (r1, r2) = split r0 + +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 [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) + + percentage n m = show ((100 * n) `div` m) ++ "%" + +-------------------------------------------------------------------- +-- the end. diff --git a/Test/QuickCheck/Batch.hs b/Test/QuickCheck/Batch.hs new file mode 100644 --- /dev/null +++ b/Test/QuickCheck/Batch.hs @@ -0,0 +1,246 @@ +{-# 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. + - + -} + +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) +import qualified Control.Exception as Exception (catch, evaluate) +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 + | TestAborted Exception + +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 ()) + (\ _ -> return ())) + -- 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 + Left _ -> return True + Right _ -> return False) diff --git a/Test/QuickCheck/Poly.hs b/Test/QuickCheck/Poly.hs new file mode 100644 --- /dev/null +++ b/Test/QuickCheck/Poly.hs @@ -0,0 +1,86 @@ +----------------------------------------------------------------------------- +-- | +-- 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 + +import Prelude + +import Test.QuickCheck +import Test.QuickCheck.Utils + +{- 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) + -} + +newtype Poly a = Poly Int + +instance Show (Poly a) where + show (Poly a) = "_" ++ show a + +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 Eq a => Eq (Poly a) where + (Poly a) == (Poly b) = a == b + +instance Ord a => Ord (Poly a) where + (Poly a) `compare` (Poly b) = a `compare` b + +{- + - These are what we export, our pseudo-polymorphic instances. + -} + +type ALPHA = Poly ALPHA_ +data ALPHA_ = ALPHA_ deriving (Eq) + +type BETA = Poly BETA_ +data BETA_ = BETA_ deriving (Eq) + +type GAMMA = Poly GAMMA_ +data GAMMA_ = GAMMA_ deriving (Eq) + +type OrdALPHA = Poly OrdALPHA_ +data OrdALPHA_ = OrdALPHA_ deriving (Eq,Ord) + +type OrdBETA = Poly OrdBETA_ +data OrdBETA_ = OrdBETA_ deriving (Eq,Ord) + +type OrdGAMMA = Poly OrdGAMMA_ +data OrdGAMMA_ = OrdGAMMA_ deriving (Eq,Ord) + +{- + - 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/Utils.hs b/Test/QuickCheck/Utils.hs new file mode 100644 --- /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