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 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 <- 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
Nothing -> Result { resultSuccessful = True, resultDescription = desc }
Just f -> Result { resultSuccessful = False, resultDescription = 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