test-framework 0.8 → 0.8.0.1
raw patch · 6 files changed
+111/−63 lines, 6 filesdep −extensible-exceptionsdep ~basenew-uploader
Dependencies removed: extensible-exceptions
Dependency ranges changed: base
Files
- Test/Framework/Runners/API.hs +8/−0
- Test/Framework/Runners/Console.hs +14/−10
- Test/Framework/Runners/Console/Utilities.hs +1/−1
- Test/Framework/Runners/Core.hs +70/−33
- Test/Framework/Runners/Options.hs +4/−1
- test-framework.cabal +14/−18
+ Test/Framework/Runners/API.hs view
@@ -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
Test/Framework/Runners/Console.hs view
@@ -1,6 +1,7 @@ module Test.Framework.Runners.Console ( defaultMain, defaultMainWithArgs, defaultMainWithOpts,- optionsDescription, interpretArgs, interpretArgsOrExit+ SuppliedRunnerOptions, optionsDescription,+ interpretArgs, interpretArgsOrExit ) where import Test.Framework.Core@@ -22,7 +23,7 @@ import Data.Monoid -+#if !MIN_VERSION_base(4,7,0) instance Functor OptDescr where fmap f (Option a b arg_descr c) = Option a b (fmap f arg_descr) c @@ -30,11 +31,14 @@ fmap f (NoArg a) = NoArg (f a) fmap f (ReqArg g s) = ReqArg (f . g) s fmap f (OptArg g s) = OptArg (f . g) s+#endif -- | @Nothing@ signifies that usage information should be displayed. -- @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"]@@ -94,7 +98,7 @@ interpretArgs args = do prog_name <- getProgName let usage_header = "Usage: " ++ prog_name ++ " [OPTIONS]"- + case getOpt Permute optionsDescription args of (oas, n, []) | Just os <- sequence oas -> return $ Right (mconcat os, n) (_, _, errs) -> return $ Left (concat errs ++ usageInfo usage_header optionsDescription)@@ -130,11 +134,11 @@ defaultMainWithOpts :: [Test] -> RunnerOptions -> IO () defaultMainWithOpts tests ropts = do let ropts' = completeRunnerOptions ropts- - when (unK$ ropt_list_only ropts') $ do ++ when (unK$ ropt_list_only ropts') $ do putStr $ listTests tests exitSuccess- + -- Get a lazy list of the test results, as executed in parallel running_tests <- runTests ropts' tests @@ -146,12 +150,12 @@ -- Show those test results to the user as we get them fin_tests <- showRunTestsTop isplain (unK $ ropt_hide_successes ropts') running_tests let test_statistics' = gatherStatistics fin_tests- + -- Output XML report (if requested) case ropt_xml_output ropts' of K (Just file) -> XML.produceReport (unK (ropt_xml_nested ropts')) test_statistics' fin_tests >>= writeFile file _ -> return ()- + -- Set the error code depending on whether the tests succeded or not exitWith $ if ts_no_failures test_statistics' then ExitSuccess@@ -160,9 +164,9 @@ -- | Print out a list of available tests. listTests :: [Test] -> String listTests tests = "\ntest-framework: All available tests:\n"++- "====================================\n"++ + "====================================\n"++ concat (map (++"\n") (concatMap (showTest "") tests))- where + where showTest :: String -> Test -> [String] showTest path (Test name _testlike) = [" "++path ++ name] showTest path (TestGroup name tests) = concatMap (showTest (path++":"++name)) tests
Test/Framework/Runners/Console/Utilities.hs view
@@ -5,7 +5,7 @@ import System.Console.ANSI import System.IO -import Control.Exception.Extensible+import Control.Exception (bracket) hideCursorDuring :: IO a -> IO a
Test/Framework/Runners/Core.hs view
@@ -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.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 @@ -> 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)])+-- | 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 -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)+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 {
Test/Framework/Runners/Options.hs view
@@ -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
test-framework.cabal view
@@ -1,6 +1,6 @@ Name: test-framework-Version: 0.8-Cabal-Version: >= 1.2.3+Version: 0.8.0.1+Cabal-Version: >= 1.6 Category: Testing Synopsis: Framework for running and organising tests, with HUnit and QuickCheck support Description: Allows tests such as QuickCheck properties and HUnit test cases to be assembled into test groups, run in@@ -9,14 +9,11 @@ License: BSD3 License-File: LICENSE Author: Max Bolingbroke <batterseapower@hotmail.com>-Maintainer: Max Bolingbroke <batterseapower@hotmail.com>-Homepage: http://batterseapower.github.com/test-framework/+Maintainer: Libraries List <libraries@haskell.org>+Homepage: https://batterseapower.github.io/test-framework/+Bug-Reports: https://github.com/haskell/test-framework/issues/ Build-Type: Simple -Flag SplitBase- Description: Choose the new smaller, split-up base package- Default: True- Flag Tests Description: Build the tests Default: False@@ -28,6 +25,7 @@ Test.Framework.Providers.API Test.Framework.Runners.Console Test.Framework.Runners.Options+ Test.Framework.Runners.API Test.Framework.Seed Other-Modules: Test.Framework.Core@@ -49,13 +47,10 @@ Test.Framework.Utilities Build-Depends: ansi-terminal >= 0.4.0, ansi-wl-pprint >= 0.5.1,- regex-posix >= 0.72, extensible-exceptions >= 0.1.1,+ base >= 4.3 && < 5, random >= 1.0, containers >= 0.1,+ regex-posix >= 0.72, old-locale >= 1.0, time >= 1.1.2, xml >= 1.3.5, hostname >= 1.0- if flag(splitBase)- Build-Depends: base >= 3 && < 5, random >= 1.0, containers >= 0.1- else- Build-Depends: base < 3 Extensions: CPP PatternGuards@@ -79,15 +74,12 @@ Buildable: False else Build-Depends: HUnit >= 1.2, QuickCheck >= 2.3 && < 2.5,+ base >= 4.3 && < 5, random >= 1.0, containers >= 0.1, ansi-terminal >= 0.4.0, ansi-wl-pprint >= 0.5.1,- regex-posix >= 0.72, extensible-exceptions >= 0.1.1,+ regex-posix >= 0.72, old-locale >= 1.0, time >= 1.1.2, xml >= 1.3.5, hostname >= 1.0, libxml >= 0.1.1, bytestring >= 0.9- if flag(splitBase)- Build-Depends: base >= 3 && < 5, random >= 1.0, containers >= 0.1- else- Build-Depends: base < 3 Extensions: CPP PatternGuards@@ -105,3 +97,7 @@ if impl(ghc) Cpp-Options: -DCOMPILER_GHC++Source-Repository head+ Type: git+ Location: https://github.com/bos/text