From e40226ce0252f154f603f34eaf74fcb146f5e11b Mon Sep 17 00:00:00 2001
From: Adam Sampson <ats@offog.org>
Date: Thu, 21 Jul 2011 09:51:54 +0000
Subject: [PATCH] Make Tock work with QuickCheck 2.1.0.3.

This is the slightly older version that Debian stable is current
shipping; it has fewer fields in its Result structure, so we need to be
more flexible about pattern-matching (which is probably a good thing
anyway).
---
 common/TestFramework.hs |  4 ++--
 common/TestUtils.hs     | 12 ++++++------
 2 files changed, 8 insertions(+), 8 deletions(-)

diff --git a/common/TestFramework.hs b/common/TestFramework.hs
index 73e4cbe..342c1e5 100644
--- a/common/TestFramework.hs
+++ b/common/TestFramework.hs
@@ -37,7 +37,7 @@ import PrettyShow
 
 instance Error QCP.Result where
   noMsg = strMsg ""
-  strMsg s = QCP.failed { QCP.reason = s }
+  strMsg s = QCP.result { QCP.ok = Just False, QCP.reason = s }
 
 class Monad m => TestMonad m r | m -> r where
   runTest :: m () -> r
@@ -51,7 +51,7 @@ instance TestMonad IO Assertion where
   
 instance TestMonad (Either QCP.Result) QCP.Result where
   runTest = either id (const QCP.succeeded)
-  testFailure s = Left $ QCP.failed { QCP.reason = s }
+  testFailure s = Left $ QCP.result { QCP.ok = Just False, QCP.reason = s }
   runIO f = return (unsafePerformIO f)
 
 compareForResult :: TestMonad m r => String -> (a -> String) -> (a -> a -> Bool) -> a -> a -> m ()
diff --git a/common/TestUtils.hs b/common/TestUtils.hs
index 3d3484d..01e2d55 100644
--- a/common/TestUtils.hs
+++ b/common/TestUtils.hs
@@ -85,12 +85,12 @@ testCheck :: Testable a => Args -> a -> Test
 testCheck args property =
     TestCase $ do result <- quickCheckWithResult args property
                   case result of
-                    Success _ _ _ -> return ()
-                    GaveUp _ _ _ -> return ()
-                    Failure numTests _ _ _ reason _ _ ->
-                      assertFailure $ "Falsifiable, after " ++ show numTests ++ " tests:\n" ++ reason
-                    NoExpectedFailure numTests _ _ ->
-                      assertFailure $ "No expected failure, after " ++ show numTests ++ " tests"
+                    Success {} -> return ()
+                    GaveUp {} -> return ()
+                    Failure {} ->
+                      assertFailure $ "Falsifiable: " ++ (reason result)
+                    NoExpectedFailure {} ->
+                      assertFailure $ "No expected failure"
 
 --}}}
 --{{{  building AST fragments and patterns