module Test.HUnit.Tools (assertRaises, mapassertEqual,
runVerbTestText, runVerboseTests, qccheck, qctest,
qc2hu, qc2huVerbose, tl)
where
import Test.HUnit
import Test.QuickCheck as QC
import qualified Control.Exception
import qualified Test.HUnit as HU
import System.Random
import System.IO
import Text.Printf
#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 610
assertRaises :: (Show a, Control.Exception.Exception e, Show e, Eq e) =>
String -> e -> IO a -> IO ()
#else
assertRaises :: Show a => String -> Control.Exception.Exception -> IO a -> IO ()
#endif
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 []
runVerbTestText :: HU.PutText st -> HU.Test -> IO (HU.Counts, st)
runVerbTestText (HU.PutText put us) t = do
hSetBuffering stdout LineBuffering
hSetBuffering stderr LineBuffering
(counts, us') <- HU.performTest reportStart reportError reportFailure us t
us'' <- put (HU.showCounts counts) True us'
return (counts, us'')
where
reportStart ss us = do hFlush stderr
hPrintf stdout "\rTesting %-70s\n"
(HU.showPath (HU.path ss))
hFlush stdout
put (HU.showCounts (HU.counts ss)) False us
reportError = reportProblem "Error:" "Error in: "
reportFailure = reportProblem "Failure:" "Failure in: "
reportProblem p0 p1 msg ss us = put line True us
where line = "### " ++ kind ++ path' ++ '\n' : msg
kind = if null path' then p0 else p1
path' = HU.showPath (HU.path ss)
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
qc2hu :: QC.Testable a => Int -> String -> a -> HU.Test
qc2hu maxTest = qccheck (defaultConfig {configMaxTest = maxTest, configMaxFail = 20000,
configEvery = testCount})
where testCountBase n = " (test " ++ show n ++ "/" ++ show maxTest ++ ")"
testCount n _ = testCountBase n ++
replicate (length (testCountBase n)) '\b'
qc2huVerbose :: QC.Testable a => Int -> String -> a -> HU.Test
qc2huVerbose maxTest =
qccheck (defaultConfig {configMaxTest = 250, configMaxFail = 20000,
configEvery = \n args -> show n ++ ":\n" ++ unlines args})
runVerboseTests :: HU.Test -> IO (HU.Counts, Int)
runVerboseTests tests =
runVerbTestText (myPutText stderr True) $ tests
where myPutText h b =
case HU.putTextToHandle h b of
PutText putf st -> PutText (myputf h putf) st
myputf h putf x y z = do r <- putf x y z
hFlush h
return r
tl :: String -> [Test] -> Test
tl msg t = HU.TestLabel msg $ HU.TestList t