Add resultTime field to T.T.Core.Result.

`resultTime` is initialized to 0 by default, and then overriden with the
actual test time by `executeTest`.

`TestReporter`s reporter is modified to return a continuation that
accepts the runtime of the entire suite before finishing.

Author: gridaphobe

core-tests/Resources.hs

@@ -59,6 +59,7 @@ testResources1 = testCase "Normal; a test excluded by a pattern" $ do
       rs <- runSMap smap
       assertBool "Resource is not available" $ all resultSuccessful rs
       readIORef ref >>= assertBool "Resource was not released" . not
+      return $ const $ return ()
 
 ------------------------------
 -- Exceptions
@@ -76,6 +77,7 @@ testResources2 = testCase "Exception during resource initialization" $
     Failure (TestThrewException (fromException -> Just (ErrorCall "exInit"))) ->
       return ()
     c -> assertFailure $ "Unexpected outcome: " ++ show c
+  return $ const $ return ()
 
 testTree3 :: IORef Bool -> TestTree
 testTree3 ref =
@@ -93,6 +95,7 @@ testResources3 = testCase "Exception in test body; resource is released" $ do
       c -> assertFailure $ "Unexpected outcome: " ++ show c
     b <- readIORef ref
     assertBool "Resource wasn't released" (not b)
+    return $ const $ return ()
 
 testTree4 :: IORef Bool -> TestTree
 testTree4 ref =
@@ -108,3 +111,4 @@ testResources4 = testCase "Exception in finalizer" $ do
       Failure (TestThrewException (fromException -> Just (ErrorCall "exFin"))) ->
         return ()
       c -> assertFailure $ "Unexpected outcome: " ++ show c
+    return $ const $ return ()

core-tests/Timeouts.hs

@@ -31,3 +31,4 @@ testTimeouts = testCase "Timeouts" $ do
       Result { resultOutcome = Success } -> assertFailure "Slow test passed"
       Result { resultOutcome = Failure (TestTimedOut 200000) } -> return ()
       _ -> assertFailure $ "Slow test failed for wrong reason: " ++ resultDescription fast
+    return $ const $ return ()

core/Test/Tasty/Core.hs

@@ -50,6 +50,8 @@ data Result = Result
     --
     -- For a failed test, 'resultDescription' should typically provide more
     -- information about the failure.
+  , resultTime :: Double
+    -- ^ How long it took to run the test, in seconds.
   }
 
 -- | 'True' for a passed test, 'False' for a failed one.
@@ -64,6 +66,7 @@ exceptionResult :: SomeException -> Result
 exceptionResult e = Result
   { resultOutcome = Failure $ TestThrewException e
   , resultDescription = "Exception: " ++ show e
+  , resultTime = 0
   }
 
 -- | Test progress information.

core/Test/Tasty/Ingredients.hs

@@ -64,7 +64,7 @@ import Test.Tasty.Options.Core
 data Ingredient
   = TestReporter
       [OptionDescription]
-      (OptionSet -> TestTree -> Maybe (StatusMap -> IO Bool))
+      (OptionSet -> TestTree -> Maybe (StatusMap -> IO (Double -> IO Bool)))
   | TestManager
       [OptionDescription]
       (OptionSet -> TestTree -> Maybe (IO Bool))

core/Test/Tasty/Ingredients/ConsoleReporter.hs

@@ -305,16 +305,17 @@ consoleTestReporter =
         | otherwise -> consoleOutput output smap
       }
 
-      if quiet
-        then do
-          fst <- failureStatus smap
-          return $ case fst of
-            OK -> True
-            _ -> False
-        else do
-          stats <- computeStatistics smap
-          printStatistics stats
-          return $ statFailures stats == 0
+      return $ \time ->
+        if quiet
+          then do
+            fst <- failureStatus smap
+            return $ case fst of
+              OK -> True
+              _ -> False
+          else do
+            stats <- computeStatistics smap
+            printStatistics stats
+            return $ statFailures stats == 0
 
 -- | Do not print test results (see README for details)
 newtype Quiet = Quiet Bool

core/Test/Tasty/Providers.hs

