diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,6 +1,25 @@ Changes ======= +Version 1.5.1 +-------------- + +_2024-06-22_ + +* Performance improvements + ([#389](https://github.com/UnkindPartition/tasty/pull/389), + [#390](https://github.com/UnkindPartition/tasty/pull/390)). +* Progress reporting in Emacs: use `\r` instead of ANSI escape sequences + ([#393](https://github.com/UnkindPartition/tasty/pull/393)). +* Console reporter: fix unintended change to `foldHeading` + ([#396](https://github.com/UnkindPartition/tasty/pull/396)). +* Prune empty test subtrees from `TestTree` + ([#403](https://github.com/UnkindPartition/tasty/pull/403)). +* Add `instance Eq Timeout` and `instance Ord Timeout` + ([#415](https://github.com/UnkindPartition/tasty/pull/415)). +* Add ability to supply options for launchers and reporters at the top-level of test tree + ([#417](https://github.com/UnkindPartition/tasty/pull/417)). + Version 1.5 --------------- diff --git a/Control/Concurrent/Async.hs b/Control/Concurrent/Async.hs --- a/Control/Concurrent/Async.hs +++ b/Control/Concurrent/Async.hs @@ -48,7 +48,7 @@ import Control.Monad import Data.IORef import Data.Typeable -import GHC.Conc +import GHC.Conc (ThreadId(..)) import GHC.Exts import GHC.IO hiding (onException) diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -820,9 +820,12 @@ 3. **Q**: Patterns with slashes do not work on Windows. How can I fix it? - **A**: If you are running Git for Windows terminal, it has a habit of converting slashes - to backslashes. Set `MSYS_NO_PATHCONV=1` to prevent this behaviour, or follow other - suggestions from [Known Issues](https://github.com/git-for-windows/build-extra/blob/main/ReleaseNotes.md#known-issues). + **A**: If you are running Git for Windows terminal, it has a habit of + converting slashes to backslashes. Set `MSYS_NO_PATHCONV=1` when running the + Git for Windows terminal and `MSYS2_ARG_CONV_EXCL=*` when running a MinGW + bash directly to prevent this behaviour, or follow other suggestions from + [Known + Issues](https://github.com/git-for-windows/build-extra/blob/main/ReleaseNotes.md#known-issues). ## Press diff --git a/Test/Tasty/Core.hs b/Test/Tasty/Core.hs --- a/Test/Tasty/Core.hs +++ b/Test/Tasty/Core.hs @@ -540,7 +540,7 @@ go :: Seq.Seq TestName -> AnnTestTree OptionSet -> AnnTestTree (OptionSet, Path) go path = \case AnnEmptyTestTree -> AnnEmptyTestTree - AnnSingleTest opts name tree -> + AnnSingleTest opts name tree -> AnnSingleTest (opts, path |> name) name tree AnnTestGroup opts name trees -> let newPath = path |> name in @@ -554,7 +554,15 @@ filterByPattern :: AnnTestTree (OptionSet, Path) -> AnnTestTree OptionSet filterByPattern = snd . go (Any False) where - go + mkGroup opts name xs = case filter isNonEmpty xs of + [] -> AnnEmptyTestTree + ys -> AnnTestGroup opts name ys + + isNonEmpty = \case + AnnEmptyTestTree -> False + _ -> True + + go :: ForceTestMatch -> AnnTestTree (OptionSet, Path) -> (TestMatched, AnnTestTree OptionSet) @@ -565,22 +573,22 @@ AnnSingleTest (opts, path) name tree | getAny forceMatch || testPatternMatches (lookupOption opts) path -> (Any True, AnnSingleTest opts name tree) - | otherwise + | otherwise -> (Any False, AnnEmptyTestTree) - AnnTestGroup (opts, _) name [] -> - (forceMatch, AnnTestGroup opts name []) + AnnTestGroup _ _ [] -> + (forceMatch, AnnEmptyTestTree) AnnTestGroup (opts, _) name trees -> case lookupOption opts of Parallel -> bimap mconcat - (AnnTestGroup opts name) + (mkGroup opts name) (unzip (map (go forceMatch) trees)) Sequential _ -> second - (AnnTestGroup opts name) + (mkGroup opts name) (mapAccumR go forceMatch trees) AnnWithResource (opts, _) res0 tree -> diff --git a/Test/Tasty/Ingredients.hs b/Test/Tasty/Ingredients.hs --- a/Test/Tasty/Ingredients.hs +++ b/Test/Tasty/Ingredients.hs @@ -92,6 +92,8 @@ -- -- For a 'TestReporter', this function automatically starts running the -- tests in the background. +-- +-- This function is not publicly exposed. tryIngredient :: Ingredient -> OptionSet -> TestTree -> Maybe (IO Bool) tryIngredient (TestReporter _ report) opts testTree = do -- Maybe monad reportFn <- report opts testTree @@ -106,8 +108,10 @@ -- -- @since 0.4 tryIngredients :: [Ingredient] -> OptionSet -> TestTree -> Maybe (IO Bool) -tryIngredients ins opts tree = +tryIngredients ins opts' tree' = msum $ map (\i -> tryIngredient i opts tree) ins + where + (opts, tree) = applyTopLevelPlusTestOptions opts' tree' -- | Return the options which are relevant for the given ingredient. -- 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 @@ -50,6 +50,7 @@ import Test.Tasty.Runners.Utils import Text.Printf import qualified Data.IntMap as IntMap +import qualified Data.IntSet as IntSet import Data.Char #ifdef USE_WCWIDTH import Foreign.C.Types (CInt(..), CWchar(..)) @@ -151,8 +152,6 @@ name (replicate postNamePadding ' ') - resultPosition = length testNamePadded - printTestName = do putStr testNamePadded hFlush stdout @@ -170,11 +169,11 @@ ("", pct) -> printf "%.0f%% " pct (txt, 0.0) -> printf "%s" txt (txt, pct) -> printf "%s: %.0f%% " txt pct - setCursorColumn resultPosition - infoOk msg -- A new progress message may be shorter than the previous one - -- so we must clean until the end of the line - clearFromCursorToLineEnd + -- so we must clean whole line and print anew. + putChar '\r' + putStr testNamePadded + infoOk msg hFlush stdout printTestResult result = do @@ -190,8 +189,8 @@ time = resultTime result when getAnsiTricks $ do - setCursorColumn resultPosition - clearFromCursorToLineEnd + putChar '\r' + putStr testNamePadded printFn (resultShortDescription result) when (floor (time * 1e6) >= minDurationMicros) $ @@ -294,8 +293,9 @@ , Any True) foldHeading _name printHeading (printBody, Any nonempty) = ( Traversal $ do - when nonempty $ printHeading - getTraversal printBody + when nonempty $ do + printHeading :: IO () + getTraversal printBody , Any nonempty ) @@ -433,8 +433,8 @@ where f :: Int -> TVar Status - -> (IntMap.IntMap () -> Int -> STM (IO Bool)) - -> (IntMap.IntMap () -> Int -> STM (IO Bool)) + -> (IntSet.IntSet -> Int -> STM (IO Bool)) + -> (IntSet.IntSet -> Int -> STM (IO Bool)) -- ok_tests is a set of tests that completed successfully -- lookahead is the number of unfinished tests that we are allowed to -- look at @@ -447,23 +447,23 @@ case this_status of Done r -> if resultSuccessful r - then k (IntMap.insert key () ok_tests) lookahead + then k (IntSet.insert key ok_tests) lookahead else return $ return False _ -> k ok_tests (lookahead-1) -- next_iter is called when we end the current iteration, -- either because we reached the end of the test tree -- or because we exhausted the lookahead - next_iter :: IntMap.IntMap () -> STM (IO Bool) + next_iter :: IntSet.IntSet -> STM (IO Bool) next_iter ok_tests = -- If we made no progress at all, wait until at least some tests -- complete. -- Otherwise, reduce the set of tests we are looking at. - if IntMap.null ok_tests + if IntSet.null ok_tests then retry - else return $ statusMapResult lookahead0 (IntMap.difference smap ok_tests) + else return $ statusMapResult lookahead0 (IntMap.withoutKeys smap ok_tests) - finish :: IntMap.IntMap () -> Int -> STM (IO Bool) + finish :: IntSet.IntSet -> Int -> STM (IO Bool) finish ok_tests _ = next_iter ok_tests -- }}} @@ -749,35 +749,19 @@ then paddedDesc else chomped -data Maximum a - = Maximum a - | MinusInfinity - -instance Ord a => Sem.Semigroup (Maximum a) where - Maximum a <> Maximum b = Maximum (a `max` b) - MinusInfinity <> a = a - a <> MinusInfinity = a -instance Ord a => Monoid (Maximum a) where - mempty = MinusInfinity -#if !MIN_VERSION_base(4,11,0) - mappend = (Sem.<>) -#endif - -- | Compute the amount of space needed to align \"OK\"s and \"FAIL\"s computeAlignment :: OptionSet -> TestTree -> Int computeAlignment opts = - fromMonoid . - foldTestTree - trivialFold - { foldSingle = \_ name _ level -> Maximum (stringWidth name + level) - , foldGroup = \_opts _ m -> mconcat m . (+ indentSize) + max 0 . + foldTestTree0 + minBound + TreeFold + { foldSingle = \_ name _ -> stringWidth name + , foldGroup = \_ _ m -> if null m then minBound else maximum m + indentSize + , foldResource = \_ _ f -> f $ throwIO NotRunningTests + , foldAfter = \_ _ _ b -> b } opts - where - fromMonoid m = - case m 0 of - MinusInfinity -> 0 - Maximum x -> x -- | Compute the length/width of the string as it would appear in a monospace -- terminal. This takes into account that even in a “mono”space font, not 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 @@ -58,7 +58,18 @@ -- @\"0.5m\"@), so that we can print it back. 'Integer' is the number of -- microseconds. | NoTimeout - deriving (Show, Typeable) + deriving + ( Eq + -- ^ Auto-derived instance, just to allow storing in a 'Map' and such. + -- + -- @since 1.5.1 + , Ord + -- ^ Auto-derived instance, just to allow storing in a 'Map' and such. + -- + -- @since 1.5.1 + , Show + , Typeable + ) instance IsOption Timeout where defaultValue = NoTimeout diff --git a/Test/Tasty/Patterns.hs b/Test/Tasty/Patterns.hs --- a/Test/Tasty/Patterns.hs +++ b/Test/Tasty/Patterns.hs @@ -48,7 +48,15 @@ defaultValue = noPattern parseValue = parseTestPattern optionName = return "pattern" - optionHelp = return "Select only tests which satisfy a pattern or awk expression" +#if !defined(mingw32_HOST_OS) + optionHelp = return "Select only tests which satisfy a pattern or awk expression." +#else + optionHelp = return + $ unwords [ "Select only tests which satisfy a pattern or awk expression." + , "Consider using `MSYS_NO_PATHCONV=1` or `MSYS2_ARG_CONV_EXCL=*`" + , "to prevent pattern mangling." + ] +#endif optionCLParser = fmap (TestPattern . fmap (foldr1 And) . nonEmpty . catMaybes . coerce @[TestPattern]) . some $ mkOptionCLParser (short 'p' <> metavar "PATTERN") diff --git a/Test/Tasty/Run.hs b/Test/Tasty/Run.hs --- a/Test/Tasty/Run.hs +++ b/Test/Tasty/Run.hs @@ -6,10 +6,11 @@ ( Status(..) , StatusMap , launchTestTree + , applyTopLevelPlusTestOptions , DependencyException(..) ) where -import qualified Data.IntMap as IntMap +import qualified Data.IntMap.Strict as IntMap import qualified Data.Sequence as Seq import qualified Data.Foldable as F import Data.Int (Int64) @@ -576,6 +577,31 @@ FailedToCreate {} -> return $ return Nothing Destroyed -> return $ return Nothing +-- While tasty allows to configure 'OptionSet' at any level of test tree, +-- it often has any effect only on options of test providers (class IsTest). +-- But test runners and reporters typically only look into the OptionSet +-- they were given as an argument. This is not unreasonable: e. g., if an option +-- is a log filename you cannot expect to change it in the middle of the run. +-- It is however too restrictive: there is no way to use 'defaultMain' but hardcode +-- a global option, without passing it via command line. +-- +-- 'applyTopLevelPlusTestOptions' allows for a compromise: unwrap top-level +-- 'PlusTestOptions' from the 'TestTree' and apply them to the 'OptionSet' +-- from command line. This way a user can wrap their tests in +-- 'adjustOption' / 'localOption' forcing, for instance, 'NumThreads' to 1. +-- +-- This function is not publicly exposed. +applyTopLevelPlusTestOptions + :: OptionSet + -- ^ Raw options, typically from the command-line arguments. + -> TestTree + -- ^ Raw test tree. + -> (OptionSet, TestTree) + -- ^ Extended options and test tree stripped of outer layers of 'PlusTestOptions'. +applyTopLevelPlusTestOptions opts (PlusTestOptions f tree) = + applyTopLevelPlusTestOptions (f opts) tree +applyTopLevelPlusTestOptions opts tree = (opts, tree) + -- | Start running the tests (in background, in parallel) and pass control -- to the callback. -- @@ -602,12 +628,17 @@ -- all resource initializers and finalizers, which is why it is more -- accurate than what could be measured from inside the first callback. -> IO a -launchTestTree opts tree k0 = do +launchTestTree opts' tree' k0 = do + -- Normally 'applyTopLevelPlusTestOptions' has been already applied by + -- 'Test.Tasty.Ingredients.tryIngredients', but 'launchTestTree' is exposed + -- publicly, so in principle clients could use it outside of 'tryIngredients'. + -- Thus running 'applyTopLevelPlusTestOptions' again, just to be sure. + let (opts, tree) = applyTopLevelPlusTestOptions opts' tree' (testActions, fins) <- createTestActions opts tree - let NumThreads numTheads = lookupOption opts + let NumThreads numThreads = lookupOption opts (t,k1) <- timed $ do - abortTests <- runInParallel numTheads (testAction <$> testActions) - (do let smap = IntMap.fromList $ zip [0..] (testStatus <$> testActions) + abortTests <- runInParallel numThreads (testAction <$> testActions) + (do let smap = IntMap.fromDistinctAscList $ zip [0..] (testStatus <$> testActions) k0 smap) `finallyRestore` \restore -> do -- Tell all running tests to wrap up. diff --git a/tasty.cabal b/tasty.cabal --- a/tasty.cabal +++ b/tasty.cabal @@ -1,6 +1,6 @@ cabal-version: >=1.10 name: tasty -version: 1.5 +version: 1.5.1 synopsis: Modern and extensible testing framework description: Tasty is a modern testing framework for Haskell. It lets you combine your unit tests, golden @@ -61,11 +61,11 @@ build-depends: base >= 4.9 && < 5, stm >= 2.3 && < 2.6, - containers < 0.7, + containers >= 0.5.8 && < 0.8, transformers >= 0.5 && < 0.7, tagged >= 0.5 && < 0.9, optparse-applicative >= 0.14 && < 0.19, - ansi-terminal >= 0.9 && < 1.1 + ansi-terminal >= 0.9 && < 1.2 -- No reason to depend on unbounded-delays on 64-bit architecture if(!arch(x86_64) && !arch(aarch64))