Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP

Loading…

Several changes #32

Merged
merged 5 commits into from

2 participants

@feuerbach

No description provided.

feuerbach added some commits
@feuerbach feuerbach Document optionsDescription 841fd20
@feuerbach feuerbach Expose SuppliedRunnerOptions
It is used in the type of optionsDescription, which is exposed.
1b4b4fc
@feuerbach feuerbach Expose TestPattern from Test.Framework.Runners.Options
It is a field type of RunnerOptions', which is exposed.
c396871
@feuerbach feuerbach Add TestRunner and runTestTree
The TestRunner class makes folding the Test structure easier.

His also led to refactoring, and now actual running (instance
TestRunner StdRunner) is separated from maintaining the path and test filtering
(runTestTree).

(HINT: the diff looks less daunting when viewed whitespace-insensitive (-w),
since some indentation had to be changed.)
d408d16
@feuerbach feuerbach Add Test.Framework.Runners.API 61e7c41
@batterseapower batterseapower merged commit b95acfb into batterseapower:master
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment
Commits on Dec 12, 2012
  1. @feuerbach

    Document optionsDescription

    feuerbach authored
  2. @feuerbach

    Expose SuppliedRunnerOptions

    feuerbach authored
    It is used in the type of optionsDescription, which is exposed.
  3. @feuerbach

    Expose TestPattern from Test.Framework.Runners.Options

    feuerbach authored
    It is a field type of RunnerOptions', which is exposed.
Commits on Dec 28, 2012
  1. @feuerbach

    Add TestRunner and runTestTree

    feuerbach authored
    The TestRunner class makes folding the Test structure easier.
    
    His also led to refactoring, and now actual running (instance
    TestRunner StdRunner) is separated from maintaining the path and test filtering
    (runTestTree).
    
    (HINT: the diff looks less daunting when viewed whitespace-insensitive (-w),
    since some indentation had to be changed.)
  2. @feuerbach
This page is out of date. Refresh to see the latest.
View
8 core/Test/Framework/Runners/API.hs
@@ -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
View
5 core/Test/Framework/Runners/Console.hs
@@ -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"]
View
105 core/Test/Framework/Runners/Core.hs
@@ -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 {
View
7 core/Test/Framework/Runners/Options.hs
@@ -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)
- }
+ }
View
1  core/test-framework.cabal
@@ -28,6 +28,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
Something went wrong with that request. Please try again.