@@ -24,6 +24,7 @@ testPassed
 testPassed desc = Result
   { resultOutcome = Success
   , resultDescription = desc
+  , resultTime = 0
   }
 
 -- | 'Result' of a failed test
@@ -33,4 +34,5 @@ testFailed
 testFailed desc = Result
   { resultOutcome = Failure TestFailed
   , resultDescription = desc
+  , resultTime = 0
   }

core/Test/Tasty/Run.hs

@@ -1,5 +1,6 @@
 -- | Running tests
-{-# LANGUAGE ScopedTypeVariables, ExistentialQuantification, RankNTypes, FlexibleContexts #-}
+{-# LANGUAGE ScopedTypeVariables, ExistentialQuantification, RankNTypes,
+             FlexibleContexts, BangPatterns #-}
 module Test.Tasty.Run
   ( Status(..)
   , StatusMap
@@ -10,6 +11,7 @@ import qualified Data.IntMap as IntMap
 import qualified Data.Sequence as Seq
 import qualified Data.Foldable as F
 import Data.Maybe
+import Data.Time.Clock.POSIX
 import Control.Monad.State
 import Control.Monad.Writer
 import Control.Monad.Reader
@@ -95,15 +97,15 @@ executeTest action statusVar timeoutOpt inits fins = mask $ \restore -> do
     -- handler doesn't interfere with our timeout.
     withAsync (action yieldProgress) $ \asy -> do
       labelThread (asyncThreadId asy) "tasty_test_execution_thread"
-      applyTimeout timeoutOpt $ wait asy
+      timed $ applyTimeout timeoutOpt $ wait asy
 
   -- no matter what, try to run each finalizer
   mbExn <- destroyResources restore
 
   atomically . writeTVar statusVar $ Done $
     case resultOrExn <* maybe (Right ()) Left mbExn of
       Left ex -> exceptionResult ex
-      Right r -> r
+      Right (t,r) -> r { resultTime = t }
 
   where
     initResources :: IO ()
@@ -138,6 +140,7 @@ executeTest action statusVar timeoutOpt inits fins = mask $ \restore -> do
             { resultOutcome = Failure $ TestTimedOut t
             , resultDescription =
                 "Timed out after " ++ tstr
+            , resultTime = fromIntegral t
             }
       fromMaybe timeoutResult <$> timeout t a
 
@@ -244,17 +247,19 @@ getResource var =
 launchTestTree
   :: OptionSet
   -> TestTree
-  -> (StatusMap -> IO a)
+  -> (StatusMap -> IO (Double -> IO a))
   -> IO a
 launchTestTree opts tree k = do
   (testActions, rvars) <- createTestActions opts tree
   let NumThreads numTheads = lookupOption opts
-  abortTests <- runInParallel numTheads (fst <$> testActions)
-  (do let smap = IntMap.fromList $ zip [0..] (snd <$> testActions)
-      k smap)
-   `finally` do
-      abortTests
-      waitForResources rvars
+  (t,k) <- timed $ do
+     abortTests <- runInParallel numTheads (fst <$> testActions)
+     (do let smap = IntMap.fromList $ zip [0..] (snd <$> testActions)
+         k smap)
+      `finally` do
+         abortTests
+         waitForResources rvars
+  k t
   where
     alive :: Resource r -> Bool
     alive r = case r of
@@ -271,3 +276,13 @@ launchTestTree opts tree k = do
 
 unexpectedState :: String -> Resource r -> SomeException
 unexpectedState where_ r = toException $ UnexpectedState where_ (show r)
+
+timed :: IO a -> IO (Double, a)
+timed t = do
+  start <- getTime
+  !r    <- t
+  end   <- getTime
+  return (end-start, r)
+
+getTime :: IO Double
+getTime = realToFrac <$> getPOSIXTime

core/tasty.cabal

@@ -57,7 +57,8 @@ library
     deepseq >= 1.3,
     unbounded-delays >= 0.1,
     async >= 2.0,
-    ansi-terminal >= 0.6.1
+    ansi-terminal >= 0.6.1,
+    time >= 1.4
 
   if impl(ghc < 7.6)
     -- for GHC.Generics