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