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
122
123
|
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
#if !MIN_VERSION_base(4,8,0)
import Data.Monoid
#endif
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
}
|
