diff --git a/src/Test/HUnit/Tools.hs b/src/Test/HUnit/Tools.hs --- a/src/Test/HUnit/Tools.hs +++ b/src/Test/HUnit/Tools.hs @@ -1,6 +1,6 @@ {- | Module : Test.HUnit.Tools - Copyright : Copyright (C) 2004-2009 John Goerzen + Copyright : Copyright (C) 2004-2010 John Goerzen License : GNU LGPL, version 2 or above Maintainer : John Goerzen @@ -14,10 +14,15 @@ module Test.HUnit.Tools (assertRaises, mapassertEqual, runVerbTestText, runVerboseTests, qccheck, qctest, - qc2hu, qc2huVerbose, tl) + qc2hu, tl) where -import Test.HUnit import Test.QuickCheck as QC +import Test.QuickCheck.Text +import Test.QuickCheck.Test +import Test.QuickCheck.Gen +import Test.QuickCheck.State +import qualified Test.QuickCheck.Property as P +import Test.QuickCheck.Property hiding (Result(reason)) import qualified Control.Exception import qualified Test.HUnit as HU import System.Random @@ -33,30 +38,31 @@ #endif assertRaises msg selector action = let thetest e = if e == selector then return () - else assertFailure $ msg ++ "\nReceived unexpected exception: " + else HU.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) + Right _ -> HU.assertFailure $ msg ++ "\nReceived no exception, but was expecting exception: " ++ (show selector) -mapassertEqual :: (Show b, Eq b) => String -> (a -> b) -> [(a, b)] -> [Test] +mapassertEqual :: (Show b, Eq b) => String -> (a -> b) -> [(a, b)] -> [HU.Test] mapassertEqual _ _ [] = [] mapassertEqual descrip func ((inp,result):xs) = - (TestCase $ assertEqual descrip result (func inp)) : mapassertEqual descrip func xs + (HU.TestCase $ HU.assertEqual descrip result (func inp)) : mapassertEqual descrip func xs -- | qccheck turns the quickcheck test into an hunit test qccheck :: (QC.Testable a) => - QC.Config -- ^ quickcheck config + QC.Args -- ^ quickcheck config -> String -- ^ label for the property -> a -- ^ quickcheck property - -> Test + -> HU.Test qccheck config lbl property = - TestLabel lbl $ TestCase $ - do rnd <- newStdGen - tests config (evaluate property) rnd 0 0 [] - + HU.TestLabel lbl $ HU.TestCase $ + do result <- localquickCheckWithResult config property + case result of + Success _ -> return () + _ -> HU.assertFailure (show result) -- Modified from HUnit {- | Like 'runTestText', but with more verbose output. -} @@ -80,15 +86,16 @@ kind = if null path' then p0 else p1 path' = HU.showPath (HU.path ss) --- | qctest is equivalent to 'qccheck defaultConfig' -qctest :: (QC.Testable a) => String -> a -> Test -qctest lbl = qccheck defaultConfig lbl +-- | qctest is equivalent to 'qccheck stdArgs' +qctest :: (QC.Testable a) => String -> a -> HU.Test +qctest lbl = qccheck stdArgs lbl +{- -- | modified version of the tests function from Test.QuickCheck -tests :: Config -> Gen Result -> StdGen -> Int -> Int -> [[String]] -> IO () +tests :: Args -> 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." + | ntest == maxSuccess config = return () + | nfail == maxDiscard config = assertFailure $ "Arguments exhausted after " ++ show ntest ++ " tests." | otherwise = do putStr (configEvery config ntest (arguments result)) case ok result of @@ -105,9 +112,10 @@ where result = generate (configSize config ntest) rnd2 gen (rnd1,rnd2) = split rnd0 +-} -{- | Convert QuickCheck tests to HUnit, with a configurable maximum test count, -and running counter on the screen for long-running tests. Often used like this: +{- | Convert QuickCheck tests to HUnit, with a configurable maximum test count. +Often used like this: >q :: QC.Testable a => String -> a -> HU.Test >q = qc2hu 250 @@ -116,18 +124,7 @@ > q "Integer -> Int (safe bounds)" prop_integer_to_int_pass] -} qc2hu :: QC.Testable a => Int -> String -> a -> HU.Test -qc2hu maxTest = qccheck (defaultConfig {configMaxTest = maxTest, configMaxFail = 20000, - configEvery = testCount}) - -- configEvery = testCount for displaying a running test counter - where testCountBase n = " (test " ++ show n ++ "/" ++ show maxTest ++ ")" - testCount n _ = testCountBase n ++ - replicate (length (testCountBase n)) '\b' - -{- | Like 'qc2hu', but show the test itself for each one. -} -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}) +qc2hu maxTest = qccheck (stdArgs {maxSuccess = maxTest, maxDiscard = 20000}) {- | Run verbose tests. Example: @@ -147,11 +144,94 @@ runVerbTestText (myPutText stderr True) $ tests where myPutText h b = case HU.putTextToHandle h b of - PutText putf st -> PutText (myputf h putf) st + HU.PutText putf st -> HU.PutText (myputf h putf) st myputf h putf x y z = do r <- putf x y z hFlush h return r {- | Label the tests list. See example under 'runVerboseTests'.-} -tl :: String -> [Test] -> Test +tl :: String -> [HU.Test] -> HU.Test tl msg t = HU.TestLabel msg $ HU.TestList t + +------------------------------------------------------------ +-- below code lifted from quickcheck2, Tests.hs, and modified for this purpose + +-- | Tests a property, using test arguments, produces a test result, and prints the results to 'stdout'. +localquickCheckWithResult :: Testable prop => Args -> prop -> IO Result +localquickCheckWithResult args p = + do tm <- newTerminal + rnd <- case replay args of + Nothing -> newStdGen + Just (rnd,_) -> return rnd + test MkState{ terminal = tm + , maxSuccessTests = maxSuccess args + , maxDiscardedTests = maxDiscard args + , computeSize = case replay args of + Nothing -> \n d -> (n * maxSize args) + `div` maxSuccess args + + (d `div` 10) + Just (_,s) -> \_ _ -> s + , numSuccessTests = 0 + , numDiscardedTests = 0 + , collected = [] + , expectedFailure = False + , randomSeed = rnd + , isShrinking = False + , numSuccessShrinks = 0 + , numTryShrinks = 0 + } (unGen (property p)) + where +-------------------------------------------------------------------------- +-- main test loop + test :: State -> (StdGen -> Int -> Prop) -> IO Result + test st f + | numSuccessTests st >= maxSuccessTests st = doneTesting st f + | numDiscardedTests st >= maxDiscardedTests st = giveUp st f + | otherwise = runATest st f + + doneTesting :: State -> (StdGen -> Int -> Prop) -> IO Result + doneTesting st f = + do if expectedFailure st then + return Success{ labels = summary st } + else + return NoExpectedFailure{ labels = summary st } + + giveUp :: State -> (StdGen -> Int -> Prop) -> IO Result + giveUp st f = + do + return GaveUp{ numTests = numSuccessTests st + , labels = summary st + } + + runATest :: State -> (StdGen -> Int -> Prop) -> IO Result + runATest st f = + do + let size = computeSize st (numSuccessTests st) (numDiscardedTests st) + (res, ts) <- run (unProp (f rnd1 size)) + callbackPostTest st res + + case ok res of + Just True -> -- successful test + do test st{ numSuccessTests = numSuccessTests st + 1 + , randomSeed = rnd2 + , collected = stamp res : collected st + , expectedFailure = expect res + } f + + Nothing -> -- discarded test + do test st{ numDiscardedTests = numDiscardedTests st + 1 + , randomSeed = rnd2 + , expectedFailure = expect res + } f + + Just False -> -- failed test + do foundFailure st res ts + if not (expect res) then + return Success{ labels = summary st } + else + return Failure{ usedSeed = randomSeed st -- correct! (this will be split first) + , usedSize = size + , reason = P.reason res + , labels = summary st + } + where (rnd1,rnd2) = split (randomSeed st) diff --git a/src/Test/QuickCheck/Instances.hs b/src/Test/QuickCheck/Instances.hs --- a/src/Test/QuickCheck/Instances.hs +++ b/src/Test/QuickCheck/Instances.hs @@ -18,8 +18,6 @@ * Word8 (also a Random instance) -* Char (bounded between chars 0 and 255) - Written by John Goerzen, jgoerzen\@complete.org -} @@ -34,10 +32,14 @@ arbitrary = do items <- arbitrary return $ Map.fromList items + +instance (CoArbitrary k, CoArbitrary v, Eq k, Ord k) => CoArbitrary (Map.Map k v) where coarbitrary = coarbitrary . Map.keys instance Arbitrary Word8 where arbitrary = sized $ \n -> choose (0, min (fromIntegral n) maxBound) + +instance CoArbitrary Word8 where coarbitrary n = variant (if n >= 0 then 2 * x else 2 * x + 1) where x = abs . fromIntegral $ n @@ -45,9 +47,4 @@ randomR (a, b) g = (\(x, y) -> (fromInteger x, y)) $ randomR (toInteger a, toInteger b) g random g = randomR (minBound, maxBound) g - -instance Arbitrary Char where - arbitrary = sized $ \n -> choose ('\NUL', '\xFF') - coarbitrary n = variant (toEnum (2 * x + 1)) - where x = (abs . fromEnum $ n)::Int diff --git a/src/Test/QuickCheck/Tools.hs b/src/Test/QuickCheck/Tools.hs --- a/src/Test/QuickCheck/Tools.hs +++ b/src/Test/QuickCheck/Tools.hs @@ -23,15 +23,17 @@ ) where -import Test.QuickCheck +import Test.QuickCheck hiding (Result, reason) +import Test.QuickCheck.Property {- | Compare two values. If same, the test passes. If different, the result indicates what was expected and what was received as part of the error. -} (@=?) :: (Eq a, Show a) => a -> a -> Result expected @=? actual = - Result {ok = Just (expected == actual), - arguments = ["Result: expected " ++ show expected ++ ", got " ++ show actual], - stamp = []} + MkResult {ok = Just (expected == actual), + expect = True, + reason = "Result: expected " ++ show expected ++ ", got " ++ show actual, + stamp = [], callbacks = []} {- | Like '@=?', but with args in a different order. -} (@?=) :: (Eq a, Show a) => a -> a -> Result diff --git a/testpack.cabal b/testpack.cabal --- a/testpack.cabal +++ b/testpack.cabal @@ -1,9 +1,9 @@ Name: testpack -Version: 1.0.2 +Version: 2.0.0 License: LGPL Maintainer: John Goerzen Author: John Goerzen -Copyright: Copyright (c) 2004-2009 John Goerzen +Copyright: Copyright (c) 2004-2010 John Goerzen license-file: COPYRIGHT extra-source-files: COPYING, Makefile homepage: http://hackage.haskell.org/cgi-bin/hackage-scripts/package/testpack @@ -35,12 +35,12 @@ -- Hack for cabal-install weirdness. cabal-install forces base 3, -- though it works fine for Setup.lhs manually. Fix. if impl(ghc >= 6.9) - build-depends: base >= 4 + build-depends: base >= 4 && <5 - Build-Depends: base, + Build-Depends: base >= 3 && < 5, haskell98, mtl, HUnit, - QuickCheck >= 1.0 && < 2.0 + QuickCheck >= 2.0 If flag(splitBase) - Build-Depends: base >= 3, containers, random + Build-Depends: base >= 3 && < 5, containers, random Else Build-Depends: base < 3