Tasty progress reporting

.github/workflows/ci.yaml

@@ -77,7 +77,7 @@ jobs:
         core-tests/resource-release-test.sh
 
     - name: Haddock
-      if: matrix.ghc != '8.0' && matrix.ghc != '8.2'
+      if: matrix.ghc != '8.0' && matrix.ghc != '8.2' && matrix.ghc != '8.4'
       run: cabal haddock all
 
   build-wasi:

README.md

@@ -191,9 +191,9 @@ your test suite with the `--help` flag. The output will look something like this
 % ./test --help
 Mmm... tasty test suite
 
-Usage: test [-p|--pattern PATTERN] [-t|--timeout DURATION] [-l|--list-tests]
-            [-j|--num-threads NUMBER] [-q|--quiet] [--hide-successes]
-            [--color never|always|auto] [--ansi-tricks ARG]
+Usage: test [-p|--pattern PATTERN] [-t|--timeout DURATION] [--no-progress]
+            [-l|--list-tests] [-j|--num-threads NUMBER] [-q|--quiet]
+            [--hide-successes] [--color never|always|auto] [--ansi-tricks ARG]
             [--smallcheck-depth NUMBER] [--smallcheck-max-count NUMBER]
             [--quickcheck-tests NUMBER] [--quickcheck-replay SEED]
             [--quickcheck-show-replay] [--quickcheck-max-size NUMBER]
@@ -206,6 +206,7 @@ Available options:
                            expression
   -t,--timeout DURATION    Timeout for individual tests (suffixes: ms,s,m,h;
                            default: s)
