module Test.Tasty.Ingredients.FailFast
( failFast
, FailFast(..)
) where
import Control.Applicative
import Control.Concurrent
import Control.Concurrent.STM
import qualified Data.IntMap.Strict as IM
import Data.Monoid
import Data.Proxy
import Data.Typeable
import Test.Tasty.Ingredients
import Test.Tasty.Options
import Test.Tasty.Runners
import Prelude
failFast :: Ingredient -> Ingredient
failFast (TestReporter opts f) = TestReporter (ffOpt:opts) f'
where ffOpt = Option (Proxy :: Proxy FailFast)
f' oset tree = let FailFast ff = lookupOption oset
in if ff
then ffHijack <$> f oset tree
else f oset tree
failFast i = i
ffHijack :: (StatusMap -> IO (Time -> IO Bool)) -> StatusMap -> IO (Time -> IO Bool)
ffHijack f sm = do
_ <- forkIO (work sm)
f sm
newtype FailFast = FailFast Bool deriving (Show, Eq, Typeable)
instance IsOption FailFast where
defaultValue = FailFast False
parseValue = fmap FailFast . safeRead
optionName = return "fail-fast"
optionHelp = return "Fail the whole suite when the first test fails."
optionCLParser = flagCLParser Nothing (FailFast True)
work :: StatusMap -> IO ()
work sm = atomically $ do
check =<< anyFailed sm
failAll sm
anyFailed :: StatusMap -> STM Bool
anyFailed = anyM (fmap isFailed . readTVar) . IM.elems
where isFailed (Done (Result { resultOutcome = Failure _})) = True
isFailed _ = False
anyM :: Monad m => (a -> m Bool) -> [a] -> m Bool
anyM _ [] = return False
anyM p (x:xs) = do q <- p x
if q
then return True
else anyM p xs
failAll :: StatusMap -> STM ()
failAll = mapM_ failOne . IM.elems
failOne :: TVar Status -> STM ()
failOne = flip modifyTVar' go
where go NotStarted = Done res
go x = x
res = Result { resultOutcome = Failure TestFailed
, resultDescription = mempty
#if MIN_VERSION_tasty(0,11,0)
, resultShortDescription = mempty
#endif
, resultTime = 0}