module Test.HUnit.Utils (assertRaises, mapassertEqual, qccheck, qctest)
where
import Test.HUnit
import Test.QuickCheck as QC
import qualified Control.Exception
import System.Random
assertRaises :: Show a => String -> Control.Exception.Exception -> IO a -> IO ()
assertRaises msg selector action =
let thetest e = if e == selector then return ()
else assertFailure $ msg ++ "\nReceived unexpected exception: "
++ (show e) ++ "\ninstead of exception: " ++ (show selector)
in do
r <- Control.Exception.try action
case r of
Left e -> thetest e
Right _ -> assertFailure $ msg ++ "\nReceived no exception, but was expecting exception: " ++ (show selector)
mapassertEqual :: (Show b, Eq b) => String -> (a -> b) -> [(a, b)] -> [Test]
mapassertEqual _ _ [] = []
mapassertEqual descrip func ((inp,result):xs) =
(TestCase $ assertEqual descrip result (func inp)) : mapassertEqual descrip func xs
qccheck :: (QC.Testable a) =>
QC.Config
-> String
-> a
-> Test
qccheck config lbl property =
TestLabel lbl $ TestCase $
do rnd <- newStdGen
tests config (evaluate property) rnd 0 0 []
qctest :: (QC.Testable a) => String -> a -> Test
qctest lbl = qccheck defaultConfig lbl
tests :: Config -> Gen Result -> StdGen -> Int -> Int -> [[String]] -> IO ()
tests config gen rnd0 ntest nfail stamps
| ntest == configMaxTest config = return ()
| nfail == configMaxFail config = assertFailure $ "Arguments exhausted after " ++ show ntest ++ " tests."
| otherwise =
do putStr (configEvery config ntest (arguments result))
case ok result of
Nothing ->
tests config gen rnd1 ntest (nfail+1) stamps
Just True ->
tests config gen rnd1 (ntest+1) nfail (stamp result:stamps)
Just False ->
assertFailure $ ( "Falsifiable, after "
++ show ntest
++ " tests:\n"
++ unlines (arguments result)
)
where
result = generate (configSize config ntest) rnd2 gen
(rnd1,rnd2) = split rnd0