Port to use QuickCheck 2.

Most of this is trivial -- e.g. getting rid of dummy definitions of
coarbitrary, which is a separate typeclass in QC2, and changing the
parameter specs to use the new Args type.

The chunk of code that runs a QC test as an HUnit test is now quite a
bit simpler because QC's top-level interface returns a result. However,
this means that some gymnastics are required to get at the right
definition of Result in different places -- QC2 has two different types
called Result, and we use both for different jobs!

Makefile.am

@@ -23,7 +23,7 @@ GHC_OPTS = \
 	-package parsec \
 	-package pretty \
 	-package process \
-	-package @LIB_VER_quickcheck@ \
+	-package QuickCheck \
 	-package random \
 	-package regex-compat \
         -package @LIB_VER_syb@ \

backends/BackendPassesTest.hs

@@ -178,20 +178,17 @@ testTransformWaitFor5 = TestCase $ testPass "testTransformWaitFor5" exp transfor
 newtype PosInts = PosInts [Int] deriving (Show)
 
 instance Arbitrary PosInts where
-  coarbitrary = error "coarbitrary"
   arbitrary = do len <- choose (1, 10)
                  replicateM len (choose (1,1000)) >>* PosInts
 
 newtype PosInt = PosInt Int deriving (Show)
 
 instance Arbitrary PosInt where
-  coarbitrary = error "coarbitrary"
   arbitrary = choose (1,20) >>* PosInt
 
 newtype StaticTypeList = StaticTypeList [A.Type] deriving (Show)
 
 instance Arbitrary StaticTypeList where
