Revision 23fe06c2 htools/test.hs
| b/htools/test.hs | ||
|---|---|---|
| 27 | 27 |
|
| 28 | 28 |
import Data.IORef |
| 29 | 29 |
import Test.QuickCheck |
| 30 |
import System.Console.GetOpt |
|
| 30 |
import System.Console.GetOpt ()
|
|
| 31 | 31 |
import System.IO |
| 32 | 32 |
import System.Exit |
| 33 | 33 |
import System (getArgs) |
| ... | ... | |
| 63 | 63 |
|
| 64 | 64 |
-- | Wrapper over a test runner with error counting. |
| 65 | 65 |
wrapTest :: IORef Int |
| 66 |
-> (Args -> IO Result) |
|
| 66 |
-> (Args -> IO Result, String)
|
|
| 67 | 67 |
-> Args |
| 68 |
-> IO (Result, Char) |
|
| 69 |
wrapTest ir test opts = do
|
|
| 68 |
-> IO (Result, Char, String)
|
|
| 69 |
wrapTest ir (test, desc) opts = do
|
|
| 70 | 70 |
r <- test opts |
| 71 | 71 |
c <- case r of |
| 72 | 72 |
Success {} -> return '.'
|
| 73 | 73 |
GaveUp {} -> return '?'
|
| 74 | 74 |
Failure {} -> incIORef ir >> return '#'
|
| 75 | 75 |
NoExpectedFailure {} -> incIORef ir >> return '*'
|
| 76 |
return (r, c) |
|
| 76 |
return (r, c, desc) |
|
| 77 |
|
|
| 78 |
runTests :: String |
|
| 79 |
-> Args |
|
| 80 |
-> [Args -> IO (Result, Char, String)] |
|
| 81 |
-> Int |
|
| 82 |
-> IO [(Result, String)] |
|
| 77 | 83 |
|
| 78 | 84 |
runTests name opts tests max_count = do |
| 79 | 85 |
_ <- printf "%25s : " name |
| 80 | 86 |
hFlush stdout |
| 81 | 87 |
results <- mapM (\t -> do |
| 82 |
(r, c) <- t opts |
|
| 88 |
(r, c, desc) <- t opts
|
|
| 83 | 89 |
putChar c |
| 84 | 90 |
hFlush stdout |
| 85 |
return r
|
|
| 91 |
return (r, desc)
|
|
| 86 | 92 |
) tests |
| 87 |
let alldone = sum . map numTests $ results
|
|
| 93 |
let alldone = sum . map (numTests . fst) $ results
|
|
| 88 | 94 |
_ <- printf "%*s(%d)\n" (max_count - length tests + 1) " " alldone |
| 89 |
mapM_ (\(idx, r) ->
|
|
| 95 |
mapM_ (\(r, desc) ->
|
|
| 90 | 96 |
case r of |
| 91 | 97 |
Failure { output = o, usedSeed = u, usedSize = size } ->
|
| 92 |
printf "Test %d failed (seed was %s, test size %d): %s\n"
|
|
| 93 |
idx (show u) size o
|
|
| 98 |
printf "Test %s failed (seed was %s, test size %d): %s\n"
|
|
| 99 |
desc (show u) size o
|
|
| 94 | 100 |
GaveUp { numTests = passed } ->
|
| 95 |
printf "Test %d incomplete: gave up with only %d\
|
|
| 101 |
printf "Test %s incomplete: gave up with only %d\
|
|
| 96 | 102 |
\ passes after discarding %d tests\n" |
| 97 |
idx passed (maxDiscard opts)
|
|
| 103 |
desc passed (maxDiscard opts)
|
|
| 98 | 104 |
_ -> return () |
| 99 |
) $ zip ([1..]::[Int]) results
|
|
| 105 |
) results |
|
| 100 | 106 |
return results |
| 101 | 107 |
|
| 102 |
allTests :: [(String, Args, [Args -> IO Result])]
|
|
| 108 |
allTests :: [(Args, (String, [(Args -> IO Result, String)]))]
|
|
| 103 | 109 |
allTests = |
| 104 |
[ ("Utils", fast, testUtils)
|
|
| 105 |
, ("PeerMap", fast, testPeerMap)
|
|
| 106 |
, ("Container", fast, testContainer)
|
|
| 107 |
, ("Instance", fast, testInstance)
|
|
| 108 |
, ("Node", fast, testNode)
|
|
| 109 |
, ("Text", fast, testText)
|
|
| 110 |
, ("OpCodes", fast, testOpCodes)
|
|
| 111 |
, ("Jobs", fast, testJobs)
|
|
| 112 |
, ("Loader", fast, testLoader)
|
|
| 113 |
, ("Types", fast, testTypes)
|
|
| 114 |
, ("Cluster", slow, testCluster)
|
|
| 110 |
[ (fast, testUtils) |
|
| 111 |
, (fast, testPeerMap) |
|
| 112 |
, (fast, testContainer) |
|
| 113 |
, (fast, testInstance) |
|
| 114 |
, (fast, testNode) |
|
| 115 |
, (fast, testText) |
|
| 116 |
, (fast, testOpCodes) |
|
| 117 |
, (fast, testJobs) |
|
| 118 |
, (fast, testLoader) |
|
| 119 |
, (fast, testTypes) |
|
| 120 |
, (slow, testCluster) |
|
| 115 | 121 |
] |
| 116 | 122 |
|
| 117 | 123 |
transformTestOpts :: Args -> Options -> IO Args |
| ... | ... | |
| 135 | 141 |
(opts, args) <- parseOpts cmd_args "test" options |
| 136 | 142 |
let tests = if null args |
| 137 | 143 |
then allTests |
| 138 |
else filter (\(name, _, _) -> name `elem` args) allTests
|
|
| 139 |
max_count = maximum $ map (\(_, _, t) -> length t) tests
|
|
| 140 |
mapM_ (\(name, targs, tl) ->
|
|
| 144 |
else filter (\(_, (name, _)) -> name `elem` args) allTests
|
|
| 145 |
max_count = maximum $ map (\(_, (_, t)) -> length t) tests
|
|
| 146 |
mapM_ (\(targs, (name, tl)) ->
|
|
| 141 | 147 |
transformTestOpts targs opts >>= \newargs -> |
| 142 | 148 |
runTests name newargs (wrap tl) max_count) tests |
| 143 | 149 |
terr <- readIORef errs |
Also available in: Unified diff