diff --git a/flake.lock b/flake.lock index ed92f36..26f659d 100644 --- a/flake.lock +++ b/flake.lock @@ -19,11 +19,11 @@ "fast-myers-diff": { "flake": false, "locked": { - "lastModified": 1717390032, - "narHash": "sha256-7O9MA3G8CQtiAQaTsj5WskieLR0BhjfFAQsq7CWJFnQ=", + "lastModified": 1725809875, + "narHash": "sha256-csh7DuQAtoIWgEKEGj+GcRrmO9Ue6a7QyNAtY3yNsLc=", "owner": "NorfairKing", "repo": "fast-myers-diff", - "rev": "ac52f5779739c46aa1c014108bbbd1e7464cdf75", + "rev": "d7c1a675af3889698b987485a630f96a993226fa", "type": "github" }, "original": { diff --git a/sydtest-aeson/src/Test/Syd/Aeson.hs b/sydtest-aeson/src/Test/Syd/Aeson.hs index 97f7563..60e9e49 100644 --- a/sydtest-aeson/src/Test/Syd/Aeson.hs +++ b/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. diff --git a/sydtest-hspec/src/Test/Syd/Hspec.hs b/sydtest-hspec/src/Test/Syd/Hspec.hs index d9698c5..182cb8a 100644 --- a/sydtest-hspec/src/Test/Syd/Hspec.hs +++ b/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 diff --git a/sydtest-mongo/src/Test/Syd/MongoDB.hs b/sydtest-mongo/src/Test/Syd/MongoDB.hs index a376ef0..32a59f6 100644 --- a/sydtest-mongo/src/Test/Syd/MongoDB.hs +++ b/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. diff --git a/sydtest-test/output-test/Spec.hs b/sydtest-test/output-test/Spec.hs index 9fc6875..ef89155 100644 --- a/sydtest-test/output-test/Spec.hs +++ b/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 diff --git a/sydtest-test/test/Test/Syd/DiffSpec.hs b/sydtest-test/test/Test/Syd/DiffSpec.hs index 02a64fc..bfe6c43 100644 --- a/sydtest-test/test/Test/Syd/DiffSpec.hs +++ b/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 diff --git a/sydtest-test/test/Test/Syd/TimingSpec.hs b/sydtest-test/test/Test/Syd/TimingSpec.hs index d67106b..0a70dbc 100644 --- a/sydtest-test/test/Test/Syd/TimingSpec.hs +++ b/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 () diff --git a/sydtest/CHANGELOG.md b/sydtest/CHANGELOG.md index 3cf51d8..72c4285 100644 --- a/sydtest/CHANGELOG.md +++ b/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 diff --git a/sydtest/default.nix b/sydtest/default.nix index a6532af..002542d 100644 --- a/sydtest/default.nix +++ b/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 ]; diff --git a/sydtest/package.yaml b/sydtest/package.yaml index cb8a5ff..ee679f1 100644 --- a/sydtest/package.yaml +++ b/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: diff --git a/sydtest/src/Test/Syd/Def/Golden.hs b/sydtest/src/Test/Syd/Def/Golden.hs index 60aed7f..27d434d 100644 --- a/sydtest/src/Test/Syd/Def/Golden.hs +++ b/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. diff --git a/sydtest/src/Test/Syd/Expectation.hs b/sydtest/src/Test/Syd/Expectation.hs index 852d75c..8540a11 100644 --- a/sydtest/src/Test/Syd/Expectation.hs +++ b/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 -- diff --git a/sydtest/src/Test/Syd/Output.hs b/sydtest/src/Test/Syd/Output.hs index e1f117d..d9761ba 100644 --- a/sydtest/src/Test/Syd/Output.hs +++ b/sydtest/src/Test/Syd/Output.hs @@ -4,6 +4,7 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeSynonymInstances #-} module Test.Syd.Output where @@ -16,12 +17,12 @@ 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.Stack import Myers.Diff @@ -413,7 +414,7 @@ outputSomeException outerException = outputAssertion :: Assertion -> [[Chunk]] outputAssertion = \case - NotEqualButShouldHaveBeenEqual actual expected -> outputEqualityAssertionFailed actual expected + NotEqualButShouldHaveBeenEqualWithDiff actual expected diffM -> outputEqualityAssertionFailed actual expected diffM EqualButShouldNotHaveBeenEqual actual notExpected -> outputNotEqualAssertionFailed actual notExpected PredicateFailedButShouldHaveSucceeded actual mName -> outputPredicateSuccessAssertionFailed actual mName PredicateSucceededButShouldHaveFailed actual mName -> outputPredicateFailAssertionFailed actual mName @@ -461,10 +462,21 @@ splitChunksIntoLines = -- We skip them one by one. Just ne -> currentLine : go ne cs -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 +outputEqualityAssertionFailed :: String -> String -> Maybe [PolyDiff Text Text] -> [[Chunk]] +outputEqualityAssertionFailed actual expected diffM = + 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. diff --git a/sydtest/src/Test/Syd/Run.hs b/sydtest/src/Test/Syd/Run.hs index ad86c68..e308bc8 100644 --- a/sydtest/src/Test/Syd/Run.hs +++ b/sydtest/src/Test/Syd/Run.hs @@ -4,6 +4,7 @@ {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NumDecimals #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecordWildCards #-} @@ -16,17 +17,23 @@ module Test.Syd.Run where import Autodocodec import Control.Concurrent import Control.Concurrent.STM +import Control.DeepSeq (force) import Control.Exception import Control.Monad.IO.Class import Control.Monad.Reader import Data.IORef import Data.Map (Map) import qualified Data.Map as M +import Data.Text (Text) +import qualified Data.Text as T import Data.Typeable +import qualified Data.Vector as V import Data.Word import GHC.Clock (getMonotonicTimeNSec) import GHC.Generics (Generic) +import Myers.Diff (Diff, getTextDiff) import OptEnvConf +import System.Timeout (timeout) import Test.QuickCheck import Test.QuickCheck.Gen import Test.QuickCheck.IO () @@ -34,6 +41,7 @@ import Test.QuickCheck.Property hiding (Result (..)) import qualified Test.QuickCheck.Property as QCP import Test.QuickCheck.Random import Text.Printf +import Text.Show.Pretty (ppShow) class IsTest e where -- | The argument from 'aroundAll' @@ -481,7 +489,9 @@ data TestStatus = TestPassed | TestFailed -- -- You will probably not want to use this directly in everyday tests, use `shouldBe` or a similar function instead. data Assertion - = NotEqualButShouldHaveBeenEqual !String !String + = -- | Both strings are not equal. The latest argument is a diff between both + -- arguments. If `Nothing`, the raw values will be displayed instead of the diff. + NotEqualButShouldHaveBeenEqualWithDiff !String !String !(Maybe [Diff Text]) | EqualButShouldNotHaveBeenEqual !String !String | PredicateSucceededButShouldHaveFailed !String -- Value @@ -493,6 +503,35 @@ data Assertion | Context !Assertion !String deriving (Show, Eq, Typeable, Generic) +-- | Returns the diff between two strings +-- +-- Be careful, this function runtime is not bounded and it can take a lot of +-- time (hours) if the input strings are complex. This is exposed for +-- reference, but you may want to use 'mkNotEqualButShouldHaveBeenEqual' which +-- ensures that diff computation timeouts. +computeDiff :: String -> String -> [Diff Text] +computeDiff a b = V.toList $ getTextDiff (T.pack a) (T.pack b) + +-- | Assertion when both arguments are not equal. While display a diff between +-- both at the end of tests. The diff computation is cancelled after 2s. +mkNotEqualButShouldHaveBeenEqual :: + (Show a) => + a -> + a -> + IO Assertion +mkNotEqualButShouldHaveBeenEqual actual expected = do + let ppActual = ppShow actual + let ppExpected = ppShow expected + + let diffNotEvaluated = computeDiff ppActual ppExpected + -- 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`. + diff <- timeout 2e6 (evaluate (force diffNotEvaluated)) + pure $ NotEqualButShouldHaveBeenEqualWithDiff ppActual ppExpected diff + instance Exception Assertion -- | An exception with context. diff --git a/sydtest/sydtest.cabal b/sydtest/sydtest.cabal index 513a876..7287e1b 100644 --- a/sydtest/sydtest.cabal +++ b/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