--- /dev/null
+-----------------------------------------------------------------------------
+--
+-- 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.
--- /dev/null
+-----------------------------------------------------------------------------
+--
+-- 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)
projects / ghc-base.git / commitdiff