[A limited amount of function testing is possible. This will be removed
nad**20040618161841
 A limited amount of function testing is possible. This will be removed
 in the next check-in, since it's not flexible enough to warrant
 inclusion in the library; it's most likely better to make a private
 function-tester. Currently testing "(const (const not) :: Double -> Int
 -> Bool -> Bool) !==! const (const not)" takes ages since around one
 million tests are performed. Furthermore only top-level functions are
 allowed:
 > [not] !==! [const True]
 *** Exception: The generic versions of (==!) and friends do not accept non-bottom functions.
 
 This file, containing a modification of some copyrighted code ripped
 from the QuickCheck sources (BSD-style license), will be removed in the
 next check-in.
 
] {
addfile ./ChasingBottoms/QuickCheckWrapper.hs
hunk ./ChasingBottoms/QuickCheckWrapper.hs 1
+-- | Code stolen from the QuickCheck sources and modified slightly.
+
+module ChasingBottoms.QuickCheckWrapper where
+
+import Debug.QuickCheck hiding (check)
+import qualified Random
+import qualified System.IO.Unsafe as Unsafe
+
+check :: Testable a => Config -> a -> IO Bool
+check config a =
+  do rnd <- Random.newStdGen
+     tests config (evaluate a) rnd 0 0 []
+  where
+  tests :: Monad m => Config -> Gen Result -> Random.StdGen
+                   -> Int -> Int -> [[String]] -> m Bool
+  tests config gen rnd0 ntest nfail stamps
+    | ntest == configMaxTest config = return True
+    | nfail == configMaxFail config = fail "Too many failing test cases."
+    | otherwise               =
+        do 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 ->
+               return False
+       where
+        result      = generate (configSize config ntest) rnd2 gen
+        (rnd1,rnd2) = Random.split rnd0
+
+testIt :: Property -> Bool
+testIt = Unsafe.unsafePerformIO . check config
+  where
+  config :: Config
+  config = Config
+    { configMaxTest = 100
+    , configMaxFail = 1000
+    , configSize    = (+ 3) . (`div` 2)
+    , configEvery   = const (const "")
+    }
}