diff --git a/Test/Tasty/Core.hs b/Test/Tasty/Core.hs --- a/Test/Tasty/Core.hs +++ b/Test/Tasty/Core.hs @@ -37,6 +37,9 @@ | Failure FailureReason -- ^ test failed because of the 'FailureReason' deriving (Show, Generic) +-- | Time in seconds. Used to measure how long the tests took to run. +type Time = Double + -- | A test result data Result = Result { resultOutcome :: Outcome @@ -50,6 +53,8 @@ -- -- For a failed test, 'resultDescription' should typically provide more -- information about the failure. + , resultTime :: Time + -- ^ How long it took to run the test, in seconds. } -- | 'True' for a passed test, 'False' for a failed one. @@ -64,6 +69,7 @@ exceptionResult e = Result { resultOutcome = Failure $ TestThrewException e , resultDescription = "Exception: " ++ show e + , resultTime = 0 } -- | Test progress information. diff --git a/Test/Tasty/Ingredients.hs b/Test/Tasty/Ingredients.hs --- a/Test/Tasty/Ingredients.hs +++ b/Test/Tasty/Ingredients.hs @@ -46,8 +46,7 @@ -- on if you want to create a new ingredient. -- -- There are two kinds of ingredients. 'TestReporter', if it agrees to run, --- automatically launches tests execution, and gets the 'StatusMap' which --- it uses to report the progress and results to the user. +-- automatically launches tests execution. -- -- 'TestManager' is the second kind of ingredient. It is typically used for -- test management purposes (such as listing the test names), although it @@ -64,7 +63,9 @@ data Ingredient = TestReporter [OptionDescription] - (OptionSet -> TestTree -> Maybe (StatusMap -> IO Bool)) + (OptionSet -> TestTree -> Maybe (StatusMap -> IO (Time -> IO Bool))) + -- ^ For the explanation on how the callback works, see the + -- documentation for 'launchTestTree'. | TestManager [OptionDescription] (OptionSet -> TestTree -> Maybe (IO Bool)) diff --git a/Test/Tasty/Ingredients/ConsoleReporter.hs b/Test/Tasty/Ingredients/ConsoleReporter.hs --- a/Test/Tasty/Ingredients/ConsoleReporter.hs +++ b/Test/Tasty/Ingredients/ConsoleReporter.hs @@ -9,7 +9,7 @@ import Prelude hiding (fail) import Control.Monad.State hiding (fail) -import Control.Monad.Reader hiding (fail) +import Control.Monad.Reader hiding (fail,reader) import Control.Concurrent.STM import Control.Exception import Control.DeepSeq @@ -21,11 +21,15 @@ import Test.Tasty.Runners.Reducers import Text.Printf import qualified Data.IntMap as IntMap +import Data.Char import Data.Maybe import Data.Monoid import Data.Proxy +import Data.Tagged import Data.Typeable import Data.Foldable (foldMap) +import Options.Applicative +import Options.Applicative.Types (ReadM(..)) import System.IO import System.Console.ANSI @@ -72,9 +76,20 @@ printTestResult result = do rDesc <- formatMessage $ resultDescription result + -- use an appropriate printing function + let + printFn = + if resultSuccessful result + then ok + else fail + time = resultTime result if resultSuccessful result - then ok "OK\n" - else fail "FAIL\n" + then printFn "OK" + else printFn "FAIL" + -- print time only if it's significant + when (time >= 0.01) $ + printFn (printf " (%.2fs)" time) + printFn "\n" when (not $ null rDesc) $ (if resultSuccessful result then infoOk else infoFail) $ @@ -217,16 +232,16 @@ (\r -> Statistics 1 (if resultSuccessful r then 0 else 1)) <$> getResultFromTVar var) -printStatistics :: (?colors :: Bool) => Statistics -> IO () -printStatistics st = do +printStatistics :: (?colors :: Bool) => Statistics -> Time -> IO () +printStatistics st time = do printf "\n" case statFailures st of 0 -> do - ok $ printf "All %d tests passed\n" (statTotal st) + ok $ printf "All %d tests passed (%.2fs)\n" (statTotal st) time fs -> do - fail $ printf "%d out of %d tests failed\n" fs (statTotal st) + fail $ printf "%d out of %d tests failed (%.2fs)\n" fs (statTotal st) time data FailureStatus = Unknown @@ -268,6 +283,7 @@ TestReporter [ Option (Proxy :: Proxy Quiet) , Option (Proxy :: Proxy HideSuccesses) + , Option (Proxy :: Proxy UseColor) ] $ \opts tree -> Just $ \smap -> @@ -281,11 +297,14 @@ hSetBuffering stdout NoBuffering let - ?colors = isTerm - let + whenColor = lookupOption opts Quiet quiet = lookupOption opts HideSuccesses hideSuccesses = lookupOption opts + let + ?colors = useColor whenColor isTerm + + let output = produceOutput opts tree case () of { _ @@ -297,16 +316,17 @@ | 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 time + return $ statFailures stats == 0 -- | Do not print test results (see README for details) newtype Quiet = Quiet Bool @@ -327,6 +347,46 @@ optionName = return "hide-successes" optionHelp = return "Do not print tests that passed successfully" optionCLParser = flagCLParser Nothing (HideSuccesses True) + +-- | When to use color on the output +data UseColor + = Never | Always | Auto + deriving (Eq, Ord, Typeable) + +-- | Control color output +instance IsOption UseColor where + defaultValue = Auto + parseValue = parseUseColor + optionName = return "color" + optionHelp = return "When to use colored output. Options are 'never', 'always' and 'auto' (default: 'auto')" + optionCLParser = + option parse + ( long name + <> help (untag (optionHelp :: Tagged UseColor String)) + ) + where + name = untag (optionName :: Tagged UseColor String) + parse = + ReadM . + maybe (Left (ErrorMsg $ "Could not parse " ++ name)) Right . + parseValue + +-- | @useColor when isTerm@ decides if colors should be used, +-- where @isTerm@ denotes where @stdout@ is a terminal device. +useColor :: UseColor -> Bool -> Bool +useColor when isTerm = + case when of + Never -> False + Always -> True + Auto -> isTerm + +parseUseColor :: String -> Maybe UseColor +parseUseColor s = + case map toLower s of + "never" -> return Never + "always" -> return Always + "auto" -> return Auto + _ -> Nothing -- }}} diff --git a/Test/Tasty/Providers.hs b/Test/Tasty/Providers.hs --- a/Test/Tasty/Providers.hs +++ b/Test/Tasty/Providers.hs @@ -24,6 +24,7 @@ testPassed desc = Result { resultOutcome = Success , resultDescription = desc + , resultTime = 0 } -- | 'Result' of a failed test @@ -33,4 +34,5 @@ testFailed desc = Result { resultOutcome = Failure TestFailed , resultDescription = desc + , resultTime = 0 } diff --git a/Test/Tasty/Run.hs b/Test/Tasty/Run.hs --- a/Test/Tasty/Run.hs +++ b/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.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,7 +97,7 @@ -- 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 @@ -103,7 +105,7 @@ 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 @@ { resultOutcome = Failure $ TestTimedOut t , resultDescription = "Timed out after " ++ tstr + , resultTime = fromIntegral t } fromMaybe timeoutResult <$> timeout t a @@ -236,25 +239,37 @@ Destroyed -> throwSTM UseOutsideOfTest _ -> throwSTM $ unexpectedState "getResource" rState --- | Start running all the tests in a test tree in parallel. The number of --- threads is determined by the 'NumThreads' option. --- --- Return a map from the test number (starting from 0) to its status --- variable. +-- | Start running all the tests in a test tree in parallel, without +-- blocking the current thread. The number of test running threads is +-- determined by the 'NumThreads' option. launchTestTree :: OptionSet -> TestTree - -> (StatusMap -> IO a) + -> (StatusMap -> IO (Time -> IO a)) + -- ^ A callback. First, it receives the 'StatusMap' through which it + -- can observe the execution of tests in real time. Typically (but not + -- necessarily), it waits until all the tests are finished. + -- + -- After this callback returns, the test-running threads (if any) are + -- terminated and all resources acquired by tests are released. + -- + -- The callback must return another callback (of type @'Time' -> 'IO' + -- a@) which additionally can report and/or record the total time + -- taken by the test suite. This time includes the time taken to run + -- all resource initializers and finalizers, which is why it is more + -- accurate than what could be measured from inside the first callback. -> 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 +286,15 @@ unexpectedState :: String -> Resource r -> SomeException unexpectedState where_ r = toException $ UnexpectedState where_ (show r) + +-- | Measure the time taken by an 'IO' action to run +timed :: IO a -> IO (Time, a) +timed t = do + start <- getTime + !r <- t + end <- getTime + return (end-start, r) + +-- | Get system time +getTime :: IO Time +getTime = realToFrac <$> getPOSIXTime diff --git a/Test/Tasty/Runners.hs b/Test/Tasty/Runners.hs --- a/Test/Tasty/Runners.hs +++ b/Test/Tasty/Runners.hs @@ -10,6 +10,7 @@ , module Test.Tasty.Runners.Reducers -- * Ingredients , Ingredient(..) + , Time , tryIngredients , ingredientOptions , ingredientsOptions diff --git a/tasty.cabal b/tasty.cabal --- a/tasty.cabal +++ b/tasty.cabal @@ -2,7 +2,7 @@ -- see http://haskell.org/cabal/users-guide/ name: tasty -version: 0.9.0.1 +version: 0.10 synopsis: Modern and extensible testing framework description: Tasty is a modern testing framework for Haskell. It lets you combine your unit tests, golden @@ -57,7 +57,8 @@ 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