module Test.Tasty.SmallCheck
( testProperty
, SmallCheckDepth(..)
, module Test.SmallCheck
) where
import Test.Tasty.Providers
import Test.Tasty.Options
import qualified Test.SmallCheck as SC
import qualified Test.SmallCheck.Drivers as SC
import Test.SmallCheck hiding (smallCheck)
import Test.SmallCheck.Drivers
import Control.Exception
import Data.Typeable
import Data.Proxy
import Data.IORef
import Text.Printf
testProperty :: SC.Testable IO a => TestName -> a -> TestTree
testProperty name prop = singleTest name $ (SC.test prop :: SC.Property IO)
newtype SmallCheckDepth = SmallCheckDepth Int
deriving (Num, Ord, Eq, Real, Enum, Integral, Typeable)
instance IsOption SmallCheckDepth where
defaultValue = 5
parseValue = fmap SmallCheckDepth . safeRead
optionName = return "smallcheck-depth"
optionHelp = return "Depth to use for smallcheck tests"
instance IsTest (SC.Property IO) where
testOptions = return [Option (Proxy :: Proxy SmallCheckDepth)]
run opts prop yieldProgress = do
let
SmallCheckDepth depth = lookupOption opts
counter <- newIORef (0 :: Int, 0 :: Int)
let
hook quality = do
let
inc (total, bad) =
case quality of
GoodTest -> ((,) $! total + 1) bad
BadTest -> ((,) $! total + 1) $! bad + 1
count <- myAtomicModifyIORef' counter (\c -> let c' = inc c in (c', fst c'))
yieldProgress $ Progress
{ progressText = show count
, progressPercent = 0
}
scResult <- try $ smallCheckWithHook depth hook prop
(total, bad) <- readIORef counter
let
desc
| bad == 0
= printf "%d tests completed" total
| otherwise
= printf "%d tests completed (but %d did not meet the condition)" total bad
return $
case scResult of
Left e -> testFailed $ show (e :: SomeException)
Right Nothing -> testPassed desc
Right (Just f) -> testFailed $ ppFailure f
myAtomicModifyIORef' :: IORef a -> (a -> (a,b)) -> IO b
myAtomicModifyIORef' ref f = do
b <- atomicModifyIORef ref
(\x -> let (a, b) = f x
in (a, a `seq` b))
b `seq` return b