+  --no-progress            Do not show progress
   -l,--list-tests          Do not run the tests; just print their names
   -j,--num-threads NUMBER  Number of threads to use for tests execution
                            (default: # of cores/capabilities)

core/CHANGELOG.md

@@ -11,6 +11,9 @@ _YYYY-MM-DD_
 * Dependencies can now be defined pattern-free with `sequentialTestGroup` ([#343](https://github.com/UnkindPartition/tasty/issues/343)).
 * Added `--min-duration-to-report` flag that specifies the time a test must take before `tasty` outputs timing information ([#341](https://github.com/UnkindPartition/tasty/issues/341)).
 * When a test failed with an exception, print it using `displayException` instead of `show` ([#330](https://github.com/UnkindPartition/tasty/issues/330)).
+* `PrintTest` constructor now has an extra field used to report progress.
+  Supply `const (pure ())` as this extra field value if you want to skip progress reporting.
+* Progress reporting is no longer ignored.
 
 Version 1.4.3
 ---------------

core/Test/Tasty/Core.hs

@@ -11,6 +11,7 @@ module Test.Tasty.Core
   , resultSuccessful
   , exceptionResult
   , Progress(..)
+  , emptyProgress
   , IsTest(..)
   , TestName
   , ResourceSpec(..)
@@ -181,8 +182,15 @@ data Progress = Progress
   }
   deriving
   ( Show -- ^ @since 1.2
+  , Eq   -- ^ @since 1.5
   )
 
+-- | Empty progress
+--
+-- @since 1.5
+emptyProgress :: Progress
+emptyProgress = Progress mempty 0.0
+
 -- | The interface to be implemented by a test provider.
 --
 -- The type @t@ is the concrete representation of the test which is used by
@@ -201,9 +209,6 @@ class Typeable t => IsTest t where
     :: OptionSet -- ^ options
     -> t -- ^ the test to run
     -> (Progress -> IO ()) -- ^ a callback to report progress.
-                           -- Note: the callback is a no-op at the moment
-                           -- and there are no plans to use it;
-                           -- feel free to ignore this argument for now.
     -> IO Result
 
   -- | The list of options that affect execution of tests of this type

core/Test/Tasty/Ingredients/ConsoleReporter.hs

@@ -76,17 +76,28 @@ import Data.Foldable (foldMap)
 --
 -- @since 0.12
 data TestOutput
-  = PrintTest
-      {- test name         -} String
-      {- print test name   -} (IO ())
-      {- print test result -} (Result -> IO ())
-      -- ^ Name of a test, an action that prints the test name, and an action
-      -- that renders the result of the action.
-  | PrintHeading String (IO ()) TestOutput
-      -- ^ Name of a test group, an action that prints the heading of a test
-      -- group and the 'TestOutput' for that test group.
-  | Skip -- ^ Inactive test (e.g. not matching the current pattern)
-  | Seq TestOutput TestOutput -- ^ Two sets of 'TestOutput' on the same level
+  = -- | Printing a test.
+    PrintTest
+      String
+        -- ^ Name of the test.
+      (IO ())
+        -- ^ Action that prints the test name.
+      (Progress -> IO ())
+        -- ^ Action that prints the progress of the test.  /Since: 1.5/
+      (Result -> IO ())
+        -- ^ Action that renders the result of the test.
+  | -- | Printing a test group.
+    PrintHeading
+      String
+        -- ^ Name of the test group
+      (IO ())
+        -- ^ Action that prints the heading of a test group.
+      TestOutput
+        -- ^ The 'TestOutput' for that test group.
+  | -- | Inactive test (e.g. not matching the current pattern).
+    Skip
+  | -- | Two sets of 'TestOutput' on the same level.
+    Seq TestOutput TestOutput
 
 -- The monoid laws should hold observationally w.r.t. the semantics defined
 -- in this module.
@@ -103,8 +114,8 @@ instance Monoid TestOutput where
 applyHook :: ([TestName] -> Result -> IO Result) -> TestOutput -> TestOutput
 applyHook hook = go []
   where
-    go path (PrintTest name printName printResult) =
-      PrintTest name printName (printResult <=< hook (name : path))
+    go path (PrintTest name printName printProgress printResult) =
+      PrintTest name printName printProgress (printResult <=< hook (name : path))
     go path (PrintHeading name printName printBody) =
       PrintHeading name printName (go (name : path) printBody)
     go path (Seq a b) = Seq (go path a) (go path b)
@@ -123,6 +134,7 @@ buildTestOutput opts tree =
     !alignment = computeAlignment opts tree
 
     MinDurationToReport{minDurationMicros} = lookupOption opts
+    AnsiTricks{getAnsiTricks} = lookupOption opts
 
     runSingleTest
       :: (IsTest t, ?colors :: Bool)
@@ -131,11 +143,40 @@ buildTestOutput opts tree =
       level <- ask
 
       let
+        indentedNameWidth = indentSize * level + stringWidth name
+        postNamePadding = alignment - indentedNameWidth
+
+        testNamePadded = printf "%s%s: %s"
+          (indent level)
+          name
+          (replicate postNamePadding ' ')
+
+        resultPosition = length testNamePadded
+
         printTestName = do
-          printf "%s%s: %s" (indent level) name
-            (replicate (alignment - indentSize * level - stringWidth name) ' ')
+          putStr testNamePadded
           hFlush stdout
 
+        printTestProgress progress
+          -- We cannot display progress properly if a terminal
+          -- does not support manipulations with cursor position.
+          | not getAnsiTricks = pure ()
+
+          | progress == emptyProgress = pure ()
+
+          | otherwise = do
+              let
+                msg = case (cleanupProgressText $ progressText progress, 100 * progressPercent progress) of
+                        ("",  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
+              hFlush stdout
+
         printTestResult result = do
           rDesc <- formatMessage $ resultDescription result
 
@@ -147,6 +188,11 @@ buildTestOutput opts tree =
                 Failure TestDepFailed -> skipped
                 _ -> fail
             time = resultTime result
+
+          when getAnsiTricks $ do
+            setCursorColumn resultPosition
+            clearFromCursorToLineEnd
+
           printFn (resultShortDescription result)
           when (floor (time * 1e6) >= minDurationMicros) $
             printFn (printf " (%.2fs)" time)
@@ -158,7 +204,7 @@ buildTestOutput opts tree =
           case resultDetailsPrinter result of
             ResultDetailsPrinter action -> action level withConsoleFormat
 
-      return $ PrintTest name printTestName printTestResult
+      return $ PrintTest name printTestName printTestProgress printTestResult
 
     runGroup :: OptionSet -> TestName -> [Ap (Reader Level) TestOutput] -> Ap (Reader Level) TestOutput
     runGroup _opts name grp = Ap $ do
@@ -177,6 +223,13 @@ buildTestOutput opts tree =
           }
           opts tree
 
+-- | Make sure the progress text does not contain any newlines or line feeds,
+-- lest our ANSI magic breaks. Since the progress text is expected to be short,
+-- we simply drop anything after a newline.
+cleanupProgressText :: String -> String
+cleanupProgressText = map (\c -> if isSpace c then ' ' else c)
+                    . takeWhile (\c -> c /= '\n' && c /= '\r' && c /= '\t')
+
 -- | Fold function for the 'TestOutput' tree into a 'Monoid'.
 --
 -- @since 0.12
@@ -194,15 +247,17 @@ foldTestOutput
   -> b
 foldTestOutput foldTest foldHeading outputTree smap =
   flip evalState 0 $ getApp $ go outputTree where
-  go (PrintTest name printName printResult) = Ap $ do
+
+  go (PrintTest name printName printProgress printResult) = Ap $ do
     ix <- get
     put $! ix + 1
     let
       statusVar =
         fromMaybe (error "internal error: index out of bounds") $
         IntMap.lookup ix smap
-      readStatusVar = getResultFromTVar statusVar
-    return $ foldTest name printName readStatusVar printResult
+
+    return $ foldTest name printName (ppProgressOrResult statusVar printProgress) printResult
+
   go (PrintHeading name printName printBody) = Ap $
     foldHeading name printName <$> getApp (go printBody)
   go (Seq a b) = mappend (go a) (go b)
@@ -213,6 +268,19 @@ foldTestOutput foldTest foldHeading outputTree smap =
 --------------------------------------------------
 -- TestOutput modes
 --------------------------------------------------
+
+ppProgressOrResult :: TVar Status -> (Progress -> IO ()) -> IO Result
+ppProgressOrResult statusVar ppProgress = go emptyProgress where
+  go old_p = either (\p -> ppProgress p *> go p) return =<< (atomically $ do
+    status <- readTVar statusVar
+    case status of
+      Executing p
+        | p == old_p -> retry
+        | otherwise -> pure $ Left p
+      Done r      -> pure $ Right r
+      _           -> retry
+    )
+
 -- {{{
 consoleOutput :: (?colors :: Bool) => TestOutput -> StatusMap -> IO ()
 consoleOutput toutput smap =
@@ -226,7 +294,8 @@ consoleOutput toutput smap =
       , Any True)
     foldHeading _name printHeading (printBody, Any nonempty) =
       ( Traversal $ do
-          when nonempty $ do printHeading :: IO (); getTraversal printBody
+          when nonempty $ printHeading
+          getTraversal printBody
       , Any nonempty
       )
 
@@ -488,7 +557,11 @@ consoleTestReporterWithHook hook = TestReporter consoleTestReporterOptions $
             ?colors = useColor whenColor isTermColor
 
           let
-            toutput = applyHook hook $ buildTestOutput opts tree
+            -- 'buildTestOutput' is a pure function and cannot query 'hSupportsANSI' itself.
+            -- We also would rather not pass @isTerm@ as an extra argument,
+            -- since it's a breaking change, thus resorting to tweaking @opts@.
+            opts' = changeOption (\(AnsiTricks x) -> AnsiTricks (x && isTerm)) opts
+            toutput = applyHook hook $ buildTestOutput opts' tree
 
           case () of { _
             | hideSuccesses && isTerm && ansiTricks ->

core/Test/Tasty/Options/Core.hs

@@ -5,6 +5,7 @@ module Test.Tasty.Options.Core
   ( NumThreads(..)
   , Timeout(..)
   , mkTimeout
+  , HideProgress(..)
   , coreOptions
   -- * Helpers
   , parseDuration
@@ -97,6 +98,21 @@ mkTimeout n =
   Timeout n $
     showFixed True (fromInteger n / (10^6) :: Micro) ++ "s"
 
+-- | Hide progress information. If progress disabled, the test launcher
+-- 'Test.Tasty.Runners.launchTestTree' completely ignores callbacks to update progress.
+-- If enabled, it's up to individual 'Test.Tasty.Ingredients.TestReporter's
+-- how to execute, some might not be able to render progress anyways.
+--
+-- @since 1.5
+newtype HideProgress = HideProgress { getHideProgress :: Bool }
+  deriving (Eq, Ord, Typeable)
+instance IsOption HideProgress where
+    defaultValue = HideProgress False
+    parseValue = fmap HideProgress . safeReadBool
+    optionName = return "hide-progress"
+    optionHelp = return "Do not show progress"
+    optionCLParser = mkFlagCLParser mempty (HideProgress True)
+
 -- | The list of all core options, i.e. the options not specific to any
 -- provider or ingredient, but to tasty itself. Currently contains
 -- 'TestPattern' and 'Timeout'.
@@ -106,4 +122,5 @@ coreOptions :: [OptionDescription]
 coreOptions =
   [ Option (Proxy :: Proxy TestPattern)
   , Option (Proxy :: Proxy Timeout)
+  , Option (Proxy :: Proxy HideProgress)
   ]

core/Test/Tasty/Run.hs

@@ -108,11 +108,12 @@ 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
-  resultOrExn <- try $ 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
     -- finalizers.
@@ -122,10 +123,15 @@ executeTest action statusVar timeoutOpt inits fins = mask $ \restore -> do
     -- anyway.
     initResources
 
+    let
+      cursorMischiefManaged = do
+        atomically $ writeTVar statusVar (Executing emptyProgress)
+        action yieldProgress
+
     -- If all initializers ran successfully, actually run the test.
     -- We run it in a separate thread, so that the test's exception
     -- handler doesn't interfere with our timeout.
-    withAsync (action yieldProgress) $ \asy -> do
+    withAsync cursorMischiefManaged $ \asy -> do
       labelThread (asyncThreadId asy) "tasty_test_execution_thread"
       timed $ applyTimeout timeoutOpt $ do
         r <- wait asy
@@ -140,7 +146,7 @@ executeTest action statusVar timeoutOpt inits fins = mask $ \restore -> do
   -- no matter what, try to run each finalizer
   mbExn <- destroyResources restore
 
-  atomically . writeTVar statusVar $ Done $
+  atomically . writeTVar statusVar . Done $
     case resultOrExn <* maybe (Right ()) Left mbExn of
       Left ex -> exceptionResult ex
       Right (t,r) -> r { resultTime = t }
@@ -218,13 +224,16 @@ executeTest action statusVar timeoutOpt inits fins = mask $ \restore -> do
 
             tell $ First mbExcn
 
-    -- The callback
-    -- Since this is not used yet anyway, disable for now.
-    -- I'm not sure whether we should get rid of this altogether. For most
-    -- providers this is either difficult to implement or doesn't make
-    -- sense at all.
-    -- See also https://github.com/UnkindPartition/tasty/issues/33
-    yieldProgress _ = return ()
+    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 ?
+      pure ()
+    yieldProgress newP = liftIO
+      . atomically
+      . writeTVar statusVar
+      $ Executing newP
 
 -- | Traversal type used in 'createTestActions'
 type Tr = ReaderT (Path, Seq Dependency) IO (TestActionTree UnresolvedAction)
@@ -389,7 +398,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

core/Test/Tasty/Runners.hs

@@ -39,6 +39,7 @@ module Test.Tasty.Runners
   , FailureReason(..)
   , resultSuccessful
   , Progress(..)
+  , emptyProgress
   , StatusMap
   , launchTestTree
   , NumThreads(..)