#if __GLASGOW_HASKELL__ >= 701
#endif
module Test.QuickCheck.Parallel (
module Test.QuickCheck,
pRun,
pRunAllProcessors,
pRunWithNum,
Name,
Depth,
Test,
pDet,
pNon ) where
import Test.QuickCheck
import Test.QuickCheck.Gen (unGen)
import Test.QuickCheck.Test (test)
#if MIN_VERSION_QuickCheck(2,6,0)
import Test.QuickCheck.Text (withNullTerminal)
#else
import Test.QuickCheck.Text (newNullTerminal)
#endif
import Test.QuickCheck.State
import Control.Concurrent
#if __GLASGOW_HASKELL__ >= 706
import GHC.Conc (getNumProcessors)
#elif __GLASGOW_HASKELL__ >= 704
import GHC.Conc (getNumProcessors, setNumCapabilities)
#else
import GHC.Conc (numCapabilities, forkOnIO)
#endif
import Control.Concurrent.STM (atomically)
import Control.Concurrent.STM.TVar
import Control.Monad (forM_, unless, when)
import System.Random
import System.Exit
import System.IO (hFlush,stdout)
import Text.Printf
type Name = String
type Depth = Int
type Test = (Name, Depth -> IO Result)
pRun :: Depth -> [Test] -> IO ()
pRun depth tests = do
#if __GLASGOW_HASKELL__ >= 704
num <- getNumCapabilities
#else
let num = numCapabilities
#endif
pRunWithNum num depth tests
pRunAllProcessors :: Depth -> [Test] -> IO ()
#if __GLASGOW_HASKELL__ < 704
pRunAllProcessors depth tests
= pRunInternal forkOnIO numCapabilities depth tests
#else
pRunAllProcessors depth tests = do
caps <- getNumCapabilities
pros <- getNumProcessors
unless (caps == pros)
$ setNumCapabilities pros
pRunInternal forkOn pros depth tests
#endif
pRunWithNum :: Int -> Depth -> [Test] -> IO ()
pRunWithNum = pRunInternal (\_ -> forkIO)
pRunInternal :: (Int -> IO () -> IO ThreadId) -> Int -> Int -> [Test] -> IO ()
pRunInternal fork n depth tests = do
chan <- newChan
ps <- getChanContents chan
work <- newMVar tests
ec' <- newTVarIO ExitSuccess
forM_ [1..n] $ \num -> fork num $ thread work chan ec' num
let wait xs i
| i >= n = return ()
| otherwise = case xs of
Nothing : ys -> wait ys $! i+1
Just s : ys -> putStr s >> hFlush stdout >> wait ys i
wait ps 0
ec <- readTVarIO ec'
exitWith ec
where
thread :: MVar [Test] -> Chan (Maybe String) -> (TVar ExitCode) -> Int -> IO ()
thread work chan ec' me = loop
where
loop = do
job <- modifyMVar work $ \jobs -> return $ case jobs of
[] -> ([], Nothing)
(j:js) -> (js, Just j)
case job of
Nothing -> writeChan chan Nothing
Just (name,prop) -> do
v <- prop depth
doesAnyFailureTest v ec'
writeChan chan . Just $ printf "%d: %-25s: %s" me name $ output v
loop
doesAnyFailureTest :: Result -> TVar (ExitCode) -> IO ()
doesAnyFailureTest v ec'
= case v of
(GaveUp _ _ _) -> noticeFailureTest ec'
#if MIN_VERSION_QuickCheck(2,6,0)
(Failure _ _ _ _ _ _ _ _) -> noticeFailureTest ec'
#else
(Failure _ _ _ _ _ _ _) -> noticeFailureTest ec'
#endif
_ -> return ()
testFailure :: ExitCode
testFailure = ExitFailure 1
noticeFailureTest :: TVar (ExitCode) -> IO ()
noticeFailureTest ec' = atomically $ do
ec <- readTVar ec'
when (ec == ExitSuccess)
$ writeTVar ec' testFailure
pDet :: Testable a => a -> Depth -> IO Result
pDet a n = mycheck Det (stdArgs { maxSuccess = n }) a
pNon :: Testable a => a -> Depth -> IO Result
pNon a n = mycheck NonDet (stdArgs { maxSuccess = n }) a
data Mode = Det | NonDet
mycheck :: Testable a => Mode -> Args -> a -> IO Result
mycheck Det config a = do
let rnd = mkStdGen 99
mytests config rnd a
mycheck NonDet config a = do
rnd <- newStdGen
mytests config rnd a
mytests :: Testable prop => Args -> StdGen -> prop -> IO Result
mytests a rnd p =
#if MIN_VERSION_QuickCheck(2,6,0)
withNullTerminal $ \tm -> do
#else
do tm <- newNullTerminal
#endif
test MkState{ terminal = tm
#if MIN_VERSION_QuickCheck(2,5,0)
, maxSuccessTests = if exhaustive p then 1 else maxSuccess a
, maxDiscardedTests = if exhaustive p then maxDiscardRatio a else maxDiscardRatio a * maxSuccess a
, numTotTryShrinks = 0
#else
, maxSuccessTests = maxSuccess a
, maxDiscardedTests = maxDiscard a
#endif
, computeSize = case replay a of
Nothing -> computeSize'
Just (_,s) -> computeSize' `at0` s
, numSuccessTests = 0
, numDiscardedTests = 0
#if MIN_VERSION_QuickCheck(2,5,1)
, numRecentlyDiscardedTests = 0
#endif
, collected = []
, expectedFailure = False
, randomSeed = rnd
, numSuccessShrinks = 0
, numTryShrinks = 0
} (unGen (property p))
where computeSize' n d
| n `roundTo` maxSize a + maxSize a <= maxSuccess a ||
n >= maxSuccess a ||
maxSuccess a `mod` maxSize a == 0 = (n `mod` maxSize a + d `div` 10) `min` maxSize a
| otherwise =
((n `mod` maxSize a) * maxSize a `div` (maxSuccess a `mod` maxSize a) + d `div` 10) `min` maxSize a
n `roundTo` m = (n `div` m) * m
at0 _ s 0 0 = s
at0 f _ n d = f n d