packages feed

tasty 1.1.0.4 → 1.2

raw patch · 13 files changed

+442/−151 lines, 13 files

Files

CHANGELOG.md view
@@ -1,6 +1,12 @@ Changes ======= +Version 1.2+-----------++Make it possible to declare dependencies between tests (see the README for+details)+ Version 1.1.0.4 ---------------
README.md view
@@ -666,15 +666,96 @@   will lead to double compilation (once for the program and once for the test   suite). -## FAQ+## Dependencies -1.  How do I make some tests execute after others?+Tasty executes tests in parallel to make them finish faster.+If this parallelism is not desirable, you can declare *dependencies* between+tests, so that one test will not start until certain other tests finish. -    Currently, your only option is to make all tests execute sequentially by-    setting the number of tasty threads to 1 ([example](#num_threads_example)).-    See [#48](https://github.com/feuerbach/tasty/issues/48) for the discussion.+Dependencies are declared using the `after` combinator: -2.  When my tests write to stdout/stderr, the output is garbled. Why is that and+* `after AllFinish "pattern" my_tests` will execute the test tree `my_tests` only after all+    tests that match the pattern finish.+* `after AllSucceed "pattern" my_tests` will execute the test tree `my_tests` only after all+    tests that match the pattern finish **and** only if they all succeed. If at+    least one dependency fails, then `my_tests` will be skipped.++The relevant types are:++``` haskell+after+  :: DependencyType -- ^ whether to run the tests even if some of the dependencies fail+  -> String         -- ^ the pattern+  -> TestTree       -- ^ the subtree that depends on other tests+  -> TestTree       -- ^ the subtree annotated with dependency information++data DependencyType = AllSucceed | AllFinish+```++The pattern follows the same AWK-like syntax and semantics as described in+[Patterns](#patterns). There is also a variant named `after_` that accepts the+AST of the pattern instead of a textual representation.++Let's consider some typical examples. (A note about terminology: here+by "resource" I mean anything stateful and external to the test: it could be a file,+a database record, or even a value stored in an `IORef` that's shared among+tests. The resource may or may not be managed by `withResource`.)++1. Two tests, Test A and Test B, access the same shared resource and cannot be+   run concurrently. To achieve this, make Test A a dependency of Test B:++   ``` haskell+   testGroup "Tests accessing the same resource"+     [ testCase "Test A" $ ...+     , after AllFinish "Test A" $+         testCase "Test B" $ ...+     ]+   ```++1. Test A creates a resource and Test B uses that resource. Like above, we make+   Test A a dependency of Test B, except now we don't want to run Test B if Test+   A failed because the resource may not have been set up properly. So we use+   `AllSucceed` instead of `AllFinish`++   ``` haskell+   testGroup "Tests creating and using a resource"+     [ testCase "Test A" $ ...+     , after AllSucceed "Test A" $+         testCase "Test B" $ ...+     ]+   ```++Here are some caveats to keep in mind regarding dependencies in Tasty:++1. If Test B depends on Test A, remember that either of the may be filtered out+   using the `--pattern` option. Collecting the dependency info happens *after*+   filtering. Therefore, if Test A is filtered out, Test B will run+   unconditionally, and if Test B is filtered out, it simply won't run.+1. Tasty does not currently check whether the pattern in a dependency matches+   anything at all, so make sure your patterns are correct and do not contain+   typos. Fortunately, misspecified dependencies usually lead to test failures+   and so can be detected that way.+1. Dependencies shouldn't form a cycle, otherwise Tasty with fail with the+   message "Test dependencies form a loop." A common cause of this is a test+   matching its own dependency pattern.+1. Using dependencies may introduce quadratic complexity. Specifically,+   resolving dependencies is *O(number_of_tests × number_of_dependencies)*,+   since each pattern has to be matched against each test name. As a guideline,+   if you have up to 1000 tests, the overhead will be negligible, but if you+   have thousands of tests or more, then you probably shouldn't have more than a+   few dependencies.++   Additionally, it is recommended that the dependencies follow the+   natural order of tests, i.e. that the later tests in the test tree depend on+   the earlier ones and not vice versa. If the execution order mandated by the+   dependencies is sufficiently different from the natural order of tests in the+   test tree, searching for the next test to execute may also have an+   overhead quadratic in the number of tests.+++## FAQ++1.  When my tests write to stdout/stderr, the output is garbled. Why is that and     what do I do?      It is not recommended that you print anything to the console when using the
Test/Tasty.hs view
@@ -55,6 +55,10 @@   -- a file or a socket. We want to create or grab the resource before   -- the tests are run, and destroy or release afterwards.   , withResource+  -- * Dependencies+  , DependencyType(..)+  , after+  , after_   )   where
Test/Tasty/Core.hs view
@@ -7,6 +7,7 @@ import Control.Exception import Test.Tasty.Options import Test.Tasty.Patterns+import Test.Tasty.Patterns.Types import Data.Foldable import qualified Data.Sequence as Seq import Data.Monoid@@ -30,6 +31,8 @@     -- may simply raise an exception.   | TestTimedOut Integer     -- ^ test didn't complete in allotted time+  | TestDepFailed -- See Note [Skipped tests]+    -- ^ a dependency of this test failed, so this test was skipped.   deriving Show  -- | Outcome of a test run@@ -63,7 +66,30 @@   , resultTime :: Time     -- ^ How long it took to run the test, in seconds.   }+  deriving Show +{- Note [Skipped tests]+   ~~~~~~~~~~~~~~~~~~~~+   There are two potential ways to represent the tests that are skipped+   because of their failed dependencies:+   1. With Outcome = Failure, and FailureReason giving the specifics (TestDepFailed)+   2. With a dedicated Outcome = Skipped++   It seems to me that (1) will lead to fewer bugs (esp. in the extension packages),+   because most of the time skipped tests should be handled in the same way+   as failed tests.+   But sometimes it is not obvious what the right behavior should be. E.g.+   should --hide-successes show or hide the skipped tests?++   Perhaps we should hide them, because they aren't really informative.+   Or perhaps we shouldn't hide them, because we are not sure that they+   will pass, and hiding them will imply a false sense of security+   ("there's at most 2 tests failing", whereas in fact there could be much more).++   So I might change this in the future, but for now treating them as+   failures seems the easiest yet reasonable approach.+-}+ -- | 'True' for a passed test, 'False' for a failed one. resultSuccessful :: Result -> Bool resultSuccessful r =@@ -92,6 +118,7 @@     -- 'progressPercent' should be a value between 0 and 1. If it's impossible     -- to compute the estimate, use 0.   }+  deriving Show  -- | The interface to be implemented by a test provider. --@@ -142,6 +169,21 @@  instance Exception ResourceError +-- | These are the two ways in which one test may depend on the others.+--+-- This is the same distinction as the+-- <http://testng.org/doc/documentation-main.html#dependent-methods hard vs soft dependencies in TestNG>.+--+-- @since 1.2+data DependencyType+  = AllSucceed+    -- ^ The current test tree will be executed after its dependencies finish, and only+    -- if all of the dependencies succeed.+  | AllFinish+    -- ^ The current test tree will be executed after its dependencies finish,+    -- regardless of whether they succeed or not.+  deriving (Eq, Show)+ -- | The main data structure defining a test suite. -- -- It consists of individual test cases and properties, organized in named@@ -166,11 +208,88 @@     -- tests.   | AskOptions (OptionSet -> TestTree)     -- ^ Ask for the options and customize the tests based on them+  | After DependencyType Expr TestTree+    -- ^ Only run after all tests that match a given pattern finish+    -- (and, depending on the 'DependencyType', succeed)  -- | Create a named group of test cases or other groups testGroup :: TestName -> [TestTree] -> TestTree testGroup = TestGroup +-- | Like 'after', but accepts the pattern as a syntax tree instead+-- of a string. Useful for generating a test tree programmatically.+--+-- ==== __Examples__+--+-- Only match on the test's own name, ignoring the group names:+--+-- @+-- 'after_' 'AllFinish' ('Test.Tasty.Patterns.Types.EQ' ('Field' 'NF') ('StringLit' \"Bar\")) $+--    'testCase' \"A test that depends on Foo.Bar\" $ ...+-- @+--+-- @since 1.2+after_+  :: DependencyType -- ^ whether to run the tests even if some of the dependencies fail+  -> Expr -- ^ the pattern+  -> TestTree -- ^ the subtree that depends on other tests+  -> TestTree -- ^ the subtree annotated with dependency information+after_ = After++-- | The 'after' combinator declares dependencies between tests.+--+-- If a 'TestTree' is wrapped in 'after', the tests in this tree will not run+-- until certain other tests («dependencies») have finished. These+-- dependencies are specified using an AWK pattern (see the «Patterns» section+-- in the README).+--+-- Moreover, if the 'DependencyType' argument is set to 'AllSucceed' and+-- at least one dependency has failed, this test tree will not run at all.+--+-- Tasty does not check that the pattern matches any tests (let alone the+-- correct set of tests), so it is on you to supply the right pattern.+--+-- ==== __Examples__+--+-- The following test will be executed only after all tests that contain+-- @Foo@ anywhere in their path finish.+--+-- @+-- 'after' 'AllFinish' \"Foo\" $+--    'testCase' \"A test that depends on Foo.Bar\" $ ...+-- @+--+-- Note, however, that our test also happens to contain @Foo@ as part of its name,+-- so it also matches the pattern and becomes a dependency of itself. This+-- will result in a 'DependencyLoop' exception. To avoid this, either+-- change the test name so that it doesn't mention @Foo@ or make the+-- pattern more specific.+--+-- You can use AWK patterns, for instance, to specify the full path to the dependency.+--+-- @+-- 'after' 'AllFinish' \"$0 == \\\"Tests.Foo.Bar\\\"\" $+--    'testCase' \"A test that depends on Foo.Bar\" $ ...+-- @+--+-- Or only specify the dependency's own name, ignoring the group names:+--+-- @+-- 'after' 'AllFinish' \"$NF == \\\"Bar\\\"\" $+--    'testCase' \"A test that depends on Foo.Bar\" $ ...+-- @+--+-- @since 1.2+after+  :: DependencyType -- ^ whether to run the tests even if some of the dependencies fail+  -> String -- ^ the pattern+  -> TestTree -- ^ the subtree that depends on other tests+  -> TestTree -- ^ the subtree annotated with dependency information+after deptype s =+  case parseExpr s of+    Nothing -> error $ "Could not parse pattern " ++ show s+    Just e -> after_ deptype e+ -- | An algebra for folding a `TestTree`. -- -- Instead of constructing fresh records, build upon `trivialFold`@@ -180,6 +299,7 @@   { foldSingle :: forall t . IsTest t => OptionSet -> TestName -> t -> b   , foldGroup :: TestName -> b -> b   , foldResource :: forall a . ResourceSpec a -> (IO a -> b) -> b+  , foldAfter :: DependencyType -> Expr -> b -> b   }  -- | 'trivialFold' can serve as the basis for custom folds. Just override@@ -198,6 +318,7 @@   { foldSingle = \_ _ _ -> mempty   , foldGroup = const id   , foldResource = \_ f -> f $ throwIO NotRunningTests+  , foldAfter = \_ _ b -> b   }  -- | Fold a test tree into a single value.@@ -227,7 +348,7 @@   -> TestTree      -- ^ the tree to fold   -> b-foldTestTree (TreeFold fTest fGroup fResource) opts0 tree0 =+foldTestTree (TreeFold fTest fGroup fResource fAfter) opts0 tree0 =   let pat = lookupOption opts0   in go pat mempty opts0 tree0   where@@ -242,6 +363,7 @@         PlusTestOptions f tree -> go pat path (f opts) tree         WithResource res0 tree -> fResource res0 $ \res -> go pat path opts (tree res)         AskOptions f -> go pat path opts (f opts)+        After deptype dep tree -> fAfter deptype dep $ go pat path opts tree  -- | Get the list of options that are relevant for a given test tree treeOptions :: TestTree -> [OptionDescription]
Test/Tasty/Ingredients/ConsoleReporter.hs view
@@ -43,7 +43,7 @@ import Data.Maybe import Data.Monoid (Any(..)) import Data.Typeable-import Options.Applicative hiding (str)+import Options.Applicative hiding (str, Success, Failure) import System.IO import System.Console.ANSI #if !MIN_VERSION_base(4,8,0)@@ -119,9 +119,10 @@           -- use an appropriate printing function           let             printFn =-              if resultSuccessful result-                then ok-                else fail+              case resultOutcome result of+                Success -> ok+                Failure TestDepFailed -> skipped+                _ -> fail             time = resultTime result           printFn (resultShortDescription result)           -- print time only if it's significant@@ -578,9 +579,10 @@ #endif  -- (Potentially) colorful output-ok, fail, infoOk, infoFail :: (?colors :: Bool) => String -> IO ()+ok, fail, skipped, infoOk, infoFail :: (?colors :: Bool) => String -> IO () fail     = output BoldIntensity   Vivid Red ok       = output NormalIntensity Dull  Green+skipped  = output NormalIntensity Dull  Magenta infoOk   = output NormalIntensity Dull  White infoFail = output NormalIntensity Dull  Red
Test/Tasty/Options/Core.hs view
@@ -13,9 +13,11 @@ import Data.Proxy import Data.Typeable import Data.Fixed-import Data.Monoid import Options.Applicative hiding (str) import GHC.Conc+#if !MIN_VERSION_base(4,11,0)+import Data.Monoid+#endif  import Test.Tasty.Options import Test.Tasty.Patterns
Test/Tasty/Parallel.hs view
@@ -1,31 +1,27 @@ -- | A helper module which takes care of parallelism {-# LANGUAGE DeriveDataTypeable #-}-module Test.Tasty.Parallel (runInParallel) where+module Test.Tasty.Parallel (ActionStatus(..), Action(..), runInParallel) where  import Control.Monad import Control.Concurrent import Control.Concurrent.STM-import Control.Exception import Foreign.StablePtr-import Data.Typeable-import GHC.Conc (labelThread) -data Interrupt = Interrupt-  deriving Typeable-instance Show Interrupt where-  show Interrupt = "interrupted"-instance Exception Interrupt--data ParThreadKilled = ParThreadKilled SomeException-  deriving Typeable-instance Show ParThreadKilled where-  show (ParThreadKilled exn) =-    "tasty: one of the test running threads was killed by: " ++-    show exn-instance Exception ParThreadKilled+-- | What to do about an 'Action'?+data ActionStatus+  = ActionReady+    -- ^ the action is ready to be executed+  | ActionSkip+    -- ^ the action should be skipped+  | ActionWait+    -- ^ not sure what to do yet; wait+  deriving Eq -shutdown :: ThreadId -> IO ()-shutdown = flip throwTo Interrupt+data Action = Action+  { actionStatus :: STM ActionStatus+  , actionRun :: IO ()+  , actionSkip :: STM ()+  }  -- | Take a list of actions and execute them in parallel, no more than @n@ -- at the same time.@@ -35,7 +31,8 @@ -- cleans up. runInParallel   :: Int -- ^ maximum number of parallel threads-  -> [IO ()] -- ^ list of actions to execute+  -> [Action] -- ^ list of actions to execute.+    -- The first action in the pair tells if the second action is ready to run.   -> IO (IO ()) -- This implementation tries its best to ensure that exceptions are -- properly propagated to the caller and threads are not left running.@@ -50,95 +47,51 @@   -- Otherwise we may get a "thread blocked indefinitely in an STM   -- transaction" exception when a child thread is blocked and GC'd.   -- (See e.g. https://github.com/feuerbach/tasty/issues/15)+  -- FIXME is this still needed?   _ <- newStablePtr callingThread -  -- A variable containing all ThreadIds of forked threads.-  ---  -- These are the threads we'll need to kill if something wrong happens.-  pidsVar <- atomically $ newTVar []--  -- If an unexpected exception has been thrown and we started killing all-  -- the spawned threads, this flag will be set to False, so that any-  -- freshly spawned threads will know to terminate, even if their pids-  -- didn't make it to the "kill list" yet.-  aliveVar <- atomically $ newTVar True--  let-    -- Kill all threads.-    shutdownAll :: IO ()-    shutdownAll = do-      pids <- atomically $ do-        writeTVar aliveVar False-        readTVar pidsVar--      -- be sure not to kill myself!-      me <- myThreadId-      mapM_ shutdown $ filter (/= me) pids+  actionsVar <- atomically $ newTMVar actions -    cleanup :: Either SomeException () -> IO ()-    cleanup Right {} = return ()-    cleanup (Left exn)-      | Just Interrupt <- fromException exn-        -- I'm being shut down either by a fellow thread (which caught an-        -- exception), or by the main thread which decided to stop running-        -- tests. In any case, just end silently.-        = return ()-      | otherwise = do-        -- Wow, I caught an exception (most probably an async one,-        -- although it doesn't really matter). Shut down all other-        -- threads, and re-throw my exception to the calling thread.-        shutdownAll-        throwTo callingThread $ ParThreadKilled exn+  pids <- replicateM nthreads (forkIO $ work actionsVar) -    forkCarefully :: IO () -> IO ThreadId-    forkCarefully action = flip myForkFinally cleanup $ do-      -- We cannot check liveness and update the pidsVar in one-      -- transaction before forking, because we don't know the new pid yet.-      ---      -- So we fork and then check/update. If something has happened in-      -- the meantime, it's not a big deal — we just cancel. OTOH, if-      -- we're alive at the time of the transaction, then we add our pid-      -- and will be killed when something happens.-      newPid <- myThreadId+  return $ mapM_ killThread pids +work :: TMVar [Action] -> IO ()+work actionsVar = go+  where+    go = do       join . atomically $ do-        alive <- readTVar aliveVar-        if alive-          then do-            modifyTVar pidsVar (newPid :)-            return action-          else-            return (return ())--  capsVar <- atomically $ newTVar nthreads--  let-    go a cont = join . atomically $ do-      caps <- readTVar capsVar-      if caps > 0-        then do-          writeTVar capsVar $! caps - 1-          let-            release = atomically $ modifyTVar' capsVar (+1)--          -- Thanks to our exception handling, we won't deadlock even if-          -- an exception strikes before we 'release'. Everything will be-          -- killed, so why bother.-          return $ do-            pid <- forkCarefully (do a :: IO (); release)-            labelThread pid "tasty_test_thread"-            cont--        else retry--  -- fork here as well, so that we can move to the UI without waiting-  -- untill all tests have finished-  pid <- forkCarefully $ foldr go (return ()) actions-  labelThread pid "tasty_thread_manager"-  return shutdownAll+        mb_ready <- findBool =<< takeTMVar actionsVar+        case mb_ready of+          Nothing ->+            -- nothing left to do; return+            return $ return ()+          Just (this, rest) -> do+            putTMVar actionsVar rest+            return $ actionRun this >> go --- Copied from base to stay compatible with GHC 7.4.-myForkFinally :: IO a -> (Either SomeException a -> IO ()) -> IO ThreadId-myForkFinally action and_then =-  mask $ \restore ->-    forkIO $ try (restore action) >>= and_then+-- | Find a ready-to-run item. Filter out the items that will never be+-- ready to run.+--+-- Return the ready item and the remaining ones.+--+-- This action may block if no items are ready to run just yet.+--+-- Return 'Nothing' if there are no runnable items left.+findBool :: [Action] -> STM (Maybe (Action, [Action]))+findBool = go []+  where+    go [] [] =+      -- nothing to do+      return Nothing+    go _ [] =+      -- nothing ready yet+      retry+    go past (this : rest) = do+      status <- actionStatus this+      case status of+        ActionReady -> return $ Just (this, reverse past ++ rest)+        ActionWait -> go (this : past) rest+        ActionSkip -> do+          actionSkip this+          go past rest
Test/Tasty/Patterns.hs view
@@ -4,8 +4,11 @@  module Test.Tasty.Patterns   ( TestPattern(..)+  , parseExpr   , parseTestPattern   , noPattern+  , Path+  , exprMatches   , testPatternMatches   ) where @@ -14,11 +17,12 @@ import Test.Tasty.Patterns.Parser import Test.Tasty.Patterns.Eval -import Data.Monoid import Data.Char-import qualified Data.Sequence as Seq import Data.Typeable import Options.Applicative hiding (Success)+#if !MIN_VERSION_base(4,11,0)+import Data.Monoid+#endif  newtype TestPattern = TestPattern (Maybe Expr)   deriving (Typeable, Show, Eq)@@ -33,18 +37,25 @@   optionHelp = return "Select only tests which satisfy a pattern or awk expression"   optionCLParser = mkOptionCLParser (short 'p' <> metavar "PATTERN") +parseExpr :: String -> Maybe Expr+parseExpr s+  | all (\c -> isAlphaNum c || c `elem` "._- ") s =+    Just $ ERE s+  | otherwise = parseAwkExpr s+ parseTestPattern :: String -> Maybe TestPattern parseTestPattern s   | null s = Just noPattern-  | all (\c -> isAlphaNum c || c `elem` "._- ") s =-    Just . TestPattern . Just $ ERE s-  | otherwise = TestPattern . Just <$> parseAwkExpr s+  | otherwise = TestPattern . Just <$> parseExpr s -testPatternMatches :: TestPattern -> Seq.Seq String -> Bool+exprMatches :: Expr -> Path -> Bool+exprMatches e fields =+  case withFields fields $ asB =<< eval e of+    Left msg -> error msg+    Right b -> b++testPatternMatches :: TestPattern -> Path -> Bool testPatternMatches pat fields =   case pat of     TestPattern Nothing -> True-    TestPattern (Just e) ->-      case withFields fields $ asB =<< eval e of-        Left msg -> error msg-        Right b -> b+    TestPattern (Just e) -> exprMatches e fields
Test/Tasty/Patterns/Eval.hs view
@@ -1,5 +1,5 @@ {-# LANGUAGE RankNTypes, ViewPatterns #-}-module Test.Tasty.Patterns.Eval (eval, withFields, asB) where+module Test.Tasty.Patterns.Eval (Path, eval, withFields, asB) where  import Prelude hiding (Ordering(..)) import Control.Monad.Reader@@ -15,6 +15,8 @@ import Data.Traversable #endif +type Path = Seq.Seq String+ data Value   = VN !Int   | VS !Bool String@@ -23,9 +25,7 @@   | Uninitialized   deriving Show -type Env = Seq.Seq String--type M = ReaderT Env (Either String)+type M = ReaderT Path (Either String)  asS :: Value -> M String asS v = return $
Test/Tasty/Patterns/Types.hs view
@@ -18,7 +18,7 @@   | Concat Expr Expr   | Match Expr String   | NoMatch Expr String-  | Field Expr -- ^ nth field of the path, where 1 is the outermost group name and 0 is the whole test name, using @/@ as a separator+  | Field Expr -- ^ nth field of the path, where 1 is the outermost group name and 0 is the whole test name, using @.@ (dot) as a separator   | StringLit String   | If Expr Expr Expr   | ERE String -- ^ an ERE token by itself, like @/foo/@ but not like @$1 ~ /foo/@
Test/Tasty/Run.hs view
@@ -1,16 +1,19 @@ -- | Running tests {-# LANGUAGE ScopedTypeVariables, ExistentialQuantification, RankNTypes,-             FlexibleContexts, BangPatterns, CPP #-}+             FlexibleContexts, BangPatterns, CPP, DeriveDataTypeable #-} module Test.Tasty.Run   ( Status(..)   , StatusMap   , launchTestTree+  , DependencyException(..)   ) where  import qualified Data.IntMap as IntMap import qualified Data.Sequence as Seq import qualified Data.Foldable as F import Data.Maybe+import Data.Graph (SCC(..), stronglyConnComp)+import Data.Typeable #ifndef VERSION_clock import Data.Time.Clock.POSIX (getPOSIXTime) #endif@@ -32,6 +35,8 @@  import Test.Tasty.Core import Test.Tasty.Parallel+import Test.Tasty.Patterns+import Test.Tasty.Patterns.Types import Test.Tasty.Options import Test.Tasty.Options.Core import Test.Tasty.Runners.Reducers@@ -44,6 +49,7 @@     -- ^ test is being run   | Done Result     -- ^ test finished with a given result+  deriving Show  -- | Mapping from test numbers (starting from 0) to their status variables. --@@ -194,37 +200,73 @@  type InitFinPair = (Seq.Seq Initializer, Seq.Seq Finalizer) +-- | Dependencies of a test+type Deps = [(DependencyType, Expr)]++-- | Traversal type used in 'createTestActions'+type Tr = Traversal+        (WriterT ([(InitFinPair -> IO (), (TVar Status, Path, Deps))], Seq.Seq Finalizer)+        (ReaderT (Path, Deps)+        IO))++-- | Exceptions related to dependencies between tests.+data DependencyException+  = DependencyLoop+    -- ^ Test dependencies form a loop. In other words, test A cannot start+    -- until test B finishes, and test B cannot start until test+    -- A finishes.+  deriving (Typeable)++instance Show DependencyException where+  show DependencyLoop = "Test dependencies form a loop."++instance Exception DependencyException+ -- | Turn a test tree into a list of actions to run tests coupled with -- variables to watch them.------ Also return a list of finalizers in the order they should run when the--- test suite completes.-createTestActions :: OptionSet -> TestTree -> IO ([(IO (), TVar Status)], Seq.Seq Finalizer)+createTestActions+  :: OptionSet+  -> TestTree+  -> IO ([(Action, TVar Status)], Seq.Seq Finalizer) createTestActions opts0 tree = do   let-    traversal ::-      Traversal (WriterT ([(InitFinPair -> IO (), TVar Status)], Seq.Seq Finalizer) IO)+    traversal :: Tr     traversal =       foldTestTree-        trivialFold+        (trivialFold :: TreeFold Tr)           { foldSingle = runSingleTest           , foldResource = addInitAndRelease+          , foldGroup = \name (Traversal a) ->+              Traversal $ local (first (Seq.|> name)) a+          , foldAfter = \deptype pat (Traversal a) ->+              Traversal $ local (second ((deptype, pat) :)) a           }         opts0 tree-  (tests, rvars) <- unwrap traversal-  let tests' = map (first ($ (Seq.empty, Seq.empty))) tests-  return (tests', rvars)+  (tests, fins) <- unwrap (mempty :: Path) (mempty :: Deps) traversal+  let+    mb_tests :: Maybe [(Action, TVar Status)]+    mb_tests = resolveDeps $ map+      (\(act, testInfo) ->+        (act (Seq.empty, Seq.empty), testInfo))+      tests+  case mb_tests of+    Just tests' -> return (tests', fins)+    Nothing -> throwIO DependencyLoop    where-    runSingleTest opts _ test = Traversal $ do+    runSingleTest :: IsTest t => OptionSet -> TestName -> t -> Tr+    runSingleTest opts name test = Traversal $ do       statusVar <- liftIO $ atomically $ newTVar NotStarted+      (parentPath, deps) <- ask       let+        path = parentPath Seq.|> name         act (inits, fins) =           executeTest (run opts test) statusVar (lookupOption opts) inits fins-      tell ([(act, statusVar)], mempty)-    addInitAndRelease (ResourceSpec doInit doRelease) a = wrap $ do+      tell ([(act, (statusVar, path, deps))], mempty)+    addInitAndRelease :: ResourceSpec a -> (IO a -> Tr) -> Tr+    addInitAndRelease (ResourceSpec doInit doRelease) a = wrap $ \path deps -> do       initVar <- atomically $ newTVar NotCreated-      (tests, fins) <- unwrap $ a (getResource initVar)+      (tests, fins) <- unwrap path deps $ a (getResource initVar)       let ntests = length tests       finishVar <- atomically $ newTVar ntests       let@@ -232,8 +274,75 @@         fin = Finalizer doRelease initVar finishVar         tests' = map (first $ local $ (Seq.|> ini) *** (fin Seq.<|)) tests       return (tests', fins Seq.|> fin)-    wrap = Traversal . WriterT . fmap ((,) ())-    unwrap = execWriterT . getTraversal+    wrap+      :: (Path ->+          Deps ->+          IO ([(InitFinPair -> IO (), (TVar Status, Path, Deps))], Seq.Seq Finalizer))+      -> Tr+    wrap = Traversal . WriterT . fmap ((,) ()) . ReaderT . uncurry+    unwrap+      :: Path+      -> Deps+      -> Tr+      -> IO ([(InitFinPair -> IO (), (TVar Status, Path, Deps))], Seq.Seq Finalizer)+    unwrap path deps = flip runReaderT (path, deps) . execWriterT . getTraversal++-- | Take care of the dependencies.+--+-- Return 'Nothing' if there is a dependency cycle.+resolveDeps :: [(IO (), (TVar Status, Path, Deps))] -> Maybe [(Action, TVar Status)]+resolveDeps tests = checkCycles $ do+  (run_test, (statusVar, path0, deps)) <- tests+  let+    -- Note: Duplicate dependencies may arise if the same test name matches+    -- multiple patterns. It's not clear that removing them is worth the+    -- trouble; might consider this in the future.+    deps' :: [(DependencyType, TVar Status, Path)]+    deps' = do+      (deptype, depexpr) <- deps+      (_, (statusVar1, path, _)) <- tests+      guard $ exprMatches depexpr path+      return (deptype, statusVar1, path)++    getStatus :: STM ActionStatus+    getStatus = foldr+      (\(deptype, statusvar, _) k -> do+        status <- readTVar statusvar+        case status of+          Done result+            | deptype == AllFinish || resultSuccessful result -> k+            | otherwise -> return ActionSkip+          _ -> return ActionWait+      )+      (return ActionReady)+      deps'+  let+    dep_paths = map (\(_, _, path) -> path) deps'+    action = Action+      { actionStatus = getStatus+      , actionRun = run_test+      , actionSkip = writeTVar statusVar $ Done $ Result+          -- See Note [Skipped tests]+          { resultOutcome = Failure TestDepFailed+          , resultDescription = ""+          , resultShortDescription = "SKIP"+          , resultTime = 0+          }+      }+  return ((action, statusVar), (path0, dep_paths))++checkCycles :: Ord b => [(a, (b, [b]))] -> Maybe [a]+checkCycles tests = do+  let+    result = fst <$> tests+    graph = [ ((), v, vs) | (v, vs) <- snd <$> tests ]+    sccs = stronglyConnComp graph+    not_cyclic = all (\scc -> case scc of+        AcyclicSCC{} -> True+        CyclicSCC{}  -> False)+      sccs+  guard not_cyclic+  return result  -- | Used to create the IO action which is passed in a WithResource node getResource :: TVar (Resource r) -> IO r
Test/Tasty/Runners.hs view
@@ -39,6 +39,7 @@   , StatusMap   , launchTestTree   , NumThreads(..)+  , DependencyException(..)     -- * Options   , suiteOptions   , coreOptions
tasty.cabal view
@@ -2,7 +2,7 @@ --  see http://haskell.org/cabal/users-guide/  name:                tasty-version:             1.1.0.4+version:             1.2 synopsis:            Modern and extensible testing framework description:         Tasty is a modern testing framework for Haskell.                      It lets you combine your unit tests, golden