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 -- This is a batch driver for runing QuickCheck.
13 -----------------------------------------------------------------------------
16 - Here is the key for reading the output.
18 - ? = every example passed, but quickcheck did not find enough good examples
19 - * = test aborted for some reason (out-of-time, bottom, etc)
20 - # = test failed outright
22 - We also provide the dangerous "isBottom".
24 - Here is is an example of use for sorting:
26 - testOptions :: TestOptions
27 - testOptions = TestOptions
28 - { no_of_tests = 100 -- number of tests to run
29 - , length_of_tests = 1 -- 1 second max per check
30 - -- where a check == n tests
31 - , debug_tests = False -- True => debugging info
34 - prop_sort1 xs = sort xs == sortBy compare xs
35 - where types = (xs :: [OrdALPHA])
38 - (head (sort xs) == minimum xs)
39 - where types = (xs :: [OrdALPHA])
40 - prop_sort3 xs = (not (null xs)) ==>
41 - last (sort xs) == maximum xs
42 - where types = (xs :: [OrdALPHA])
46 - (head (sort (xs ++ ys)) == min (minimum xs) (minimum ys))
47 - where types = (xs :: [OrdALPHA], ys :: [OrdALPHA])
51 - (last (sort (xs ++ ys)) == max (maximum xs) (maximum ys))
52 - where types = (xs :: [OrdALPHA], ys :: [OrdALPHA])
56 - (head (sort (xs ++ ys)) == max (maximum xs) (maximum ys))
57 - where types = (xs :: [OrdALPHA], ys :: [OrdALPHA])
59 - test_sort = runTests "sort" testOptions
67 - When run, this gives
71 - You would tie together all the test_* functions
72 - into one test_everything, on a per module basis.
74 - Examples of use of bottom and isBottom:
75 - {- test for abort -}
76 - prop_head2 = isBottom (head [])
77 - {- test for strictness -}
78 - prop_head3 = isBottom (head bottom)
81 module Debug.QuickCheck.Batch
82 ( run -- :: Testable a => a -> TestOptions -> IO TestResult
83 , runTests -- :: String -> TestOptions ->
84 -- [TestOptions -> IO TestResult] -> IO ()
85 , defOpt -- :: TestOptions
87 , isBottom -- :: a -> Bool
88 , 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)