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.

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

This implementation uses `unsafePerformIO` for simplicity, but could be
fixed in a future commit.

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/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/Output.hs

@@ -1,13 +1,16 @@
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE MultiWayIf #-}
+{-# LANGUAGE NumDecimals #-}
 {-# LANGUAGE NumericUnderscores #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE RecordWildCards #-}
 {-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE TypeSynonymInstances #-}
 
 module Test.Syd.Output where
 
 import Control.Arrow (second)
+import Control.DeepSeq
 import Control.Exception
 import Data.List (sortOn)
 import qualified Data.List as L
@@ -16,16 +19,19 @@ import qualified Data.List.NonEmpty as NE
 import Data.Map (Map)
 import qualified Data.Map as M
 import Data.Maybe
+import Data.String (IsString (..))
 import Data.Text (Text)
 import qualified Data.Text as T
 import qualified Data.Text.Lazy.Builder as LTB
 import qualified Data.Text.Lazy.Builder as Text
 import qualified Data.Text.Lazy.IO as LTIO
 import qualified Data.Vector as V
 import Data.Word
+import GHC.IO (unsafePerformIO)
 import GHC.Stack
 import Myers.Diff
 import Safe
+import System.Timeout (timeout)
 import Test.QuickCheck.IO ()
 import Test.Syd.OptParse
 import Test.Syd.Run
@@ -463,8 +469,27 @@ splitChunksIntoLines =
 
 outputEqualityAssertionFailed :: String -> String -> [[Chunk]]
 outputEqualityAssertionFailed actual expected =
-  let diff = V.toList $ getTextDiff (T.pack actual) (T.pack expected)
-      -- Add a header to a list of lines of chunks
+  let diffM = unsafePerformIO $ do
+        let diff = V.toList $ getTextDiff (T.pack actual) (T.pack expected)
+        -- we want to evaluate the diff in order to ensure that its
+        -- computation happen in the timeout block
+        -- and is not instead later because of lazy evaluation.
+        --
+        -- The safe option here is to evaluate to normal form with `force`.
+        timeout 2e6 (evaluate (force diff))
+   in case diffM of
+        Just diff -> formatDiff actual expected diff
+        Nothing ->
+          concat
+            [ [[chunk "Expected these values to be equal:"]],
+              [[chunk "Diff computation took too long and was canceled"]],
+              [[fromString actual]],
+              [[fromString expected]]
+            ]
+
+formatDiff :: String -> String -> [PolyDiff Text Text] -> [[Chunk]]
+formatDiff actual expected diff =
+  let -- Add a header to a list of lines of chunks
       chunksLinesWithHeader :: Chunk -> [[Chunk]] -> [[Chunk]]
       chunksLinesWithHeader header = \case
         -- If there is only one line, put the header on that line.

sydtest/sydtest.cabal

@@ -66,8 +66,9 @@ library
     , base >=4.7 && <5
     , bytestring
     , containers
+    , deepseq
     , dlist
-    , fast-myers-diff
+    , fast-myers-diff >=0.0.1
     , filepath
     , mtl
     , opt-env-conf >=0.5