feat: add a 2s timeout on test diff computation

Ensures that the diff computed when `shouldBe` test are failing is not
taking more than 2s, otherwise do not display a diff.

This fix NorfairKing#92
in which we observed that diff can take an arbitrary amount of time, up
to a few minutes or hours.

This implementations changes the API of a few internal functions (see
the `Changelog` entries), but no change on the "common" API.

- Diff time is taken into account in the time of the test. Note that the
  diff can be computed multiples time during flaky detection.
- This also fix an issue discussed in
  NorfairKing#80, if the values being
  diffed contains lazy exception, it won't crash the test suite anymore,
  but instead, the exception will be raised in the test context.

sydtest-hspec/src/Test/Syd/Hspec.hs

@@ -127,23 +127,24 @@ runImportedItem (ImportedItem Hspec.Item {..}) trs progressReporter wrapper = do
       )
       callback
   report ProgressTestDone
-  let (testRunResultStatus, testRunResultException) = case Hspec.resultStatus result of
-        Hspec.Success -> (TestPassed, Nothing)
-        -- This is certainly a debatable choice, but there's no need to make
-        -- tests fail here, and there's no way to know ahead of time whether
-        -- a test is pending so we have no choice.
-        Hspec.Pending _ _ -> (TestPassed, Nothing)
-        Hspec.Failure mloc fr ->
-          let withExtraContext :: Maybe String -> SomeException -> SomeException
-              withExtraContext = maybe id (\extraContext se -> SomeException $ addContextToException se extraContext)
-              niceLocation :: Hspec.Location -> String
-              niceLocation Hspec.Location {..} = intercalate ":" [locationFile, show locationLine, show locationColumn]
-              withLocationContext :: SomeException -> SomeException
-              withLocationContext = withExtraContext $ niceLocation <$> mloc
-              exception = failureReasonToException withExtraContext fr
-           in ( TestFailed,
-                Just $ SomeException $ addContextToException (withLocationContext exception) (Hspec.resultInfo result)
-              )
+  (testRunResultStatus, testRunResultException) <- case Hspec.resultStatus result of
+    Hspec.Success -> pure (TestPassed, Nothing)
+    -- This is certainly a debatable choice, but there's no need to make
+    -- tests fail here, and there's no way to know ahead of time whether
+    -- a test is pending so we have no choice.
+    Hspec.Pending _ _ -> pure (TestPassed, Nothing)
+    Hspec.Failure mloc fr -> do
+      let withExtraContext :: Maybe String -> SomeException -> SomeException
+          withExtraContext = maybe id (\extraContext se -> SomeException $ addContextToException se extraContext)
+          niceLocation :: Hspec.Location -> String
+          niceLocation Hspec.Location {..} = intercalate ":" [locationFile, show locationLine, show locationColumn]
+          withLocationContext :: SomeException -> SomeException
+          withLocationContext = withExtraContext $ niceLocation <$> mloc
+      exception <- failureReasonToException withExtraContext fr
+      pure
+        ( TestFailed,
+          Just $ SomeException $ addContextToException (withLocationContext exception) (Hspec.resultInfo result)
+        )
   let testRunResultNumTests = Nothing
   let testRunResultNumShrinks = Nothing
   let testRunResultGoldenCase = Nothing
@@ -155,12 +156,12 @@ runImportedItem (ImportedItem Hspec.Item {..}) trs progressReporter wrapper = do
 
   pure TestRunResult {..}
 
-failureReasonToException :: (Maybe String -> SomeException -> SomeException) -> Hspec.FailureReason -> SomeException
+failureReasonToException :: (Maybe String -> SomeException -> SomeException) -> Hspec.FailureReason -> IO SomeException
 failureReasonToException withExtraContext = \case
-  Hspec.NoReason -> SomeException $ ExpectationFailed "Hspec had no more information about this failure."
-  Hspec.Reason s -> SomeException $ ExpectationFailed s
-  Hspec.ExpectedButGot mExtraContext expected actual -> withExtraContext mExtraContext $ SomeException $ NotEqualButShouldHaveBeenEqual actual expected
-  Hspec.Error mExtraContext e -> withExtraContext mExtraContext e
+  Hspec.NoReason -> pure $ SomeException $ ExpectationFailed "Hspec had no more information about this failure."
+  Hspec.Reason s -> pure $ SomeException $ ExpectationFailed s
+  Hspec.ExpectedButGot mExtraContext expected actual -> withExtraContext mExtraContext . SomeException <$> mkNotEqualButShouldHaveBeenEqual actual expected
+  Hspec.Error mExtraContext e -> pure $ withExtraContext mExtraContext e
 #if MIN_VERSION_hspec_core(2,11,0)
