{-# OPTIONS_GHC -cpp #-} ----------------------------------------------------------------------------- -- | -- Module : Test.QuickCheck.Batch -- Copyright : (c) Andy Gill 2001 -- License : BSD-style (see the file libraries/base/LICENSE) -- -- Maintainer : libraries@haskell.org -- Stability : experimental -- Portability : non-portable (uses Control.Exception, Control.Concurrent) -- -- A batch driver for running QuickCheck. -- -- /Note:/ in GHC only, it is possible to place a time limit on each test, -- to ensure that testing terminates. -- ----------------------------------------------------------------------------- {- - Here is the key for reading the output. - . = test successful - ? = every example passed, but quickcheck did not find enough good examples - * = test aborted for some reason (out-of-time, bottom, etc) - # = test failed outright - - We also provide the dangerous "isBottom". - - Here is is an example of use for sorting: - - testOptions :: TestOptions - testOptions = TestOptions - { no_of_tests = 100 -- number of tests to run - , length_of_tests = 1 -- 1 second max per check - -- where a check == n tests - , debug_tests = False -- True => debugging info - } - - prop_sort1 xs = sort xs == sortBy compare xs - where types = (xs :: [OrdALPHA]) - prop_sort2 xs = - (not (null xs)) ==> - (head (sort xs) == minimum xs) - where types = (xs :: [OrdALPHA]) - prop_sort3 xs = (not (null xs)) ==> - last (sort xs) == maximum xs - where types = (xs :: [OrdALPHA]) - prop_sort4 xs ys = - (not (null xs)) ==> - (not (null ys)) ==> - (head (sort (xs ++ ys)) == min (minimum xs) (minimum ys)) - where types = (xs :: [OrdALPHA], ys :: [OrdALPHA]) - prop_sort6 xs ys = - (not (null xs)) ==> - (not (null ys)) ==> - (last (sort (xs ++ ys)) == max (maximum xs) (maximum ys)) - where types = (xs :: [OrdALPHA], ys :: [OrdALPHA]) - prop_sort5 xs ys = - (not (null xs)) ==> - (not (null ys)) ==> - (head (sort (xs ++ ys)) == max (maximum xs) (maximum ys)) - where types = (xs :: [OrdALPHA], ys :: [OrdALPHA]) - - test_sort = runTests "sort" testOptions - [ run prop_sort1 - , run prop_sort2 - , run prop_sort3 - , run prop_sort4 - , run prop_sort5 - ] - - When run, this gives - Main> test_sort - sort : ..... - - You would tie together all the test_* functions - into one test_everything, on a per module basis. - -} module Test.QuickCheck.Batch ( run -- :: Testable a => a -> TestOptions -> IO TestResult , runTests -- :: String -> TestOptions -> -- [TestOptions -> IO TestResult] -> IO () , defOpt -- :: TestOptions , TestOptions (..) , TestResult (..) , isBottom -- :: a -> Bool , bottom -- :: a {- _|_ -} ) where import Prelude import System.Random #ifdef __GLASGOW_HASKELL__ import Control.Concurrent #endif import Control.Exception hiding (catch, evaluate) import qualified Control.Exception as Exception (catch, evaluate) import Test.QuickCheck import System.IO.Unsafe data TestOptions = TestOptions { no_of_tests :: Int, -- ^ number of tests to run. length_of_tests :: Int, -- ^ time limit for test, in seconds. -- If zero, no time limit. -- /Note:/ only GHC supports time limits. debug_tests :: Bool } defOpt :: TestOptions defOpt = TestOptions { no_of_tests = 100 , length_of_tests = 1 , debug_tests = False } data TestResult = TestOk String Int [[String]] | TestExausted String Int [[String]] | TestFailed [String] Int | TestAborted Exception tests :: Config -> Gen Result -> StdGen -> Int -> Int -> [[String]] -> IO TestResult tests config gen rnd0 ntest nfail stamps | ntest == configMaxTest config = return (TestOk "OK, passed" ntest stamps) | nfail == configMaxFail config = return (TestExausted "Arguments exhausted after" ntest stamps) | otherwise = do (if not (null txt) then putStr txt else return ()) case ok result of Nothing -> tests config gen rnd1 ntest (nfail+1) stamps Just True -> tests config gen rnd1 (ntest+1) nfail (stamp result:stamps) Just False -> do return (TestFailed (arguments result) ntest) where txt = configEvery config ntest (arguments result) result = generate (configSize config ntest) rnd2 gen (rnd1,rnd2) = split rnd0 batch n v = Config { configMaxTest = n , configMaxFail = n * 10 , configSize = (+ 3) . (`div` 2) , configEvery = \n args -> if v then show n ++ ":\n" ++ unlines args else "" } -- | Run the test. -- Here we use the same random number each time, -- so we get reproducable results! run :: Testable a => a -> TestOptions -> IO TestResult run a TestOptions { no_of_tests = n, length_of_tests = len, debug_tests = debug } = #ifdef __GLASGOW_HASKELL__ do me <- myThreadId ready <- newEmptyMVar r <- if len == 0 then try theTest else try (do -- This waits a bit, then raises an exception in its parent, -- saying, right, you've had long enough! watcher <- forkIO (Exception.catch (do threadDelay (len * 1000 * 1000) takeMVar ready throwTo me NonTermination return ()) (\ _ -> return ())) -- Tell the watcher we are starting... putMVar ready () -- This is cheating, because possibly some of the internal message -- inside "r" might be _|_, but anyway.... r <- theTest -- Now, we turn off the watcher. -- Ignored if the watcher is already dead, -- (unless some unlucky thread picks up the same name) killThread watcher return r) case r of Right r -> return r Left e -> return (TestAborted e) #else Exception.catch theTest $ \ e -> return (TestAborted e) #endif where theTest = tests (batch n debug) (evaluate a) (mkStdGen 0) 0 0 [] -- | Prints a one line summary of various tests with common theme runTests :: String -> TestOptions -> [TestOptions -> IO TestResult] -> IO () runTests name scale actions = do putStr (rjustify 25 name ++ " : ") f <- tr 1 actions [] 0 mapM fa f return () where rjustify n s = replicate (max 0 (n - length s)) ' ' ++ s tr n [] xs c = do putStr (rjustify (max 0 (35-n)) " (" ++ show c ++ ")\n") return xs tr n (action:actions) others c = do r <- action scale case r of (TestOk _ m _) -> do { putStr "." ; tr (n+1) actions others (c+m) } (TestExausted s m ss) -> do { putStr "?" ; tr (n+1) actions others (c+m) } (TestAborted e) -> do { putStr "*" ; tr (n+1) actions others c } (TestFailed f num) -> do { putStr "#" ; tr (n+1) actions ((f,n,num):others) (c+num) } fa :: ([String],Int,Int) -> IO () fa (f,n,no) = do putStr "\n" putStr (" ** test " ++ show (n :: Int) ++ " of " ++ name ++ " failed with the binding(s)\n") sequence_ [putStr (" ** " ++ v ++ "\n") | v <- f ] putStr "\n" bottom :: a bottom = error "_|_" -- | Look out behind you! These can be misused badly. -- However, in the context of a batch tester, can also be very useful. -- -- Examples of use of bottom and isBottom: -- -- > {- test for abort -} -- > prop_head2 = isBottom (head []) -- > {- test for strictness -} -- > prop_head3 = isBottom (head bottom) isBottom :: a -> Bool isBottom a = unsafePerformIO (do a' <- try (Exception.evaluate a) case a' of Left _ -> return True Right _ -> return False)