Wrap QuickCheck tests into HUnit tests.

This means all the tests now get run as part of one list, and HUnit keeps track
of the number of failures for us. (The reason I was doing this was so that
tocktest will exit non-zero on QuickCheck test failure too.)

As part of this, I've reworked TestMain's main function quite a bit. It'll now
filter QuickCheck tests into response to options too.

TestMain.hs

@@ -73,6 +73,8 @@ data TestOption =
   | RunJust String
   deriving (Eq)
 
+type TestSet = (Test, [LabelledQuickCheckTest])
+
 -- We run all the HUnit tests before all the QuickCheck tests.
 -- We run them apart so that the output from QuickCheck doesn't get
 -- confusing by being amongst the HUnit output,
@@ -80,32 +82,41 @@ data TestOption =
 -- interesting (and most worked on tests) so we see failures earlier.
 main :: IO ()
 main = do (opts, nonOpts, errs) <- getArgs >>* getOpt RequireOrder options
-          when (not $ null errs) $ err (concat errs)
+          when (not $ null errs) $
-          when (not $ null nonOpts) $ err ("Options not recognised: " ++ concat nonOpts)
+            err $ concat errs
+          when (not $ null nonOpts) $
+            err $ "Options not recognised: " ++ concat nonOpts
+
           qcLevel <- case findLevel opts of
                        Right level -> return level
-                       Left unknownLevel -> err ("Unknown level: " ++ unknownLevel)
+                       Left unknown -> err $ "Unknown level: " ++ unknown
-          tests' <- sequence tests
+
-          testsToRun <- case (find (== ListTests) opts, findJust opts) of
+          allSets <- sequence tests
-            (Just _, _) -> do mapM_ putStrLn $ "Possible test names: " : map fst (getLabels $ map fst tests')
+          let labelled = getLabels allSets
+          selectedSets <-
+            case (find (== ListTests) opts, findJust opts) of
+              (Just _, _) ->
+                do mapM_ putStrLn $ "Possible test names: " : map fst labelled
                    return []
-            (_,Just name) -> return $ map snd (filter ((isInfixOf name) . fst) (getLabels $ map fst tests'))
+              (_, Just name) ->
-            (_,Nothing) -> return $ map fst tests'
+                return [t | (n, t) <- labelled, name `isInfixOf` n]
+              _ -> return allSets
+
+          let hunitTests = map fst selectedSets
+          let qcTests = case qcLevel of
+                          Just level ->
+                            map (makeQCTest level . snd) selectedSets
+                          Nothing -> []
+          let testsToRun = hunitTests ++ qcTests
 
           (counts, _) <- let (h, reps) = case findType opts of
                                            Just True -> (stdout, False)
                                            _ -> (stderr, True)
                              test = TestList testsToRun
                          in runTestText (putTextToHandle h reps) test
-          let hunitFailed = errors counts + failures counts
 
-          when (not $ null testsToRun) $
+          let numFailed = errors counts + failures counts
-            case qcLevel of
+          when (numFailed /= 0) $
-              -- Monadic mess!
-              Just level -> mapM_ (runQCTest level) $ concatMap snd tests'
-              Nothing -> return ()
-
-          when (hunitFailed /= 0) $
             exitWith $ ExitFailure 1
   where
     err msg = ioError (userError (msg ++ usageInfo header options))
@@ -141,17 +152,18 @@ main = do (opts, nonOpts, errs) <- getArgs >>* getOpt RequireOrder options
                      "extensive" -> Right $ Just QC_Extensive
                      unknown -> Left unknown
 
-    runQCTest :: QuickCheckLevel -> LabelledQuickCheckTest -> IO ()
+    makeQCTest :: QuickCheckLevel -> [LabelledQuickCheckTest] -> Test
-    runQCTest level (label, test) = putStr (label ++ ": ") >> test level
+    makeQCTest level ts =
+        TestList [TestLabel s $ t level | (s, t) <- ts]
 
-    getLabels :: [Test] -> [(String, Test)]
+    getLabels :: [TestSet] -> [(String, TestSet)]
-    getLabels = map (uncurry getLabel) . zip [0..]
+    getLabels tss = [getLabel n t | (n, t) <- zip [0..] tss]
       where
-        getLabel :: Int -> Test -> (String, Test)
+        getLabel :: Int -> TestSet -> (String, TestSet)
-        getLabel _ t@(TestLabel label _) = (label, t)
+        getLabel _ t@(TestLabel label _, _) = (label, t)
         getLabel n t = ("Unknown test: " ++ show n, t)
 
-    tests :: [IO (Test, [LabelledQuickCheckTest])]
+    tests :: [IO TestSet]
     tests = [
               ArrayUsageCheckTest.ioqcTests
               ,return BackendPassesTest.qcTests

common/TestUtils.hs

@@ -1,6 +1,6 @@
 {-
 Tock: a compiler for parallel languages
-Copyright (C) 2007  University of Kent
+Copyright (C) 2007, 2008  University of Kent
 
 This program is free software; you can redistribute it and/or modify it
 under the terms of the GNU General Public License as published by the
@@ -41,6 +41,7 @@ module TestUtils where
 import Control.Monad.State
 import Data.Generics
 import qualified Data.Map as Map
+import System.Random
 import Test.HUnit hiding (State,Testable)
 import Test.QuickCheck
 
@@ -61,10 +62,11 @@ import Utils
 data QuickCheckLevel = QC_Low | QC_Medium | QC_High | QC_Extensive
   deriving (Show, Eq, Ord)
 
-type QuickCheckTest = QuickCheckLevel -> IO ()
+type QuickCheckTest = QuickCheckLevel -> Test
 
 type LabelledQuickCheckTest = (String, QuickCheckTest)
 
+-- | Adjust the size of a QuickCheck test depending on the check level.
 scaleQC :: Testable a => (Int,Int,Int,Int) -> a -> QuickCheckTest
 scaleQC (low,med,high,ext) test level
   = case level of
@@ -73,8 +75,38 @@ scaleQC (low,med,high,ext) test level
       QC_High      -> run high test
       QC_Extensive -> run ext test
   where
-    run :: Testable a => Int -> a -> IO ()
+    run :: Testable a => Int -> a -> Test
-    run n = check (defaultConfig { configMaxTest = n })
+    run n = testCheck $ defaultConfig { configMaxTest = 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               =
+          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
 
 --}}}
 --{{{  building AST fragments and patterns

flow/FlowGraphTest.hs

@@ -749,7 +749,7 @@ configForSize n = defaultConfig { configMaxTest = n, configSize = \x -> x `div`
     scale = n `div` 10
 
 deepCheck :: Testable a => a -> QuickCheckTest
-deepCheck test level = (flip check) test $ configForSize $
+deepCheck test level = (flip testCheck) test $ configForSize $
   case level of 
     QC_Low -> 100
     QC_Medium -> 1000