[project @ 2002-04-24 16:31:37 by simonmar]
[packages/base.git] / Debug / QuickCheck / Batch.hs
1 -----------------------------------------------------------------------------
2 -- |
3 -- Module : Debug.QuickCheck.Batch
4 -- Copyright : (c) Andy Gill 2001
5 -- License : BSD-style (see the file libraries/core/LICENSE)
6 --
7 -- Maintainer : libraries@haskell.org
8 -- Stability : experimental
9 -- Portability : non-portable (uses Control.Exception, Control.Concurrent)
10 --
11 -- $Id: Batch.hs,v 1.2 2002/04/24 16:31:43 simonmar Exp $
12 --
13 -- This is a batch driver for runing QuickCheck.
14 --
15 -----------------------------------------------------------------------------
16
17 {-
18 - Here is the key for reading the output.
19 - . = test successful
20 - ? = every example passed, but quickcheck did not find enough good examples
21 - * = test aborted for some reason (out-of-time, bottom, etc)
22 - # = test failed outright
23 -
24 - We also provide the dangerous "isBottom".
25 -
26 - Here is is an example of use for sorting:
27 -
28 - testOptions :: TestOptions
29 - testOptions = TestOptions
30 - { no_of_tests = 100 -- number of tests to run
31 - , length_of_tests = 1 -- 1 second max per check
32 - -- where a check == n tests
33 - , debug_tests = False -- True => debugging info
34 - }
35 -
36 - prop_sort1 xs = sort xs == sortBy compare xs
37 - where types = (xs :: [OrdALPHA])
38 - prop_sort2 xs =
39 - (not (null xs)) ==>
40 - (head (sort xs) == minimum xs)
41 - where types = (xs :: [OrdALPHA])
42 - prop_sort3 xs = (not (null xs)) ==>
43 - last (sort xs) == maximum xs
44 - where types = (xs :: [OrdALPHA])
45 - prop_sort4 xs ys =
46 - (not (null xs)) ==>
47 - (not (null ys)) ==>
48 - (head (sort (xs ++ ys)) == min (minimum xs) (minimum ys))
49 - where types = (xs :: [OrdALPHA], ys :: [OrdALPHA])
50 - prop_sort6 xs ys =
51 - (not (null xs)) ==>
52 - (not (null ys)) ==>
53 - (last (sort (xs ++ ys)) == max (maximum xs) (maximum ys))
54 - where types = (xs :: [OrdALPHA], ys :: [OrdALPHA])
55 - prop_sort5 xs ys =
56 - (not (null xs)) ==>
57 - (not (null ys)) ==>
58 - (head (sort (xs ++ ys)) == max (maximum xs) (maximum ys))
59 - where types = (xs :: [OrdALPHA], ys :: [OrdALPHA])
60 -
61 - test_sort = runTests "sort" testOptions
62 - [ run prop_sort1
63 - , run prop_sort2
64 - , run prop_sort3
65 - , run prop_sort4
66 - , run prop_sort5
67 - ]
68 -
69 - When run, this gives
70 - Main> test_sort
71 - sort : .....
72 -
73 - You would tie together all the test_* functions
74 - into one test_everything, on a per module basis.
75 -
76 - Examples of use of bottom and isBottom:
77 - {- test for abort -}
78 - prop_head2 = isBottom (head [])
79 - {- test for strictness -}
80 - prop_head3 = isBottom (head bottom)
81 -}
82
83 module Debug.QuickCheck.Batch
84 ( run -- :: Testable a => a -> TestOptions -> IO TestResult
85 , runTests -- :: String -> TestOptions ->
86 -- [TestOptions -> IO TestResult] -> IO ()
87 , defOpt -- :: TestOptions
88 , TestOptions (..)
89 , isBottom -- :: a -> Bool
90 , bottom -- :: a {- _|_ -}
91 ) where
92
93 import System.Random
94 import Control.Concurrent
95 import Control.Exception hiding (catch, evaluate)
96 import qualified Control.Exception as Exception (catch, evaluate)
97 import Debug.QuickCheck
98 import System.IO.Unsafe
99
100 data TestOptions = TestOptions {
101 no_of_tests :: Int,
102 length_of_tests :: Int,
103 debug_tests :: Bool }
104
105 defOpt :: TestOptions
106 defOpt = TestOptions
107 { no_of_tests = 100
108 , length_of_tests = 1
109 , debug_tests = False
110 }
111
112 data TestResult = TestOk String Int [[String]]
113 | TestExausted String Int [[String]]
114 | TestFailed [String] Int
115 | TestAborted Exception
116
117 tests :: Config -> Gen Result -> StdGen -> Int -> Int -> [[String]]
118 -> IO TestResult
119 tests config gen rnd0 ntest nfail stamps
120 | ntest == configMaxTest config = return (TestOk "OK, passed" ntest stamps)
121 | nfail == configMaxFail config = return (TestExausted "Arguments exhausted after"
122 ntest stamps)
123 | otherwise =
124 do (if not (null txt) then putStr txt else return ())
125 case ok result of
126 Nothing ->
127 tests config gen rnd1 ntest (nfail+1) stamps
128 Just True ->
129 tests config gen rnd1 (ntest+1) nfail (stamp result:stamps)
130 Just False ->
131 do return (TestFailed (arguments result) ntest)
132 where
133 txt = configEvery config ntest (arguments result)
134 result = generate (configSize config ntest) rnd2 gen
135 (rnd1,rnd2) = split rnd0
136
137 batch n v = Config
138 { configMaxTest = n
139 , configMaxFail = n * 10
140 , configSize = (+ 3) . (`div` 2)
141 , configEvery = \n args -> if v then show n ++ ":\n" ++ unlines args else ""
142 }
143
144 -- Here we use the same random number each time,
145 -- so we get reproducable results!
146 run :: Testable a => a -> TestOptions -> IO TestResult
147 run a TestOptions { no_of_tests = n, length_of_tests = len, debug_tests = debug } =
148 do me <- myThreadId
149 ready <- newEmptyMVar
150 r <- if len == 0
151 then try theTest
152 else try (do
153 -- This waits a bit, then raises an exception in its parent,
154 -- saying, right, you've had long enough!
155 watcher <- forkIO (Exception.catch
156 (do threadDelay (len * 1000 * 1000)
157 takeMVar ready
158 throwTo me NonTermination
159 return ())
160 (\ _ -> return ()))
161 -- Tell the watcher we are starting...
162 putMVar ready ()
163 -- This is cheating, because possibly some of the internal message
164 -- inside "r" might be _|_, but anyway....
165 r <- theTest
166 -- Now, we turn off the watcher.
167 -- Ignored if the watcher is already dead,
168 -- (unless some unlucky thread picks up the same name)
169 killThread watcher
170 return r)
171 case r of
172 Right r -> return r
173 Left e -> return (TestAborted e)
174 where
175 theTest = tests (batch n debug) (evaluate a) (mkStdGen 0) 0 0 []
176
177 -- Prints a one line summary of various tests with common theme
178 runTests :: String -> TestOptions -> [TestOptions -> IO TestResult] -> IO ()
179 runTests name scale actions =
180 do putStr (rjustify 25 name ++ " : ")
181 f <- tr 1 actions [] 0
182 mapM fa f
183 return ()
184 where
185 rjustify n s = replicate (max 0 (n - length s)) ' ' ++ s
186
187 tr n [] xs c = do
188 putStr (rjustify (max 0 (35-n)) " (" ++ show c ++ ")\n")
189 return xs
190 tr n (action:actions) others c =
191 do r <- action scale
192 case r of
193 (TestOk _ m _)
194 -> do { putStr "." ;
195 tr (n+1) actions others (c+m) }
196 (TestExausted s m ss)
197
198 -> do { putStr "?" ;
199 tr (n+1) actions others (c+m) }
200 (TestAborted e)
201 -> do { putStr "*" ;
202 tr (n+1) actions others c }
203 (TestFailed f num)
204 -> do { putStr "#" ;
205 tr (n+1) actions ((f,n,num):others) (c+num) }
206
207 fa :: ([String],Int,Int) -> IO ()
208 fa (f,n,no) =
209 do putStr "\n"
210 putStr (" ** test "
211 ++ show (n :: Int)
212 ++ " of "
213 ++ name
214 ++ " failed with the binding(s)\n")
215 sequence_ [putStr (" ** " ++ v ++ "\n")
216 | v <- f ]
217 putStr "\n"
218
219 -- Look out behind you! These can be misused badly.
220 -- However, in the context of a batch tester, can also be very useful.
221
222 bottom = error "_|_"
223
224 isBottom :: a -> Bool
225 isBottom a = unsafePerformIO (do
226 a' <- try (Exception.evaluate a)
227 case a' of
228 Left _ -> return True
229 Right _ -> return False)