sydtest 0.33.3.0 → 0.33.4.0
raw patch · 6 files changed
+221/−119 lines, 6 files
Files
- CHANGELOG.md +25/−0
- src/Test/Syd/MutationMode/Common.hs +12/−14
- src/Test/Syd/Run.hs +105/−65
- src/Test/Syd/Runner/Asynchronous.hs +61/−38
- src/Test/Syd/Runner/Single.hs +17/−1
- sydtest.cabal +1/−1
CHANGELOG.md view
@@ -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
src/Test/Syd/MutationMode/Common.hs view
@@ -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' / @<<loop>>@ 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' / @<<loop>>@ 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. --
src/Test/Syd/Run.hs view
@@ -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 ()
src/Test/Syd/Runner/Asynchronous.hs view
@@ -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
src/Test/Syd/Runner/Single.hs view
@@ -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 =
sydtest.cabal view
@@ -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