Skip to content
New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Jump to bottom

Expose functions for error messages testing in golden tests #126

Merged
merged 1 commit into from
Jul 25, 2023
Merged

Expose functions for error messages testing in golden tests #126

Show file tree
Hide file tree
Changes from all commits
Commits
Show all changes
1 commit
Select commit
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
1 change: 1 addition & 0 deletions cardano-api-gen/cardano-api-gen.cabal
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -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,
5 changes: 5 additions & 0 deletions cardano-api/cardano-api.cabal
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -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

Expand All @@ -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
Expand Down
80 changes: 80 additions & 0 deletions cardano-api/gen/Test/Hedgehog/Golden/ErrorMessage.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
@@ -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")
52 changes: 8 additions & 44 deletions cardano-api/test/cardano-api-golden/Test/Golden/ErrorsSpec.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -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"
Expand Down Expand Up @@ -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