ccada062231d78905ae96282e15f065aed655e10
[packages/base.git] / Debug / QuickCheck.hs
1 -----------------------------------------------------------------------------
2 --
3 -- Module : Debug.QuickCheck
4 -- Copyright : (c) Koen Claessen, John Hughes 2001
5 -- License : BSD-style (see the file libraries/core/LICENSE)
6 --
7 -- Maintainer : libraries@haskell.org
8 -- Stability : experimental
9 -- Portability : portable
10 --
11 -- $Id: QuickCheck.hs,v 1.1 2001/08/17 12:48:38 simonmar Exp $
12 --
13 -- QuickCheck v.0.2
14 -- DRAFT implementation; last update 000104.
15 -- Koen Claessen, John Hughes.
16 -- This file represents work in progress, and might change at a later date.
17 --
18 -----------------------------------------------------------------------------
19
20 module Debug.QuickCheck
21 -- testing functions
22 ( quickCheck -- :: prop -> IO ()
23 , verboseCheck -- :: prop -> IO ()
24 , test -- :: prop -> IO () -- = quickCheck
25
26 , Config(..) -- :: *
27 , check -- :: Config -> prop -> IO ()
28
29 -- property combinators
30 , forAll -- :: Gen a -> (a -> prop) -> prop
31 , (==>) -- :: Bool -> prop -> prop
32
33 -- gathering test-case information
34 , label -- :: String -> prop -> prop
35 , collect -- :: Show a => a -> prop -> prop
36 , classify -- :: Bool -> String -> prop -> prop
37 , trivial -- :: Bool -> prop -> prop
38
39 -- generator combinators
40 , Gen -- :: * -> * ; Functor, Monad
41
42 , elements -- :: [a] -> Gen a
43 , two -- :: Gen a -> Gen (a,a)
44 , three -- :: Gen a -> Gen (a,a,a)
45 , four -- :: Gen a -> Gen (a,a,a,a)
46
47 , sized -- :: (Int -> Gen a) -> Gen a
48 , resize -- :: Int -> Gen a -> Gen a
49 , choose -- :: Random a => (a, a) -> Gen a
50 , oneof -- :: [Gen a] -> Gen a
51 , frequency -- :: [(Int, Gen a)] -> Gen a
52
53 , vector -- :: Arbitrary a => Int -> Gen [a]
54
55 -- default generators
56 , Arbitrary(..) -- :: class
57 , rand -- :: Gen StdGen
58 , promote -- :: (a -> Gen b) -> Gen (a -> b)
59 , variant -- :: Int -> Gen a -> Gen a
60
61 -- testable
62 , Testable(..) -- :: class
63 , Property -- :: *
64
65 -- For writing your own driver
66 , Result(..) -- :: data
67 , generate -- :: Int -> StdGen -> Gen a -> a
68 , evaluate -- :: Testable a => a -> Gen Result
69 )
70 where
71
72 import System.Random
73 import Data.List( group, sort, intersperse )
74 import Control.Monad( liftM2, liftM3, liftM4 )
75
76 infixr 0 ==>
77 infix 1 `classify`
78
79 --------------------------------------------------------------------
80 -- Generator
81
82 newtype Gen a
83 = Gen (Int -> StdGen -> a)
84
85 sized :: (Int -> Gen a) -> Gen a
86 sized fgen = Gen (\n r -> let Gen m = fgen n in m n r)
87
88 resize :: Int -> Gen a -> Gen a
89 resize n (Gen m) = Gen (\_ r -> m n r)
90
91 rand :: Gen StdGen
92 rand = Gen (\n r -> r)
93
94 promote :: (a -> Gen b) -> Gen (a -> b)
95 promote f = Gen (\n r -> \a -> let Gen m = f a in m n r)
96
97 variant :: Int -> Gen a -> Gen a
98 variant v (Gen m) = Gen (\n r -> m n (rands r !! (v+1)))
99 where
100 rands r0 = r1 : rands r2 where (r1, r2) = split r0
101
102 generate :: Int -> StdGen -> Gen a -> a
103 generate n rnd (Gen m) = m size rnd'
104 where
105 (size, rnd') = randomR (0, n) rnd
106
107 instance Functor Gen where
108 fmap f m = m >>= return . f
109
110 instance Monad Gen where
111 return a = Gen (\n r -> a)
112 Gen m >>= k =
113 Gen (\n r0 -> let (r1,r2) = split r0
114 Gen m' = k (m n r1)
115 in m' n r2)
116
117 -- derived
118
119 choose :: Random a => (a, a) -> Gen a
120 choose bounds = (fst . randomR bounds) `fmap` rand
121
122 elements :: [a] -> Gen a
123 elements xs = (xs !!) `fmap` choose (0, length xs - 1)
124
125 vector :: Arbitrary a => Int -> Gen [a]
126 vector n = sequence [ arbitrary | i <- [1..n] ]
127
128 oneof :: [Gen a] -> Gen a
129 oneof gens = elements gens >>= id
130
131 frequency :: [(Int, Gen a)] -> Gen a
132 frequency xs = choose (1, tot) >>= (`pick` xs)
133 where
134 tot = sum (map fst xs)
135
136 pick n ((k,x):xs)
137 | n <= k = x
138 | otherwise = pick (n-k) xs
139
140 -- general monadic
141
142 two :: Monad m => m a -> m (a, a)
143 two m = liftM2 (,) m m
144
145 three :: Monad m => m a -> m (a, a, a)
146 three m = liftM3 (,,) m m m
147
148 four :: Monad m => m a -> m (a, a, a, a)
149 four m = liftM4 (,,,) m m m m
150
151 --------------------------------------------------------------------
152 -- Arbitrary
153
154 class Arbitrary a where
155 arbitrary :: Gen a
156 coarbitrary :: a -> Gen b -> Gen b
157
158 instance Arbitrary () where
159 arbitrary = return ()
160 coarbitrary _ = variant 0
161
162 instance Arbitrary Bool where
163 arbitrary = elements [True, False]
164 coarbitrary b = if b then variant 0 else variant 1
165
166 instance Arbitrary Int where
167 arbitrary = sized $ \n -> choose (-n,n)
168 coarbitrary n = variant (if n >= 0 then 2*n else 2*(-n) + 1)
169
170 instance Arbitrary Integer where
171 arbitrary = sized $ \n -> choose (-fromIntegral n,fromIntegral n)
172 coarbitrary n = variant (fromInteger (if n >= 0 then 2*n else 2*(-n) + 1))
173
174 instance Arbitrary Float where
175 arbitrary = liftM3 fraction arbitrary arbitrary arbitrary
176 coarbitrary x = coarbitrary (decodeFloat x)
177
178 instance Arbitrary Double where
179 arbitrary = liftM3 fraction arbitrary arbitrary arbitrary
180 coarbitrary x = coarbitrary (decodeFloat x)
181
182 fraction a b c = fromInteger a + (fromInteger b / (abs (fromInteger c) + 1))
183
184 instance (Arbitrary a, Arbitrary b) => Arbitrary (a, b) where
185 arbitrary = liftM2 (,) arbitrary arbitrary
186 coarbitrary (a, b) = coarbitrary a . coarbitrary b
187
188 instance (Arbitrary a, Arbitrary b, Arbitrary c) => Arbitrary (a, b, c) where
189 arbitrary = liftM3 (,,) arbitrary arbitrary arbitrary
190 coarbitrary (a, b, c) = coarbitrary a . coarbitrary b . coarbitrary c
191
192 instance (Arbitrary a, Arbitrary b, Arbitrary c, Arbitrary d)
193 => Arbitrary (a, b, c, d)
194 where
195 arbitrary = liftM4 (,,,) arbitrary arbitrary arbitrary arbitrary
196 coarbitrary (a, b, c, d) =
197 coarbitrary a . coarbitrary b . coarbitrary c . coarbitrary d
198
199 instance Arbitrary a => Arbitrary [a] where
200 arbitrary = sized (\n -> choose (0,n) >>= vector)
201 coarbitrary [] = variant 0
202 coarbitrary (a:as) = coarbitrary a . variant 1 . coarbitrary as
203
204 instance (Arbitrary a, Arbitrary b) => Arbitrary (a -> b) where
205 arbitrary = promote (`coarbitrary` arbitrary)
206 coarbitrary f gen = arbitrary >>= ((`coarbitrary` gen) . f)
207
208 --------------------------------------------------------------------
209 -- Testable
210
211 data Result
212 = Result { ok :: Maybe Bool, stamp :: [String], arguments :: [String] }
213
214 nothing :: Result
215 nothing = Result{ ok = Nothing, stamp = [], arguments = [] }
216
217 newtype Property
218 = Prop (Gen Result)
219
220 result :: Result -> Property
221 result res = Prop (return res)
222
223 evaluate :: Testable a => a -> Gen Result
224 evaluate a = gen where Prop gen = property a
225
226 class Testable a where
227 property :: a -> Property
228
229 instance Testable () where
230 property _ = result nothing
231
232 instance Testable Bool where
233 property b = result (nothing{ ok = Just b })
234
235 instance Testable Result where
236 property res = result res
237
238 instance Testable Property where
239 property prop = prop
240
241 instance (Arbitrary a, Show a, Testable b) => Testable (a -> b) where
242 property f = forAll arbitrary f
243
244 forAll :: (Show a, Testable b) => Gen a -> (a -> b) -> Property
245 forAll gen body = Prop $
246 do a <- gen
247 res <- evaluate (body a)
248 return (argument a res)
249 where
250 argument a res = res{ arguments = show a : arguments res }
251
252 (==>) :: Testable a => Bool -> a -> Property
253 True ==> a = property a
254 False ==> a = property ()
255
256 label :: Testable a => String -> a -> Property
257 label s a = Prop (add `fmap` evaluate a)
258 where
259 add res = res{ stamp = s : stamp res }
260
261 classify :: Testable a => Bool -> String -> a -> Property
262 classify True name = label name
263 classify False _ = property
264
265 trivial :: Testable a => Bool -> a -> Property
266 trivial = (`classify` "trivial")
267
268 collect :: (Show a, Testable b) => a -> b -> Property
269 collect v = label (show v)
270
271 --------------------------------------------------------------------
272 -- Testing
273
274 data Config = Config
275 { configMaxTest :: Int
276 , configMaxFail :: Int
277 , configSize :: Int -> Int
278 , configEvery :: Int -> [String] -> String
279 }
280
281 quick :: Config
282 quick = Config
283 { configMaxTest = 100
284 , configMaxFail = 1000
285 , configSize = (+ 3) . (`div` 2)
286 , configEvery = \n args -> let s = show n in s ++ [ '\b' | _ <- s ]
287 }
288
289 verbose :: Config
290 verbose = quick
291 { configEvery = \n args -> show n ++ ":\n" ++ unlines args
292 }
293
294 test, quickCheck, verboseCheck :: Testable a => a -> IO ()
295 test = check quick
296 quickCheck = check quick
297 verboseCheck = check verbose
298
299 check :: Testable a => Config -> a -> IO ()
300 check config a =
301 do rnd <- newStdGen
302 tests config (evaluate a) rnd 0 0 []
303
304 tests :: Config -> Gen Result -> StdGen -> Int -> Int -> [[String]] -> IO ()
305 tests config gen rnd0 ntest nfail stamps
306 | ntest == configMaxTest config = do done "OK, passed" ntest stamps
307 | nfail == configMaxFail config = do done "Arguments exhausted after" ntest stamps
308 | otherwise =
309 do putStr (configEvery config ntest (arguments result))
310 case ok result of
311 Nothing ->
312 tests config gen rnd1 ntest (nfail+1) stamps
313 Just True ->
314 tests config gen rnd1 (ntest+1) nfail (stamp result:stamps)
315 Just False ->
316 putStr ( "Falsifiable, after "
317 ++ show ntest
318 ++ " tests:\n"
319 ++ unlines (arguments result)
320 )
321 where
322 result = generate (configSize config ntest) rnd2 gen
323 (rnd1,rnd2) = split rnd0
324
325 done :: String -> Int -> [[String]] -> IO ()
326 done mesg ntest stamps =
327 do putStr ( mesg ++ " " ++ show ntest ++ " tests" ++ table )
328 where
329 table = display
330 . map entry
331 . reverse
332 . sort
333 . map pairLength
334 . group
335 . sort
336 . filter (not . null)
337 $ stamps
338
339 display [] = ".\n"
340 display [x] = " (" ++ x ++ ").\n"
341 display xs = ".\n" ++ unlines (map (++ ".") xs)
342
343 pairLength xss@(xs:_) = (length xss, xs)
344 entry (n, xs) = percentage n ntest
345 ++ " "
346 ++ concat (intersperse ", " xs)
347
348 percentage n m = show ((100 * n) `div` m) ++ "%"
349
350 --------------------------------------------------------------------
351 -- the end.