testpack 1.0.2 → 2.0.0
raw patch · 4 files changed
+131/−52 lines, 4 filesdep ~QuickCheckdep ~base
Dependency ranges changed: QuickCheck, base
Files
- src/Test/HUnit/Tools.hs +115/−35
- src/Test/QuickCheck/Instances.hs +4/−7
- src/Test/QuickCheck/Tools.hs +6/−4
- testpack.cabal +6/−6
src/Test/HUnit/Tools.hs view
@@ -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 <jgoerzen@complete.org>@@ -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)
src/Test/QuickCheck/Instances.hs view
@@ -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
src/Test/QuickCheck/Tools.hs view
@@ -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
testpack.cabal view
@@ -1,9 +1,9 @@ Name: testpack-Version: 1.0.2+Version: 2.0.0 License: LGPL Maintainer: John Goerzen <jgoerzen@complete.org> 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