--------------------------------------------------------------------
-- |
-- Module    : Test.SmallCheck.Drivers
-- Copyright : (c) Colin Runciman et al.
-- License   : BSD3
-- Maintainer: Roman Cheplyaka <roma@ro-che.info>
--
-- You should only need this module if you wish to create your own way to
-- run SmallCheck tests
--------------------------------------------------------------------

{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleContexts #-}
#if __GLASGOW_HASKELL__ >= 704
{-# LANGUAGE Safe #-}
#endif

module Test.SmallCheck.Drivers (
  smallCheck, smallCheckM, smallCheckWithHook,
  test,
  ppFailure,
  PropertyFailure(..), PropertySuccess(..), Argument, Reason, TestQuality(..)
  ) where

import Control.Monad (when)
import Test.SmallCheck.Property
import Test.SmallCheck.Property.Result
import Text.Printf (printf)
import Data.IORef (readIORef, writeIORef, IORef, newIORef) -- NB: explicit import list to avoid name clash with modifyIORef'

-- | A simple driver that runs the test in the 'IO' monad and prints the
-- results.
smallCheck :: Testable IO a => Depth -> a -> IO ()
smallCheck :: Depth -> a -> IO ()
smallCheck Depth
d a
a = do
  ((Integer
good, Integer
bad), Maybe PropertyFailure
mbEx) <- Depth -> a -> IO ((Integer, Integer), Maybe PropertyFailure)
forall a.
Testable IO a =>
Depth -> a -> IO ((Integer, Integer), Maybe PropertyFailure)
runTestWithStats Depth
d a
a
  let testsRun :: Integer
testsRun = Integer
good Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
bad
  case Maybe PropertyFailure
mbEx of
    Maybe PropertyFailure
Nothing -> do
      String -> Integer -> IO ()
forall r. PrintfType r => String -> r
printf String
"Completed %d tests without failure.\n" Integer
testsRun
      Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Integer
bad Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
> Integer
0) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
        String -> Integer -> IO ()
forall r. PrintfType r => String -> r
printf String
"But %d did not meet ==> condition.\n" Integer
bad
    Just PropertyFailure
x -> do
      String -> Integer -> IO ()
forall r. PrintfType r => String -> r
printf String
"Failed test no. %d.\n" Integer
testsRun
      String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ PropertyFailure -> String
ppFailure PropertyFailure
x

runTestWithStats :: Testable IO a => Depth -> a -> IO ((Integer, Integer), Maybe PropertyFailure)
runTestWithStats :: Depth -> a -> IO ((Integer, Integer), Maybe PropertyFailure)
runTestWithStats Depth
d a
prop = do
  IORef Integer
good <- Integer -> IO (IORef Integer)
forall a. a -> IO (IORef a)
newIORef Integer
0
  IORef Integer
bad <- Integer -> IO (IORef Integer)
forall a. a -> IO (IORef a)
newIORef Integer
0

  let
    hook :: TestQuality -> IO ()
hook TestQuality
GoodTest = IORef Integer -> (Integer -> Integer) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef' IORef Integer
good (Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+Integer
1)
    hook TestQuality
BadTest  = IORef Integer -> (Integer -> Integer) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef' IORef Integer
bad  (Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+Integer
1)

  Maybe PropertyFailure
r <- Depth -> (TestQuality -> IO ()) -> a -> IO (Maybe PropertyFailure)
forall (m :: * -> *) a.
Testable m a =>
Depth -> (TestQuality -> m ()) -> a -> m (Maybe PropertyFailure)
smallCheckWithHook Depth
d TestQuality -> IO ()
hook a
prop

  Integer
goodN <- IORef Integer -> IO Integer
forall a. IORef a -> IO a
readIORef IORef Integer
good
  Integer
badN  <- IORef Integer -> IO Integer
forall a. IORef a -> IO a
readIORef IORef Integer
bad

  ((Integer, Integer), Maybe PropertyFailure)
-> IO ((Integer, Integer), Maybe PropertyFailure)
forall (m :: * -> *) a. Monad m => a -> m a
return ((Integer
goodN, Integer
badN), Maybe PropertyFailure
r)

-- NB: modifyIORef' is in base starting at least from GHC 7.6.1.
--
-- So get rid of this once 7.6.1 becomes widely adopted.
modifyIORef' :: IORef a -> (a -> a) -> IO ()
modifyIORef' :: IORef a -> (a -> a) -> IO ()
modifyIORef' IORef a
ref a -> a
f = do
    a
x <- IORef a -> IO a
forall a. IORef a -> IO a
readIORef IORef a
ref
    let x' :: a
x' = a -> a
f a
x
    a
x' a -> IO () -> IO ()
`seq` IORef a -> a -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef a
ref a
x'

-- | Use this if:
--
-- * You need to run a test in a monad different from 'IO'
--
-- * You need to analyse the results rather than just print them
smallCheckM :: Testable m a => Depth -> a -> m (Maybe PropertyFailure)
smallCheckM :: Depth -> a -> m (Maybe PropertyFailure)
smallCheckM Depth
d = Depth -> (TestQuality -> m ()) -> a -> m (Maybe PropertyFailure)
forall (m :: * -> *) a.
Testable m a =>
Depth -> (TestQuality -> m ()) -> a -> m (Maybe PropertyFailure)
smallCheckWithHook Depth
d (m () -> TestQuality -> m ()
forall a b. a -> b -> a
const (m () -> TestQuality -> m ()) -> m () -> TestQuality -> m ()
forall a b. (a -> b) -> a -> b
$ () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ())

-- | Like `smallCheckM`, but allows to specify a monadic hook that gets
-- executed after each test is run.
--
-- Useful for applications that want to report progress information to the
-- user.
smallCheckWithHook :: Testable m a => Depth -> (TestQuality -> m ()) -> a -> m (Maybe PropertyFailure)
smallCheckWithHook :: Depth -> (TestQuality -> m ()) -> a -> m (Maybe PropertyFailure)
smallCheckWithHook Depth
d TestQuality -> m ()
hook a
a = Depth
-> (TestQuality -> m ()) -> Property m -> m (Maybe PropertyFailure)
forall (m :: * -> *).
Monad m =>
Depth
-> (TestQuality -> m ()) -> Property m -> m (Maybe PropertyFailure)
runProperty Depth
d TestQuality -> m ()
hook (Property m -> m (Maybe PropertyFailure))
-> Property m -> m (Maybe PropertyFailure)
forall a b. (a -> b) -> a -> b
$ a -> Property m
forall (m :: * -> *) a. Testable m a => a -> Property m
test a
a