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
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
|
module Test.Framework.Runners.Core (
RunTest(..), RunningTest, SomeImproving(..), FinishedTest, runTests,
TestRunner(..), runTestTree
) where
import Test.Framework.Core
import Test.Framework.Improving
import Test.Framework.Options
import Test.Framework.Runners.Options
import Test.Framework.Runners.TestPattern
import Test.Framework.Runners.ThreadPool
import Test.Framework.Seed
import Test.Framework.Utilities
import Control.Concurrent.MVar
import Control.Exception (mask, finally, onException)
import Control.Monad
import Data.Maybe
import Data.Monoid
import Data.Typeable
-- | A test that has been executed or is in the process of execution
data RunTest a = RunTest TestName TestTypeName a
| RunTestGroup TestName [RunTest a]
deriving (Show)
data SomeImproving = forall i r. TestResultlike i r => SomeImproving (i :~> r)
type RunningTest = RunTest SomeImproving
type FinishedTest = RunTest (String, Bool)
runTests :: CompleteRunnerOptions -- ^ Top-level runner options
-> [Test] -- ^ Tests to run
-> IO [RunningTest]
runTests ropts tests = do
let test_patterns = unK $ ropt_test_patterns ropts
test_options = unK $ ropt_test_options ropts
(run_tests, actions) <- runTests' $ map (runTestTree test_options test_patterns) tests
_ <- executeOnPool (unK $ ropt_threads ropts) actions
return run_tests
-- | 'TestRunner' class simplifies folding a 'Test'. You need to specify
-- the important semantic actions by instantiating this class, and
-- 'runTestTree' will take care of recursion and test filtering.
class TestRunner b where
-- | How to handle a single test
runSimpleTest :: (Testlike i r t, Typeable t) => TestOptions -> TestName -> t -> b
-- | How to skip a test that doesn't satisfy the pattern
skipTest :: b
-- | How to handle an IO test (created with 'buildTestBracketed')
runIOTest :: IO (b, IO ()) -> b
-- | How to run a test group
runGroup :: TestName -> [b] -> b
-- | Run the test tree using a 'TestRunner'
runTestTree
:: TestRunner b
=> TestOptions
-> [TestPattern]
-- ^ skip the tests that do not match any of these patterns, unless
-- the list is empty
-> Test
-> b
runTestTree initialOpts pats topTest = go initialOpts [] topTest
where
go opts path t = case t of
Test name testlike ->
if null pats || any (`testPatternMatches` (path ++ [name])) pats
then runSimpleTest opts name testlike
else skipTest
TestGroup name tests ->
let path' = path ++ [name]
in runGroup name $ map (go opts path') tests
PlusTestOptions extra_topts test -> go (opts `mappend` extra_topts) path test
BuildTestBracketed build ->
runIOTest $ onLeft (go opts path) `fmap` build
newtype StdRunner = StdRunner { run :: IO (Maybe (RunningTest, [IO ()])) }
instance TestRunner StdRunner where
runSimpleTest topts name testlike = StdRunner $ do
(result, action) <- runTest (completeTestOptions topts) testlike
return (Just (RunTest name (testTypeName testlike) (SomeImproving result), [action]))
skipTest = StdRunner $ return Nothing
runGroup name tests = StdRunner $ do
(results, actions) <- runTests' tests
return $ if null results then Nothing else Just ((RunTestGroup name results), actions)
runIOTest ioTest = StdRunner $ mask $ \restore -> ioTest >>= \(StdRunner test, cleanup) -> do
mb_res <- restore test `onException` cleanup
case mb_res of
-- No sub-tests: perform the cleanup NOW
Nothing -> cleanup >> return Nothing
Just (run_test, actions) -> do
-- Sub-tests: perform the cleanup as soon as each of them have completed
(mvars, actions') <- liftM unzip $ forM actions $ \action -> do
mvar <- newEmptyMVar
return (mvar, action `finally` putMVar mvar ())
-- NB: the takeMVar action MUST be last in the list because the returned actions are
-- scheduled left-to-right, and we want all the actions we depend on to be scheduled
-- before we wait for them to complete, or we might deadlock.
--
-- FIXME: this is a bit of a hack because it uses one pool thread just waiting
-- for some other pool threads to complete! Switch to parallel-io?
return $ Just (run_test, actions' ++ [(cleanup >> mapM_ takeMVar mvars)])
runTests' :: [StdRunner] -> IO ([RunningTest], [IO ()])
runTests' = fmap (onRight concat . unzip . catMaybes) . mapM run
completeTestOptions :: TestOptions -> CompleteTestOptions
completeTestOptions to = TestOptions {
topt_seed = K $ topt_seed to `orElse` RandomSeed,
topt_maximum_generated_tests = K $ topt_maximum_generated_tests to `orElse` 100,
topt_maximum_unsuitable_generated_tests = K $ topt_maximum_unsuitable_generated_tests to `orElse` 1000,
topt_maximum_test_size = K $ topt_maximum_test_size to `orElse` 100,
topt_maximum_test_depth = K $ topt_maximum_test_depth to `orElse` 5,
topt_timeout = K $ topt_timeout to `orElse` Nothing
}
|
