From 6df110dce423183b060e93c26fe26946874e937c Mon Sep 17 00:00:00 2001 From: Adam Sampson Date: Wed, 12 Mar 2008 19:38:02 +0000 Subject: [PATCH] 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 | 60 ++++++++++++++++++++++++++----------------- common/TestUtils.hs | 40 ++++++++++++++++++++++++++--- flow/FlowGraphTest.hs | 2 +- 3 files changed, 73 insertions(+), 29 deletions(-) diff --git a/TestMain.hs b/TestMain.hs index 12299d6..ebe14f9 100644 --- a/TestMain.hs +++ b/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 nonOpts) $ err ("Options not recognised: " ++ concat nonOpts) + when (not $ null errs) $ + 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) - tests' <- sequence tests - testsToRun <- case (find (== ListTests) opts, findJust opts) of - (Just _, _) -> do mapM_ putStrLn $ "Possible test names: " : map fst (getLabels $ map fst tests') - return [] - (_,Just name) -> return $ map snd (filter ((isInfixOf name) . fst) (getLabels $ map fst tests')) - (_,Nothing) -> return $ map fst tests' + Left unknown -> err $ "Unknown level: " ++ unknown + + allSets <- sequence 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 [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) $ - case qcLevel of - -- Monadic mess! - Just level -> mapM_ (runQCTest level) $ concatMap snd tests' - Nothing -> return () - - when (hunitFailed /= 0) $ + let numFailed = errors counts + failures counts + when (numFailed /= 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 () - runQCTest level (label, test) = putStr (label ++ ": ") >> test level + makeQCTest :: QuickCheckLevel -> [LabelledQuickCheckTest] -> Test + makeQCTest level ts = + TestList [TestLabel s $ t level | (s, t) <- ts] - getLabels :: [Test] -> [(String, Test)] - getLabels = map (uncurry getLabel) . zip [0..] + getLabels :: [TestSet] -> [(String, TestSet)] + getLabels tss = [getLabel n t | (n, t) <- zip [0..] tss] where - getLabel :: Int -> Test -> (String, Test) - getLabel _ t@(TestLabel label _) = (label, t) + getLabel :: Int -> TestSet -> (String, TestSet) + 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 diff --git a/common/TestUtils.hs b/common/TestUtils.hs index c33f496..3d5e0bf 100644 --- a/common/TestUtils.hs +++ b/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 n = check (defaultConfig { configMaxTest = n }) + run :: Testable a => Int -> a -> Test + 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 diff --git a/flow/FlowGraphTest.hs b/flow/FlowGraphTest.hs index 470663d..d5aee25 100644 --- a/flow/FlowGraphTest.hs +++ b/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