[Pkg-haskell-commits] [SCM] haskell-testpack branch, master, updated. debian/1.0.2-1-4-gb0d6b36

[jeremy.shaw]

The following commit has been merged in the master branch:
commit 1284e14641e9f205455c425d7262df107ad84a58
Author: jeremy.shaw <jeremy.shaw at linspireinc.com>
Date:   Wed Sep 13 03:21:00 2006 +0100

    Add functions to turn QuickCheck tests into HUnit tests

diff --git a/MissingH/HUnit.hs b/MissingH/HUnit.hs
index 937a65e..06a6cb5 100644
--- a/MissingH/HUnit.hs
+++ b/MissingH/HUnit.hs
@@ -32,9 +32,11 @@ Written by John Goerzen, jgoerzen\@complete.org
 
 
 
-module MissingH.HUnit(assertRaises, mapassertEqual) where
+module MissingH.HUnit(assertRaises, mapassertEqual, qccheck, qctest) where
 import Test.HUnit
+import Test.QuickCheck as QC
 import qualified Control.Exception
+import System.Random
 
 {- | Asserts that a specific exception is raised by a given action. -}
 
@@ -53,3 +55,42 @@ mapassertEqual :: (Show b, Eq b) => String -> (a -> b) -> [(a, b)] -> [Test]
 mapassertEqual descrip func [] = []
 mapassertEqual descrip func ((inp,result):xs) =
     (TestCase $ assertEqual descrip result (func inp)) : mapassertEqual descrip func xs
+
+-- * Turn QuickCheck tests into HUnit tests
+
+-- |qccheck turns the quickcheck test into an hunit test
+qccheck :: (QC.Testable a) => 
+           Config -- ^ quickcheck config
+        -> String -- ^ label for the property
+        -> a      -- ^ quickcheck property
+        -> Test
+qccheck config lbl property =
+    TestLabel lbl $ TestCase $
+              do rnd <- newStdGen
+                 tests config (evaluate property) rnd 0 0 []
+
+-- |qctest is equivalent to 'qccheck defaultConfig'
+qctest ::  (QC.Testable a) => String -> a -> Test
+qctest lbl property = qccheck defaultConfig lbl property
+
+-- |modified version of the tests function from Test.QuickCheck
+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

-- 
haskell-testpack