{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Test.Hedgehog.Golden.ErrorMessage where
import Cardano.Api (Error (..))
import Cardano.Api.Pretty
import qualified Control.Concurrent.QSem as IO
import Control.Exception (bracket_)
import Control.Monad
import Control.Monad.IO.Class
import Data.Algorithm.Diff (PolyDiff (Both), getGroupedDiff)
import Data.Algorithm.DiffOutput (ppDiff)
import Data.Data
import qualified Data.List as List
import qualified Data.Text as Text
import qualified Data.Text.IO as Text
import GHC.Stack (HasCallStack, withFrozenCallStack)
import qualified GHC.Stack as GHC
import qualified System.Directory as IO
import qualified System.Environment as IO
import System.FilePath (takeDirectory, (</>))
import qualified System.IO as IO
import qualified System.IO.Unsafe as IO
import Hedgehog
import qualified Hedgehog.Extras.Test as H
import qualified Hedgehog.Internal.Property 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) =>
String -> [a] -> TestTree
testAllErrorMessages String
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 :: String
typeName = TypeRep -> String
forall a. Show a => a -> String
show (TypeRep -> String) -> TypeRep -> String
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 =
String -> Property -> TestTree
testProperty String
"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
String -> PropertyT IO ()
forall (m :: * -> *). (MonadTest m, HasCallStack) => String -> m ()
H.note_ (String -> PropertyT IO ()) -> String -> PropertyT IO ()
forall a b. (a -> b) -> a -> b
$ String
"Untested constructors: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> [Constr] -> String
forall a. Show a => a -> String
show [Constr]
notTestedConstructors
[Constr]
notTestedConstructors [Constr] -> [Constr] -> PropertyT IO ()
forall (m :: * -> *) a.
(MonadTest m, Eq a, Show a, HasCallStack) =>
a -> a -> m ()
=== []
String -> [TestTree] -> TestTree
testGroup String
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 (String -> a -> TestTree
forall a.
(HasCallStack, Data a, Error a) =>
String -> a -> TestTree
testErrorMessage String
goldenFilesLocation) [a]
errs
testAllErrorMessages_
:: forall a
. (HasCallStack, Error a)
=> FilePath
-> String
-> String
-> [(String, a)]
-> TestTree
testAllErrorMessages_ :: forall a.
(HasCallStack, Error a) =>
String -> String -> String -> [(String, a)] -> TestTree
testAllErrorMessages_ String
goldenFilesLocation String
moduleName String
typeName [(String, 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
String -> [TestTree] -> TestTree
testGroup String
typeName ([TestTree] -> TestTree) -> [TestTree] -> TestTree
forall a b. (a -> b) -> a -> b
$
((String, a) -> TestTree) -> [(String, a)] -> [TestTree]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((String -> a -> TestTree) -> (String, a) -> TestTree
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry ((String -> a -> TestTree) -> (String, a) -> TestTree)
-> (String -> a -> TestTree) -> (String, a) -> TestTree
forall a b. (a -> b) -> a -> b
$ String -> String -> String -> String -> a -> TestTree
forall a.
(HasCallStack, Error a) =>
String -> String -> String -> String -> a -> TestTree
testErrorMessage_ String
goldenFilesLocation String
moduleName String
typeName) [(String, a)]
errs
testErrorMessage
:: (HasCallStack, Data a, Error a)
=> FilePath
-> a
-> TestTree
testErrorMessage :: forall a.
(HasCallStack, Data a, Error a) =>
String -> a -> TestTree
testErrorMessage String
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 :: String
typeName = TypeRep -> String
forall a. Show a => a -> String
show TypeRep
errTypeRep
moduleName :: String
moduleName = TyCon -> String
tyConModule (TyCon -> String) -> TyCon -> String
forall a b. (a -> b) -> a -> b
$ TypeRep -> TyCon
typeRepTyCon TypeRep
errTypeRep
constructorName :: String
constructorName = Constr -> String
forall a. Show a => a -> String
show (Constr -> String) -> Constr -> String
forall a b. (a -> b) -> a -> b
$ a -> Constr
forall a. Data a => a -> Constr
toConstr a
err
String -> String -> String -> String -> a -> TestTree
forall a.
(HasCallStack, Error a) =>
String -> String -> String -> String -> a -> TestTree
testErrorMessage_ String
goldenFilesLocation String
moduleName String
typeName String
constructorName a
err
testErrorMessage_
:: (HasCallStack, Error a)
=> FilePath
-> String
-> String
-> String
-> a
-> TestTree
testErrorMessage_ :: forall a.
(HasCallStack, Error a) =>
String -> String -> String -> String -> a -> TestTree
testErrorMessage_ String
goldenFilesLocation String
moduleName String
typeName String
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 :: String
fqtn = String
moduleName String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"." String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
typeName
String -> Property -> TestTree
testProperty String
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
String -> PropertyT IO ()
forall (m :: * -> *). (MonadTest m, HasCallStack) => String -> m ()
H.note_ String
"Incorrect error message in golden file"
String -> PropertyT IO ()
forall (m :: * -> *). (MonadTest m, HasCallStack) => String -> m ()
H.note_ String
"What the value looks like in memory"
let pErr :: String
pErr = Doc AnsiStyle -> String
docToString (a -> Doc AnsiStyle
forall ann. a -> Doc ann
forall e ann. Error e => e -> Doc ann
prettyError a
err)
String -> PropertyT IO ()
forall (m :: * -> *). (MonadTest m, HasCallStack) => String -> m ()
H.note_ (String -> PropertyT IO ()) -> String -> PropertyT IO ()
forall a b. (a -> b) -> a -> b
$ String -> String
forall a. Show a => a -> String
show String
pErr
String -> String -> PropertyT IO ()
forall (m :: * -> *).
(HasCallStack, MonadIO m, MonadTest m) =>
String -> String -> m ()
diffVsGoldenFile
String
pErr
(String
goldenFilesLocation String -> String -> String
</> String
fqtn String -> String -> String
</> String
constructorName String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
".txt")
diffVsGoldenFile
:: HasCallStack
=> (MonadIO m, MonadTest m)
=> String
-> FilePath
-> m ()
diffVsGoldenFile :: forall (m :: * -> *).
(HasCallStack, MonadIO m, MonadTest m) =>
String -> String -> m ()
diffVsGoldenFile String
actualContent String
goldenFile = (HasCallStack => m ()) -> m ()
forall a. HasCallStack => (HasCallStack => a) -> a
GHC.withFrozenCallStack ((HasCallStack => m ()) -> m ()) -> (HasCallStack => m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ do
Maybe String -> (String -> m ()) -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Maybe String
mGoldenFileLogFile ((String -> m ()) -> m ()) -> (String -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \String
logFile ->
IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ IO () -> IO ()
forall a. IO a -> IO a
semBracket (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> String -> IO ()
IO.appendFile String
logFile (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
goldenFile String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"\n"
Bool
fileExists <- IO Bool -> m Bool
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> m Bool) -> IO Bool -> m Bool
forall a b. (a -> b) -> a -> b
$ String -> IO Bool
IO.doesFileExist String
goldenFile
if
| Bool
recreateGoldenFiles -> String -> String -> m ()
forall (m :: * -> *).
(HasCallStack, MonadIO m, MonadTest m) =>
String -> String -> m ()
writeGoldenFile String
goldenFile String
actualContent
| Bool
fileExists -> String -> [String] -> m ()
forall (m :: * -> *).
(HasCallStack, MonadIO m, MonadTest m) =>
String -> [String] -> m ()
checkAgainstGoldenFile String
goldenFile [String]
actualLines
| Bool
createGoldenFiles -> String -> String -> m ()
forall (m :: * -> *).
(HasCallStack, MonadIO m, MonadTest m) =>
String -> String -> m ()
writeGoldenFile String
goldenFile String
actualContent
| Bool
otherwise -> String -> m ()
forall (m :: * -> *).
(HasCallStack, MonadIO m, MonadTest m) =>
String -> m ()
reportGoldenFileMissing String
goldenFile
where
actualLines :: [String]
actualLines = String -> [String]
List.lines String
actualContent
writeGoldenFile
:: ()
=> HasCallStack
=> MonadIO m
=> MonadTest m
=> FilePath
-> String
-> m ()
writeGoldenFile :: forall (m :: * -> *).
(HasCallStack, MonadIO m, MonadTest m) =>
String -> String -> m ()
writeGoldenFile String
goldenFile String
actualContent = (HasCallStack => m ()) -> m ()
forall a. HasCallStack => (HasCallStack => a) -> a
GHC.withFrozenCallStack ((HasCallStack => m ()) -> m ()) -> (HasCallStack => m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ do
String -> m ()
forall (m :: * -> *). (MonadTest m, HasCallStack) => String -> m ()
H.note_ (String -> m ()) -> String -> m ()
forall a b. (a -> b) -> a -> b
$ String
"Creating golden file " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
goldenFile
String -> m ()
forall (m :: * -> *).
(MonadTest m, MonadIO m, HasCallStack) =>
String -> m ()
H.createDirectoryIfMissing_ (String -> String
takeDirectory String
goldenFile)
String -> String -> m ()
forall (m :: * -> *).
(MonadTest m, MonadIO m, HasCallStack) =>
String -> String -> m ()
writeFile' String
goldenFile String
actualContent
recreateGoldenFiles :: Bool
recreateGoldenFiles :: Bool
recreateGoldenFiles = IO Bool -> Bool
forall a. IO a -> a
IO.unsafePerformIO (IO Bool -> Bool) -> IO Bool -> Bool
forall a b. (a -> b) -> a -> b
$ do
Maybe String
value <- String -> IO (Maybe String)
IO.lookupEnv String
"RECREATE_GOLDEN_FILES"
Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> IO Bool) -> Bool -> IO Bool
forall a b. (a -> b) -> a -> b
$ Maybe String
value Maybe String -> Maybe String -> Bool
forall a. Eq a => a -> a -> Bool
== String -> Maybe String
forall a. a -> Maybe a
Just String
"1"
createGoldenFiles :: Bool
createGoldenFiles :: Bool
createGoldenFiles = IO Bool -> Bool
forall a. IO a -> a
IO.unsafePerformIO (IO Bool -> Bool) -> IO Bool -> Bool
forall a b. (a -> b) -> a -> b
$ do
Maybe String
value <- String -> IO (Maybe String)
IO.lookupEnv String
"CREATE_GOLDEN_FILES"
Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> IO Bool) -> Bool -> IO Bool
forall a b. (a -> b) -> a -> b
$ Maybe String
value Maybe String -> Maybe String -> Bool
forall a. Eq a => a -> a -> Bool
== String -> Maybe String
forall a. a -> Maybe a
Just String
"1"
writeFile' :: (MonadTest m, MonadIO m, HasCallStack) => FilePath -> String -> m ()
writeFile' :: forall (m :: * -> *).
(MonadTest m, MonadIO m, HasCallStack) =>
String -> String -> m ()
writeFile' String
filePath String
contents = (HasCallStack => m ()) -> m ()
forall a. HasCallStack => (HasCallStack => a) -> a
GHC.withFrozenCallStack ((HasCallStack => m ()) -> m ()) -> (HasCallStack => m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ do
m () -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (m () -> m ()) -> (String -> m ()) -> String -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> m ()
forall (m :: * -> *). (MonadTest m, HasCallStack) => String -> m ()
H.annotate (String -> m ()) -> String -> m ()
forall a b. (a -> b) -> a -> b
$ String
"Writing file: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
filePath
IO () -> m ()
forall (m :: * -> *) a.
(MonadTest m, MonadIO m, HasCallStack) =>
IO a -> m a
H.evalIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ String -> IOMode -> (Handle -> IO ()) -> IO ()
forall r. String -> IOMode -> (Handle -> IO r) -> IO r
IO.withFile String
filePath IOMode
IO.WriteMode ((Handle -> IO ()) -> IO ()) -> (Handle -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Handle
handle -> do
Handle -> TextEncoding -> IO ()
IO.hSetEncoding Handle
handle TextEncoding
IO.utf8
Handle -> String -> IO ()
IO.hPutStr Handle
handle String
contents
checkAgainstGoldenFile
:: ()
=> HasCallStack
=> MonadIO m
=> MonadTest m
=> FilePath
-> [String]
-> m ()
checkAgainstGoldenFile :: forall (m :: * -> *).
(HasCallStack, MonadIO m, MonadTest m) =>
String -> [String] -> m ()
checkAgainstGoldenFile String
goldenFile [String]
actualLines = (HasCallStack => m ()) -> m ()
forall a. HasCallStack => (HasCallStack => a) -> a
GHC.withFrozenCallStack ((HasCallStack => m ()) -> m ()) -> (HasCallStack => m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ do
[String]
referenceLines <- IO [String] -> m [String]
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [String] -> m [String]) -> IO [String] -> m [String]
forall a b. (a -> b) -> a -> b
$ String -> IOMode -> (Handle -> IO [String]) -> IO [String]
forall r. String -> IOMode -> (Handle -> IO r) -> IO r
IO.withFile String
goldenFile IOMode
IO.ReadMode ((Handle -> IO [String]) -> IO [String])
-> (Handle -> IO [String]) -> IO [String]
forall a b. (a -> b) -> a -> b
$ \Handle
handle -> do
Handle -> TextEncoding -> IO ()
IO.hSetEncoding Handle
handle TextEncoding
IO.utf8
String -> [String]
List.lines (String -> [String]) -> (Text -> String) -> Text -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
Text.unpack (Text -> [String]) -> IO Text -> IO [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Handle -> IO Text
Text.hGetContents Handle
handle
let difference :: [Diff [String]]
difference = [String] -> [String] -> [Diff [String]]
forall a. Eq a => [a] -> [a] -> [Diff [a]]
getGroupedDiff [String]
actualLines [String]
referenceLines
case [Diff [String]]
difference of
[] -> () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
[Both{}] -> () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
[Diff [String]]
_ -> do
String -> m ()
forall (m :: * -> *). (MonadTest m, HasCallStack) => String -> m ()
H.note_ (String -> m ()) -> String -> m ()
forall a b. (a -> b) -> a -> b
$
[String] -> String
unlines
[ String
"Golden test failed against the golden file."
, String
"To recreate golden file, run with RECREATE_GOLDEN_FILES=1."
]
CallStack -> String -> m ()
forall (m :: * -> *) a. MonadTest m => CallStack -> String -> m a
H.failMessage CallStack
HasCallStack => CallStack
GHC.callStack (String -> m ()) -> String -> m ()
forall a b. (a -> b) -> a -> b
$ [Diff [String]] -> String
ppDiff [Diff [String]]
difference
sem :: IO.QSem
sem :: QSem
sem = IO QSem -> QSem
forall a. IO a -> a
IO.unsafePerformIO (IO QSem -> QSem) -> IO QSem -> QSem
forall a b. (a -> b) -> a -> b
$ Int -> IO QSem
IO.newQSem Int
1
{-# NOINLINE sem #-}
semBracket :: IO a -> IO a
semBracket :: forall a. IO a -> IO a
semBracket = IO () -> IO () -> IO a -> IO a
forall a b c. IO a -> IO b -> IO c -> IO c
bracket_ (QSem -> IO ()
IO.waitQSem QSem
sem) (QSem -> IO ()
IO.signalQSem QSem
sem)
mGoldenFileLogFile :: Maybe FilePath
mGoldenFileLogFile :: Maybe String
mGoldenFileLogFile =
IO (Maybe String) -> Maybe String
forall a. IO a -> a
IO.unsafePerformIO (IO (Maybe String) -> Maybe String)
-> IO (Maybe String) -> Maybe String
forall a b. (a -> b) -> a -> b
$
String -> IO (Maybe String)
IO.lookupEnv String
"GOLDEN_FILE_LOG_FILE"
reportGoldenFileMissing
:: ()
=> HasCallStack
=> MonadIO m
=> MonadTest m
=> FilePath
-> m ()
reportGoldenFileMissing :: forall (m :: * -> *).
(HasCallStack, MonadIO m, MonadTest m) =>
String -> m ()
reportGoldenFileMissing String
goldenFile = (HasCallStack => m ()) -> m ()
forall a. HasCallStack => (HasCallStack => a) -> a
GHC.withFrozenCallStack ((HasCallStack => m ()) -> m ()) -> (HasCallStack => m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ do
String -> m ()
forall (m :: * -> *). (MonadTest m, HasCallStack) => String -> m ()
H.note_ (String -> m ()) -> String -> m ()
forall a b. (a -> b) -> a -> b
$
[String] -> String
unlines
[ String
"Golden file " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
goldenFile String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" does not exist."
, String
"To create it, run with CREATE_GOLDEN_FILES=1."
, String
"To recreate it, run with RECREATE_GOLDEN_FILES=1."
]
m ()
forall (m :: * -> *) a. (MonadTest m, HasCallStack) => m a
H.failure