Improved error reporting in tests

Author: bladyjoker

lambda-buffers-compiler/lambda-buffers-compiler.cabal

@@ -153,8 +153,8 @@ test-suite tests
   hs-source-dirs: test
   main-is:        Test.hs
   build-depends:
-    , containers
-    , generic-lens
+    , containers                  >=0.6
+    , generic-lens                >=2.2
     , hedgehog
     , lambda-buffers-compiler
     , lambda-buffers-compiler-pb  >=0.1

lambda-buffers-compiler/test/Test/LambdaBuffers/Compiler.hs

@@ -16,7 +16,7 @@ import Test.Tasty.Hedgehog (testProperty)
 test :: TestTree
 test =
   testGroup
-    "Compiler Proto API tests"
+    "Compiler API tests"
     [ allCorrectCompInpCompile
     , allCorrectCompInpCompileAfterBenignMut
     ]
@@ -40,10 +40,11 @@ allCorrectCompInpCompileAfterBenignMut =
             [ Mut.shuffleModules
             , Mut.shuffleTyDefs
             ]
-      (compInp', _) <- H.forAllWith (const "mutation") (Mut.mutFn mut compInp)
+      compInp' <- H.forAllWith (const "") (Mut.mutFn mut compInp)
       let compOut = runCompiler compInp
           compOut' = runCompiler compInp'
       compilationOk compOut
       compilationOk compOut'
+      Mut.mutAssert mut compOut'
 
 -- TODO(bladyjoker): Add error producing mutations.

lambda-buffers-compiler/test/Test/LambdaBuffers/Compiler/Gen/Mutation.hs

@@ -4,55 +4,67 @@ import Control.Lens ((&), (.~), (^.))
 import Data.List.NonEmpty (nonEmpty)
 import Data.ProtoLens (Message (messageName))
 import Data.Proxy (Proxy (Proxy))
+import GHC.Stack (HasCallStack)
 import Hedgehog qualified as H
 import Hedgehog.Gen qualified as H
 import Proto.Compiler (CompilerError, CompilerInput, CompilerOutput, CompilerOutput'CompilerOutput (CompilerOutput'CompilerError, CompilerOutput'CompilerResult), CompilerResult)
 import Proto.Compiler_Fields (maybe'compilerOutput, modules, typeDefs)
 import Test.LambdaBuffers.Compiler.Gen.Utils (pick)
 import Test.Tasty (TestName)
-import Test.Tasty.HUnit (Assertion, HasCallStack, assertFailure)
 
-data Mutation = MkMutation
+data Mutation m = MkMutation
   { mutLabel :: TestName
-  , mutFn :: CompilerInput -> H.Gen (CompilerInput, CompilerOutput -> Assertion)
+  , mutFn :: CompilerInput -> H.Gen CompilerInput
+  , mutAssert :: H.MonadTest m => CompilerOutput -> m ()
   }
 
-instance Show Mutation where
-  show :: Mutation -> String
+instance Show (Mutation m) where
+  show :: Mutation m -> String
   show = show . mutLabel
 
 -- | Benign mutations
-shuffleModules :: Mutation
-shuffleModules = MkMutation "Shuffling modules inside of the CompilerInput should not affect compilation" $ \compInp -> do
-  shuffled <- H.shuffle (compInp ^. modules)
-  return
-    ( compInp & modules .~ shuffled
-    , compilerResOrFail (\_ -> return ())
+shuffleModules :: Mutation m
+shuffleModules =
+  MkMutation
+    "Shuffling modules inside of the CompilerInput should not affect compilation"
+    ( \compInp -> do
+        shuffled <- H.shuffle (compInp ^. modules)
+        return $ compInp & modules .~ shuffled
     )
+    (compilerResOrFail (const H.success))
 
-shuffleTyDefs :: Mutation
-shuffleTyDefs = MkMutation "Shuffling type definitions inside of the Module should not affect compilation" $ \compInp -> do
-  case nonEmpty $ compInp ^. modules of
-    Nothing ->
-      return
-        ( compInp
-        , compilerResOrFail (\_ -> return ())
-        )
-    Just ms -> do
-      (m, ms') <- pick ms
-      shuffled <- H.shuffle (m ^. typeDefs)
-      let m' = m & typeDefs .~ shuffled
-      return
-        ( compInp & modules .~ m' : ms'
-        , compilerResOrFail (\_ -> return ())
-        )
+shuffleTyDefs :: Mutation m
+shuffleTyDefs =
+  MkMutation
+    "Shuffling type definitions inside of the Module should not affect compilation"
+    ( \compInp -> do
+        case nonEmpty $ compInp ^. modules of
+          Nothing ->
+            return compInp
+          Just ms -> do
+            (m, ms') <- pick ms
+            shuffled <- H.shuffle (m ^. typeDefs)
+            let m' = m & typeDefs .~ shuffled
+            return $ compInp & modules .~ m' : ms'
+    )
+    (compilerResOrFail (const H.success))
 
 -- | Utils
-compilerOut :: HasCallStack => (CompilerError -> Assertion) -> (CompilerResult -> Assertion) -> CompilerOutput -> Assertion
-compilerOut err res co = case co ^. maybe'compilerOutput of
-  Nothing -> assertFailure $ "compiler_output field must be set in " <> show (messageName (Proxy @CompilerOutput))
-  Just (CompilerOutput'CompilerError cerr) -> err cerr
-  Just (CompilerOutput'CompilerResult cres) -> res cres
+compilerOut :: HasCallStack => H.MonadTest m => (CompilerError -> m ()) -> (CompilerResult -> m ()) -> CompilerOutput -> m ()
+compilerOut err res co = do
+  H.annotate "Received CompilerOutput"
+  H.annotateShow co
+  case co ^. maybe'compilerOutput of
+    Nothing -> do
+      H.annotate $ "compiler_output field must be set in " <> show (messageName (Proxy @CompilerOutput))
+      H.failure
+    Just (CompilerOutput'CompilerError cerr) -> err cerr
+    Just (CompilerOutput'CompilerResult cres) -> res cres
 
-compilerResOrFail :: HasCallStack => (CompilerResult -> Assertion) -> CompilerOutput -> Assertion
-compilerResOrFail = compilerOut (\cerr -> assertFailure $ "Expected to succeed but failed with " <> show cerr)
+compilerResOrFail :: HasCallStack => H.MonadTest m => (CompilerResult -> m ()) -> CompilerOutput -> m ()
+compilerResOrFail =
+  compilerOut
+    ( \cerr -> do
+        H.annotateShow cerr
+        H.failure
+    )