From 035bf2940b46b2c50c9d8ea6051773e2956c2aaf Mon Sep 17 00:00:00 2001
From: Marcin Szamotulski <coot@coot.me>
Date: Sun, 30 Apr 2023 11:05:06 +0200
Subject: [PATCH] Fixed performance regression when using --no-progress

---
 core/Test/Tasty/Ingredients/ConsoleReporter.hs | 3 +--
 core/Test/Tasty/Run.hs                         | 7 +++++--
 2 files changed, 6 insertions(+), 4 deletions(-)

diff --git a/core/Test/Tasty/Ingredients/ConsoleReporter.hs b/core/Test/Tasty/Ingredients/ConsoleReporter.hs
index 55e6e614..5beb08e7 100644
--- a/core/Test/Tasty/Ingredients/ConsoleReporter.hs
+++ b/core/Test/Tasty/Ingredients/ConsoleReporter.hs
@@ -143,8 +143,7 @@ buildTestOutput opts tree =
           hFlush stdout
 
         printTestProgress progress
-          | getHideProgress (lookupOption opts ) ||
-            progress == emptyProgress = pure ()
+          | progress == emptyProgress = pure ()
 
           | otherwise = do
               let
diff --git a/core/Test/Tasty/Run.hs b/core/Test/Tasty/Run.hs
index 3b239e87..e5d5d0d6 100644
--- a/core/Test/Tasty/Run.hs
+++ b/core/Test/Tasty/Run.hs
@@ -104,10 +104,11 @@ executeTest
     -- a parameter
   -> TVar Status -- ^ variable to write status to
   -> Timeout -- ^ optional timeout to apply
+  -> HideProgress -- ^ hide progress option
   -> Seq Initializer -- ^ initializers (to be executed in this order)
   -> Seq Finalizer -- ^ finalizers (to be executed in this order)
   -> IO ()
-executeTest action statusVar timeoutOpt inits fins = mask $ \restore -> do
+executeTest action statusVar timeoutOpt hideProgressOpt inits fins = mask $ \restore -> do
   resultOrExn <- try . restore $ do
     -- N.B. this can (re-)throw an exception. It's okay. By design, the
     -- actual test will not be run, then. We still run all the
@@ -220,6 +221,8 @@ executeTest action statusVar timeoutOpt inits fins = mask $ \restore -> do
 
             tell $ First mbExcn
 
+    yieldProgress _newP | getHideProgress hideProgressOpt =
+      pure ()
     yieldProgress newP | newP == emptyProgress =
       -- This could be changed to `Maybe Progress` to lets more easily indicate
       -- when progress should try to be printed ?
@@ -357,7 +360,7 @@ createTestActions opts0 tree = do
       (parentPath, testDeps) <- ask
       let
         testPath = parentPath |> name
-        testAction = executeTest (run opts test) testStatus (lookupOption opts)
+        testAction = executeTest (run opts test) testStatus (lookupOption opts) (lookupOption opts)
       pure $ TAction (TestAction {..})
 
     foldResource :: OptionSet -> ResourceSpec a -> (IO a -> Tr) -> Tr