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.
This commit is contained in:
Adam Sampson
parent
8120a75186
commit
6df110dce4
60
TestMain.hs
60
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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user