{-# 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

-- | 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 :: 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
  -- 'err' here is only needed for its 'Data' instance and it's never evaluated
  -- it's equivalent of having @err = undefined :: a@
  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

-- | 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_ :: 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

-- | 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 :: 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

-- | 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_ :: 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")