From: simonmar Date: Fri, 17 Aug 2001 12:48:38 +0000 (+0000) Subject: [project @ 2001-08-17 12:48:38 by simonmar] X-Git-Tag: nhc98-1-18-release~1175 X-Git-Url: http://git.megacz.com/?a=commitdiff_plain;h=2c5d10f19ae7ce0dac5eaa4ca64a94d1e1ee0043;p=haskell-directory.git [project @ 2001-08-17 12:48:38 by simonmar] Add QuickCheck from package util. --- diff --git a/Debug/QuickCheck.hs b/Debug/QuickCheck.hs new file mode 100644 index 0000000..ccada06 --- /dev/null +++ b/Debug/QuickCheck.hs @@ -0,0 +1,351 @@ +----------------------------------------------------------------------------- +-- +-- Module : Debug.QuickCheck +-- Copyright : (c) Koen Claessen, John Hughes 2001 +-- License : BSD-style (see the file libraries/core/LICENSE) +-- +-- Maintainer : libraries@haskell.org +-- Stability : experimental +-- Portability : portable +-- +-- $Id: QuickCheck.hs,v 1.1 2001/08/17 12:48:38 simonmar Exp $ +-- +-- 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 Debug.QuickCheck + -- testing functions + ( quickCheck -- :: prop -> IO () + , verboseCheck -- :: prop -> IO () + , test -- :: prop -> IO () -- = quickCheck + + , 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 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 + } + +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/Debug/QuickCheck/Batch.hs b/Debug/QuickCheck/Batch.hs new file mode 100644 index 0000000..f5056f8 --- /dev/null +++ b/Debug/QuickCheck/Batch.hs @@ -0,0 +1,229 @@ +----------------------------------------------------------------------------- +-- +-- Module : Debug.QuickCheck.Batch +-- Copyright : (c) Andy Gill 2001 +-- License : BSD-style (see the file libraries/core/LICENSE) +-- +-- Maintainer : libraries@haskell.org +-- Stability : experimental +-- Portability : non-portable (uses Control.Exception, Control.Concurrent) +-- +-- $Id: Batch.hs,v 1.1 2001/08/17 12:48:38 simonmar Exp $ +-- +-- This is a batch driver for runing QuickCheck. +-- +----------------------------------------------------------------------------- + +{- + - 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. + - + - Examples of use of bottom and isBottom: + - {- test for abort -} + - prop_head2 = isBottom (head []) + - {- test for strictness -} + - prop_head3 = isBottom (head bottom) + -} + +module Debug.QuickCheck.Batch + ( run -- :: Testable a => a -> TestOptions -> IO TestResult + , runTests -- :: String -> TestOptions -> + -- [TestOptions -> IO TestResult] -> IO () + , defOpt -- :: TestOptions + , TestOptions (..) + , isBottom -- :: a -> Bool + , bottom -- :: a {- _|_ -} + ) where + +import System.Random +import Control.Concurrent +import Control.Exception hiding (catch, evaluate) +import qualified Control.Exception as Exception (catch, evaluate) +import Debug.QuickCheck +import System.IO.Unsafe + +data TestOptions = TestOptions { + no_of_tests :: Int, + length_of_tests :: Int, + 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 "" + } + +-- 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 } = + 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) + 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" + +-- Look out behind you! These can be misused badly. +-- However, in the context of a batch tester, can also be very useful. + +bottom = error "_|_" + +isBottom :: a -> Bool +isBottom a = unsafePerformIO (do + a' <- try (Exception.evaluate a) + case a' of + Left _ -> return True + Right _ -> return False) diff --git a/Debug/QuickCheck/Utils.hs b/Debug/QuickCheck/Utils.hs new file mode 100644 index 0000000..f6ad91f --- /dev/null +++ b/Debug/QuickCheck/Utils.hs @@ -0,0 +1,53 @@ +----------------------------------------------------------------------------- +-- +-- Module : Debug.QuickCheck.Poly +-- Copyright : (c) Andy Gill 2001 +-- License : BSD-style (see the file libraries/core/LICENSE) +-- +-- Maintainer : libraries@haskell.org +-- Stability : experimental +-- Portability : portable +-- +-- $Id: Utils.hs,v 1.1 2001/08/17 12:48:38 simonmar Exp $ +-- +-- These are some general purpose utilities for use with QuickCheck. +-- +----------------------------------------------------------------------------- + +module Debug.QuickCheckUtils + ( isAssociativeBy + , isAssociative + , isCommutableBy + , isCommutable + , isTotalOrder + ) where + +import Debug.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