module Test.QuickCheck.Parallel (
module Test.QuickCheck,
pRun,
pRun',
pRunAllProcessors,
pRunWithNum,
pDet,
pNon ) where
import Test.QuickCheck
import Test.QuickCheck.Gen (unGen)
import Test.QuickCheck.Test (test)
import Test.QuickCheck.Text (newNullTerminal)
import Test.QuickCheck.State
import Control.Concurrent
#if __GLASGOW_HASKELL__ < 702
import GHC.Conc (numCapabilities)
#elif __GLASGOW_HASKELL__ < 704
#else
import GHC.Conc (getNumProcessors, setNumCapabilities)
#endif
import Control.Monad (forM_, unless)
import System.Random
import System.IO (hFlush,stdout)
import Text.Printf
type Name = String
type Depth = Int
type Test = (Name, Depth -> IO String)
pRun :: Int -> Int -> [Test] -> IO ()
pRun = pRunWithNum
pRun' :: Int -> [Test] -> IO ()
pRun' depth tests = do
#if __GLASGOW_HASKELL__ >= 702
num <- getNumCapabilities
#else
let num = numCapabilities
#endif
pRun num depth tests
pRunAllProcessors :: Int -> [Test] -> IO ()
#if __GLASGOW_HASKELL__ < 704
pRunAllProcessors = pRun'
#else
pRunAllProcessors depth tests = do
caps <- getNumCapabilities
pros <- getNumProcessors
unless (caps == pros)
$ setNumCapabilities pros
pRun pros depth tests
#endif
pRunWithNum :: Int -> Int -> [Test] -> IO ()
pRunWithNum n depth tests = do
chan <- newChan
ps <- getChanContents chan
work <- newMVar tests
forM_ [1..n] $ forkIO . thread work chan
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
where
thread :: MVar [Test] -> Chan (Maybe String) -> Int -> IO ()
thread work chan 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
writeChan chan . Just $ printf "%d: %-25s: %s" me name v
loop
pDet :: Testable a => a -> Int -> IO String
pDet a n =
do result <- mycheck Det (stdArgs { maxSuccess = n }) a
return $ output result
pNon :: Testable a => a -> Int -> IO String
pNon a n =
do result <- mycheck NonDet (stdArgs { maxSuccess = n }) a
return $ output result
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 =
do tm <- newNullTerminal
test MkState{ terminal = tm
, maxSuccessTests = maxSuccess a
, maxDiscardedTests = maxDiscard a
, computeSize = case replay a of
Nothing -> computeSize'
Just (_,s) -> \_ _ -> s
, numSuccessTests = 0
, numDiscardedTests = 0
, 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
| otherwise =
(n `mod` maxSize a) * maxSize a `div` (maxSuccess a `mod` maxSize a) + d `div` 10
n `roundTo` m = (n `div` m) * m