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