-  coarbitrary = error "coarbitrary"
   arbitrary = do len <- choose (1,10)
                  tl <- replicateM len $ frequency
                    [ (10, return A.Int)
@@ -206,7 +203,6 @@ instance Arbitrary StaticTypeList where
 newtype DynTypeList = DynTypeList [A.Type] deriving (Show)
 
 instance Arbitrary DynTypeList where
-  coarbitrary = error "coarbitrary"
   arbitrary = do len <- choose (1,10)
                  tl <- replicateM len $ frequency
                    [ (10, return A.Int)
@@ -224,7 +220,6 @@ instance Arbitrary DynTypeList where
 newtype AbbrevTypesIs = AbbrevTypesIs ([A.Dimension], [A.Dimension], [A.Subscript]) deriving (Show)
 
 instance Arbitrary AbbrevTypesIs where
-  coarbitrary = error "coarbitrary"
   arbitrary = do lenSrc <- choose (1,10)
                  lenDest <- choose (1, lenSrc)
                  srcDims <- replicateM lenSrc $ oneof [return A.UnknownDimension, choose (1,1000) >>* dimension]

checks/ArrayUsageCheckTest.hs

@@ -30,7 +30,7 @@ import Data.Ord
 import qualified Data.Set as Set
 import Prelude hiding ((**),fail)
 import Test.HUnit
-import Test.QuickCheck hiding (check)
+import Test.QuickCheck
 
 
 import ArrayUsageCheck
@@ -543,7 +543,6 @@ instance Show MakeEquationInput where
   show = const ""
 
 instance Arbitrary MakeEquationInput where
-  coarbitrary = error "coarbitrary"
   arbitrary = generateEquationInput >>* MEI
 
 frequency' :: [(Int, StateT s Gen a)] -> StateT s Gen a
@@ -1054,7 +1053,6 @@ generateProblem = choose (1,10) >>= (\n -> replicateM n $ choose (-20,20)) >>=
     makeAns = Map.fromList
 
 instance Arbitrary OmegaTestInput where
-  coarbitrary = error "coarbitrary"
   arbitrary = generateProblem >>* OMI
 
 qcOmegaEquality :: [LabelledQuickCheckTest]
@@ -1140,7 +1138,6 @@ normaliseEquality eq = case listToMaybe $ filter (/= 0) $ elems eq of
 newtype OmegaPruneInput = OPI MutatedProblem deriving (Show)
 
 instance Arbitrary OmegaPruneInput where
-  coarbitrary = error "coarbitrary"
   arbitrary = ((generateProblem >>* snd)  >>= (return . snd) >>= mutateEquations) >>* OPI
 
 qcOmegaPrune :: [LabelledQuickCheckTest]

common/TestFramework.hs

@@ -23,14 +23,21 @@ module TestFramework where
 import Control.Monad.Error
 import Data.Generics (Data)
 import System.IO.Unsafe
+import System.Random (mkStdGen)
 import Test.HUnit hiding (Testable)
-import Test.QuickCheck hiding (check)
+import Test.QuickCheck
+import qualified Test.QuickCheck.Property as QCP
 
 import PrettyShow
 
-instance Error Result where
+-- Test.QuickCheck.Property is qualified because QuickCheck 2 has two different
+-- types both called Result: the one that Test.QuickCheck exports represents
+-- the result of running a set of tests, and QCP.Result the result of a single
+-- test. The latter's what QC 1 called Result, and what we want here.
+
+instance Error QCP.Result where
   noMsg = strMsg ""
-  strMsg s = Result (Just False) [s] []
+  strMsg s = QCP.failed { QCP.reason = s }
 
 class Monad m => TestMonad m r | m -> r where
   runTest :: m () -> r
@@ -42,9 +49,9 @@ instance TestMonad IO Assertion where
   testFailure = assertFailure
   runIO = id
   
-instance TestMonad (Either Result) Result where
-  runTest = either id (const $ Result (Just True) [] [])
-  testFailure s = Left $ Result (Just False) [] [s]
+instance TestMonad (Either QCP.Result) QCP.Result where
+  runTest = either id (const QCP.succeeded)
+  testFailure s = Left $ QCP.failed { QCP.reason = s }
   runIO f = return (unsafePerformIO f)
 
 compareForResult :: TestMonad m r => String -> (a -> String) -> (a -> a -> Bool) -> a -> a -> m ()
@@ -59,10 +66,10 @@ compareForResult msg showFunc cmpFunc exp act
 (*&&*) :: TestMonad m r => m () -> m () -> m ()
 (*&&*) = (>>)
 
-type QCProp = Either Result ()
+type QCProp = Either QCP.Result ()
 
 -- | A type-constrained version of runTest for QuickCheck Testable things:
-runQCTest :: QCProp -> Result
+runQCTest :: QCProp -> QCP.Result
 runQCTest = runTest
 
 testEqual :: (Show a, Eq a, TestMonad m r) => String -> a -> a -> m ()

common/TestUtils.hs

@@ -78,33 +78,19 @@ scaleQC (low,med,high,ext) test level
       QC_Extensive -> run ext test
   where
     run :: Testable a => Int -> a -> Test
-    run n = testCheck $ defaultConfig { configMaxTest = n }
+    run n = testCheck $ stdArgs { maxSuccess = n }
 
 -- | Run a QuickCheck test as an HUnit test.
-testCheck :: Testable a => Config -> a -> Test
-testCheck config property =
-    TestCase $ do rnd <- newStdGen
-                  tests config (evaluate property) rnd 0 0 []
-  where
-    -- | The 'tests' function from QuickCheck, modified to throw assertion
-    -- failures when something goes wrong. (This is taken from MissingH.)
-    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
-        = 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
+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"
 
 --}}}
 --{{{  building AST fragments and patterns

configure.ac

@@ -111,8 +111,6 @@ else
   AC_PICK_HASKELL_LIB_VER([base],[4],[LIB_VER_base])
   AC_PICK_HASKELL_LIB_VER([syb],[0],LIB_VER_syb)
 fi
-#For now, we need QuickCheck 1:
-AC_PICK_HASKELL_LIB_VER([QuickCheck],[1],[LIB_VER_quickcheck])
 
 PKG_CHECK_MODULES(CCSP, ccsp-1.6 >= 1.6.3,,
 	AC_MSG_WARN([CCSP not located using pkg-config; you will not be able to compile output from the C backend on this machine: ] $CCSP_PKG_ERRORS)

flow/FlowGraphTest.hs

@@ -558,7 +558,6 @@ enforceSize1 f = sized $ \n -> if n == 0 then resize 1 f else f
 
 -- | An instance of Arbitrary for A.Structured that wraps the "genStructured" function.
 instance Arbitrary (QC (A.Process, Map.Map [Meta] A.Process)) where
-  coarbitrary = error "coarbitrary"
   arbitrary = enforceSize1 $ sized $ \n -> evalStateT (genProcess n) (Id 0) >>* findEmpty >>* QC
     where
       -- Copies the value for the empty-list key into the first element of the tuple:
@@ -566,10 +565,6 @@ instance Arbitrary (QC (A.Process, Map.Map [Meta] A.Process)) where
       findEmpty xs = (fromJust $ Map.lookup [] m, m)
         where m = Map.fromList xs
 
-  -- coarbitrary is for defined "twiddle" functions over data generated by arbitrary.
-  -- For example, we could have the twiddle functions changing an expression
-  -- in the tree.  I don't think this would be of use right now, given what we're testing
-
 instance Show (QC (A.Process, Map.Map [Meta] A.Process)) where
   show (QC (p,m)) = pshow (p,nub $ concat $ Map.keys m)
 
@@ -808,13 +803,13 @@ pickFuncRep gr = Map.fromList $ filter ((/= emptyMeta) . fst) $ map (helpApplyFu
 -- | It is important to have these functions in the right ratio.  The number of possible trees is
 -- 2^N, where N is the test size.  Therefore I suggest keeping N <= 10 as a sensible limit.
 -- Hence, if there are 1000 tests, we divide the test number by 100 to get the test size.
-configForSize :: Int -> Config
-configForSize n = defaultConfig { configMaxTest = n, configSize = \x -> x `div` scale }
+argsForSize :: Int -> Args
+argsForSize n = stdArgs { maxSuccess = n, maxSize = n `div` scale }
   where
     scale = n `div` 10
 
 deepCheck :: Testable a => a -> QuickCheckTest
-deepCheck test level = (flip testCheck) test $ configForSize $
+deepCheck test level = (flip testCheck) test $ argsForSize $
   case level of 
     QC_Low -> 100
     QC_Medium -> 1000