Do not catch async exception as test failure

This is related to #80

The current exception handler for test was incorrectly catching async
exception (the handler for `AsyncException` was not enough, the "parent"
of the async exception hierarchy is `SomeAsyncException`).

This lead to surprising behaviors with ctrl-C. when receiving a
`ctrl-c` (e.g. an interruption of the test-suite by the user), the test
runner was cancelled, cancelling the print loop of the test and
cancelling all workers. However, the exception was caught in workers as
a "test-failure", leading to it being ignored and the different tests
retrieved and meaning that the test runner survived the interruption.
They will hence continue their life (e.g. purging the job queue). It was
sometime leading to a lot of delay before ending the process, or even
sometime other errors related to the different involved `MVar` (when no
producer / consumer detection detects the error.

Note that a second ctrl-c would cancels the program execution completely
(Because that's how the RTS behaves).

HOWEVER, the behavior is completely different in the repl, because the
repl won't terminate itself on second ctrl-C. Hence the worker threads
are leaked and continues running, and even survives the repl reloads. In
the best case, that's a waste of resources and CPU time, but if you
happen to rerun new sydtest, it can stacks and some tests may run
concurrently with the "ghost" version of themself, which may or may not
work ;)

sydtest-test/default.nix

@@ -1,15 +1,17 @@
-{ mkDerivation, base, bytestring, fast-myers-diff, lib
+{ mkDerivation, async, base, bytestring, fast-myers-diff, lib
 , opt-env-conf-test, path, path-io, QuickCheck, random
-, safe-coloured-text, stm, sydtest, sydtest-discover, text, vector
+, safe-coloured-text, stm, sydtest, sydtest-discover, text, time
+, vector
 }:
 mkDerivation {
   pname = "sydtest-test";
   version = "0.0.0.0";
   src = ./.;
   libraryHaskellDepends = [ base ];
   testHaskellDepends = [
-    base bytestring fast-myers-diff opt-env-conf-test path path-io
-    QuickCheck random safe-coloured-text stm sydtest text vector
+    async base bytestring fast-myers-diff opt-env-conf-test path
+    path-io QuickCheck random safe-coloured-text stm sydtest text time
+    vector
   ];
   testToolDepends = [ sydtest-discover ];
   doHaddock = false;

sydtest-test/package.yaml

@@ -36,6 +36,8 @@ tests:
     - sydtest >=0.17
     - text
     - vector
+    - time
+    - async
 
   sydtest-output-test:
     main: Main.hs

sydtest-test/sydtest-test.cabal

@@ -88,6 +88,7 @@ test-suite sydtest-test
       Test.Syd.AroundSpec
       Test.Syd.DescriptionsSpec
       Test.Syd.DiffSpec
+      Test.Syd.ExceptionSpec
       Test.Syd.ExpectationSpec
       Test.Syd.FootgunSpec
       Test.Syd.GoldenSpec
@@ -107,6 +108,7 @@ test-suite sydtest-test
       sydtest-discover:sydtest-discover
   build-depends:
       QuickCheck
+    , async
     , base >=4.7 && <5
     , bytestring
     , fast-myers-diff
@@ -117,5 +119,6 @@ test-suite sydtest-test
     , stm
     , sydtest >=0.17
     , text
+    , time
     , vector
   default-language: Haskell2010

sydtest-test/test/Test/Syd/ExceptionSpec.hs

@@ -0,0 +1,37 @@
+{-# LANGUAGE NumericUnderscores #-}
+
+module Test.Syd.ExceptionSpec where
+
+import Control.Concurrent (threadDelay)
+import Control.Concurrent.Async
+import Data.Time.Clock
+import Test.Syd
+
+spec :: TestDefM outers () ()
+spec = describe "exception handling" $ do
+  it "stops immediatly with async" $ do
+    -- Tests that when an async exception is sent to sydTest (for example,
+    -- ctrl-c), it behaves as expected and terminates immediately and does not
+    -- do anything surprising.
+    startTime <- liftIO getCurrentTime
+
+    -- Runs two threads, one will be done in 1s, and the other is a test suite
+    -- with one test which should run for 10s.
+    -- When the first threads terminate, it will throw AsyncCancel in the
+    -- sydTest test suite, which should terminate asap.
+    -- This will be checked using the timer t. That's fragile, but we know that:
+    --
+    -- t should be more than 100ms (because of the first threadDelay)
+    -- t should be no much more than 100ms. Especially, it should not be 10s
+    -- (waiting for the complete threadDelay in the test suite) or even more if
+    -- the exception is completly ignored (or test is retried)
+    _ <- race (threadDelay 100_000) $ do
+      sydTest $ do
+        it "is a dumb slow test" $ do
+          threadDelay 10_000_000
+
+    endTime <- liftIO getCurrentTime
+
+    -- Less than 1 second
+    (endTime `diffUTCTime` startTime) `shouldSatisfy` (< 1)
+    pure ()

sydtest/CHANGELOG.md

@@ -1,5 +1,12 @@
 # Changelog
 
+## [0.17.0.2] - 2024-09-26
+
+### Changed
+
+- Sydtest won't crash anymore, behave weirdly, or leak resources when executed
+  in a REPL and interrupted by C-c.
+
 ## [0.17.0.1] - 2024-09-26
 
 ### Changed

sydtest/default.nix

@@ -6,7 +6,7 @@
 }:
 mkDerivation {
   pname = "sydtest";
-  version = "0.17.0.1";
+  version = "0.17.0.2";
   src = ./.;
   libraryHaskellDepends = [
     async autodocodec base bytestring containers dlist fast-myers-diff

sydtest/package.yaml

@@ -1,5 +1,5 @@
 name: sydtest
-version: 0.17.0.1
+version: 0.17.0.2
 github: "NorfairKing/sydtest"
 license: OtherLicense
 license-file: LICENSE.md

sydtest/src/Test/Syd/Run.hs

@@ -374,8 +374,13 @@ runGoldenTestWithArg createGolden TestRunSettings {..} _ wrapper = do
 
 exceptionHandlers :: [Handler (Either SomeException a)]
 exceptionHandlers =
-  [ -- Re-throw AsyncException, otherwise execution will not terminate on SIGINT (ctrl-c).
-    Handler (\e -> throwIO (e :: AsyncException)),
+  [ -- 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))
   ]

sydtest/sydtest.cabal

@@ -5,7 +5,7 @@ cabal-version: 1.12
 -- see: https://github.com/sol/hpack
 
 name:           sydtest
-version:        0.17.0.1
+version:        0.17.0.2
 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