-- | This module allows to use SmallCheck properties in tasty.
{-# 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) -- for re-export
import Test.SmallCheck.Drivers
import Control.Exception
import Data.Typeable
import Data.Proxy
import Data.IORef
import Text.Printf

-- | Create a 'Test' for a SmallCheck 'SC.Testable' property
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)

-- | The \"depth\" parameter for SmallCheck
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'))

        -- submit progress data to tasty
        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 -- we don't know the total number of tests
          }

    -- small check does not catch exceptions on its own, so lets do it
    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

-- Copied from base to stay compatible with GHC 7.4.
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