module Test.SmallCheck.Drivers (
smallCheck, smallCheckI, depthCheck
) where
import System.IO (stdout, hFlush)
import Control.Monad (when)
import Test.SmallCheck.Property
smallCheck :: Testable a => Depth -> a -> IO ()
smallCheck d = iterCheck 0 (Just d)
depthCheck :: Testable a => Depth -> a -> IO ()
depthCheck d = iterCheck d (Just d)
smallCheckI :: Testable a => a -> IO ()
smallCheckI = iterCheck 0 Nothing
iterCheck :: Testable a => Depth -> Maybe Depth -> a -> IO ()
iterCheck dFrom mdTo t = iter dFrom
where
iter d = do
putStrLn ("Depth "++show d++":")
let results = test t d
ok <- check (mdTo==Nothing) 0 0 True results
maybe (whenUserWishes " Deeper" () $ iter (d+1))
(\dTo -> when (ok && d < dTo) $ iter (d+1))
mdTo
check :: Bool -> Integer -> Integer -> Bool -> [TestCase] -> IO Bool
check i n x ok rs | null rs = do
putStr (" Completed "++show n++" test(s)")
putStrLn (if ok then " without failure." else ".")
when (x > 0) $
putStrLn (" But "++show x++" did not meet ==> condition.")
return ok
check i n x ok (TestCase Inappropriate _ : rs) = do
progressReport i n x
check i (n+1) (x+1) ok rs
check i n x f (TestCase Pass _ : rs) = do
progressReport i n x
check i (n+1) x f rs
check i n x f (TestCase Fail args : rs) = do
putStrLn (" Failed test no. "++show (n+1)++". Test values follow.")
mapM_ (putStrLn . (" "++)) args
( if i then
whenUserWishes " Continue" False $ check i (n+1) x False rs
else
return False )
whenUserWishes :: String -> a -> IO a -> IO a
whenUserWishes wish x action = do
putStr (wish++"? ")
hFlush stdout
reply <- getLine
( if (null reply || reply=="y") then action
else return x )
progressReport :: Bool -> Integer -> Integer -> IO ()
progressReport i n x | n >= x = do
when i $ ( putStr (n' ++ replicate (length n') '\b') >>
hFlush stdout )
where
n' = show n