-  Hspec.ColorizedReason s -> SomeException $ ExpectationFailed s
+  Hspec.ColorizedReason s -> pure $ SomeException $ ExpectationFailed s
 #endif

sydtest-test/output-test/Spec.hs

@@ -128,12 +128,12 @@ spec = do
         { goldenTestRead = pure (Just ()),
           goldenTestProduce = pure (),
           goldenTestWrite = \() -> pure (),
-          goldenTestCompare = \actual expected -> pure $ case 1 `div` (0 :: Int) of
-            1 -> Nothing
+          goldenTestCompare = \actual expected -> case 1 `div` (0 :: Int) of
+            1 -> pure Nothing
             _ ->
               if actual == expected
-                then Nothing
-                else Just $ NotEqualButShouldHaveBeenEqual (show actual) (show expected)
+                then pure Nothing
+                else Just <$> mkNotEqualButShouldHaveBeenEqual (show actual) (show expected)
         }
 
     describe "outputResultForest" $ do

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

@@ -286,5 +286,5 @@ spec = do
       length (getTextDiff (T.pack (replicate 10000 'a')) "b") `shouldBe` 15
 
   describe "outputEqualityAssertionFailed" $ do
-    it "can output a large diff quickly enough" $
-      length (outputEqualityAssertionFailed (replicate 10000 'a') "b") `shouldBe` 3
+    it "can output an empty" $
+      length (outputEqualityAssertionFailed (replicate 10000 'a') "b" Nothing) `shouldBe` 3

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

@@ -6,7 +6,11 @@
 module Test.Syd.TimingSpec (spec) where
 
 import Control.Concurrent
+import Control.Exception (try)
+import Control.Monad
+import GHC.IO.Exception (ExitCode)
 import System.IO.Unsafe
+import System.Timeout (timeout)
 import Test.QuickCheck
 import Test.Syd
 
@@ -28,6 +32,31 @@ spec = doNotRandomiseExecutionOrder $ do
   it "takes at least 100 milliseconds (property) " $
     property $ \() -> do
       threadDelay 10_000
