module Test.Framework.Providers.SmallCheck
( testProperty
, withDepth
) where
import Test.Framework.Providers.API
import qualified Test.SmallCheck as SC
import qualified Test.SmallCheck.Drivers as SC
import Test.SmallCheck.Drivers
import Data.Maybe
import Data.List
import Data.Monoid
import Data.IORef
import qualified Control.Monad.IO.Class as T
import System.Timeout
import Control.Concurrent.Chan
import Control.Applicative
testProperty :: SC.Testable IO a => TestName -> a -> Test
testProperty name prop = Test name $ (SC.test prop :: SC.Property IO)
withDepth :: SC.Depth -> Test -> Test
withDepth d = plusTestOptions mempty { topt_maximum_test_depth = Just d }
data Result
= Timeout
| Pass
| Fail SC.PropertyFailure
instance Show Result where
show Timeout = "Timed out"
show Pass = "OK"
show (Fail s) = ppFailure s
instance TestResultlike Int Result where
testSucceeded Pass = True
testSucceeded _ = False
instance Testlike Int Result (SC.Property IO) where
testTypeName _ = "Properties"
runTest topts prop = do
let
timeoutAmount = unK $ topt_timeout topts
depth = unK $ topt_maximum_test_depth topts
chan <- newChan
let
action = do
mb_result <- timeout (fromMaybe (1) timeoutAmount) $ smallCheckWithHook depth (const $ writeChan chan (Left ())) prop
writeChan chan $ Right $
case mb_result of
Nothing -> Timeout
Just Nothing -> Pass
Just (Just x) -> Fail x
improving <- reifyListToImproving . accumulate <$> getChanContents chan
return (improving, action)
accumulate :: [Either () a] -> [Either Int a]
accumulate xs =
(\f -> snd $ mapAccumL f 0 xs) $
\n e ->
case e of
Left {} ->
let n' = n+1
in n' `seq` (n', Left n')
Right x -> (n, Right x)
reifyListToImproving :: [Either i f] -> (i :~> f)
reifyListToImproving (Left improvement:rest) = Improving improvement (reifyListToImproving rest)
reifyListToImproving (Right final:_) = Finished final
reifyListToImproving [] = error "reifyListToImproving: list finished before a final value arrived"