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