From 4b67d34bdb3705d190bd34be6cba1d7ccd7bc7f4 Mon Sep 17 00:00:00 2001 From: Martijn Bastiaan Date: Sun, 26 Mar 2023 10:47:27 +0200 Subject: [PATCH] Add `sequentialTestGroup` Tasty 1.2 introduced a way for tests to specify dependencies. That is, what tests should run before themselves. These dependencies are specified using an AWK-like expression annotated to a `TestTree`. These expressions can match against any test in the full `TestTree`. This approach has a few rough edges: * Any pattern has to be tested against any test in the tree. If your test tree mostly consists of tests specifying dependencies for each other, this means calculating your test tree is of quadratic complexity. * It's easy to introduce dependency cycles, or other mistakes introducing needless sequentiality. The latter being especially insidious as it easily goes unnoticed. This commit introduces the ability to specify dependencies by using a combinator taking a list of `TestTree`s. This way of specifying dependencies removes the quadratic complexity in favor of a linear one, while eliminating the ability to accidentally introduce cycles or unintended sequentiality. --- README.md | 15 +- core-tests/SequentialTestGroup.hs | 273 ++++++++++++++++++++++++++++++ core-tests/core-tests.cabal | 4 +- core-tests/test.hs | 2 + core/CHANGELOG.md | 1 + core/Test/Tasty.hs | 1 + core/Test/Tasty/Core.hs | 112 ++++++++++-- core/Test/Tasty/Run.hs | 122 ++++++++++--- 8 files changed, 491 insertions(+), 39 deletions(-) create mode 100644 core-tests/SequentialTestGroup.hs diff --git a/README.md b/README.md index ca0532af..3b35d448 100644 --- a/README.md +++ b/README.md @@ -691,13 +691,16 @@ 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. -Dependencies are declared using the `after` combinator: +Dependencies are declared using the `after` or `sequentialTestGroup` combinator: * `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. +* `sequentialTestGroup groupName dependencyType [tree1, tree2, ..]` will execute all tests + in `tree1` first, after which it will execute all tests in `tree2`, and so forth. Like + `after`, `dependencyType` can either be set to `AllFinish` or `AllSucceed`. The relevant types are: @@ -708,6 +711,12 @@ after -> TestTree -- ^ the subtree that depends on other tests -> TestTree -- ^ the subtree annotated with dependency information +sequentialTestGroup + :: TestName -- ^ Name of the group + -> DependencyType -- ^ whether to run the tests even if some of the dependencies fail + -> [TestTree] -- ^ Trees to execute sequentially + -> TestTree + data DependencyType = AllSucceed | AllFinish ``` @@ -744,7 +753,7 @@ tests. The resource may or may not be managed by `withResource`.) ] ``` -Here are some caveats to keep in mind regarding dependencies in Tasty: +Here are some caveats to keep in mind when using patterns to specify dependencies in Tasty: 1. If Test B depends on Test A, remember that either of them may be filtered out using the `--pattern` option. Collecting the dependency info happens *after* @@ -771,6 +780,8 @@ Here are some caveats to keep in mind regarding dependencies in Tasty: test tree, searching for the next test to execute may also have an overhead quadratic in the number of tests. +Use `sequentialTestGroup` to mitigate these problems. + ## FAQ diff --git a/core-tests/SequentialTestGroup.hs b/core-tests/SequentialTestGroup.hs new file mode 100644 index 00000000..f4bef93d --- /dev/null +++ b/core-tests/SequentialTestGroup.hs @@ -0,0 +1,273 @@ +{-# LANGUAGE DeriveGeneric, DeriveFoldable, FlexibleInstances, LambdaCase, NamedFieldPuns, + TypeApplications, ViewPatterns #-} + +-- | +module SequentialTestGroup where + +import Control.Concurrent +import Control.Monad (forM_, zipWithM_) +import Data.Coerce (coerce) +import Data.List (mapAccumL) +import Data.Maybe (fromMaybe) +import Data.Tuple (swap) +import GHC.Generics (Generic) +import GHC.IO.Unsafe (unsafePerformIO) +import System.Random (randomIO) +import Utils (runSMap) + +import Test.Tasty +import Test.Tasty.HUnit +import Test.Tasty.Options +import Test.Tasty.Runners +import qualified Test.Tasty.QuickCheck as Q + +-- | Magic constant determining the number of threads to run with. Should be at +-- least 2 to trigger chaotic behavior. +nUM_THREADS :: NumThreads +nUM_THREADS = NumThreads 3 + +testSequentialTestGroup :: TestTree +testSequentialTestGroup = + adjustOption (const nUM_THREADS) $ + + testGroup "SequentialTestGroup" + [ testGroup "tree0" [toTestTree (GenUniqueLabels True) (labelTree tree0)] + , testGroup "tree1" [toTestTree (GenUniqueLabels True) (labelTree tree1)] + , testGroup "tree2" [toTestTree (GenUniqueLabels True) (labelTree tree2)] + , testGroup "tree3" [toTestTree (GenUniqueLabels True) (labelTree tree3)] + , testGroup "tree4" [toTestTree (GenUniqueLabels True) (labelTree tree4)] + , testGroup "tree5" [toTestTree (GenUniqueLabels True) (labelTree tree5)] + , testGroup "tree5_no_unique" [toTestTree (GenUniqueLabels False) (labelTree tree5)] + , testGroup "treeReg" [toTestTree (GenUniqueLabels True) (labelTree emptySeq)] + + , Q.testProperty "prop_tree" unsafeRunTest + + , testGroup "filtering" + [ testCase "A" $ filterTestTree "A" @?= ["A.B","A.C","A.D","A.E.F","A.E.G","A.E.H"] + , testCase "B" $ filterTestTree "B" @?= ["A.B"] + , testCase "C" $ filterTestTree "C" @?= ["A.C"] + , testCase "D" $ filterTestTree "D" @?= ["A.D"] + , testCase "E" $ filterTestTree "E" @?= ["A.E.F", "A.E.G", "A.E.H"] + , testCase "F" $ filterTestTree "F" @?= ["A.E.F"] + , testCase "G" $ filterTestTree "G" @?= ["A.E.F", "A.E.G"] + , testCase "H" $ filterTestTree "H" @?= ["A.E.F", "A.E.G", "A.E.H"] + ] + ] + +tree0 :: SimpleTestTree () () +tree0 = Test () + +tree1 :: SimpleTestTree () () +tree1 = InParallel () [Test (), Test (), Test ()] + +tree2 :: SimpleTestTree () () +tree2 = Sequentially () [Test (), Test (), Test ()] + +tree3 :: SimpleTestTree () () +tree3 = Sequentially () [tree1, tree2] + +tree4 :: SimpleTestTree () () +tree4 = Sequentially () [tree2, tree1] + +tree5 :: SimpleTestTree () () +tree5 = InParallel () [tree0, tree1, tree2, tree3, tree4] + +filterTestTree :: HasCallStack => String -> [TestName] +filterTestTree pattern = + testsNames (singleOption (TestPattern (Just expr))) $ + testGroup "A" + [ emptyTest "B" + , emptyTest "C" + , emptyTest "D" + , sequentialTestGroup "E" AllSucceed + [ emptyTest "F" + , emptyTest "G" + , emptyTest "H" + ] + ] + where + expr = fromMaybe (error $ "Invalid pattern: " ++ pattern) (parseExpr pattern) + + testsNames :: OptionSet -> TestTree -> [TestName] + testsNames {- opts -} {- tree -} = + foldTestTree + trivialFold + { foldSingle = \_opts name _test -> [name] + , foldGroup = \_opts groupName names -> map ((groupName ++ ".") ++) (concat names) + } + + emptyTest name = testCase name (pure ()) + +-- | Dependencies should account for empty test groups +emptySeq :: SimpleTestTree () () +emptySeq = Sequentially () [Test (), Sequentially () [], Test ()] + +-- | Whether to generate unique labels in 'labelTree'. 'AfterTree' should work +-- properly, even if there are name collisions in the test tree. +newtype GenUniqueLabels = GenUniqueLabels Bool + deriving Show + +instance Q.Arbitrary GenUniqueLabels where + arbitrary = coerce (Q.arbitrary @Bool) + shrink = coerce (Q.shrink @Bool) + +-- | Range composed from a lower bound up to and including an upper bound +type Range a = (a, a) + +-- | Is given element in range? +inRange :: Ord a => Range a -> a -> Bool +inRange (lower, upper) a = a >= lower && a <= upper + +-- | Extract a range from any constructor of 'SimpleTestTree' +getRange :: SimpleTestTree (Range Word) Word -> Range Word +getRange tree = case tree of + InParallel r _ -> r + Sequentially r _ -> r + Test n -> (n, n) + +-- | Simplified version of Tasty's TestTree. Used to generate test cases for +-- 'AfterTree'. +data SimpleTestTree n l + = InParallel n [SimpleTestTree n l] + | Sequentially n [SimpleTestTree n l] + | Test l + deriving (Show, Eq, Ord, Generic, Foldable) + +-- | Attach a unique label to each test. Trees are labeled left-to-right in +-- ascending order. Each node contains a range, which indicates what words +-- are stored in the leafs corresponding to that node. +labelTree :: SimpleTestTree () () -> SimpleTestTree (Range Word) Word +labelTree = snd . go 0 + where + go n0 = \case + Test () -> (n0 + 1, Test n0) + + InParallel () ts0 -> + let + (n1, ts1) = mapAccumL go n0 ts0 + in + (n1, InParallel (n0, n1-1) ts1) + + Sequentially () ts0 -> + let + (n1, ts1) = mapAccumL go n0 ts0 + in + (n1, Sequentially (n0, n1-1) ts1) + +-- | Generates a 'SimpleTestTree' with arbitrary branches with 'InParallel' and +-- 'Sequentially'. The generated test tree is at most 5 levels deep, and each +-- level generates smaller and smaller 'InParallel' lists. This prevents trees +-- from growing incredibly large. +instance Q.Arbitrary (SimpleTestTree () ()) where + arbitrary = Q.sized (go . min 5) + where + go n = do + if n <= 0 then + pure (Test ()) + else + Q.frequency + [ (1, InParallel () <$> (take n <$> Q.listOf (go (n-1)))) + , (1, Sequentially () <$> (take n <$> Q.listOf (go (n-1)))) + , (1, pure (Test ())) + ] + + shrink = Q.genericShrink + +-- | Run a simple test tree (see 'toTestTree' for more information) in a separate +-- Tasty "session" to not pollute the test report. Marked unsafe as it uses +-- 'unsafePerformIO' - which makes it possible to run with 'Q.testProperty'. +unsafeRunTest :: GenUniqueLabels -> SimpleTestTree () () -> () +unsafeRunTest genUniqueLabels testTree0 = unsafePerformIO $ do + results <- launchTestTree (singleOption nUM_THREADS) testTree1 $ \smap -> do + res <- runSMap smap + pure (const (pure res)) + + forM_ results $ \Result{resultOutcome}-> + case resultOutcome of + Success -> pure () + Failure reason -> assertFailure (show reason) + where + testTree1 :: TestTree + testTree1 = toTestTree genUniqueLabels (labelTree testTree0) +{-# NOINLINE unsafeRunTest #-} + +-- | Constructs a 'TestTree' from a 'SimpleTestTree'. 'testGroup' is used to +-- construct parallel test cases in 'InParallel'. Sequential test cases are +-- constructed using 'sequentialTestGroup' in 'Sequentially'. A 'Test' prepends its +-- label to a list shared between all tests. Finally, 'checkResult' is used +-- to check whether the labels were prepended in a sensible order. +toTestTree :: GenUniqueLabels -> SimpleTestTree (Range Word) Word -> TestTree +toTestTree (GenUniqueLabels genUniqueLabels) tree = + withResource (newMVar []) (const (pure ())) $ \mVar -> + sequentialTestGroup "Seq" AllSucceed [go tree mVar, checkResult tree mVar] + where + go :: SimpleTestTree n Word -> IO (MVar [Word]) -> TestTree + go tree mVarIO = case tree of + InParallel _ stts -> + testGroup "Par" (map (`go` mVarIO) stts) + + Sequentially _ ts -> + sequentialTestGroup "Seq" AllSucceed (map (`go` mVarIO) ts) + + Test n -> do + -- Caller might opt to not generate unique labels for each test: AfterTree + -- should still function properly in face of name collisions. + let label = if genUniqueLabels then "T" ++ show n else "T" + + testCase label $ do + -- Induce a (very) small delay to make sure tests finish in a chaotic + -- order when executed in parallel. + smallDelay <- (`mod` 100) <$> randomIO + threadDelay smallDelay + + mVar <- mVarIO + modifyMVar_ mVar (\ns -> pure $ n:ns) + +-- | Checks whether all test cases wrote their labels in the order imposed by +-- the given 'SimpleTestTree'. The invariant that should hold is: given any +-- @Sequentially t1 t2@, all labels associated with @t1@ should appear _later_ +-- in the word-list than all labels associated with @t2@. +checkResult :: SimpleTestTree (Range Word) Word -> IO (MVar [Word]) -> TestTree +checkResult fullTree resultM = + testCase "checkResult" (resultM >>= takeMVar >>= go fullTree) + where + go :: SimpleTestTree (Range Word) Word -> [Word] -> Assertion + go tree result0 = case tree of + InParallel _ ts -> + mapM_ (`go` result0) ts + + Sequentially r (reverse -> trees) -> do + let + -- Parallel execution might "pollute" the result list with tests that are + -- not in any of the trees in 'trees'. + result1 = filter (inRange r) result0 + + -- Note that 'result' is preprended during test execution, so tests that + -- ran last appear first. Hence, we reverse the tree list when matching + -- on 'Sequentially'. + (_, results) = mapAccumL goResult result1 trees + + -- Recurse on all branches; if any element is missing or misplaced, the 'Test' + -- branch will make sure the test fails. + zipWithM_ go trees results + + Test n -> + assertBool + (show n ++ " should be present in " ++ show result0) + (n `elem` result0) + + -- Pop off all the test results beloningn to the given tree, pass along the rest + goResult :: [Word] -> SimpleTestTree (Range Word) Word -> ([Word], [Word]) + goResult results tree = swap (span (inRange (getRange tree)) results) + + +-- Run with: +-- +-- ghcid -c cabal repl tasty-core-tests -T SequentialTestGroup.main +-- +-- Add -W if you want to run tests in spite of warnings. Remove 'ghcid -c' if you +-- do not want to run it automatically on changes. +-- +main :: IO () +main = do + defaultMain testSequentialTestGroup \ No newline at end of file diff --git a/core-tests/core-tests.cabal b/core-tests/core-tests.cabal index 8742a72e..b3545a19 100644 --- a/core-tests/core-tests.cabal +++ b/core-tests/core-tests.cabal @@ -21,10 +21,10 @@ common commons executable tasty-core-tests import: commons main-is: test.hs - other-modules: Resources, Timeouts, Utils, AWK, Dependencies + other-modules: Resources, Timeouts, Utils, AWK, Dependencies, SequentialTestGroup -- other-extensions: build-depends: base >= 4.9 && <= 5, tasty, tasty-hunit, tasty-golden, tasty-quickcheck, containers, stm, mtl, - filepath, bytestring, optparse-applicative + filepath, bytestring, optparse-applicative, random -- hs-source-dirs: default-extensions: CPP, NumDecimals ghc-options: -Wall -fno-warn-type-defaults -fno-warn-name-shadowing -fno-warn-incomplete-uni-patterns diff --git a/core-tests/test.hs b/core-tests/test.hs index c86cd57d..806e5589 100644 --- a/core-tests/test.hs +++ b/core-tests/test.hs @@ -11,6 +11,7 @@ import Resources import Timeouts import Dependencies import AWK +import SequentialTestGroup (testSequentialTestGroup) main :: IO () main = do @@ -23,6 +24,7 @@ mainGroup = do [ testResources , testTimeouts , testDependencies + , testSequentialTestGroup , patternTests , awkTests_ , optionMessagesTests diff --git a/core/CHANGELOG.md b/core/CHANGELOG.md index 1286bd9d..f62f6c81 100644 --- a/core/CHANGELOG.md +++ b/core/CHANGELOG.md @@ -8,6 +8,7 @@ _YYYY-MM-DD_ * Dependency loop error now lists all test cases that formed a cycle * `foldGroup` now takes `[b]` instead of `b` as its last argument to allow for custom fold strategies. This is a backwards incompatible change, but you can get the old behavior by applying `mconcat`. +* Dependencies can now be defined pattern-free with `sequentialTestGroup`. (#343) Version 1.4.3 --------------- diff --git a/core/Test/Tasty.hs b/core/Test/Tasty.hs index de6288cf..e34aaa8a 100644 --- a/core/Test/Tasty.hs +++ b/core/Test/Tasty.hs @@ -33,6 +33,7 @@ module Test.Tasty TestName , TestTree , testGroup + , sequentialTestGroup -- * Running tests , defaultMain , defaultMainWithIngredients diff --git a/core/Test/Tasty/Core.hs b/core/Test/Tasty/Core.hs index b3ed98ab..6cf6ef97 100644 --- a/core/Test/Tasty/Core.hs +++ b/core/Test/Tasty/Core.hs @@ -16,8 +16,10 @@ module Test.Tasty.Core , ResourceSpec(..) , ResourceError(..) , DependencyType(..) + , ExecutionMode(..) , TestTree(..) , testGroup + , sequentialTestGroup , after , after_ , TreeFold(..) @@ -29,6 +31,10 @@ module Test.Tasty.Core import Control.Exception import qualified Data.Map as Map +import Data.Bifunctor (Bifunctor(second, bimap)) +import Data.List (mapAccumR) +import Data.Monoid (Any (getAny, Any)) +import Data.Sequence ((|>)) import qualified Data.Sequence as Seq import Data.Tagged import Data.Typeable @@ -38,6 +44,7 @@ import Test.Tasty.Patterns import Test.Tasty.Patterns.Types import Test.Tasty.Providers.ConsoleFormat import Text.Printf +import Text.Read (readMaybe) -- | If a test failed, 'FailureReason' describes why. -- @@ -243,7 +250,25 @@ data DependencyType | AllFinish -- ^ The current test tree will be executed after its dependencies finish, -- regardless of whether they succeed or not. - deriving (Eq, Show) + deriving + ( Eq + , Show + , Read -- ^ @since 1.5 + ) + +-- | Determines mode of execution of a 'TestGroupWithMode' +data ExecutionMode + = Sequential DependencyType + -- ^ Execute tests one after another + | Parallel + -- ^ Execute tests in parallel + deriving (Show, Read) + +instance IsOption ExecutionMode where + defaultValue = Parallel + parseValue = readMaybe + optionName = Tagged "" -- internal option + optionHelp = Tagged "" -- internal option -- | The main data structure defining a test suite. -- @@ -281,12 +306,21 @@ data TestTree -- -- @since 1.2 --- | Create a named group of test cases or other groups +-- | Create a named group of test cases or other groups. Tests are executed in +-- parallel. For sequential execution, see 'sequentialTestGroup'. -- -- @since 0.1 testGroup :: TestName -> [TestTree] -> TestTree testGroup = TestGroup +-- | Create a named group of test cases or other groups. Tests are executed in +-- order. For parallel execution, see 'testGroup'. +sequentialTestGroup :: TestName -> DependencyType -> [TestTree] -> TestTree +sequentialTestGroup nm depType = setSequential . TestGroup nm . map setParallel + where + setParallel = PlusTestOptions (setOption Parallel) + setSequential = PlusTestOptions (setOption (Sequential depType)) + -- | Like 'after', but accepts the pattern as a syntax tree instead -- of a string. Useful for generating a test tree programmatically. -- @@ -398,6 +432,17 @@ trivialFold = TreeFold , foldAfter = \_ _ _ b -> b } + +-- | Indicates whether a test matched in an evaluated subtree. If no filter was +-- used, tests always match. +type TestMatched = Any + +-- | Used to force tests to be included, even if they would be filtered out by +-- a user's filter. This is used to force dependencies of a test to run. For +-- example, if test @A@ depends on test @B@ and test @A@ is selected to run, test +-- @B@ will be forced to match. +type ForceTestMatch = Any + -- | Fold a test tree into a single value. -- -- The fold result type should be a monoid. This is used to fold multiple @@ -439,7 +484,7 @@ foldTestTree0 -- ^ the tree to fold -> b foldTestTree0 empty (TreeFold fTest fGroup fResource fAfter) opts0 tree0 = - go (filterByPattern (evaluateOptions opts0 tree0)) + go (filterByPattern (annotatePath (evaluateOptions opts0 tree0))) where go :: AnnTestTree OptionSet -> b go = \case @@ -478,23 +523,62 @@ evaluateOptions opts = \case After deptype dep tree -> AnnAfter opts deptype dep $ evaluateOptions opts tree --- | Filter test tree by pattern, replacing leafs with 'AnnEmptyTestTree'. -filterByPattern :: AnnTestTree OptionSet -> AnnTestTree OptionSet -filterByPattern = go mempty +-- | Annotate 'AnnTestTree' with paths. +annotatePath :: AnnTestTree OptionSet -> AnnTestTree (OptionSet, Path) +annotatePath = go mempty where - go :: Seq.Seq TestName -> AnnTestTree OptionSet -> AnnTestTree OptionSet + go :: Seq.Seq TestName -> AnnTestTree OptionSet -> AnnTestTree (OptionSet, Path) go path = \case AnnEmptyTestTree -> AnnEmptyTestTree - t@(AnnSingleTest opts name _) - | testPatternMatches (lookupOption opts) (path Seq.|> name) - -> t - | otherwise -> AnnEmptyTestTree + AnnSingleTest opts name tree -> + AnnSingleTest (opts, path |> name) name tree AnnTestGroup opts name trees -> - AnnTestGroup opts name $ map (go (path Seq.|> name)) trees + let newPath = path |> name in + AnnTestGroup (opts, newPath) name (map (go newPath) trees) AnnWithResource opts res0 tree -> - AnnWithResource opts res0 $ \res -> go path (tree res) + AnnWithResource (opts, path) res0 $ \res -> go path (tree res) AnnAfter opts deptype dep tree -> - AnnAfter opts deptype dep (go path tree) + AnnAfter (opts, path) deptype dep (go path tree) + +-- | Filter test tree by pattern, replacing leafs with 'AnnEmptyTestTree'. +filterByPattern :: AnnTestTree (OptionSet, Path) -> AnnTestTree OptionSet +filterByPattern = snd . go mempty + where + go + :: ForceTestMatch + -> AnnTestTree (OptionSet, Path) + -> (TestMatched, AnnTestTree OptionSet) + go forceMatch = \case + AnnEmptyTestTree -> + (Any False, AnnEmptyTestTree) + + AnnSingleTest (opts, path) name tree + | getAny forceMatch || testPatternMatches (lookupOption opts) path + -> (Any True, AnnSingleTest opts name tree) + | otherwise + -> (Any False, AnnEmptyTestTree) + + AnnTestGroup (opts, _) name trees -> + case lookupOption opts of + Parallel -> + bimap + mconcat + (AnnTestGroup opts name) + (unzip (map (go forceMatch) trees)) + Sequential _ -> + second + (AnnTestGroup opts name) + (mapAccumR go forceMatch trees) + + AnnWithResource (opts, _) res0 tree -> + ( fst (go forceMatch (tree (throwIO NotRunningTests))) + , AnnWithResource opts res0 $ \res -> snd (go forceMatch (tree res)) + ) + + AnnAfter (opts, _) deptype dep tree -> + second + (AnnAfter opts deptype dep) + (go forceMatch tree) -- | Get the list of options that are relevant for a given test tree treeOptions :: TestTree -> [OptionDescription] diff --git a/core/Test/Tasty/Run.hs b/core/Test/Tasty/Run.hs index ab009313..5c0f69f4 100644 --- a/core/Test/Tasty/Run.hs +++ b/core/Test/Tasty/Run.hs @@ -1,7 +1,7 @@ -- | Running tests {-# LANGUAGE ScopedTypeVariables, ExistentialQuantification, RankNTypes, FlexibleContexts, CPP, DeriveDataTypeable, LambdaCase, - RecordWildCards #-} + RecordWildCards, NamedFieldPuns #-} module Test.Tasty.Run ( Status(..) , StatusMap @@ -16,7 +16,7 @@ import Data.Int (Int64) import Data.Maybe import Data.List (intercalate) import Data.Graph (SCC(..), stronglyConnComp) -import Data.Sequence (Seq, (|>), (<|)) +import Data.Sequence (Seq, (|>), (<|), (><)) import Data.Typeable import Control.Monad (forever, guard, join, liftM) import Control.Monad.IO.Class (liftIO) @@ -32,6 +32,10 @@ import Data.Monoid (First(..)) import GHC.Conc (labelThread) import Prelude -- Silence AMP and FTP import warnings +#if MIN_VERSION_base(4,18,0) +import Data.Traversable (mapAccumM) +#endif + #ifdef MIN_VERSION_unbounded_delays import Control.Concurrent.Timeout (timeout) #else @@ -222,11 +226,8 @@ executeTest action statusVar timeoutOpt inits fins = mask $ \restore -> do -- See also https://github.com/UnkindPartition/tasty/issues/33 yieldProgress _ = return () --- | Dependencies of a test -type Dep = (DependencyType, Expr) - -- | Traversal type used in 'createTestActions' -type Tr = ReaderT (Path, [Dep]) IO (TestActionTree UnresolvedAction) +type Tr = ReaderT (Path, Seq Dependency) IO (TestActionTree UnresolvedAction) -- | Exceptions related to dependencies between tests. -- @@ -252,13 +253,51 @@ instance Show DependencyException where instance Exception DependencyException +-- | Specifies how to calculate a dependency +data DependencySpec + = ExactDep (Seq TestName) (TVar Status) + -- ^ Dependency specified by 'TestGroup'. Note that the first field is only + -- there for dependency cycle detection - which can be introduced by using + -- 'PatternDep'. + | PatternDep Expr + -- ^ All tests matching this 'Expr' should be considered dependencies + deriving (Eq) + +instance Show DependencySpec where + show (PatternDep dep) = "PatternDep (" ++ show dep ++ ")" + show (ExactDep testName _) = "ExactDep (" ++ show testName ++ ") ()" + +-- | Dependency of a test. Either it points to an exact path it depends on, or +-- contains a pattern that should be tested against all tests in a 'TestTree'. +data Dependency = Dependency DependencyType DependencySpec + deriving (Eq, Show) + +-- | Is given 'Dependency' a dependency that was introduced with 'After'? +isPatternDependency :: Dependency -> Bool +isPatternDependency (Dependency _ (PatternDep {})) = True +isPatternDependency _ = False + +#if !MIN_VERSION_base(4,18,0) +-- The mapAccumM function behaves like a combination of mapM and mapAccumL that +-- traverses the structure while evaluating the actions and passing an accumulating +-- parameter from left to right. It returns a final value of this accumulator +-- together with the new structure. The accummulator is often used for caching the +-- intermediate results of a computation. +mapAccumM :: Monad m => (acc -> x -> m (acc, y)) -> acc -> [x] -> m (acc, [y]) +mapAccumM _ acc [] = return (acc, []) +mapAccumM f acc (x:xs) = do + (acc', y) <- f acc x + (acc'', ys) <- mapAccumM f acc' xs + return (acc'', y:ys) +#endif + -- | An action with meta information data TestAction act = TestAction { testAction :: act -- ^ Some action, typically 'UnresolvedAction', 'ResolvedAction', or 'Action'. , testPath :: Path -- ^ Path pointing to this action (a series of group names + a test name) - , testDeps :: [Dep] + , testDeps :: Seq Dependency -- ^ Dependencies introduced by AWK-like patterns , testStatus :: TVar Status -- ^ Status var that can be used to monitor test progress @@ -328,7 +367,7 @@ createTestActions opts0 tree = do -- to run them, and meta information needed to watch test progress and calculate -- dependencies in 'resolveDeps'. unresolvedTestTree :: TestActionTree UnresolvedAction <- - flip runReaderT (mempty :: (Path, [Dep])) $ + flip runReaderT (mempty :: (Path, Seq Dependency)) $ foldTestTree0 (pure (tGroup [])) (TreeFold { .. }) opts0 tree let @@ -364,10 +403,18 @@ createTestActions opts0 tree = do pure $ TResource ini fin testTree foldAfter :: OptionSet -> DependencyType -> Expr -> Tr -> Tr - foldAfter _opts depType pat = local (second ((depType, pat):)) + foldAfter _opts depType pat = local (second (Dependency depType (PatternDep pat) <|)) foldGroup :: OptionSet -> TestName -> [Tr] -> Tr - foldGroup _opts name trees = tGroup <$> local (first (|> name)) (sequence trees) + foldGroup opts name trees = + case lookupOption opts of + Parallel -> + tGroup <$> local (first (|> name)) (sequence trees) + Sequential depType -> + tGroup <$> + local + (first (|> name)) + (snd <$> mapAccumM (goSeqGroup depType) mempty trees) -- * Utility functions collectTests :: TestActionTree act -> [TestAction act] @@ -382,25 +429,35 @@ createTestActions opts0 tree = do TGroup _ trees -> mconcat (map collectFinalizers trees) TAction _ -> mempty + goSeqGroup + :: DependencyType + -> Seq Dependency + -> Tr + -> ReaderT (Path, Seq Dependency) IO (Seq Dependency, TestActionTree UnresolvedAction) + goSeqGroup depType prevDeps treeM = do + tree0 <- local (second (prevDeps ><)) treeM + + let + toDep TestAction {..} = Dependency depType (ExactDep testPath testStatus) + deps0 = Seq.fromList (toDep <$> collectTests tree0) + + -- If this test tree is empty (either due to it being actually empty, or due + -- to all tests being filtered) we need to propagate the previous dependencies. + deps1 = if Seq.null deps0 then prevDeps else deps0 + + pure (deps1, tree0) + -- | Take care of the dependencies. -- -- Return 'Left' if there is a dependency cycle, containing the detected cycles. resolveDeps :: [TestAction ResolvedAction] -> Either [[Path]] [TestAction Action] -resolveDeps tests = checkCycles $ do +resolveDeps tests = maybeCheckCycles $ do TestAction { testAction=run_test, .. } <- 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) <- testDeps - TestAction { testStatus = testStatus1, testPath = testPath1 } <- tests - guard $ exprMatches depexpr testPath1 - return (deptype, testStatus1, testPath1) + deps' = concatMap findDeps testDeps getStatus :: STM ActionStatus getStatus = foldr @@ -429,7 +486,30 @@ resolveDeps tests = checkCycles $ do } } return (TestAction { testAction = action, .. }, (testPath, dep_paths)) - + where + -- Skip cycle checking if no patterns are used: sequential test groups can't + -- introduce cycles on their own. + maybeCheckCycles + | any (any isPatternDependency . testDeps) tests = checkCycles + | otherwise = Right . map fst + + findDeps :: Dependency -> [(DependencyType, TVar Status, Seq TestName)] + findDeps (Dependency depType depSpec) = + case depSpec of + ExactDep testPath statusVar -> + -- A dependency defined using 'TestGroup' has already been pinpointed + -- to its 'statusVar' in 'createTestActions'. + [(depType, statusVar, testPath)] + PatternDep expr -> do + -- A dependency defined using patterns needs to scan the whole test + -- tree for matching tests. + TestAction{testPath, testStatus} <- tests + guard $ exprMatches expr testPath + [(depType, testStatus, testPath)] + +-- | Check a graph, given as an adjacency list, for cycles. Return 'Left' if the +-- graph contained cycles, or return all nodes in the graph as a 'Right' if it +-- didn't. checkCycles :: Ord b => [(a, (b, [b]))] -> Either [[b]] [a] checkCycles tests = do let