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 #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
  #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-aeson/src/Test/Syd/Aeson.hs

@@ -41,17 +41,16 @@ goldenJSONFile fp produceActualValue =
         ensureDir (parent p)
         SB.writeFile (fromAbsFile p) $ LB.toStrict $ JSON.encodePretty value,
       goldenTestCompare = \actual expected ->
-        pure $
-          if actual == expected
-            then Nothing
-            else
+        if actual == expected
+          then pure Nothing
+          else do
+            assertion <-
+              textsNotEqualButShouldHaveBeenEqual
+                (TE.decodeUtf8 (LB.toStrict (JSON.encodePretty actual)))
+                (TE.decodeUtf8 (LB.toStrict (JSON.encodePretty expected)))
+            pure $
               Just
-                ( Context
-                    ( textsNotEqualButShouldHaveBeenEqual
-                        (TE.decodeUtf8 (LB.toStrict (JSON.encodePretty actual)))
-                        (TE.decodeUtf8 (LB.toStrict (JSON.encodePretty expected)))
-                    )
-                    (goldenContext fp)
+                ( Context assertion (goldenContext fp)
                 )
     }
 
@@ -83,10 +82,11 @@ goldenJSONValueFile fp produceActualValue =
         ensureDir (parent p)
         SB.writeFile (fromAbsFile p) $ LB.toStrict $ JSON.encodePretty value,
       goldenTestCompare = \actual expected ->
-        pure $
-          if actual == expected
-            then Nothing
-            else Just (Context (stringsNotEqualButShouldHaveBeenEqual (ppShow actual) (ppShow expected)) (goldenContext fp))
+        if actual == expected
+          then pure Nothing
+          else do
+            assertion <- stringsNotEqualButShouldHaveBeenEqual (ppShow actual) (ppShow expected)
+            pure $ Just (Context assertion (goldenContext fp))
     }
 
 -- | Test that the given 'JSON.Value' is the same as what we find in the given golden file.

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-mongo/src/Test/Syd/MongoDB.hs

@@ -59,10 +59,11 @@ goldenBSONDocumentFile fp produceActualDocument =
         ensureDir (parent ap)
         SB.writeFile (fromAbsFile ap) $ LB.toStrict $ runPut $ putDocument d,
       goldenTestCompare = \actual expected ->
-        pure $
-          if actual == expected
-            then Nothing
-            else Just (Context (stringsNotEqualButShouldHaveBeenEqual (ppShow actual) (ppShow expected)) (goldenContext fp))
+        if actual == expected
+          then pure Nothing
+          else do
+            assertion <- stringsNotEqualButShouldHaveBeenEqual (ppShow actual) (ppShow expected)
+            pure $ Just (Context assertion (goldenContext fp))
     }
 
 -- | Test that the given 'Bson.Document' is the same as what we find in the given golden file.

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

@@ -287,4 +287,6 @@ spec = do
 
   describe "outputEqualityAssertionFailed" $ do
     it "can output a large diff quickly enough" $
-      length (outputEqualityAssertionFailed (replicate 10000 'a') "b") `shouldBe` 3
+      let a = replicate 10000 'a'
+          b = "b"
+       in length (outputEqualityAssertionFailed a b (Just $ computeDiff a b)) `shouldBe` 3

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

@@ -6,7 +6,10 @@
 module Test.Syd.TimingSpec (spec) where
 
 import Control.Concurrent
+import Control.Exception (try)
+import GHC.IO.Exception (ExitCode)
 import System.IO.Unsafe
+import System.Timeout (timeout)
 import Test.QuickCheck
 import Test.Syd
 
@@ -28,6 +31,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 :: Int, 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,6 @@
 # Changelog
 
+<<<<<<< HEAD
 ## [0.17.0.2] - 2024-09-26
 
 ### Changed
@@ -13,6 +14,32 @@
 
 * Only use `withArgs` when the argument list isn't already empty.
   This works around a concurrency issue wherein `withArgs` cannot be run twice from multiple threads.
+=======
+### 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)`.
+
+>>>>>>> 401ad8a (feat: add a 2s timeout on test diff computation)
 
 ## [0.17.0.0] - 2024-08-04
 

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.2";
   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.