diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,6 +1,13 @@ Changes ======= +Version 0.11.2.4 +---------------- + +1. Make the `--quiet` mode more efficient on a large number of tests +2. Fix a bug where a cursor would disappear if the test suite was terminated by + a signal other than SIGINT. + Version 0.11.2.3 ---------------- diff --git a/Test/Tasty/CmdLine.hs b/Test/Tasty/CmdLine.hs --- a/Test/Tasty/CmdLine.hs +++ b/Test/Tasty/CmdLine.hs @@ -1,5 +1,5 @@ -- | Parsing options supplied on the command line -{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE CPP, ScopedTypeVariables, DeriveDataTypeable #-} module Test.Tasty.CmdLine ( optionParser , suiteOptions @@ -10,17 +10,28 @@ import Options.Applicative import Data.Monoid import Data.Proxy -import Data.Foldable +import Data.Foldable (foldMap) import Prelude -- Silence AMP and FTP import warnings import System.Exit import System.IO +-- for installSignalHandlers +#ifdef UNIX +import Control.Concurrent (mkWeakThreadId, myThreadId) +import Control.Exception (Exception(..), throwTo) +import Control.Monad (forM_) +import Data.Typeable (Typeable) +import System.Posix.Signals +import System.Mem.Weak (deRefWeak) +#endif + import Test.Tasty.Core import Test.Tasty.Ingredients import Test.Tasty.Options import Test.Tasty.Options.Env import Test.Tasty.Runners.Reducers + -- | Generate a command line parser from a list of option descriptions optionParser :: [OptionDescription] -> Parser OptionSet optionParser = getApp . foldMap toSet where @@ -40,6 +51,7 @@ -- details. defaultMainWithIngredients :: [Ingredient] -> TestTree -> IO () defaultMainWithIngredients ins testTree = do + installSignalHandlers cmdlineOpts <- execParser $ info (helper <*> suiteOptionParser ins testTree) ( fullDesc <> @@ -58,3 +70,28 @@ Just act -> do ok <- act if ok then exitSuccess else exitFailure + +-- from https://ro-che.info/articles/2014-07-30-bracket +-- Install a signal handler so that e.g. the cursor is restored if the test +-- suite is killed by SIGTERM. +installSignalHandlers :: IO () +installSignalHandlers = do +#ifdef UNIX + main_thread_id <- myThreadId + weak_tid <- mkWeakThreadId main_thread_id + forM_ [ sigABRT, sigBUS, sigFPE, sigHUP, sigILL, sigQUIT, sigSEGV, + sigSYS, sigTERM, sigUSR1, sigUSR2, sigXCPU, sigXFSZ ] $ \sig -> + installHandler sig (Catch $ send_exception weak_tid sig) Nothing + where + send_exception weak_tid sig = do + m <- deRefWeak weak_tid + case m of + Nothing -> return () + Just tid -> throwTo tid (toException $ SignalException sig) + +newtype SignalException = SignalException Signal + deriving (Show, Typeable) +instance Exception SignalException +#else + return () +#endif 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 @@ -16,6 +16,7 @@ import Test.Tasty.Run import Test.Tasty.Ingredients import Test.Tasty.Options +import Test.Tasty.Options.Core import Test.Tasty.Runners.Reducers import Test.Tasty.Runners.Utils import Text.Printf @@ -241,39 +242,56 @@ fs -> do fail $ printf "%d out of %d tests failed (%.2fs)\n" fs (statTotal st) time -data FailureStatus - = Unknown - | Failed - | OK - -instance Monoid FailureStatus where - mappend Failed _ = Failed - mappend _ Failed = Failed - - mappend OK OK = OK - - mappend _ _ = Unknown - - mempty = OK - -- | Wait until -- -- * all tests have finished successfully, and return 'True', or -- -- * at least one test has failed, and return 'False' -statusMapResult :: StatusMap -> IO Bool -statusMapResult smap = atomically $ do - fst <- getApp $ flip foldMap smap $ \svar -> Ap $ do - status <- readTVar svar - return $ case status of - Done r -> - if resultSuccessful r then OK else Failed - _ -> Unknown - case fst of - OK -> return True - Failed -> return False - Unknown -> retry +statusMapResult + :: Int -- ^ lookahead + -> StatusMap + -> IO Bool +statusMapResult lookahead0 smap + | IntMap.null smap = return True + | otherwise = + join . atomically $ + IntMap.foldrWithKey f finish smap mempty lookahead0 + where + f :: Int + -> TVar Status + -> (IntMap.IntMap () -> Int -> STM (IO Bool)) + -> (IntMap.IntMap () -> Int -> STM (IO Bool)) + -- ok_tests is a set of tests that completed successfully + -- lookahead is the number of unfinished tests that we are allowed to + -- look at + f key tvar k ok_tests lookahead + | lookahead <= 0 = + -- We looked at too many unfinished tests. + next_iter ok_tests + | otherwise = do + this_status <- readTVar tvar + case this_status of + Done r -> + if resultSuccessful r + then k (IntMap.insert key () ok_tests) lookahead + else return $ return False + _ -> k ok_tests (lookahead-1) + -- next_iter is called when we end the current iteration, + -- either because we reached the end of the test tree + -- or because we exhausted the lookahead + next_iter :: IntMap.IntMap () -> STM (IO Bool) + next_iter ok_tests = + -- If we made no progress at all, wait until at least some tests + -- complete. + -- Otherwise, reduce the set of tests we are looking at. + if IntMap.null ok_tests + then retry + else return $ statusMapResult lookahead0 (IntMap.difference smap ok_tests) + + finish :: IntMap.IntMap () -> Int -> STM (IO Bool) + finish ok_tests _ = next_iter ok_tests + -- }}} -------------------------------------------------- @@ -295,10 +313,11 @@ whenColor = lookupOption opts Quiet quiet = lookupOption opts HideSuccesses hideSuccesses = lookupOption opts + NumThreads numThreads = lookupOption opts if quiet then do - b <- statusMapResult smap + b <- statusMapResult numThreads smap return $ \_time -> return b else @@ -318,7 +337,6 @@ output = produceOutput opts tree case () of { _ - | quiet -> return () | hideSuccesses && isTerm -> consoleOutputHidingSuccesses output smap | hideSuccesses && not isTerm -> 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.11.2.3 +version: 0.11.2.4 synopsis: Modern and extensible testing framework description: Tasty is a modern testing framework for Haskell. It lets you combine your unit tests, golden @@ -63,6 +63,10 @@ if impl(ghc < 7.6) -- for GHC.Generics build-depends: ghc-prim + + if !os(windows) + build-depends: unix + cpp-options: -DUNIX -- hs-source-dirs: default-language: Haskell2010