From 25f5e366f7c33c425325eafe44f41fc45a21bd8d 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 f716a491..92a4090c 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 9187d58e..645f3eb0 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.Seq Initializer -- ^ initializers (to be executed in this order)
   -> Seq.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 ?
@@ -316,7 +319,7 @@ createTestActions opts0 tree = do
       let
         path = parentPath Seq.|> name
         act (inits, fins) =
-          executeTest (run opts test) statusVar (lookupOption opts) inits fins
+          executeTest (run opts test) statusVar (lookupOption opts) (lookupOption opts) inits fins
       tell ([(act, CreateTestAction statusVar path deps)], mempty)
     addInitAndRelease :: OptionSet -> ResourceSpec a -> (IO a -> Tr) -> Tr
     addInitAndRelease _opts (ResourceSpec doInit doRelease) a = wrap $ \path deps -> do