{-# LANGUAGE ScopedTypeVariables #-}
module Test.Hedgehog.Golden.ErrorMessage where
import Cardano.Api (Error (..))
import Cardano.Api.Pretty
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
testAllErrorMessages
:: forall a
. (HasCallStack, Data a, Error a)
=> FilePath
-> [a]
-> TestTree
testAllErrorMessages :: forall a.
(HasCallStack, Data a, Error a) =>
FilePath -> [a] -> TestTree
testAllErrorMessages FilePath
goldenFilesLocation [a]
errs = (HasCallStack => TestTree) -> TestTree
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack ((HasCallStack => TestTree) -> TestTree)
-> (HasCallStack => TestTree) -> TestTree
forall a b. (a -> b) -> a -> b
$ do
let err :: a
err = a
forall a. HasCallStack => a
undefined :: a
typeName :: FilePath
typeName = TypeRep -> FilePath
forall a. Show a => a -> FilePath
show (TypeRep -> FilePath) -> TypeRep -> FilePath
forall a b. (a -> b) -> a -> b
$ a -> TypeRep
forall a. Typeable a => a -> TypeRep
typeOf a
err
testedConstructors :: [Constr]
testedConstructors = (a -> Constr) -> [a] -> [Constr]
forall a b. (a -> b) -> [a] -> [b]
map a -> Constr
forall a. Data a => a -> Constr
toConstr [a]
errs
allConstructors :: [Constr]
allConstructors = DataType -> [Constr]
dataTypeConstrs (DataType -> [Constr]) -> DataType -> [Constr]
forall a b. (a -> b) -> a -> b
$ a -> DataType
forall a. Data a => a -> DataType
dataTypeOf a
err
notTestedConstructors :: [Constr]
notTestedConstructors = [Constr
c | Constr
c <- [Constr]
allConstructors, Constr
c Constr -> [Constr] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [Constr]
testedConstructors]
testAllConstructors :: TestTree
testAllConstructors =
FilePath -> Property -> TestTree
testProperty FilePath
"check if all constructors are tested" (Property -> TestTree)
-> (PropertyT IO () -> Property) -> PropertyT IO () -> TestTree
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TestLimit -> Property -> Property
withTests TestLimit
1 (Property -> Property)
-> (PropertyT IO () -> Property) -> PropertyT IO () -> Property
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HasCallStack => PropertyT IO () -> Property
PropertyT IO () -> Property
property (PropertyT IO () -> TestTree) -> PropertyT IO () -> TestTree
forall a b. (a -> b) -> a -> b
$ do
FilePath -> PropertyT IO ()
forall (m :: * -> *).
(MonadTest m, HasCallStack) =>
FilePath -> m ()
H.note_ (FilePath -> PropertyT IO ()) -> FilePath -> PropertyT IO ()
forall a b. (a -> b) -> a -> b
$ FilePath
"Untested constructors: " FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> [Constr] -> FilePath
forall a. Show a => a -> FilePath
show [Constr]
notTestedConstructors
[Constr]
notTestedConstructors [Constr] -> [Constr] -> PropertyT IO ()
forall (m :: * -> *) a.
(MonadTest m, Eq a, Show a, HasCallStack) =>
a -> a -> m ()
=== []
FilePath -> [TestTree] -> TestTree
testGroup FilePath
typeName ([TestTree] -> TestTree) -> [TestTree] -> TestTree
forall a b. (a -> b) -> a -> b
$
TestTree
testAllConstructors TestTree -> [TestTree] -> [TestTree]
forall a. a -> [a] -> [a]
: (a -> TestTree) -> [a] -> [TestTree]
forall a b. (a -> b) -> [a] -> [b]
map (FilePath -> a -> TestTree
forall a.
(HasCallStack, Data a, Error a) =>
FilePath -> a -> TestTree
testErrorMessage FilePath
goldenFilesLocation) [a]
errs
testAllErrorMessages_
:: forall a
. (HasCallStack, Error a)
=> FilePath
-> String
-> String
-> [(String, a)]
-> TestTree
testAllErrorMessages_ :: forall a.
(HasCallStack, Error a) =>
FilePath -> FilePath -> FilePath -> [(FilePath, a)] -> TestTree
testAllErrorMessages_ FilePath
goldenFilesLocation FilePath
moduleName FilePath
typeName [(FilePath, a)]
errs = (HasCallStack => TestTree) -> TestTree
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack ((HasCallStack => TestTree) -> TestTree)
-> (HasCallStack => TestTree) -> TestTree
forall a b. (a -> b) -> a -> b
$ do
FilePath -> [TestTree] -> TestTree
testGroup FilePath
typeName ([TestTree] -> TestTree) -> [TestTree] -> TestTree
forall a b. (a -> b) -> a -> b
$
((FilePath, a) -> TestTree) -> [(FilePath, a)] -> [TestTree]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((FilePath -> a -> TestTree) -> (FilePath, a) -> TestTree
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry ((FilePath -> a -> TestTree) -> (FilePath, a) -> TestTree)
-> (FilePath -> a -> TestTree) -> (FilePath, a) -> TestTree
forall a b. (a -> b) -> a -> b
$ FilePath -> FilePath -> FilePath -> FilePath -> a -> TestTree
forall a.
(HasCallStack, Error a) =>
FilePath -> FilePath -> FilePath -> FilePath -> a -> TestTree
testErrorMessage_ FilePath
goldenFilesLocation FilePath
moduleName FilePath
typeName) [(FilePath, a)]
errs
testErrorMessage
:: (HasCallStack, Data a, Error a)
=> FilePath
-> a
-> TestTree
testErrorMessage :: forall a.
(HasCallStack, Data a, Error a) =>
FilePath -> a -> TestTree
testErrorMessage FilePath
goldenFilesLocation a
err = (HasCallStack => TestTree) -> TestTree
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack ((HasCallStack => TestTree) -> TestTree)
-> (HasCallStack => TestTree) -> TestTree
forall a b. (a -> b) -> a -> b
$ do
let errTypeRep :: TypeRep
errTypeRep = a -> TypeRep
forall a. Typeable a => a -> TypeRep
typeOf a
err
typeName :: FilePath
typeName = TypeRep -> FilePath
forall a. Show a => a -> FilePath
show TypeRep
errTypeRep
moduleName :: FilePath
moduleName = TyCon -> FilePath
tyConModule (TyCon -> FilePath) -> TyCon -> FilePath
forall a b. (a -> b) -> a -> b
$ TypeRep -> TyCon
typeRepTyCon TypeRep
errTypeRep
constructorName :: FilePath
constructorName = Constr -> FilePath
forall a. Show a => a -> FilePath
show (Constr -> FilePath) -> Constr -> FilePath
forall a b. (a -> b) -> a -> b
$ a -> Constr
forall a. Data a => a -> Constr
toConstr a
err
FilePath -> FilePath -> FilePath -> FilePath -> a -> TestTree
forall a.
(HasCallStack, Error a) =>
FilePath -> FilePath -> FilePath -> FilePath -> a -> TestTree
testErrorMessage_ FilePath
goldenFilesLocation FilePath
moduleName FilePath
typeName FilePath
constructorName a
err
testErrorMessage_
:: (HasCallStack, Error a)
=> FilePath
-> String
-> String
-> String
-> a
-> TestTree
testErrorMessage_ :: forall a.
(HasCallStack, Error a) =>
FilePath -> FilePath -> FilePath -> FilePath -> a -> TestTree
testErrorMessage_ FilePath
goldenFilesLocation FilePath
moduleName FilePath
typeName FilePath
constructorName a
err = (HasCallStack => TestTree) -> TestTree
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack ((HasCallStack => TestTree) -> TestTree)
-> (HasCallStack => TestTree) -> TestTree
forall a b. (a -> b) -> a -> b
$ do
let fqtn :: FilePath
fqtn = FilePath
moduleName FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
"." FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
typeName
FilePath -> Property -> TestTree
testProperty FilePath
constructorName (Property -> TestTree)
-> (PropertyT IO () -> Property) -> PropertyT IO () -> TestTree
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TestLimit -> Property -> Property
withTests TestLimit
1 (Property -> Property)
-> (PropertyT IO () -> Property) -> PropertyT IO () -> Property
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HasCallStack => PropertyT IO () -> Property
PropertyT IO () -> Property
property (PropertyT IO () -> TestTree) -> PropertyT IO () -> TestTree
forall a b. (a -> b) -> a -> b
$ do
FilePath -> PropertyT IO ()
forall (m :: * -> *).
(MonadTest m, HasCallStack) =>
FilePath -> m ()
H.note_ FilePath
"Incorrect error message in golden file"
FilePath -> FilePath -> PropertyT IO ()
forall (m :: * -> *).
(HasCallStack, MonadIO m, MonadTest m) =>
FilePath -> FilePath -> m ()
H.diffVsGoldenFile
(Doc AnsiStyle -> FilePath
docToString (a -> Doc AnsiStyle
forall ann. a -> Doc ann
forall e ann. Error e => e -> Doc ann
prettyError a
err))
(FilePath
goldenFilesLocation FilePath -> FilePath -> FilePath
</> FilePath
fqtn FilePath -> FilePath -> FilePath
</> FilePath
constructorName FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
".txt")