libhugs-quickcheck-bundled 98.200609.21-5.4+b3 / usr / lib / hugs / packages / QuickCheck / Test / QuickCheck / Batch.hs

{-# 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



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 } =




























     Exception.catch theTest $ \ e -> return (TestAborted e)

  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)