Fixed performance regression when using --no-progress

UnkindPartition · Apr 30, 2023 · 25f5e36 · 25f5e36
1 parent b81d877
commit 25f5e36
Show file tree

Hide file tree

Showing 2 changed files with 6 additions and 4 deletions.
diff --git 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
@@ -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