+  -- Ensure that long diff timeouts
+  -- See https://github.com/NorfairKing/sydtest/issues/92
+  it "long diff timing is bounded" $ do
+    -- with n = 1000 it takes 30s on my laptop, so 10k is enough to trigger the
+    -- 2s timeout.
+    let n = 10_0000
+    let test = do
+          res <- try $ sydTest $ do
+            it "test" $ do
+              let numbers = [0, 1 .. n]
+                  numbers' = reverse numbers
+
+              numbers `shouldBe` numbers'
+
+          case res of
+            Right () -> fail "The subtest must fail"
+            Left (_ :: ExitCode) -> pure ()
+
+    -- We timeout after 10s. If the test timeouts by itself, it means that the
+    -- diff timeout worked after 2seconds.
+    --
+    -- Why 10s? Because it's more than 2s, and gives enough room for scheduling
+    -- and additional operations (such as generating the random numbers)
+    -- without too much risk of generating a flaky test.
+    timeout 10_000_000 test `shouldReturn` Just ()
 
 {-# NOINLINE take10ms #-}
 take10ms :: IO ()

sydtest/CHANGELOG.md

@@ -1,5 +1,30 @@
 # Changelog
 
+### Added
+
+- The test `Assertion` which displays a diff in case of error (so `shouldBe`, `shouldReturn`, golden tests and variations) will now timeout (after `2s`) when computing the diff between expected and actual value. In case of timeout, the values are displayed without any diff formatting. This ensure that test suite runtime won't be dominated by computing diff on some pathological cases. See https://github.com/NorfairKing/sydtest/issues/92
+- The smart constructor `mkNotEqualButShouldHaveBeenEqual` 
+- You can use your own diff algorithm using the constructor `NotEqualButShouldHaveBeenEqualWithDiff`.
+- Test suite does not crash if failed assertion trie to print values containing
+  lazy exception. For example `shouldBe (1, error "nop") (2, 3)` was crashing
+  sydTest, the exception is now reported as the failure reason for the test.
+  Note that this is counter intuitive, because the test is failing because
+  values are not equal (e.g. `(1, _) != (2, _)`), and this will be reported
+  differently.
+
+
+### Changed
+
+The diff computation between actual value and reference changed so diff can timeout. See See https://github.com/NorfairKing/sydtest/issues/92 for discussion.
+
+This does not change the usual API (`shouldBe` or `GoldenTest`), but some internal changed and you may need to adapt. The change is straightforward, most of the functions are not `IO`:
+
+- `stringsNotEqualButShouldHaveBeenEqual`, `textsNotEqualButShouldHaveBeenEqual` and `bytestringsNotEqualButShouldHaveBeenEqual` are now `IO Assertion` (was `Assertion`) in order to implement the timeout logic described for `shouldBe`
+- The `Assertion` `NotEqualButShouldHaveBeenEqual` is removed and replaced by `NotEqualButShouldHaveBeenEqualWithDiff` which embed the difference between both values.
+- the record field `goldenTestCompare` of `GoldenTest` changed from `a -> a ->
+  Maybe Assertion` to `a -> a -> IO (Maybe Assertion)`.
+
+
 ## [0.17.0.0] - 2024-08-04
 
 ### Changed

sydtest/default.nix

@@ -1,5 +1,5 @@
 { mkDerivation, async, autodocodec, base, bytestring, containers
-, dlist, fast-myers-diff, filepath, lib, MonadRandom, mtl
+, deepseq, dlist, fast-myers-diff, filepath, lib, MonadRandom, mtl
 , opt-env-conf, path, path-io, pretty-show, QuickCheck
 , quickcheck-io, random, random-shuffle, safe, safe-coloured-text
 , safe-coloured-text-terminfo, stm, svg-builder, text, vector
@@ -9,9 +9,9 @@ mkDerivation {
   version = "0.17.0.0";
   src = ./.;
   libraryHaskellDepends = [
-    async autodocodec base bytestring containers dlist fast-myers-diff
-    filepath MonadRandom mtl opt-env-conf path path-io pretty-show
-    QuickCheck quickcheck-io random random-shuffle safe
+    async autodocodec base bytestring containers deepseq dlist
+    fast-myers-diff filepath MonadRandom mtl opt-env-conf path path-io
+    pretty-show QuickCheck quickcheck-io random random-shuffle safe
     safe-coloured-text safe-coloured-text-terminfo stm svg-builder text
     vector
   ];

sydtest/package.yaml

@@ -29,7 +29,7 @@ library:
     - bytestring
     - containers
     - dlist
-    - fast-myers-diff
+    - fast-myers-diff >= 0.0.1
     - filepath
     - mtl
     - opt-env-conf >=0.5
@@ -45,6 +45,7 @@ library:
     - svg-builder
     - text
     - vector
+    - deepseq
   when:
     - condition: 'os(windows)'
       then:

sydtest/src/Test/Syd/Def/Golden.hs

@@ -34,10 +34,11 @@ goldenByteStringFile fp produceBS =
         ensureDir $ parent resolvedFile
         SB.writeFile (fromAbsFile resolvedFile) actual,
       goldenTestCompare = \actual expected ->
-        pure $
-          if actual == expected
-            then Nothing
-            else Just $ Context (bytestringsNotEqualButShouldHaveBeenEqual actual expected) (goldenContext fp)
+        if actual == expected
+          then pure Nothing
+          else do
+            assertion <- bytestringsNotEqualButShouldHaveBeenEqual actual expected
+            pure $ Just $ Context assertion (goldenContext fp)
     }
 
 -- | Test that the given lazy bytestring is the same as what we find in the given golden file.
@@ -61,12 +62,13 @@ goldenLazyByteStringFile fp produceBS =
         ensureDir $ parent resolvedFile
         SB.writeFile (fromAbsFile resolvedFile) (LB.toStrict actual),
       goldenTestCompare = \actual expected ->
-        pure $
-          let actualBS = LB.toStrict actual
-              expectedBS = LB.toStrict expected
-           in if actualBS == expectedBS
-                then Nothing
-                else Just $ Context (bytestringsNotEqualButShouldHaveBeenEqual actualBS expectedBS) (goldenContext fp)
+        let actualBS = LB.toStrict actual
+            expectedBS = LB.toStrict expected
+         in if actualBS == expectedBS
+              then pure Nothing
+              else do
+                assertion <- bytestringsNotEqualButShouldHaveBeenEqual actualBS expectedBS
+                pure $ Just $ Context assertion (goldenContext fp)
     }
 
 -- | Test that the given lazy bytestring is the same as what we find in the given golden file.
@@ -90,12 +92,13 @@ goldenByteStringBuilderFile fp produceBS =
         ensureDir $ parent resolvedFile
         SB.writeFile (fromAbsFile resolvedFile) (LB.toStrict (SBB.toLazyByteString actual)),
       goldenTestCompare = \actual expected ->
-        pure $
-          let actualBS = LB.toStrict (SBB.toLazyByteString actual)
-              expectedBS = LB.toStrict (SBB.toLazyByteString expected)
-           in if actualBS == expectedBS
-                then Nothing
-                else Just $ Context (bytestringsNotEqualButShouldHaveBeenEqual actualBS expectedBS) (goldenContext fp)
+        let actualBS = LB.toStrict (SBB.toLazyByteString actual)
+            expectedBS = LB.toStrict (SBB.toLazyByteString expected)
+         in if actualBS == expectedBS
+              then pure Nothing
+              else do
+                assertion <- bytestringsNotEqualButShouldHaveBeenEqual actualBS expectedBS
+                pure $ Just $ Context assertion (goldenContext fp)
     }
 
 -- | Test that the given text is the same as what we find in the given golden file.
