diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,30 @@ # Changelog +## [0.33.4.0] - 2026-11-06 + +### Added + +* `tryTestFailure`, to catch what a test throws in an `IsTest` instance. + +### Changed + +* A test that throws an exception classified as asynchronous, as `effectful`'s + `Error` effect does, now fails with that exception instead of stopping the + test suite. + `exceptionHandlers` now re-throws only `AsyncException` (which includes + Ctrl-C's `UserInterrupt`), `async`'s `AsyncCancelled` and + `System.Timeout.Timeout`. +* An exception that escapes an `IsTest` instance now fails that test instead + of stopping the suite. +* Mutation mode decides which exceptions stop the run the same way, so one + that is only classified as asynchronous counts as killing the mutation. + +### Fixed + +* The asynchronous runner no longer hangs when an exception escapes a test. +* `--fail-fast` no longer hangs when two tests fail at the same moment. +* A staged golden test that throws now fails instead of hanging. + ## [0.33.3.0] - 2026-10-30 ### Added diff --git a/src/Test/Syd/MutationMode/Common.hs b/src/Test/Syd/MutationMode/Common.hs --- a/src/Test/Syd/MutationMode/Common.hs +++ b/src/Test/Syd/MutationMode/Common.hs @@ -50,6 +50,7 @@ import Control.Exception (Exception) import qualified Control.Exception as Exception +import Data.Either (fromRight) import Data.List (intercalate) import qualified Data.Text as T import Data.Word (Word64) @@ -74,6 +75,7 @@ import Test.Syd.Mutation.Runtime (MutationId (..), renderMutationId) import Test.Syd.Mutation.TestId (TestId, renderTestId) import Test.Syd.OptParse (Settings, settingTerminalCapabilities) +import Test.Syd.Run (tryTestFailure) import Text.Colour (Chunk, chunk, cyan, fore, green, hPutChunksUtf8With, red, unlinesChunks, yellow) -- | Difference of two 'getMonotonicTimeNSec' readings expressed in @@ -133,23 +135,19 @@ SuiteTimedOut Word (Maybe (Path Rel File)) deriving (Eq, Show) --- | Wrap a per-suite runner so that any synchronous exception escaping it is --- treated as 'SuiteKilled'. A mutation that makes the child process --- unrunnable (e.g. 'BlockedIndefinitelyOnMVar' / @<>@ propagating from --- 'waitExitCode', an 'IOException' from log-file IO, a parse failure on the --- child's output) is conceptually indistinguishable from a mutation that --- makes the child crash — both mean the test detected the mutation. +-- | Wrap a per-suite runner so that any exception escaping it is treated as +-- 'SuiteKilled', except the ones that stop the run. +-- A mutation that makes the child process unrunnable (e.g. +-- 'BlockedIndefinitelyOnMVar' / @<>@ propagating from 'waitExitCode', an +-- 'IOException' from log-file IO, a parse failure on the child's output) is +-- conceptually indistinguishable from a mutation that makes the child crash: +-- both mean the test detected the mutation. -- --- 'SomeAsyncException' is re-thrown so Ctrl-C and other cancellations still --- propagate out of the runner. +-- 'tryTestFailure' decides, so Ctrl-C and other cancellations still propagate +-- out of the runner, exactly as they do out of a test. classifySyncExceptionAsKilled :: IO SuiteOutcome -> IO SuiteOutcome classifySyncExceptionAsKilled action = - Exception.handle - ( \(e :: Exception.SomeException) -> case Exception.fromException e of - Just (_ :: Exception.SomeAsyncException) -> Exception.throwIO e - Nothing -> pure (SuiteKilled Nothing) - ) - action + fromRight (SuiteKilled Nothing) <$> tryTestFailure action -- | Retry an 'IO' action that produces a tagged failure reason. -- diff --git a/src/Test/Syd/Run.hs b/src/Test/Syd/Run.hs --- a/src/Test/Syd/Run.hs +++ b/src/Test/Syd/Run.hs @@ -34,7 +34,7 @@ import Myers.Diff (Diff, getTextDiff) import OptEnvConf import System.Random (mkStdGen, setStdGen) -import System.Timeout (timeout) +import System.Timeout (Timeout, timeout) import Test.QuickCheck import Test.QuickCheck.Gen import Test.QuickCheck.IO () @@ -106,11 +106,10 @@ IO (Either SomeException r) applyWrapper2 wrapper func = do var <- liftIO newEmptyMVar - r <- (`catches` exceptionHandlers) $ - fmap Right $ - wrapper $ \outerArgs innerArg -> do - res <- (Right <$> (func outerArgs innerArg >>= evaluate)) `catches` exceptionHandlers - liftIO $ putMVar var res + r <- tryTestFailure $ + wrapper $ \outerArgs innerArg -> do + res <- tryTestFailure (func outerArgs innerArg >>= evaluate) + liftIO $ putMVar var res case r of Right () -> liftIO $ readMVar var Left e -> pure (Left e :: Either SomeException r) @@ -222,54 +221,69 @@ pure result report ProgressTestStarting - qcr <- quickCheckWithResult qcargs (aroundProperty wrapperWithProgress p) + -- QuickCheck catches what a property throws, except what is classified as + -- asynchronous: that it re-throws, losing the counterexample. + errOrQcr <- tryTestFailure $ quickCheckWithResult qcargs (aroundProperty wrapperWithProgress p) report ProgressTestDone let testRunResultGoldenCase = Nothing - let testRunResultNumTests = Just $ fromIntegral $ numTests qcr - case qcr of - Success {} -> do - let testRunResultStatus = TestPassed - let testRunResultException = Nothing - let testRunResultNumShrinks = Nothing - let testRunResultFailingInputs = [] - let testRunResultExtraInfo = Nothing - let testRunResultLabels = Just $ labels qcr - let testRunResultClasses = Just $ classes qcr - let testRunResultTables = Just $ tables qcr - pure TestRunResult {..} - GaveUp {} -> do + case errOrQcr of + Left e -> do + let testRunResultNumTests = Nothing let testRunResultStatus = TestFailed - let testRunResultException = Nothing + let testRunResultException = Just e let testRunResultNumShrinks = Nothing let testRunResultFailingInputs = [] - let testRunResultExtraInfo = Just $ printf "Gave up, %d discarded tests" (numDiscarded qcr) - let testRunResultLabels = Just $ labels qcr - let testRunResultClasses = Just $ classes qcr - let testRunResultTables = Just $ tables qcr - pure TestRunResult {..} - Failure {} -> do - let testRunResultStatus = TestFailed - let testRunResultException = do - se <- theException qcr - pure (se :: SomeException) - let testRunResultNumShrinks = Just $ fromIntegral $ numShrinks qcr - let testRunResultFailingInputs = failingTestCase qcr let testRunResultExtraInfo = Nothing - let testRunResultLabels = Just $ M.singleton (failingLabels qcr) 1 - let testRunResultClasses = Just $ M.fromSet (const 1) (failingClasses qcr) + let testRunResultLabels = Nothing + let testRunResultClasses = Nothing let testRunResultTables = Nothing pure TestRunResult {..} - NoExpectedFailure {} -> do - let testRunResultStatus = TestFailed - let testRunResultException = Nothing - let testRunResultNumShrinks = Nothing - let testRunResultFailingInputs = [] - let testRunResultLabels = Just $ labels qcr - let testRunResultClasses = Just $ classes qcr - let testRunResultTables = Just $ tables qcr - let testRunResultExtraInfo = Just $ printf "Expected the property to fail but it didn't." - pure TestRunResult {..} + Right qcr -> do + let testRunResultNumTests = Just $ fromIntegral $ numTests qcr + case qcr of + Success {} -> do + let testRunResultStatus = TestPassed + let testRunResultException = Nothing + let testRunResultNumShrinks = Nothing + let testRunResultFailingInputs = [] + let testRunResultExtraInfo = Nothing + let testRunResultLabels = Just $ labels qcr + let testRunResultClasses = Just $ classes qcr + let testRunResultTables = Just $ tables qcr + pure TestRunResult {..} + GaveUp {} -> do + let testRunResultStatus = TestFailed + let testRunResultException = Nothing + let testRunResultNumShrinks = Nothing + let testRunResultFailingInputs = [] + let testRunResultExtraInfo = Just $ printf "Gave up, %d discarded tests" (numDiscarded qcr) + let testRunResultLabels = Just $ labels qcr + let testRunResultClasses = Just $ classes qcr + let testRunResultTables = Just $ tables qcr + pure TestRunResult {..} + Failure {} -> do + let testRunResultStatus = TestFailed + let testRunResultException = do + se <- theException qcr + pure (se :: SomeException) + let testRunResultNumShrinks = Just $ fromIntegral $ numShrinks qcr + let testRunResultFailingInputs = failingTestCase qcr + let testRunResultExtraInfo = Nothing + let testRunResultLabels = Just $ M.singleton (failingLabels qcr) 1 + let testRunResultClasses = Just $ M.fromSet (const 1) (failingClasses qcr) + let testRunResultTables = Nothing + pure TestRunResult {..} + NoExpectedFailure {} -> do + let testRunResultStatus = TestFailed + let testRunResultException = Nothing + let testRunResultNumShrinks = Nothing + let testRunResultFailingInputs = [] + let testRunResultLabels = Just $ labels qcr + let testRunResultClasses = Just $ classes qcr + let testRunResultTables = Just $ tables qcr + let testRunResultExtraInfo = Just $ printf "Expected the property to fail but it didn't." + pure TestRunResult {..} aroundProperty :: ((a -> b -> IO ()) -> IO ()) -> (a -> b -> Property) -> Property aroundProperty action p = MkProperty . MkGen $ \r n -> aroundProp action $ \a b -> (unGen . unProperty $ p a b) r n @@ -417,20 +431,26 @@ goldenChan <- newChan let StagedGolden runStagedGolden = createStagedGolden outerArgs innerArgs let testThread = do - report ProgressTestStarting - runStagedGolden $ \golden -> liftIO $ do - writeChan goldenChan $ Just golden - -- Wait until the golden test has been processed and we can - -- continue. - takeMVar continueVar - writeChan goldenChan Nothing + -- Catch everything, so that the reader always hears how the test ended. + done <- try $ do + report ProgressTestStarting + runStagedGolden $ \golden -> liftIO $ do + writeChan goldenChan (Right golden) + -- Wait until the golden test has been processed and we can + -- continue. + takeMVar continueVar + writeChan goldenChan (Left done) -- withAsync means we can cancel the test thread when a golden test fails. result <- withAsync testThread $ \_ -> do let go mCase = do - mNextGolden <- readChan goldenChan - case mNextGolden of - Nothing -> pure (TestPassed, mCase, Nothing) - Just GoldenTest {..} -> do + doneOrNextGolden <- readChan goldenChan + case doneOrNextGolden of + Left (Left e) -> do + -- Re-throw what stops the suite, as if the test had thrown it here. + errOrNothing <- tryTestFailure (throwIO e) + pure (TestFailed, mCase, Just (either id (\() -> e) errOrNothing)) + Left (Right ()) -> pure (TestPassed, mCase, Nothing) + Right GoldenTest {..} -> do mGolden <- goldenTestRead case mGolden of Nothing -> @@ -472,17 +492,37 @@ let testRunResultTables = Nothing pure TestRunResult {..} +-- | Catch every exception an action throws, except the ones that stop the +-- test suite. +-- +-- In an 'IsTest' instance, use this around whatever runs the test. +-- A library's own exception handling is not enough. +-- It often re-throws any exception classified as asynchronous, which is how +-- @effectful@ classifies its errors, so the test would crash the suite +-- instead of failing. +-- The runner catches whatever an instance lets escape in the same way, but it +-- cannot report the details the instance knows, like a counterexample. +-- See https://github.com/NorfairKing/sydtest/issues/110 +tryTestFailure :: IO a -> IO (Either SomeException a) +tryTestFailure action = (Right <$> action) `catches` exceptionHandlers + +-- | Re-throw the exceptions that stop the test suite, and catch the rest. +-- +-- Exceptions are told apart by type, because GHC does not record whether an +-- exception was thrown by the test itself or delivered to it from outside. +-- Ctrl-C delivers 'UserInterrupt', a timeout delivers 'Timeout', and @async@ +-- cancels a thread with 'AsyncCancelled'. +-- Re-throwing every 'AsyncException' also lets 'ThreadKilled', +-- 'StackOverflow' and 'HeapOverflow' through. +-- Letting these through is what makes Ctrl-C stop the suite, and what keeps +-- @race@ and @concurrently@ from carrying on with half their threads gone. +-- See https://github.com/NorfairKing/sydtest/issues/80 exceptionHandlers :: [Handler (Either SomeException a)] exceptionHandlers = - [ -- Re-throw SomeAsyncException, otherwise execution will not terminate on SIGINT (ctrl-c). - -- This is also critical for correctness, because library such as async - -- uses this signal for `concurrently`, and `race`, ..., and if we ignore - -- this exception, we can end in a context where half of the logic has - -- stopped and yet we continue. - -- See https://github.com/NorfairKing/sydtest/issues/80 - Handler (\e -> throwIO (e :: SomeAsyncException)), - -- Catch all the rest - Handler (\e -> return $ Left (e :: SomeException)) + [ Handler (\e -> throwIO (e :: AsyncException)), + Handler (\e -> throwIO (e :: AsyncCancelled)), + Handler (\e -> throwIO (e :: Timeout)), + Handler (pure . Left) ] type Test = IO () diff --git a/src/Test/Syd/Runner/Asynchronous.hs b/src/Test/Syd/Runner/Asynchronous.hs --- a/src/Test/Syd/Runner/Asynchronous.hs +++ b/src/Test/Syd/Runner/Asynchronous.hs @@ -39,9 +39,9 @@ runSpecForestAsynchronously settings nbThreads testForest = do setPseudorandomness (settingSeed settings) handleForest <- makeHandleForest testForest - failFastVar <- newEmptyMVar - let runRunner = runner settings nbThreads failFastVar handleForest - runPrinter = liftIO $ waiter failFastVar handleForest + abortVar <- newEmptyMVar + let runRunner = runner settings nbThreads abortVar handleForest + runPrinter = liftIO $ waiter abortVar handleForest ((), resultForest) <- concurrently runRunner runPrinter pure resultForest @@ -49,12 +49,12 @@ runSpecForestInterleavedWithOutputAsynchronously settings nbThreads testForest = do setPseudorandomness (settingSeed settings) handleForest <- makeHandleForest testForest - failFastVar <- newEmptyMVar + abortVar <- newEmptyMVar suiteBegin <- getMonotonicTimeNSec - let runRunner = runner settings nbThreads failFastVar handleForest + let runRunner = runner settings nbThreads abortVar handleForest runPrinter = case settingOutputFormat settings of - OutputFormatPretty -> liftIO $ printer settings failFastVar suiteBegin handleForest - OutputFormatTerse -> liftIO $ waiter failFastVar handleForest + OutputFormatPretty -> liftIO $ printer settings abortVar suiteBegin handleForest + OutputFormatTerse -> liftIO $ waiter abortVar handleForest ((), resultForest) <- concurrently runRunner runPrinter let outputLine :: [Chunk] -> IO () @@ -81,6 +81,31 @@ makeHandleForest :: TestForest a b -> IO (HandleForest a b) makeHandleForest = traverse $ traverse $ \() -> newEmptyMVar +-- | Why the suite stops before every test has produced a result. +data Abort + = AbortFailFast + | -- | An exception escaped a test function, so its result will never arrive. + AbortException !SomeException + +-- | Wait for a test's result, or 'Nothing' if the suite stopped early. +awaitTestResult :: MVar Abort -> MVar (Timed TestRunReport) -> IO (Maybe (Timed TestRunReport)) +awaitTestResult abortVar var = do + abortOrResult <- race (readMVar abortVar) (takeMVar var) + case abortOrResult of + Left AbortFailFast -> pure Nothing + Left (AbortException e) -> throwIO e + Right result -> pure (Just result) + +-- | Record any exception that escapes an action, then let it propagate. +-- +-- Any exception that escapes before a test's result is put leaves the +-- result-collecting thread waiting forever, hence 'SomeException'. +recordEscapingExceptions :: MVar Abort -> IO a -> IO a +recordEscapingExceptions abortVar action = + action `catch` \e -> do + void $ tryPutMVar abortVar $ AbortException e + throwIO (e :: SomeException) + type Job = Int -> IO () -- | Job queue for workers that can synchronise @@ -181,8 +206,8 @@ -- -- 2. Asks workers to wait after finishing what they were doing at the end of -- an outer resource block. -runner :: Settings -> Word -> MVar () -> HandleForest '[] () -> IO () -runner settings nbThreads failFastVar handleForest = do +runner :: Settings -> Word -> MVar Abort -> HandleForest '[] () -> IO () +runner settings nbThreads abortVar handleForest = do let nbWorkers = nbThreads let nbSpacesOnTheJobQueue = nbWorkers * 2 jobQueue <- newJobQueue nbSpacesOnTheJobQueue @@ -197,10 +222,10 @@ goTree :: forall a. HandleTree a () -> R a () goTree = \case DefSpecifyNode _ td var -> do - -- If the fail-fast var has been put, we stop enqueuing jobs. - mDoneEarly <- liftIO $ tryReadMVar failFastVar - case mDoneEarly of - Just () -> pure () + -- Once the suite is aborting, we stop enqueuing jobs. + mAbort <- liftIO $ tryReadMVar abortVar + case mAbort of + Just _ -> pure () Nothing -> do Env {..} <- ask @@ -219,13 +244,13 @@ let job :: Int -> IO () job workerNr = do -- Start the test - result <- runNow workerNr + result <- recordEscapingExceptions abortVar $ runNow workerNr -- Put the result in the mvar putMVar var result -- If we should fail fast, put the - -- fail-fast var so that no new + -- abort var so that no new -- jobs are started by the -- scheduler. when @@ -233,7 +258,11 @@ && testRunReportFailed settings (timedValue result) ) $ do - putMVar failFastVar () + -- 'tryPutMVar' because another worker may be + -- failing fast at the same time, and blocking here + -- would leave this worker counted as working + -- forever. + void $ tryPutMVar abortVar AbortFailFast -- When enqueuing a sequential job, make sure all workers are -- done before and after. @@ -368,8 +397,8 @@ eExternalResources :: !(HList externalResources) } -printer :: Settings -> MVar () -> Word64 -> HandleForest '[] () -> IO (Timed ResultForest) -printer settings failFastVar suiteBegin handleForest = do +printer :: Settings -> MVar Abort -> Word64 -> HandleForest '[] () -> IO (Timed ResultForest) +printer settings abortVar suiteBegin handleForest = do let outputLine :: [Chunk] -> IO () outputLine lineChunks = liftIO $ @@ -401,14 +430,10 @@ goTree :: HandleTree a b -> P (Maybe ResultTree) goTree = \case DefSpecifyNode t td var -> do - failFastOrResult <- - liftIO $ - race - (readMVar failFastVar) - (takeMVar var) - case failFastOrResult of - Left () -> pure Nothing - Right result -> do + mResult <- liftIO $ awaitTestResult abortVar var + case mResult of + Nothing -> pure Nothing + Just result -> do let td' = td {testDefVal = result} level <- ask outputLinesP $ outputSpecifyLines settings level treeWidth t td' @@ -417,9 +442,10 @@ outputLinesP $ outputPendingLines t mr pure $ Just $ PendingNode t mr DefDescribeNode t sf -> do - mDoneEarly <- liftIO $ tryReadMVar failFastVar - case mDoneEarly of - Just () -> pure Nothing + mAbort <- liftIO $ tryReadMVar abortVar + case mAbort of + Just AbortFailFast -> pure Nothing + Just (AbortException e) -> liftIO $ throwIO e Nothing -> do outputLineP $ outputDescribeLine t fmap (DescribeNode t) <$> addLevel (goForest sf) @@ -454,8 +480,8 @@ type P = ReaderT Int IO -waiter :: MVar () -> HandleForest '[] () -> IO (Timed ResultForest) -waiter failFastVar handleForest = timeItT 0 $ do +waiter :: MVar Abort -> HandleForest '[] () -> IO (Timed ResultForest) +waiter abortVar handleForest = timeItT 0 $ do let goForest :: HandleForest a b -> IO (Maybe ResultForest) goForest hts = do rts <- catMaybes <$> mapM goTree hts @@ -464,13 +490,10 @@ goTree :: HandleTree a b -> IO (Maybe ResultTree) goTree = \case DefSpecifyNode t td var -> do - failFastOrResult <- - race - (readMVar failFastVar) - (takeMVar var) - case failFastOrResult of - Left () -> pure Nothing - Right result -> do + mResult <- awaitTestResult abortVar var + case mResult of + Nothing -> pure Nothing + Just result -> do let td' = td {testDefVal = result} pure $ Just $ SpecifyNode t td' DefPendingNode t mr -> pure $ Just $ PendingNode t mr diff --git a/src/Test/Syd/Runner/Single.hs b/src/Test/Syd/Runner/Single.hs --- a/src/Test/Syd/Runner/Single.hs +++ b/src/Test/Syd/Runner/Single.hs @@ -2,6 +2,7 @@ module Test.Syd.Runner.Single (runSingleTestWithFlakinessMode) where +import Control.Exception (SomeException) import Data.List.NonEmpty (NonEmpty (..)) import qualified Data.List.NonEmpty as NE import System.Timeout (timeout) @@ -92,7 +93,22 @@ Just result -> Right result runFunc :: IO TestRunResult - runFunc = testDefVal td progressReporter (\f -> f l ()) + runFunc = either exceptionResult id <$> tryTestFailure (testDefVal td progressReporter (\f -> f l ())) + + exceptionResult :: SomeException -> TestRunResult + exceptionResult e = + TestRunResult + { testRunResultStatus = TestFailed, + testRunResultException = Just e, + testRunResultNumTests = Nothing, + testRunResultNumShrinks = Nothing, + testRunResultFailingInputs = [], + testRunResultLabels = Nothing, + testRunResultClasses = Nothing, + testRunResultTables = Nothing, + testRunResultGoldenCase = Nothing, + testRunResultExtraInfo = Nothing + } timeoutResult :: TestRunResult timeoutResult = diff --git a/sydtest.cabal b/sydtest.cabal --- a/sydtest.cabal +++ b/sydtest.cabal @@ -5,7 +5,7 @@ -- see: https://github.com/sol/hpack name: sydtest -version: 0.33.3.0 +version: 0.33.4.0 synopsis: A modern testing framework for Haskell with good defaults and advanced testing features. description: A modern testing framework for Haskell with good defaults and advanced testing features. Sydtest aims to make the common easy and the hard possible. See https://github.com/NorfairKing/sydtest#readme for more information. category: Testing