{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}

{-# OPTIONS_GHC -Wno-unused-imports #-}
{-# OPTIONS_GHC -Wno-redundant-constraints #-}
{-# OPTIONS_GHC -Wno-unused-local-binds #-}

module Hedgehog.Extras.Aeson
  ( goldenTestJsonValue
  , goldenTestJsonValuePretty
  ) where

import           Control.Monad
import           Control.Monad.IO.Class
import           Data.Aeson
import           Data.Aeson.Encode.Pretty
import           Data.Bool
import           Data.Either
import           Data.Eq
import           Data.Function
import           Data.Functor
import           Data.Maybe
import           Data.Semigroup
import           GHC.Stack
import           Hedgehog
import           System.IO
import           Text.Show

import qualified Data.ByteString.Lazy as LBS
import qualified Hedgehog.Internal.Property as H

writeNewGoldFiles :: Bool
writeNewGoldFiles :: Bool
writeNewGoldFiles = Bool
False

strictComparison :: Bool
strictComparison :: Bool
strictComparison = Bool
False

goldenTestJsonValue :: forall a. ()
  => Eq a
  => FromJSON a
  => Show a
  => ToJSON a
  => HasCallStack
  => a
  -> FilePath
  -> Property
goldenTestJsonValue :: forall a.
(Eq a, FromJSON a, Show a, ToJSON a, HasCallStack) =>
a -> FilePath -> Property
goldenTestJsonValue a
x FilePath
path = forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack forall a b. (a -> b) -> a -> b
$ TestLimit -> Property -> Property
withTests TestLimit
1 forall b c a. (b -> c) -> (a -> b) -> a -> c
. HasCallStack => PropertyT IO () -> Property
property forall a b. (a -> b) -> a -> b
$ do
  ByteString
bs <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (FilePath -> IO ByteString
LBS.readFile FilePath
path)
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
writeNewGoldFiles forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> ByteString -> IO ()
LBS.writeFile (FilePath
path forall a. Semigroup a => a -> a -> a
<> FilePath
".gold") forall a b. (a -> b) -> a -> b
$ forall a. ToJSON a => a -> ByteString
encode a
x
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
strictComparison forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. ToJSON a => a -> ByteString
encode (forall a. FromJSON a => ByteString -> Either FilePath a
eitherDecode @a ByteString
bs) forall (m :: * -> *) a.
(MonadTest m, Eq a, Show a, HasCallStack) =>
a -> a -> m ()
=== forall a b. b -> Either a b
Right ByteString
bs
  case forall a. FromJSON a => ByteString -> Either FilePath a
eitherDecode ByteString
bs of
    Left  FilePath
err -> forall (m :: * -> *) a.
(MonadTest m, HasCallStack) =>
Maybe Diff -> FilePath -> m a
H.failWith forall a. Maybe a
Nothing forall a b. (a -> b) -> a -> b
$ FilePath
"could not decode: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> FilePath
show FilePath
err
    Right a
x'  -> a
x forall (m :: * -> *) a.
(MonadTest m, Eq a, Show a, HasCallStack) =>
a -> a -> m ()
=== a
x'

goldenTestJsonValuePretty
  :: forall a. ()
  => Eq a
  => FromJSON a
  => HasCallStack
  => Show a
  => ToJSON a
  => a
  -> FilePath
  -> Property
goldenTestJsonValuePretty :: forall a.
(Eq a, FromJSON a, HasCallStack, Show a, ToJSON a) =>
a -> FilePath -> Property
goldenTestJsonValuePretty a
x FilePath
path =
  forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack
    forall a b. (a -> b) -> a -> b
$ TestLimit -> Property -> Property
withTests TestLimit
1
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. HasCallStack => PropertyT IO () -> Property
property
    forall a b. (a -> b) -> a -> b
$ do
        ByteString
bs <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (FilePath -> IO ByteString
LBS.readFile FilePath
path)
        -- Sort keys by their order of appearance in the argument list
        -- of `keyOrder`. Keys not in the argument list are moved to the
        -- end, while their order is preserved.
        let
          defConfig' :: Config
defConfig' = Config
            { confIndent :: Indent
confIndent          = Int -> Indent
Spaces Int
4
            , confCompare :: Text -> Text -> Ordering
confCompare         = [Text] -> Text -> Text -> Ordering
keyOrder [Text
"file", Text
"hash"]
            , confNumFormat :: NumberFormat
confNumFormat       = NumberFormat
Generic
            , confTrailingNewline :: Bool
confTrailingNewline = Bool
False
            }
        forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
writeNewGoldFiles forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> ByteString -> IO ()
LBS.writeFile (FilePath
path forall a. Semigroup a => a -> a -> a
<> FilePath
".gold") forall a b. (a -> b) -> a -> b
$ forall a. ToJSON a => Config -> a -> ByteString
encodePretty' Config
defConfig' a
x
        forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
strictComparison forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a. ToJSON a => Config -> a -> ByteString
encodePretty' Config
defConfig') (forall a. FromJSON a => ByteString -> Either FilePath a
eitherDecode @a ByteString
bs) forall (m :: * -> *) a.
(MonadTest m, Eq a, Show a, HasCallStack) =>
a -> a -> m ()
=== forall a b. b -> Either a b
Right ByteString
bs
        case forall a. FromJSON a => ByteString -> Either FilePath a
eitherDecode ByteString
bs of
          Left  FilePath
err -> forall (m :: * -> *) a.
(MonadTest m, HasCallStack) =>
Maybe Diff -> FilePath -> m a
H.failWith forall a. Maybe a
Nothing forall a b. (a -> b) -> a -> b
$ FilePath
"could not decode: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> FilePath
show FilePath
err
          Right a
x'  -> a
x forall (m :: * -> *) a.
(MonadTest m, Eq a, Show a, HasCallStack) =>
a -> a -> m ()
=== a
x'