@@ -115,10 +118,11 @@ goldenTextFile fp produceBS =
         ensureDir $ parent resolvedFile
         SB.writeFile (fromAbsFile resolvedFile) (TE.encodeUtf8 actual),
       goldenTestCompare = \actual expected ->
-        pure $
-          if actual == expected
-            then Nothing
-            else Just $ Context (textsNotEqualButShouldHaveBeenEqual actual expected) (goldenContext fp)
+        if actual == expected
+          then pure Nothing
+          else do
+            assertion <- textsNotEqualButShouldHaveBeenEqual actual expected
+            pure $ Just $ Context assertion (goldenContext fp)
     }
 
 -- | Test that the given string is the same as what we find in the given golden file.
@@ -138,10 +142,11 @@ goldenStringFile fp produceBS =
         ensureDir $ parent resolvedFile
         SB.writeFile (fromAbsFile resolvedFile) (TE.encodeUtf8 (T.pack actual)),
       goldenTestCompare = \actual expected ->
-        pure $
-          if actual == expected
-            then Nothing
-            else Just $ Context (stringsNotEqualButShouldHaveBeenEqual actual expected) (goldenContext fp)
+        if actual == expected
+          then pure Nothing
+          else do
+            assertion <- stringsNotEqualButShouldHaveBeenEqual actual expected
+            pure $ Just $ Context assertion (goldenContext fp)
     }
 
 -- | Test that the show instance has not changed for the given value.

sydtest/src/Test/Syd/Expectation.hs

@@ -11,20 +11,25 @@ import Control.Exception
 #if MIN_VERSION_mtl(2,3,0)
 import Control.Monad (unless, when)
 #endif
+import Control.DeepSeq (force)
 import Control.Monad.Reader
 import Data.ByteString (ByteString)
 import Data.List
 import Data.Text (Text)
 import qualified Data.Text as T
 import Data.Typeable
+import qualified Data.Vector as V
 import GHC.Stack
+import Myers.Diff (Diff, getTextDiff)
+import System.Timeout (timeout)
 import Test.QuickCheck.IO ()
 import Test.Syd.Run
+import Text.Colour (Chunk)
 import Text.Show.Pretty
 
 -- | Assert that two values are equal according to `==`.
 shouldBe :: (HasCallStack, Show a, Eq a) => a -> a -> IO ()
