1 -----------------------------------------------------------------------------
3 -- Module : Debug.QuickCheck.Batch
4 -- Copyright : (c) Andy Gill 2001
5 -- License : BSD-style (see the file libraries/core/LICENSE)
7 -- Maintainer : libraries@haskell.org
8 -- Stability : experimental
9 -- Portability : non-portable (uses Control.Exception, Control.Concurrent)
11 -- $Id: Batch.hs,v 1.2 2002/04/24 16:31:43 simonmar Exp $
13 -- This is a batch driver for runing QuickCheck.
15 -----------------------------------------------------------------------------
18 - Here is the key for reading the output.
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
24 - We also provide the dangerous "isBottom".
26 - Here is is an example of use for sorting:
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
36 - prop_sort1 xs = sort xs == sortBy compare xs
37 - where types = (xs :: [OrdALPHA])
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])
48 - (head (sort (xs ++ ys)) == min (minimum xs) (minimum ys))
49 - where types = (xs :: [OrdALPHA], ys :: [OrdALPHA])
53 - (last (sort (xs ++ ys)) == max (maximum xs) (maximum ys))
54 - where types = (xs :: [OrdALPHA], ys :: [OrdALPHA])
58 - (head (sort (xs ++ ys)) == max (maximum xs) (maximum ys))
59 - where types = (xs :: [OrdALPHA], ys :: [OrdALPHA])
61 - test_sort = runTests "sort" testOptions
69 - When run, this gives
73 - You would tie together all the test_* functions
74 - into one test_everything, on a per module basis.
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)
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
89 , isBottom -- :: a -> Bool
90 , bottom -- :: a {- _|_ -}
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
100 data TestOptions = TestOptions {
102 length_of_tests :: Int,
103 debug_tests :: Bool }
105 defOpt :: TestOptions
108 , length_of_tests = 1
109 , debug_tests = False
112 data TestResult = TestOk String Int [[String]]
113 | TestExausted String Int [[String]]
114 | TestFailed [String] Int
115 | TestAborted Exception
117 tests :: Config -> Gen Result -> StdGen -> Int -> Int -> [[String]]
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"
124 do (if not (null txt) then putStr txt else return ())
127 tests config gen rnd1 ntest (nfail+1) stamps
129 tests config gen rnd1 (ntest+1) nfail (stamp result:stamps)
131 do return (TestFailed (arguments result) ntest)
133 txt = configEvery config ntest (arguments result)
134 result = generate (configSize config ntest) rnd2 gen
135 (rnd1,rnd2) = split rnd0
139 , configMaxFail = n * 10
140 , configSize = (+ 3) . (`div` 2)
141 , configEvery = \n args -> if v then show n ++ ":\n" ++ unlines args else ""
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 } =
149 ready <- newEmptyMVar
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)
158 throwTo me NonTermination
161 -- Tell the watcher we are starting...
163 -- This is cheating, because possibly some of the internal message
164 -- inside "r" might be _|_, but anyway....
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)
173 Left e -> return (TestAborted e)
175 theTest = tests (batch n debug) (evaluate a) (mkStdGen 0) 0 0 []
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
185 rjustify n s = replicate (max 0 (n - length s)) ' ' ++ s
188 putStr (rjustify (max 0 (35-n)) " (" ++ show c ++ ")\n")
190 tr n (action:actions) others c =
195 tr (n+1) actions others (c+m) }
196 (TestExausted s m ss)
199 tr (n+1) actions others (c+m) }
202 tr (n+1) actions others c }
205 tr (n+1) actions ((f,n,num):others) (c+num) }
207 fa :: ([String],Int,Int) -> IO ()
214 ++ " failed with the binding(s)\n")
215 sequence_ [putStr (" ** " ++ v ++ "\n")
219 -- Look out behind you! These can be misused badly.
220 -- However, in the context of a batch tester, can also be very useful.
224 isBottom :: a -> Bool
225 isBottom a = unsafePerformIO (do
226 a' <- try (Exception.evaluate a)
228 Left _ -> return True
229 Right _ -> return False)