Report All Failures for Golden Tests at Once

CHANGELOG-draft.md

@@ -51,6 +51,7 @@ THIS FILE ACCUMULATES THE RELEASE NOTES FOR THE UPCOMING RELEASE.
 * Clean up JSON golden tests (#1729, #1732, #1733)
 * Make regenerated JSON output deterministic (#1734)
 * Import fix for snappy linker issue (#1736)
+* Report all failures for golden tests at once (#1746)
 
 ## Federation changes
 

libs/wire-api/package.yaml

@@ -96,11 +96,13 @@ tests:
     - cassava
     - currency-codes
     - directory
+    - extra
     - iso3166-country-codes
     - iso639
     - lens
     - mime
     - pem
+    - polysemy
     - pretty
     - proto-lens
     - QuickCheck

libs/wire-api/test/unit/Test/Wire/API/Golden/Runner.hs

@@ -25,6 +25,7 @@ module Test.Wire.API.Golden.Runner
   )
 where
 
+import Control.Monad.Extra (eitherM)
 import Data.Aeson
 import Data.Aeson.Encode.Pretty (Config (..), defConfig, encodePretty')
 import qualified Data.ByteString as ByteString
@@ -34,37 +35,87 @@ import Data.ProtoLens.Message (Message)
 import Data.ProtoLens.TextFormat (pprintMessage, readMessage)
 import qualified Data.Text.Lazy.IO as LText
 import Imports
+import Polysemy (Embed, Members, Sem, embed, runM)
+import Polysemy.Error (Error, runError, throw)
 import Test.Tasty.HUnit
 import Text.PrettyPrint (render)
 import Type.Reflection (typeRep)
 import Wire.API.ServantProto
 
+data TestOutcomeError a
+  = FileDoesNotExist FilePath
+  | FailedToDecode String
+  | AesonValueMismatch
+      Value
+      -- ^ Expected value
+      Value
+      -- ^ Actual value
+      FilePath
+      -- ^ The path to the file
+  | FailedToParse a (Result a) FilePath
+
+instance (Typeable a, Show a) => Show (TestOutcomeError a) where
+  show = \case
+    FileDoesNotExist path -> "Golden JSON file " <> show path <> " does not exist"
+    FailedToDecode err -> "Failed to decode: " <> err
+    AesonValueMismatch expected actual path ->
+      show (typeRep @a) <> ": ToJSON should match golden file: " <> show path
+        <> "\n"
+        <> "expected: "
+        <> show expected
+        <> "\n"
+        <> " but got: "
+        <> show actual
+    FailedToParse obj result path ->
+      (show (typeRep @a) <> ": FromJSON of " <> show path <> " should match object")
+        <> "\n"
+        <> "expected: "
+        <> show (Success obj)
+        <> "\n"
+        <> " but got: "
+        <> show result
+
 testObjects :: forall a. (Typeable a, ToJSON a, FromJSON a, Eq a, Show a) => [(a, FilePath)] -> IO ()
 testObjects objs = do
-  allFilesExist <- and <$> traverse (uncurry testObject) objs
-  assertBool "Some golden JSON files do not exist" allFilesExist
+  allResults <- traverse (run . uncurry testObject) objs
+  let errorResults = foldMap (either pure (const [])) allResults
+      errorMsgs = intercalate "\n" . fmap show $ errorResults
+  assertBool errorMsgs . null $ errorResults
+  where
+    run :: Sem '[Error (TestOutcomeError a), Embed IO] () -> IO (Either (TestOutcomeError a) ())
+    run = runM . runError
 
-testObject :: forall a. (Typeable a, ToJSON a, FromJSON a, Eq a, Show a) => a -> FilePath -> IO Bool
+-- | A passing test returns a '()'. If there is a failure, a 'TestOutcomeError
+-- a' is thrown in the 'Sem r' monad.
+testObject ::
+  forall a r.
+  ( Members '[Error (TestOutcomeError a), Embed IO] r,
+    Typeable a,
+    ToJSON a,
+    FromJSON a,
+    Eq a,
+    Show a
+  ) =>
+  a ->
+  FilePath ->
+  Sem r ()
 testObject obj path = do
   let actualValue = toJSON obj :: Value
       actualJson = encodePretty' config actualValue
       dir = "test/golden"
       fullPath = dir <> "/" <> path
-  createDirectoryIfMissing True dir
-  exists <- doesFileExist fullPath
-  unless exists $ ByteString.writeFile fullPath (LBS.toStrict actualJson)
-
-  expectedValue <- assertRight =<< eitherDecodeFileStrict fullPath
-  assertEqual
-    (show (typeRep @a) <> ": ToJSON should match golden file: " <> path)
-    expectedValue
-    actualValue
-  assertEqual
-    (show (typeRep @a) <> ": FromJSON of " <> path <> " should match object")
-    (Success obj)
-    (fromJSON actualValue)
-
-  pure exists
+  embed @IO $ createDirectoryIfMissing True dir
+  embed @IO (doesFileExist fullPath) >>= \case
+    False -> do
+      embed . ByteString.writeFile fullPath . LBS.toStrict $ actualJson
+      throw . FileDoesNotExist @a $ path
+    True -> do
+      expectedValue <-
+        eitherM (throw . FailedToDecode @a) pure . embed . eitherDecodeFileStrict $ fullPath
+      unless (expectedValue == actualValue) . throw $
+        AesonValueMismatch @a expectedValue actualValue path
+      let p = fromJSON actualValue
+      unless (Success obj == p) . throw $ FailedToParse obj p path
   where
     config = defConfig {confCompare = compare, confTrailingNewline = True}
 

libs/wire-api/wire-api.cabal

@@ -4,7 +4,7 @@ cabal-version: 1.12
 --
 -- see: https://github.com/sol/hpack
 --
--- hash: efca28ca2d2ca3ccfcaf3b543293e01d05d18802dd38283d7658ec50939231d9
+-- hash: 28861da9d191063741dbc581d2ea12fae6d15f3e93e9ffda6952873854db2b0a
 
 name:           wire-api
 version:        0.1.0
@@ -437,12 +437,14 @@ test-suite wire-api-tests
     , containers >=0.5
     , currency-codes
     , directory
+    , extra
     , imports
     , iso3166-country-codes
     , iso639
     , lens
     , mime
     , pem
+    , polysemy
     , pretty
     , proto-lens
     , string-conversions