module Test.QuickCheck.Parallel (
module Test.QuickCheck,
pRun,
pDet,
pNon
) where
import Test.QuickCheck
import Data.List
import Control.Concurrent
import Control.Exception hiding (evaluate)
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 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 : xs -> wait xs $! i+1
Just s : xs -> putStr s >> hFlush stdout >> wait xs 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 = mycheck Det defaultConfig
{ configMaxTest = n
, configEvery = \n args -> unlines args } a
pNon :: Testable a => a -> Int -> IO String
pNon a n = mycheck NonDet defaultConfig
{ configMaxTest = n
, configEvery = \n args -> unlines args } a
data Mode = Det | NonDet
mycheck :: Testable a => Mode -> Config -> a -> IO String
mycheck Det config a = do
let rnd = mkStdGen 99
mytests config (evaluate a) rnd 0 0 []
mycheck NonDet config a = do
rnd <- newStdGen
mytests config (evaluate a) rnd 0 0 []
mytests :: Config -> Gen Result -> StdGen -> Int -> Int -> [[String]] -> IO String
mytests config gen rnd0 ntest nfail stamps
| ntest == configMaxTest config = do done "OK," ntest stamps
| nfail == configMaxFail config = do done "Arguments exhausted after" ntest stamps
| otherwise = do
case ok result of
Nothing ->
mytests config gen rnd1 ntest (nfail+1) stamps
Just True ->
mytests config gen rnd1 (ntest+1) nfail (stamp result:stamps)
Just False ->
return ( "Falsifiable after "
++ show ntest
++ " tests:\n"
++ unlines (arguments result)
)
where
result = generate (configSize config ntest) rnd2 gen
(rnd1,rnd2) = split rnd0
done :: String -> Int -> [[String]] -> IO String
done mesg ntest stamps =
return ( mesg ++ " " ++ show ntest ++ " tests" ++ table )
where
table = display
. map entry
. reverse
. sort
. map pairLength
. group
. sort
. filter (not . null)
$ stamps
display [] = ".\n"
display [x] = " (" ++ x ++ ").\n"
display xs = ".\n" ++ unlines (map (++ ".") xs)
pairLength xss@(xs:_) = (length xss, xs)
entry (n, xs) = percentage n ntest
++ " "
++ concat (intersperse ", " xs)
percentage n m = show ((100 * n) `div` m) ++ "%"
forM_ = flip mapM_