Add withCounterexample to get a re-useable handle on counterexamples

src/Test/QuickCheck.hs

@@ -78,6 +78,7 @@ module Test.QuickCheck
   , quickCheckWith
   , quickCheckWithResult
   , quickCheckResult
+  , recheck
   , isSuccess
     -- ** Running tests verbosely
   , verboseCheck
@@ -317,6 +318,12 @@ module Test.QuickCheck
   , (.||.)
   , disjoin
     -- ** What to do on failure
+#ifndef NO_TYPEABLE
+  , Witness(..)
+  , witness
+  , coerceWitness
+  , castWitness
+#endif
   , counterexample
   , printTestCase
   , whenFail

src/Test/QuickCheck/Property.hs

@@ -3,6 +3,7 @@
 {-# LANGUAGE CPP #-}
 #ifndef NO_TYPEABLE
 {-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE ExistentialQuantification #-}
 #endif
 #ifndef NO_SAFE_HASKELL
 {-# LANGUAGE Safe #-}
@@ -33,7 +34,7 @@ import Data.Set(Set)
 import Control.DeepSeq
 #endif
 #ifndef NO_TYPEABLE
-import Data.Typeable (Typeable)
+import Data.Typeable (Typeable, cast)
 #endif
 import Data.Maybe
 
@@ -254,6 +255,25 @@ data Callback
 data CallbackKind = Counterexample    -- ^ Affected by the 'verbose' combinator
                   | NotCounterexample -- ^ Not affected by the 'verbose' combinator
 
+#ifndef NO_TYPEABLE
+data Witness = forall a. (Typeable a, Show a) => Wit a
+
+instance Show Witness where
+  show (Wit a) = show a
+
+coerceWitness :: Typeable a => Witness -> a
+coerceWitness (Wit a) = case cast a of
+  Nothing -> error $ "Can't coerceWitness " ++ show a
+  Just a -> a
+
+castWitness :: Typeable a => Witness -> Maybe a
+castWitness (Wit a) = cast a
+
+#define WITNESSES(a) , theWitnesses a
+#else
+#define WITNESSES(a)
+#endif
+
 -- | The result of a single test.
 data Result
   = MkResult
@@ -289,6 +309,7 @@ data Result
     -- ^ the callbacks for this test case
   , testCase            :: [String]
     -- ^ the generated test case
+  WITNESSES(:: [Witness])
   }
 
 exception :: String -> AnException -> Result
@@ -329,6 +350,7 @@ succeeded, failed, rejected :: Result
       , requiredCoverage    = []
       , callbacks           = []
       , testCase            = []
+      WITNESSES(= [])
       }
 
 --------------------------------------------------------------------------
@@ -502,6 +524,23 @@ withMaxShrinks n = n `seq` mapTotalResult (\res -> res{ maybeMaxShrinks = Just n
 withMaxSize :: Testable prop => Int -> prop -> Property
 withMaxSize n = n `seq` mapTotalResult (\res -> res{ maybeMaxTestSize = Just n })
 
+#ifndef NO_TYPEABLE
+-- | Return a value in the 'witnesses' field of the 'Result' returned by 'quickCheckResult'. Witnesses
+-- are returned outer-most first.
+--
+-- In ghci, for example:
+--
+-- >>> [Wit x] <- fmap witnesses . quickCheckResult $ \ x -> witness x $ x == (0 :: Int)
+-- *** Failed! Falsified (after 2 tests):
+-- 1
+-- >>> x
+-- 1
+-- >>> :t x
+-- x :: Int
+witness :: (Typeable a, Show a, Testable prop) => a -> prop -> Property
+witness a = a `seq` mapTotalResult (\res -> res{ theWitnesses = Wit a : theWitnesses res })
+#endif
+
 -- | Check that all coverage requirements defined by 'cover' and 'coverTable'
 -- are met, using a statistically sound test, and fail if they are not met.
 --
@@ -963,7 +1002,9 @@ disjoin ps =
                      callbacks result2,
                    testCase =
                      testCase result1 ++
-                     testCase result2 }
+                     testCase result2
+                   WITNESSES(= theWitnesses result1 ++ theWitnesses result2)
+                   }
                Nothing -> result2
          -- The "obvious" semantics of .||. has:
          --   discard .||. true = true

src/Test/QuickCheck/Test.hs

@@ -144,6 +144,10 @@ data Result
       -- ^ The test case's labels (see 'label')
     , failingClasses  :: Set String
       -- ^ The test case's classes (see 'classify')
+#ifndef NO_TYPEABLE
+    , witnesses :: [Witness]
+      -- ^ The existentially quantified witnesses provided by 'witness'
+#endif
     }
   -- | A property that should have failed did not
   | NoExpectedFailure
@@ -199,6 +203,11 @@ quickCheckWithResult :: Testable prop => Args -> prop -> IO Result
 quickCheckWithResult a p =
   withState a (\s -> test s (property p))
 
+-- | Re-run a property with the seed and size that failed in a run of 'quickCheckResult'.
+recheck :: Testable prop => Result -> prop -> IO ()
+recheck res@Failure{} = quickCheckWith stdArgs{ replay = Just (usedSeed res, usedSize res)} . once
+recheck _ = error "Can only recheck tests that failed with a counterexample."
+
 withState :: Args -> (State -> IO a) -> IO a
 withState a test = (if chatty a then withStdioTerminal else withNullTerminal) $ \tm -> do
      rnd <- case replay a of
@@ -481,6 +490,9 @@ runATest st prop =
                             , failingTestCase = testCase
                             , failingLabels   = P.labels res
                             , failingClasses  = Set.fromList (map fst $ filter snd $ P.classes res)
+#ifndef NO_TYPEABLE
+                            , witnesses = theWitnesses res
+#endif
                             }
  where
   (rnd1,rnd2) = split (randomSeed st)