{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, FlexibleContexts,
TypeOperators, DeriveDataTypeable, TypeFamilies,
GeneralizedNewtypeDeriving #-}
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 :: TestName -> a -> TestTree
testProperty name :: TestName
name prop :: a
prop = TestName -> Property IO -> TestTree
forall t. IsTest t => TestName -> t -> TestTree
singleTest TestName
name (Property IO -> TestTree) -> Property IO -> TestTree
forall a b. (a -> b) -> a -> b
$ (a -> Property IO
forall (m :: * -> *) a. Testable m a => a -> Property m
SC.test a
prop :: SC.Property IO)
newtype SmallCheckDepth = SmallCheckDepth Int
deriving (Integer -> SmallCheckDepth
SmallCheckDepth -> SmallCheckDepth
SmallCheckDepth -> SmallCheckDepth -> SmallCheckDepth
(SmallCheckDepth -> SmallCheckDepth -> SmallCheckDepth)
-> (SmallCheckDepth -> SmallCheckDepth -> SmallCheckDepth)
-> (SmallCheckDepth -> SmallCheckDepth -> SmallCheckDepth)
-> (SmallCheckDepth -> SmallCheckDepth)
-> (SmallCheckDepth -> SmallCheckDepth)
-> (SmallCheckDepth -> SmallCheckDepth)
-> (Integer -> SmallCheckDepth)
-> Num SmallCheckDepth
forall a.
(a -> a -> a)
-> (a -> a -> a)
-> (a -> a -> a)
-> (a -> a)
-> (a -> a)
-> (a -> a)
-> (Integer -> a)
-> Num a
fromInteger :: Integer -> SmallCheckDepth
$cfromInteger :: Integer -> SmallCheckDepth
signum :: SmallCheckDepth -> SmallCheckDepth
$csignum :: SmallCheckDepth -> SmallCheckDepth
abs :: SmallCheckDepth -> SmallCheckDepth
$cabs :: SmallCheckDepth -> SmallCheckDepth
negate :: SmallCheckDepth -> SmallCheckDepth
$cnegate :: SmallCheckDepth -> SmallCheckDepth
* :: SmallCheckDepth -> SmallCheckDepth -> SmallCheckDepth
$c* :: SmallCheckDepth -> SmallCheckDepth -> SmallCheckDepth
- :: SmallCheckDepth -> SmallCheckDepth -> SmallCheckDepth
$c- :: SmallCheckDepth -> SmallCheckDepth -> SmallCheckDepth
+ :: SmallCheckDepth -> SmallCheckDepth -> SmallCheckDepth
$c+ :: SmallCheckDepth -> SmallCheckDepth -> SmallCheckDepth
Num, Eq SmallCheckDepth
Eq SmallCheckDepth =>
(SmallCheckDepth -> SmallCheckDepth -> Ordering)
-> (SmallCheckDepth -> SmallCheckDepth -> Bool)
-> (SmallCheckDepth -> SmallCheckDepth -> Bool)
-> (SmallCheckDepth -> SmallCheckDepth -> Bool)
-> (SmallCheckDepth -> SmallCheckDepth -> Bool)
-> (SmallCheckDepth -> SmallCheckDepth -> SmallCheckDepth)
-> (SmallCheckDepth -> SmallCheckDepth -> SmallCheckDepth)
-> Ord SmallCheckDepth
SmallCheckDepth -> SmallCheckDepth -> Bool
SmallCheckDepth -> SmallCheckDepth -> Ordering
SmallCheckDepth -> SmallCheckDepth -> SmallCheckDepth
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: SmallCheckDepth -> SmallCheckDepth -> SmallCheckDepth
$cmin :: SmallCheckDepth -> SmallCheckDepth -> SmallCheckDepth
max :: SmallCheckDepth -> SmallCheckDepth -> SmallCheckDepth
$cmax :: SmallCheckDepth -> SmallCheckDepth -> SmallCheckDepth
>= :: SmallCheckDepth -> SmallCheckDepth -> Bool
$c>= :: SmallCheckDepth -> SmallCheckDepth -> Bool
> :: SmallCheckDepth -> SmallCheckDepth -> Bool
$c> :: SmallCheckDepth -> SmallCheckDepth -> Bool
<= :: SmallCheckDepth -> SmallCheckDepth -> Bool
$c<= :: SmallCheckDepth -> SmallCheckDepth -> Bool
< :: SmallCheckDepth -> SmallCheckDepth -> Bool
$c< :: SmallCheckDepth -> SmallCheckDepth -> Bool
compare :: SmallCheckDepth -> SmallCheckDepth -> Ordering
$ccompare :: SmallCheckDepth -> SmallCheckDepth -> Ordering
$cp1Ord :: Eq SmallCheckDepth
Ord, SmallCheckDepth -> SmallCheckDepth -> Bool
(SmallCheckDepth -> SmallCheckDepth -> Bool)
-> (SmallCheckDepth -> SmallCheckDepth -> Bool)
-> Eq SmallCheckDepth
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: SmallCheckDepth -> SmallCheckDepth -> Bool
$c/= :: SmallCheckDepth -> SmallCheckDepth -> Bool
== :: SmallCheckDepth -> SmallCheckDepth -> Bool
$c== :: SmallCheckDepth -> SmallCheckDepth -> Bool
Eq, Num SmallCheckDepth
Ord SmallCheckDepth
(Num SmallCheckDepth, Ord SmallCheckDepth) =>
(SmallCheckDepth -> Rational) -> Real SmallCheckDepth
SmallCheckDepth -> Rational
forall a. (Num a, Ord a) => (a -> Rational) -> Real a
toRational :: SmallCheckDepth -> Rational
$ctoRational :: SmallCheckDepth -> Rational
$cp2Real :: Ord SmallCheckDepth
$cp1Real :: Num SmallCheckDepth
Real, Int -> SmallCheckDepth
SmallCheckDepth -> Int
SmallCheckDepth -> [SmallCheckDepth]
SmallCheckDepth -> SmallCheckDepth
SmallCheckDepth -> SmallCheckDepth -> [SmallCheckDepth]
SmallCheckDepth
-> SmallCheckDepth -> SmallCheckDepth -> [SmallCheckDepth]
(SmallCheckDepth -> SmallCheckDepth)
-> (SmallCheckDepth -> SmallCheckDepth)
-> (Int -> SmallCheckDepth)
-> (SmallCheckDepth -> Int)
-> (SmallCheckDepth -> [SmallCheckDepth])
-> (SmallCheckDepth -> SmallCheckDepth -> [SmallCheckDepth])
-> (SmallCheckDepth -> SmallCheckDepth -> [SmallCheckDepth])
-> (SmallCheckDepth
-> SmallCheckDepth -> SmallCheckDepth -> [SmallCheckDepth])
-> Enum SmallCheckDepth
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
enumFromThenTo :: SmallCheckDepth
-> SmallCheckDepth -> SmallCheckDepth -> [SmallCheckDepth]
$cenumFromThenTo :: SmallCheckDepth
-> SmallCheckDepth -> SmallCheckDepth -> [SmallCheckDepth]
enumFromTo :: SmallCheckDepth -> SmallCheckDepth -> [SmallCheckDepth]
$cenumFromTo :: SmallCheckDepth -> SmallCheckDepth -> [SmallCheckDepth]
enumFromThen :: SmallCheckDepth -> SmallCheckDepth -> [SmallCheckDepth]
$cenumFromThen :: SmallCheckDepth -> SmallCheckDepth -> [SmallCheckDepth]
enumFrom :: SmallCheckDepth -> [SmallCheckDepth]
$cenumFrom :: SmallCheckDepth -> [SmallCheckDepth]
fromEnum :: SmallCheckDepth -> Int
$cfromEnum :: SmallCheckDepth -> Int
toEnum :: Int -> SmallCheckDepth
$ctoEnum :: Int -> SmallCheckDepth
pred :: SmallCheckDepth -> SmallCheckDepth
$cpred :: SmallCheckDepth -> SmallCheckDepth
succ :: SmallCheckDepth -> SmallCheckDepth
$csucc :: SmallCheckDepth -> SmallCheckDepth
Enum, Enum SmallCheckDepth
Real SmallCheckDepth
(Real SmallCheckDepth, Enum SmallCheckDepth) =>
(SmallCheckDepth -> SmallCheckDepth -> SmallCheckDepth)
-> (SmallCheckDepth -> SmallCheckDepth -> SmallCheckDepth)
-> (SmallCheckDepth -> SmallCheckDepth -> SmallCheckDepth)
-> (SmallCheckDepth -> SmallCheckDepth -> SmallCheckDepth)
-> (SmallCheckDepth
-> SmallCheckDepth -> (SmallCheckDepth, SmallCheckDepth))
-> (SmallCheckDepth
-> SmallCheckDepth -> (SmallCheckDepth, SmallCheckDepth))
-> (SmallCheckDepth -> Integer)
-> Integral SmallCheckDepth
SmallCheckDepth -> Integer
SmallCheckDepth
-> SmallCheckDepth -> (SmallCheckDepth, SmallCheckDepth)
SmallCheckDepth -> SmallCheckDepth -> SmallCheckDepth
forall a.
(Real a, Enum a) =>
(a -> a -> a)
-> (a -> a -> a)
-> (a -> a -> a)
-> (a -> a -> a)
-> (a -> a -> (a, a))
-> (a -> a -> (a, a))
-> (a -> Integer)
-> Integral a
toInteger :: SmallCheckDepth -> Integer
$ctoInteger :: SmallCheckDepth -> Integer
divMod :: SmallCheckDepth
-> SmallCheckDepth -> (SmallCheckDepth, SmallCheckDepth)
$cdivMod :: SmallCheckDepth
-> SmallCheckDepth -> (SmallCheckDepth, SmallCheckDepth)
quotRem :: SmallCheckDepth
-> SmallCheckDepth -> (SmallCheckDepth, SmallCheckDepth)
$cquotRem :: SmallCheckDepth
-> SmallCheckDepth -> (SmallCheckDepth, SmallCheckDepth)
mod :: SmallCheckDepth -> SmallCheckDepth -> SmallCheckDepth
$cmod :: SmallCheckDepth -> SmallCheckDepth -> SmallCheckDepth
div :: SmallCheckDepth -> SmallCheckDepth -> SmallCheckDepth
$cdiv :: SmallCheckDepth -> SmallCheckDepth -> SmallCheckDepth
rem :: SmallCheckDepth -> SmallCheckDepth -> SmallCheckDepth
$crem :: SmallCheckDepth -> SmallCheckDepth -> SmallCheckDepth
quot :: SmallCheckDepth -> SmallCheckDepth -> SmallCheckDepth
$cquot :: SmallCheckDepth -> SmallCheckDepth -> SmallCheckDepth
$cp2Integral :: Enum SmallCheckDepth
$cp1Integral :: Real SmallCheckDepth
Integral, Typeable)
instance IsOption SmallCheckDepth where
defaultValue :: SmallCheckDepth
defaultValue = 5
parseValue :: TestName -> Maybe SmallCheckDepth
parseValue = (Int -> SmallCheckDepth) -> Maybe Int -> Maybe SmallCheckDepth
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Int -> SmallCheckDepth
SmallCheckDepth (Maybe Int -> Maybe SmallCheckDepth)
-> (TestName -> Maybe Int) -> TestName -> Maybe SmallCheckDepth
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TestName -> Maybe Int
forall a. Read a => TestName -> Maybe a
safeRead
optionName :: Tagged SmallCheckDepth TestName
optionName = TestName -> Tagged SmallCheckDepth TestName
forall (m :: * -> *) a. Monad m => a -> m a
return "smallcheck-depth"
optionHelp :: Tagged SmallCheckDepth TestName
optionHelp = TestName -> Tagged SmallCheckDepth TestName
forall (m :: * -> *) a. Monad m => a -> m a
return "Depth to use for smallcheck tests"
instance IsTest (SC.Property IO) where
testOptions :: Tagged (Property IO) [OptionDescription]
testOptions = [OptionDescription] -> Tagged (Property IO) [OptionDescription]
forall (m :: * -> *) a. Monad m => a -> m a
return [Proxy SmallCheckDepth -> OptionDescription
forall v. IsOption v => Proxy v -> OptionDescription
Option (Proxy SmallCheckDepth
forall k (t :: k). Proxy t
Proxy :: Proxy SmallCheckDepth)]
run :: OptionSet -> Property IO -> (Progress -> IO ()) -> IO Result
run opts :: OptionSet
opts prop :: Property IO
prop yieldProgress :: Progress -> IO ()
yieldProgress = do
let
SmallCheckDepth depth :: Int
depth = OptionSet -> SmallCheckDepth
forall v. IsOption v => OptionSet -> v
lookupOption OptionSet
opts
IORef (Int, Int)
counter <- (Int, Int) -> IO (IORef (Int, Int))
forall a. a -> IO (IORef a)
newIORef (0 :: Int, 0 :: Int)
let
hook :: TestQuality -> IO ()
hook quality :: TestQuality
quality = do
let
inc :: (Int, Int) -> (Int, Int)
inc (total :: Int
total, bad :: Int
bad) =
case TestQuality
quality of
GoodTest -> ((,) (Int -> Int -> (Int, Int)) -> Int -> Int -> (Int, Int)
forall a b. (a -> b) -> a -> b
$! Int
total Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 1) Int
bad
BadTest -> ((,) (Int -> Int -> (Int, Int)) -> Int -> Int -> (Int, Int)
forall a b. (a -> b) -> a -> b
$! Int
total Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 1) (Int -> (Int, Int)) -> Int -> (Int, Int)
forall a b. (a -> b) -> a -> b
$! Int
bad Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 1
Int
count <- IORef (Int, Int) -> ((Int, Int) -> ((Int, Int), Int)) -> IO Int
forall a b. IORef a -> (a -> (a, b)) -> IO b
myAtomicModifyIORef' IORef (Int, Int)
counter (\c :: (Int, Int)
c -> let c' :: (Int, Int)
c' = (Int, Int) -> (Int, Int)
inc (Int, Int)
c in ((Int, Int)
c', (Int, Int) -> Int
forall a b. (a, b) -> a
fst (Int, Int)
c'))
Progress -> IO ()
yieldProgress (Progress -> IO ()) -> Progress -> IO ()
forall a b. (a -> b) -> a -> b
$ Progress :: TestName -> Float -> Progress
Progress
{ progressText :: TestName
progressText = Int -> TestName
forall a. Show a => a -> TestName
show Int
count
, progressPercent :: Float
progressPercent = 0
}
Either SomeException (Maybe PropertyFailure)
scResult <- IO (Maybe PropertyFailure)
-> IO (Either SomeException (Maybe PropertyFailure))
forall e a. Exception e => IO a -> IO (Either e a)
try (IO (Maybe PropertyFailure)
-> IO (Either SomeException (Maybe PropertyFailure)))
-> IO (Maybe PropertyFailure)
-> IO (Either SomeException (Maybe PropertyFailure))
forall a b. (a -> b) -> a -> b
$ Int
-> (TestQuality -> IO ())
-> Property IO
-> IO (Maybe PropertyFailure)
forall (m :: * -> *) a.
Testable m a =>
Int -> (TestQuality -> m ()) -> a -> m (Maybe PropertyFailure)
smallCheckWithHook Int
depth TestQuality -> IO ()
hook Property IO
prop
(total :: Int
total, bad :: Int
bad) <- IORef (Int, Int) -> IO (Int, Int)
forall a. IORef a -> IO a
readIORef IORef (Int, Int)
counter
let
desc :: TestName
desc
| Int
bad Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== 0
= TestName -> Int -> TestName
forall r. PrintfType r => TestName -> r
printf "%d tests completed" Int
total
| Bool
otherwise
= TestName -> Int -> Int -> TestName
forall r. PrintfType r => TestName -> r
printf "%d tests completed (but %d did not meet the condition)" Int
total Int
bad
Result -> IO Result
forall (m :: * -> *) a. Monad m => a -> m a
return (Result -> IO Result) -> Result -> IO Result
forall a b. (a -> b) -> a -> b
$
case Either SomeException (Maybe PropertyFailure)
scResult of
Left e :: SomeException
e -> TestName -> Result
testFailed (TestName -> Result) -> TestName -> Result
forall a b. (a -> b) -> a -> b
$ SomeException -> TestName
forall a. Show a => a -> TestName
show (SomeException
e :: SomeException)
Right Nothing -> TestName -> Result
testPassed TestName
desc
Right (Just f :: PropertyFailure
f) -> TestName -> Result
testFailed (TestName -> Result) -> TestName -> Result
forall a b. (a -> b) -> a -> b
$ PropertyFailure -> TestName
ppFailure PropertyFailure
f
myAtomicModifyIORef' :: IORef a -> (a -> (a,b)) -> IO b
myAtomicModifyIORef' :: IORef a -> (a -> (a, b)) -> IO b
myAtomicModifyIORef' ref :: IORef a
ref f :: a -> (a, b)
f = do
b
b <- IORef a -> (a -> (a, b)) -> IO b
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef IORef a
ref
(\x :: a
x -> let (a :: a
a, b :: b
b) = a -> (a, b)
f a
x
in (a
a, a
a a -> b -> b
forall a b. a -> b -> b
`seq` b
b))
b
b b -> IO b -> IO b
forall a b. a -> b -> b
`seq` b -> IO b
forall (m :: * -> *) a. Monad m => a -> m a
return b
b