Permalink
Browse files

Merge pull request #32 from feuerbach/master

Several changes
  • Loading branch information...
2 parents 5e3f58f + 61e7c41 commit b95acfb627ae6d53a74f0d6f6018a1b3debb7746 @batterseapower committed Jan 1, 2013
@@ -0,0 +1,8 @@
+-- | This module exports everything that you need to be able to create your own test runner.
+module Test.Framework.Runners.API (
+ module Test.Framework.Runners.Options,
+ TestRunner(..), runTestTree
+ ) where
+
+import Test.Framework.Runners.Options
+import Test.Framework.Runners.Core
@@ -1,6 +1,7 @@
module Test.Framework.Runners.Console (
defaultMain, defaultMainWithArgs, defaultMainWithOpts,
- optionsDescription, interpretArgs, interpretArgsOrExit
+ SuppliedRunnerOptions, optionsDescription,
+ interpretArgs, interpretArgsOrExit
) where
import Test.Framework.Core
@@ -35,6 +36,8 @@ instance Functor ArgDescr where
-- @Just@ simply gives us the contribution to overall options by the command line option.
type SuppliedRunnerOptions = Maybe RunnerOptions
+-- | Options understood by test-framework. This can be used to add more
+-- options to the tester executable.
optionsDescription :: [OptDescr SuppliedRunnerOptions]
optionsDescription = [
Option [] ["help"]
@@ -1,5 +1,6 @@
module Test.Framework.Runners.Core (
RunTest(..), RunningTest, SomeImproving(..), FinishedTest, runTests,
+ TestRunner(..), runTestTree
) where
import Test.Framework.Core
@@ -16,6 +17,7 @@ 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
@@ -33,45 +35,80 @@ runTests :: CompleteRunnerOptions -- ^ Top-level runner options
-> IO [RunningTest]
runTests ropts tests = do
let test_patterns = unK $ ropt_test_patterns ropts
- use_test path name = null test_patterns || any (`testPatternMatches` (path ++ [name])) test_patterns
- (run_tests, actions) <- runTests' use_test [] (unK $ ropt_test_options ropts) tests
+ 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
-runTest' :: ([String] -> String -> Bool) -> [String]
- -> TestOptions -> Test -> IO (Maybe (RunningTest, [IO ()]))
-runTest' use_test path topts (Test name testlike)
- | use_test path name = do
- (result, action) <- runTest (completeTestOptions topts) testlike
- return (Just (RunTest name (testTypeName testlike) (SomeImproving result), [action]))
- | otherwise = return Nothing
-runTest' use_test path topts (TestGroup name tests) = do
- (results, actions) <- runTests' use_test (path ++ [name]) topts tests
- return $ if null results then Nothing else Just ((RunTestGroup name results), actions)
-runTest' use_test path topts (PlusTestOptions extra_topts test) = runTest' use_test path (topts `mappend` extra_topts) test
-runTest' use_test path topts (BuildTestBracketed build) = mask $ \restore -> build >>= \(test, cleanup) -> do
- mb_res <- restore (runTest' use_test path topts 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' :: ([String] -> String -> Bool) -> [String]
- -> TestOptions -> [Test] -> IO ([RunningTest], [IO ()])
-runTests' use_test path topts = fmap (onRight concat . unzip . catMaybes) . mapM (runTest' use_test path topts)
+-- | 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 {
@@ -1,4 +1,7 @@
-module Test.Framework.Runners.Options where
+module Test.Framework.Runners.Options (
+ module Test.Framework.Runners.Options,
+ TestPattern
+ ) where
import Test.Framework.Options
import Test.Framework.Utilities
@@ -42,4 +45,4 @@ instance Monoid (RunnerOptions' Maybe) where
ropt_color_mode = getLast (mappendBy (Last . ropt_color_mode) ro1 ro2),
ropt_hide_successes = getLast (mappendBy (Last . ropt_hide_successes) ro1 ro2),
ropt_list_only = getLast (mappendBy (Last . ropt_list_only) ro1 ro2)
- }
+ }
@@ -24,6 +24,7 @@ Library
Test.Framework.Providers.API
Test.Framework.Runners.Console
Test.Framework.Runners.Options
+ Test.Framework.Runners.API
Test.Framework.Seed
Other-Modules: Test.Framework.Core

0 comments on commit b95acfb

Please sign in to comment.