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