-
Notifications
You must be signed in to change notification settings - Fork 23
Commit
This commit does not belong to any branch on this repository, and may belong to a fork outside of the repository.
Expose functions for error messages testing in golden tests
- Loading branch information
1 parent
2c0c168
commit 0be6b9c
Showing
4 changed files
with
94 additions
and
44 deletions.
There are no files selected for viewing
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
| 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") |
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters