tasty 0.9.0.1 → 0.10
raw patch · 7 files changed
+137/−39 lines, 7 filesdep +timedep ~ansi-terminaldep ~asyncdep ~containers
Dependencies added: time
Dependency ranges changed: ansi-terminal, async, containers, deepseq, mtl, regex-tdfa-rc, stm, tagged
Files
- Test/Tasty/Core.hs +6/−0
- Test/Tasty/Ingredients.hs +4/−3
- Test/Tasty/Ingredients/ConsoleReporter.hs +79/−19
- Test/Tasty/Providers.hs +2/−0
- Test/Tasty/Run.hs +42/−15
- Test/Tasty/Runners.hs +1/−0
- tasty.cabal +3/−2
Test/Tasty/Core.hs view
@@ -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.
Test/Tasty/Ingredients.hs view
@@ -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))
Test/Tasty/Ingredients/ConsoleReporter.hs view
@@ -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 -- }}}
Test/Tasty/Providers.hs view
@@ -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 }
Test/Tasty/Run.hs view
@@ -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
Test/Tasty/Runners.hs view
@@ -10,6 +10,7 @@ , module Test.Tasty.Runners.Reducers -- * Ingredients , Ingredient(..)+ , Time , tryIngredients , ingredientOptions , ingredientsOptions
tasty.cabal view
@@ -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