module Test.Sandbox.QuickCheck (
quickCheck
, quickCheckWith
, verboseCheck
, verboseCheckWith
) where
import Control.Monad.Trans (liftIO)
import Control.Monad.Error.Class (throwError)
import Control.Monad.Reader (ask)
import Data.Maybe (fromMaybe)
import System.Exit (exitFailure)
import System.Random
import Test.Sandbox.Internals
import Test.QuickCheck hiding (quickCheck, quickCheckWith, verboseCheck, verboseCheckWith)
import Test.QuickCheck.Monadic
import Test.QuickCheck.Property ()
import Test.QuickCheck.Random
import Test.QuickCheck.Exception
quickCheck :: PropertyM Sandbox () -> Sandbox ()
quickCheck prop = getQuickCheckOptions
>>= maybe (quickCheck' quickCheckResult prop) (`quickCheckWith` prop)
quickCheckWith :: Args -> PropertyM Sandbox () -> Sandbox ()
quickCheckWith args = quickCheck' (quickCheckWithResult args)
verboseCheck :: PropertyM Sandbox () -> Sandbox ()
verboseCheck prop = getQuickCheckOptions
>>= maybe (quickCheck' verboseCheckResult prop) (`verboseCheckWith` prop)
verboseCheckWith :: Args -> PropertyM Sandbox () -> Sandbox ()
verboseCheckWith args = quickCheck' (verboseCheckWithResult args)
quickCheck' :: (Property -> IO Result) -> PropertyM Sandbox () -> Sandbox ()
quickCheck' tester prop = do
seed <- getVariable seedVariable Nothing :: Sandbox (Maybe Int)
ref <- ask
res <- liftIO . tester $ monadic (runSandboxProperty ref) prop
case res of
#if MIN_VERSION_QuickCheck(2,7,0)
Failure { theException = e, output = o } -> if fmap isInterrupt e == Just True then liftIO exitFailure
else throwError (o ++ maybe "" (\s -> " (used seed " ++ show s ++ ")") seed)
#elif MIN_VERSION_QuickCheck(2,6,0)
Failure { interrupted = i, output = o } -> if i then liftIO exitFailure
else throwError (o ++ maybe "" (\s -> " (used seed " ++ show s ++ ")") seed)
#else
Failure { reason = r, output = o } -> if "user interrupt" `isInfixOf` r then liftIO exitFailure
else throwError (o ++ maybe "" (\s -> " (used seed " ++ show s ++ ")") seed)
#endif
NoExpectedFailure { output = o } -> throwError o
_ -> return ()
runSandboxProperty :: SandboxStateRef -> Sandbox Property -> Property
runSandboxProperty ref prop = ioProperty $
runSandbox prop ref >>= either error return
getQuickCheckOptions :: Sandbox (Maybe Args)
getQuickCheckOptions = do
options <- getOptions
case options of
Nothing -> do
(gen, seed) <- randomSeed
_ <- setVariable seedVariable (Just seed)
return $ Just stdArgs { replay = Just (gen, 0) }
Just stuff -> do
(gen, seed) <- case stoSeed stuff of
Nothing -> randomSeed
Just SandboxRandomSeed -> randomSeed
Just (SandboxFixedSeed i) -> fixedSeed i
_ <- setVariable seedVariable (Just seed)
return $ Just stdArgs { replay = Just (gen, 0)
, maxSuccess = fromMaybe (maxSuccess stdArgs) (stoMaximumGeneratedTests stuff)
, maxDiscardRatio = fromMaybe (maxDiscardRatio stdArgs) (stoMaximumUnsuitableGeneratedTests stuff)
, maxSize = fromMaybe (maxSize stdArgs) (stoMaximumTestSize stuff) }
where randomSeed = liftIO randomIO >>= fixedSeed
#if MIN_VERSION_QuickCheck(2,7,0)
fixedSeed s = return (mkQCGen s, s)
#else
fixedSeed s = return (mkStdGen s, s)
#endif
seedVariable :: String
seedVariable = "__QUICKCHECK_SEED__"