{-# LANGUAGE CPP #-}
-----------------------------------------------------------------------------
-- |
-- Module      :  Test.QuickCheck.Parallel
-- Copyright   :  (c) Don Stewart 2006
-- License     :  BSD-style (see the file LICENSE)
--
-- Maintainer  :  shelarcy <shelarcy@gmail.com>
-- Stability   :  experimental
-- Portability :  non-portable (uses Control.Exception, Control.Concurrent)
--
-- A parallel batch driver for running QuickCheck on threaded or SMP systems.
-- See the /Example.hs/ file for a complete overview.
--

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.Exit
import System.IO          (hFlush,stdout)
import Text.Printf

type Name   = String
type Depth  = Int
type Test   = (Name, Depth -> IO Result)

-- | Deprecated: Backwards-compatible API
{-# DEPRECATED pRun "use pRun' or pRunAllProcessors, pRunWithNum instead." #-}
pRun :: Int -> Int -> [Test] -> IO ()
pRun = pRunWithNum

-- | Variant of 'pRunWithNum'. Run a list of QuickCheck properties in parallel
-- chunks, using number of Haskell threads that can run truly simultaneously
-- (on separate physical processors) at any given time. (see 'getNumCapabilities'
-- for more details).
pRun'  :: Int -> [Test] -> IO ()
pRun' depth tests = do
#if __GLASGOW_HASKELL__ >= 702
    num <- getNumCapabilities
#else
    let num = numCapabilities
#endif
    pRun num depth tests

-- | Variant of 'pRunWithNum'. Run a list of QuickCheck properties in parallel
-- chunks, using all Processors.
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

-- | Run a list of QuickCheck properties in parallel chunks, using
-- 'n' Haskell threads (first argument), and test to a depth of 'd'
-- (second argument). Compile your application with '-threaded' and run
-- with the SMP runtime's '-N4' (or however many OS threads you want to
-- donate), for best results.
--
-- > import Test.QuickCheck.Parallel
-- >
-- > do n <- getArgs >>= readIO . head
-- >    pRun n 1000 [ ("sort1", pDet prop_sort1) ]
--
-- Will run 'n' threads over the property list, to depth 1000.
--
pRunWithNum :: Int -> Int -> [Test] -> IO ()
pRunWithNum n depth tests = do
    chan <- newChan
    ps   <- getChanContents chan
    work <- newMVar tests
    ec'  <- newMVar ExitSuccess

    forM_ [1..n] $ forkIO . thread work chan ec'

    let wait xs i
            | i >= n    = return () -- done
            | otherwise = case xs of
                    Nothing : ys -> wait ys $! i+1
                    Just s  : ys -> putStr s >> hFlush stdout >> wait ys i
    wait ps 0
    ec <- takeMVar ec'
    exitWith ec

  where
    thread :: MVar [Test] -> Chan (Maybe String) -> (MVar 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 -- done
                Just (name,prop) -> do
                    v <- prop depth
                    doesAnyFailureTest v ec'
                    writeChan chan . Just $ printf "%d: %-25s: %s" me name $ output v
                    loop
    doesAnyFailureTest :: Result -> MVar (ExitCode) -> IO ()
    doesAnyFailureTest v ec'
      = case v of
          (GaveUp _ _ _)          -> modifyMVar_ ec' (\_ -> return $ ExitFailure 1)
          (Failure _ _ _ _ _ _ _) -> modifyMVar_ ec' (\_ -> return $ ExitFailure 1)
          _                       -> return ()

-- | Wrap a property, and run it on a deterministic set of data
pDet :: Testable a => a -> Int -> IO Result
pDet a n = mycheck Det (stdArgs { maxSuccess = n }) a

-- | Wrap a property, and run it on a non-deterministic set of data
pNon :: Testable a => a -> Int -> 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  -- deterministic
     mytests config rnd a

mycheck NonDet config a = do
    rnd <- newStdGen        -- different each run
    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
          -- e.g. with maxSuccess = 250, maxSize = 100, goes like this:
          -- 0, 1, 2, ..., 99, 0, 1, 2, ..., 99, 0, 2, 4, ..., 98.
          | 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