1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
|
-- |
-- Copyright : (c) 2011 Duncan Coutts
--
-- test-framework stub API
--
-- Currently we cannot use the nice test-framework package for this testsuite
-- since test-framework indirectly depends on bytestring and this makes cabal
-- think we've got a circular dependency.
--
-- On the other hand, it's very nice to have the testsuite run automatically
-- rather than being a totally separate package (which would fix).
--
-- So until we can fix that we implement our own trivial layer.
--
module TestFramework where
import Test.QuickCheck (Testable(..))
import Test.QuickCheck.Test
import Text.Printf
import System.Environment
import Control.Monad
import Control.Exception
-- Ideally we'd be using:
--import Test.Tasty
--import Test.Tasty.QuickCheck
type TestName = String
type Test = [(TestName, Int -> IO (Bool, Int))]
testGroup :: String -> [Test] -> Test
testGroup _ = concat
testProperty :: Testable a => String -> a -> Test
testProperty name p = [(name, runQcTest)]
where
runQcTest n = do
result <- quickCheckWithResult testArgs p
case result of
Success {} -> return (True, numTests result)
_ -> return (False, numTests result)
where
testArgs = stdArgs {
maxSuccess = n
--chatty = ... if we want to increase verbosity
}
assertBool :: String -> Bool -> Bool
assertBool _ = id
testCase :: String -> Bool -> Test
testCase name tst = [(name, runPlainTest)]
where
runPlainTest _ = do
r <- evaluate tst
putStrLn "+++ OK, passed test."
return (r, 1)
defaultMain :: [Test] -> IO ()
defaultMain = runTests . concat
runTests :: [(String, Int -> IO (Bool,Int))] -> IO ()
runTests tests = do
x <- getArgs
let n = if null x then 100 else read . head $ x
(results, passed) <- liftM unzip $ mapM (\(s,a) -> printf "%-40s: " s >> a n) tests
_ <- printf "Passed %d tests!\n" (sum passed)
when (not . and $ results) $ fail "Not all tests passed!"
|
