test-framework 0.7.0 → 0.8

raw patch · 6 files changed

+41/−13 lines, 6 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• Test/Framework.hs +1/−1
• Test/Framework/Core.hs +13/−8
• Test/Framework/Improving.hs +5/−1
• Test/Framework/Runners/Console.hs +1/−1
• Test/Framework/Runners/Core.hs +20/−1
• test-framework.cabal +1/−1

@@ -10,7 +10,7 @@         module Test.Framework.Seed     ) where -import Test.Framework.Core (Test, TestName, testGroup, plusTestOptions, buildTest, mutuallyExclusive)+import Test.Framework.Core (Test, TestName, testGroup, plusTestOptions, buildTest, buildTestBracketed, mutuallyExclusive) import Test.Framework.Options import Test.Framework.Runners.Console import Test.Framework.Runners.Options

@@ -4,6 +4,7 @@ import Test.Framework.Improving import Test.Framework.Options +import Control.Arrow (first, second) import Control.Concurrent.MVar import Data.Typeable @@ -40,7 +41,7 @@             (Testlike i r t, Typeable t) => Test TestName t -- ^ A single test of some particular type           | TestGroup TestName [Test]                       -- ^ Assemble a number of tests into a cohesive group           | PlusTestOptions TestOptions Test                -- ^ Add some options to child tests-          | BuildTest (IO Test)                             -- ^ Convenience for creating tests from an 'IO' action+          | BuildTestBracketed (IO (Test, IO ()))           -- ^ Convenience for creating tests from an 'IO' action, with cleanup  -- | Assemble a number of tests into a cohesive group testGroup :: TestName -> [Test] -> Test@@ -52,24 +53,28 @@  -- | Convenience for creating tests from an 'IO' action buildTest :: IO Test -> Test-buildTest = BuildTest+buildTest mx = BuildTestBracketed (fmap (flip (,) (return ())) mx) +-- | Convenience for creating tests from an 'IO' action, with a cleanup handler for when tests are finished+buildTestBracketed :: IO (Test, IO ()) -> Test+buildTestBracketed = BuildTestBracketed + data MutuallyExcluded t = ME (MVar ()) t     deriving Typeable  -- This requires UndecidableInstances, but I think it can't be made inconsistent? instance Testlike i r t => Testlike i r (MutuallyExcluded t) where-    runTest cto (ME mvar x) = withMVar mvar $ \() -> runTest cto x+    runTest cto (ME mvar x) = fmap (second (\act -> withMVar mvar $ \() -> act)) $ runTest cto x     testTypeName ~(ME _ x) = testTypeName x  -- | Mark all tests in this portion of the tree as mutually exclusive, so only one runs at a time {-# NOINLINE mutuallyExclusive #-} mutuallyExclusive :: Test -> Test-mutuallyExclusive init_t = BuildTest $ do+mutuallyExclusive init_t = buildTest $ do     mvar <- newMVar ()-    let go (Test tn t)            = Test tn (ME mvar t)-        go (TestGroup tn ts)      = TestGroup tn (map go ts)-        go (PlusTestOptions to t) = PlusTestOptions to (go t)-        go (BuildTest build)      = BuildTest (fmap go build)+    let go (Test tn t)                = Test tn (ME mvar t)+        go (TestGroup tn ts)          = TestGroup tn (map go ts)+        go (PlusTestOptions to t)     = PlusTestOptions to (go t)+        go (BuildTestBracketed build) = BuildTestBracketed (fmap (first go) build)     return (go init_t)

@@ -1,6 +1,6 @@ module Test.Framework.Improving (         (:~>)(..), bimapImproving, improvingLast, consumeImproving,-        ImprovingIO, yieldImprovement, runImprovingIO, liftIO,+        ImprovingIO, yieldImprovement, runImprovingIO, tunnelImprovingIO, liftIO,         timeoutImprovingIO, maybeTimeoutImprovingIO     ) where @@ -48,6 +48,10 @@     -- by the timeout code then they know about it reasonably promptly.     yield     writeChan chan (Left improvement)++-- NB: could have a more general type but it would be impredicative+tunnelImprovingIO :: ImprovingIO i f (ImprovingIO i f a -> IO a)+tunnelImprovingIO = IIO $ \chan -> return $ \iio -> unIIO iio chan  runImprovingIO :: ImprovingIO i f f -> IO (i :~> f, IO ()) runImprovingIO iio = do

@@ -167,7 +167,7 @@     showTest path (Test name _testlike)    = ["  "++path ++ name]     showTest path (TestGroup name tests)   = concatMap (showTest (path++":"++name)) tests     showTest path (PlusTestOptions _ test) = showTest path test-    showTest _    (BuildTest _)            = []+    showTest path (BuildTestBracketed _)   = ["  "++path ++ "<created at runtime>"]   completeRunnerOptions :: RunnerOptions -> CompleteRunnerOptions

@@ -11,6 +11,9 @@ 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 @@ -47,7 +50,23 @@     (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 (BuildTest build) = build >>= runTest' use_test path topts+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 ()])

@@ -1,5 +1,5 @@ Name:                test-framework-Version:             0.7.0+Version:             0.8 Cabal-Version:       >= 1.2.3 Category:            Testing Synopsis:            Framework for running and organising tests, with HUnit and QuickCheck support