diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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 --------------- diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -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 diff --git a/Test/Tasty.hs b/Test/Tasty.hs --- a/Test/Tasty.hs +++ b/Test/Tasty.hs @@ -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 diff --git a/Test/Tasty/Core.hs b/Test/Tasty/Core.hs --- a/Test/Tasty/Core.hs +++ b/Test/Tasty/Core.hs @@ -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 +-- . +-- +-- @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] diff --git a/Test/Tasty/Ingredients/ConsoleReporter.hs b/Test/Tasty/Ingredients/ConsoleReporter.hs --- a/Test/Tasty/Ingredients/ConsoleReporter.hs +++ b/Test/Tasty/Ingredients/ConsoleReporter.hs @@ -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 diff --git a/Test/Tasty/Options/Core.hs b/Test/Tasty/Options/Core.hs --- a/Test/Tasty/Options/Core.hs +++ b/Test/Tasty/Options/Core.hs @@ -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 diff --git a/Test/Tasty/Parallel.hs b/Test/Tasty/Parallel.hs --- a/Test/Tasty/Parallel.hs +++ b/Test/Tasty/Parallel.hs @@ -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 diff --git a/Test/Tasty/Patterns.hs b/Test/Tasty/Patterns.hs --- a/Test/Tasty/Patterns.hs +++ b/Test/Tasty/Patterns.hs @@ -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 diff --git a/Test/Tasty/Patterns/Eval.hs b/Test/Tasty/Patterns/Eval.hs --- a/Test/Tasty/Patterns/Eval.hs +++ b/Test/Tasty/Patterns/Eval.hs @@ -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 $ diff --git a/Test/Tasty/Patterns/Types.hs b/Test/Tasty/Patterns/Types.hs --- a/Test/Tasty/Patterns/Types.hs +++ b/Test/Tasty/Patterns/Types.hs @@ -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/@ diff --git a/Test/Tasty/Run.hs b/Test/Tasty/Run.hs --- a/Test/Tasty/Run.hs +++ b/Test/Tasty/Run.hs @@ -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 diff --git a/Test/Tasty/Runners.hs b/Test/Tasty/Runners.hs --- a/Test/Tasty/Runners.hs +++ b/Test/Tasty/Runners.hs @@ -39,6 +39,7 @@ , StatusMap , launchTestTree , NumThreads(..) + , DependencyException(..) -- * Options , suiteOptions , coreOptions diff --git a/tasty.cabal b/tasty.cabal --- a/tasty.cabal +++ b/tasty.cabal @@ -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