-shouldBe actual expected = unless (actual == expected) $ throwIO $ NotEqualButShouldHaveBeenEqual (ppShow actual) (ppShow expected)
+shouldBe actual expected = unless (actual == expected) $ throwIO =<< mkNotEqualButShouldHaveBeenEqual actual expected
 
 infix 1 `shouldBe`
 
@@ -58,7 +63,7 @@ shouldNotSatisfyNamed actual name p = when (p actual) $ throwIO $ PredicateSucce
 shouldReturn :: (HasCallStack, Show a, Eq a) => IO a -> a -> IO ()
 shouldReturn computeActual expected = do
   actual <- computeActual
-  unless (actual == expected) $ throwIO $ NotEqualButShouldHaveBeenEqual (ppShow actual) (ppShow expected)
+  unless (actual == expected) $ throwIO =<< mkNotEqualButShouldHaveBeenEqual actual expected
 
 infix 1 `shouldReturn`
 
@@ -100,32 +105,32 @@ shouldMatchList a b = shouldSatisfyNamed a ("matches list\n" <> ppShow b) (match
 -- Note that using function could mess up the colours in your terminal if the Texts contain ANSI codes.
 -- In that case you may want to `show` your values first or use `shouldBe` instead.
 stringShouldBe :: (HasCallStack) => String -> String -> IO ()
-stringShouldBe actual expected = unless (actual == expected) $ throwIO $ stringsNotEqualButShouldHaveBeenEqual actual expected
+stringShouldBe actual expected = unless (actual == expected) $ throwIO =<< stringsNotEqualButShouldHaveBeenEqual actual expected
 
 -- | Assert that two 'Text's are equal according to `==`.
 --
 -- Note that using function could mess up the colours in your terminal if the Texts contain ANSI codes.
 -- In that case you may want to `show` your values first or use `shouldBe` instead.
 textShouldBe :: (HasCallStack) => Text -> Text -> IO ()
-textShouldBe actual expected = unless (actual == expected) $ throwIO $ textsNotEqualButShouldHaveBeenEqual actual expected
+textShouldBe actual expected = unless (actual == expected) $ throwIO =<< textsNotEqualButShouldHaveBeenEqual actual expected
 
 -- | An assertion that says two 'String's should have been equal according to `==`.
 --
 -- Note that using function could mess up the colours in your terminal if the Texts contain ANSI codes.
 -- In that case you may want to `show` your values first or use `shouldBe` instead.
-stringsNotEqualButShouldHaveBeenEqual :: String -> String -> Assertion
-stringsNotEqualButShouldHaveBeenEqual actual expected = NotEqualButShouldHaveBeenEqual actual expected
+stringsNotEqualButShouldHaveBeenEqual :: String -> String -> IO Assertion
+stringsNotEqualButShouldHaveBeenEqual actual expected = mkNotEqualButShouldHaveBeenEqual actual expected
 
 -- | An assertion that says two 'Text's should have been equal according to `==`.
 --
 -- Note that using function could mess up the colours in your terminal if the Texts contain ANSI codes.
 -- In that case you may want to `show` your values first or use `shouldBe` instead.
-textsNotEqualButShouldHaveBeenEqual :: Text -> Text -> Assertion
-textsNotEqualButShouldHaveBeenEqual actual expected = NotEqualButShouldHaveBeenEqual (T.unpack actual) (T.unpack expected)
+textsNotEqualButShouldHaveBeenEqual :: Text -> Text -> IO Assertion
+textsNotEqualButShouldHaveBeenEqual actual expected = mkNotEqualButShouldHaveBeenEqual (T.unpack actual) (T.unpack expected)
 
 -- | An assertion that says two 'ByteString's should have been equal according to `==`.
-bytestringsNotEqualButShouldHaveBeenEqual :: ByteString -> ByteString -> Assertion
-bytestringsNotEqualButShouldHaveBeenEqual actual expected = NotEqualButShouldHaveBeenEqual (show actual) (show expected)
+bytestringsNotEqualButShouldHaveBeenEqual :: ByteString -> ByteString -> IO Assertion
+bytestringsNotEqualButShouldHaveBeenEqual actual expected = mkNotEqualButShouldHaveBeenEqual (show actual) (show expected)
 
 -- | Make a test fail
 --