From 4af2698e916e67ce1a0b7ebbec8217b64e8e1d38 Mon Sep 17 00:00:00 2001 From: Mateusz Galazyn Date: Tue, 18 Jul 2023 12:48:32 +0200 Subject: [PATCH] Expose functions for error messages testing in golden tests --- cardano-api-gen/cardano-api-gen.cabal | 1 + cardano-api/cardano-api.cabal | 5 ++ .../gen/Test/Hedgehog/Golden/ErrorMessage.hs | 80 +++++++++++++++++++ .../Test/Golden/ErrorsSpec.hs | 52 ++---------- 4 files changed, 94 insertions(+), 44 deletions(-) create mode 100644 cardano-api/gen/Test/Hedgehog/Golden/ErrorMessage.hs diff --git a/cardano-api-gen/cardano-api-gen.cabal b/cardano-api-gen/cardano-api-gen.cabal index 99dcd21494..8f462c36ad 100644 --- a/cardano-api-gen/cardano-api-gen.cabal +++ b/cardano-api-gen/cardano-api-gen.cabal @@ -41,5 +41,6 @@ library Test.Gen.Cardano.Api.Metadata, Test.Gen.Cardano.Api.Typed, Test.Gen.Cardano.Crypto.Seed, + Test.Hedgehog.Golden.ErrorMessage, Test.Hedgehog.Roundtrip.Bech32, Test.Hedgehog.Roundtrip.CBOR, diff --git a/cardano-api/cardano-api.cabal b/cardano-api/cardano-api.cabal index 80aa09ccda..7e2af4dd68 100644 --- a/cardano-api/cardano-api.cabal +++ b/cardano-api/cardano-api.cabal @@ -217,6 +217,7 @@ library gen Test.Gen.Cardano.Api.Metadata Test.Gen.Cardano.Api.Typed Test.Gen.Cardano.Crypto.Seed + Test.Hedgehog.Golden.ErrorMessage Test.Hedgehog.Roundtrip.Bech32 Test.Hedgehog.Roundtrip.CBOR @@ -234,7 +235,11 @@ library gen , cardano-ledger-core >= 1.4 , cardano-ledger-shelley >= 1.4.1.0 , containers + , filepath , hedgehog >= 1.1 + , hedgehog-extras + , tasty + , tasty-hedgehog , text test-suite cardano-api-test diff --git a/cardano-api/gen/Test/Hedgehog/Golden/ErrorMessage.hs b/cardano-api/gen/Test/Hedgehog/Golden/ErrorMessage.hs new file mode 100644 index 0000000000..724c406f1c --- /dev/null +++ b/cardano-api/gen/Test/Hedgehog/Golden/ErrorMessage.hs @@ -0,0 +1,80 @@ +{-# LANGUAGE ScopedTypeVariables #-} +module Test.Hedgehog.Golden.ErrorMessage where + +import Cardano.Api (Error (..)) + +import Data.Data +import GHC.Stack (HasCallStack, withFrozenCallStack) +import System.FilePath (()) + +import Hedgehog +import qualified Hedgehog.Extras.Test.Base as H +import qualified Hedgehog.Extras.Test.Golden as H +import Test.Tasty +import Test.Tasty.Hedgehog + + +-- | Generate test tree for the list of values. This 'TestTree' will serialize the values using 'Error' +-- instance and compare them against golden files in the provided location. +testAllErrorMessages :: forall a. (HasCallStack, Data a, Error a) + => FilePath -- ^ golden files location + -> [a] -- ^ list of values to test against + -> TestTree +testAllErrorMessages goldenFilesLocation errs = withFrozenCallStack $ do + -- 'err' here is only needed for its 'Data' instance and it's never evaluated + -- it's equivalent of having @err = undefined :: a@ + let err = head errs + typeName = show $ typeOf err + testedConstructors = map toConstr errs + allConstructors = dataTypeConstrs $ dataTypeOf err + notTestedConstructors = [ c | c <- allConstructors, c `notElem` testedConstructors] + testAllConstructors = + testProperty "check if all constructors are tested" . withTests 1 . property $ do + H.note_ $ "Untested constructors: " <> show notTestedConstructors + notTestedConstructors === [] + + testGroup typeName $ + testAllConstructors : map (testErrorMessage goldenFilesLocation) errs + +-- | Creates error messages for all values and tests them against the golden files. +-- +-- An escape hatch when adding of 'Data a' instance gets impossible (like when we embed 'TypeRep' in our error +-- data types) or requires significant multi-package changes and outweighs the benefits here. +testAllErrorMessages_ :: forall a. (HasCallStack, Error a) + => FilePath -- ^ golden files path + -> String -- ^ module name + -> String -- ^ type name + -> [(String, a)] -- ^ list of constructor names and values + -> TestTree +testAllErrorMessages_ goldenFilesLocation moduleName typeName errs = withFrozenCallStack $ do + testGroup typeName $ + fmap (uncurry $ testErrorMessage_ goldenFilesLocation moduleName typeName) errs + +-- | Create 'TestTree' validating serialized value @a@ using 'Error' against the golden files. +testErrorMessage :: (HasCallStack, Data a, Error a) + => FilePath -- ^ golden files path + -> a -- ^ value to test + -> TestTree +testErrorMessage goldenFilesLocation err = withFrozenCallStack $ do + let errTypeRep = typeOf err + typeName = show errTypeRep + moduleName = tyConModule $ typeRepTyCon errTypeRep + constructorName = show $ toConstr err + testErrorMessage_ goldenFilesLocation moduleName typeName constructorName err + +-- | Create 'TestTree' validating serialized value @a@ using 'Error' against the golden files. +-- +-- Requires providing a module name, a type name and a constructor name of @a@. Useful when 'Data a' +-- instance is not available. +testErrorMessage_ :: (HasCallStack, Error a) + => FilePath -- ^ golden files path + -> String -- ^ module name + -> String -- ^ type name + -> String -- ^ constructor name + -> a -- ^ value to test + -> TestTree +testErrorMessage_ goldenFilesLocation moduleName typeName constructorName err = withFrozenCallStack $ do + let fqtn = moduleName <> "." <> typeName + testProperty constructorName . withTests 1 . property $ do + H.note_ "Incorrect error message in golden file" + displayError err `H.diffVsGoldenFile` (goldenFilesLocation fqtn constructorName <> ".txt") diff --git a/cardano-api/test/cardano-api-golden/Test/Golden/ErrorsSpec.hs b/cardano-api/test/cardano-api-golden/Test/Golden/ErrorsSpec.hs index 3c482b56ad..ea69ec5adb 100644 --- a/cardano-api/test/cardano-api-golden/Test/Golden/ErrorsSpec.hs +++ b/cardano-api/test/cardano-api-golden/Test/Golden/ErrorsSpec.hs @@ -52,14 +52,10 @@ import qualified Data.Map as Map import Data.Maybe (fromJust) import qualified Data.Set as Set import Data.Text (Text) -import GHC.Stack (HasCallStack, withFrozenCallStack) -import System.FilePath (()) +import GHC.Stack (HasCallStack) -import Hedgehog -import qualified Hedgehog.Extras.Test.Base as H -import qualified Hedgehog.Extras.Test.Golden as H +import qualified Test.Hedgehog.Golden.ErrorMessage as ErrorMessage import Test.Tasty -import Test.Tasty.Hedgehog seed1 :: ByteString seed1 = "00000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000" @@ -343,47 +339,15 @@ test_TxMetadataRangeError = , TxMetadataNumberOutOfRange 0 ] +goldenFilesPath :: FilePath +goldenFilesPath = "test/cardano-api-golden/files/golden/errors" + testAllErrorMessages :: forall a. (HasCallStack, Data a, Error a) => [a] -> TestTree -testAllErrorMessages errs = withFrozenCallStack $ do - -- 'err' here is only needed for its 'Data' instance and it's never evaluated - -- it's equivalent of having @err = undefined :: a@ - let err = head errs - typeName = show $ typeOf err - testedConstructors = map toConstr errs - allConstructors = dataTypeConstrs $ dataTypeOf err - notTestedConstructors = [ c | c <- allConstructors, c `notElem` testedConstructors] - testAllConstructors = - testProperty "check if all constructors are tested" . withTests 1 . property $ do - H.note_ $ "Untested constructors: " <> show notTestedConstructors - notTestedConstructors === [] - - testGroup typeName $ - testAllConstructors : map testErrorMessage errs - --- | Creates error messages for all values and tests them agains the golden files. --- --- An escape hatch when adding of 'Data' instance gets impossible (like when we embed 'TypeRep' in our error data --- types) or requires significant multi-package changes and outweights the benefits here. +testAllErrorMessages = ErrorMessage.testAllErrorMessages goldenFilesPath + testAllErrorMessages_ :: forall a. (HasCallStack, Error a) => String -- ^ module name -> String -- ^ type name -> [(String, a)] -- ^ list of constructor names and values -> TestTree -testAllErrorMessages_ moduleName typeName errs = withFrozenCallStack $ do - testGroup typeName $ - fmap (uncurry $ testErrorMessage_ moduleName typeName) errs - -testErrorMessage :: (HasCallStack, Data a, Error a) => a -> TestTree -testErrorMessage err = withFrozenCallStack $ do - let errTypeRep = typeOf err - typeName = show errTypeRep - moduleName = tyConModule $ typeRepTyCon errTypeRep - constructorName = show $ toConstr err - testErrorMessage_ moduleName typeName constructorName err - -testErrorMessage_ :: (HasCallStack, Error a) => String -> String -> String -> a -> TestTree -testErrorMessage_ moduleName typeName constructorName err = withFrozenCallStack $ do - let fqtn = moduleName <> "." <> typeName - testProperty constructorName . withTests 1 . property $ do - H.note_ "Incorrect error message in golden file" - displayError err `H.diffVsGoldenFile` ("test/cardano-api-golden/files/golden/errors" fqtn constructorName <> ".txt") +testAllErrorMessages_ = ErrorMessage.testAllErrorMessages_ goldenFilesPath