{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}

module Test.Cardano.Ledger.Core.JSON (
  roundTripJsonSpec,
  roundTripJsonEraSpec,
  roundTripJsonProperty,
  goldenJsonPParamsSpec,
  goldenJsonPParamsUpdateSpec,
) where

import Cardano.Ledger.Core
import Data.Aeson (FromJSON, ToJSON, eitherDecode, eitherDecodeFileStrict, encode)
import Data.Aeson.Encode.Pretty (encodePretty)
import qualified Data.ByteString.Lazy as BSL
import Data.Function ((&))
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import Data.Typeable (Proxy (..), Typeable, typeRep)
import GHC.Stack
import Test.Cardano.Ledger.Common
import Test.Cardano.Ledger.Core.Arbitrary ()
import Test.Cardano.Ledger.Era (EraTest)

-- | QuickCheck property spec that uses `roundTripJsonProperty`
roundTripJsonSpec ::
  forall t.
  (HasCallStack, Typeable t, Show t, Eq t, ToJSON t, FromJSON t, Arbitrary t) =>
  Spec
roundTripJsonSpec :: forall t.
(HasCallStack, Typeable t, Show t, Eq t, ToJSON t, FromJSON t,
 Arbitrary t) =>
Spec
roundTripJsonSpec =
  String -> (t -> Property) -> Spec
forall prop.
(HasCallStack, Testable prop) =>
String -> prop -> Spec
prop (TypeRep -> String
forall a. Show a => a -> String
show (Proxy t -> TypeRep
forall {k} (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> TypeRep
typeRep (Proxy t -> TypeRep) -> Proxy t -> TypeRep
forall a b. (a -> b) -> a -> b
$ forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @t)) ((t -> Property) -> Spec) -> (t -> Property) -> Spec
forall a b. (a -> b) -> a -> b
$ forall t.
(HasCallStack, Show t, Eq t, ToJSON t, FromJSON t) =>
t -> Property
roundTripJsonProperty @t

-- | Roundtrip JSON testing for types that implement ToJSON/FromJSON.
roundTripJsonProperty ::
  forall t.
  (HasCallStack, Show t, Eq t, ToJSON t, FromJSON t) =>
  t ->
  Property
roundTripJsonProperty :: forall t.
(HasCallStack, Show t, Eq t, ToJSON t, FromJSON t) =>
t -> Property
roundTripJsonProperty t
original = do
  let encoded :: ByteString
encoded = t -> ByteString
forall a. ToJSON a => a -> ByteString
encode t
original
      encodedString :: String
encodedString =
        String
"Encoded: \n  " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Text -> String
T.unpack (ByteString -> Text
T.decodeUtf8 (ByteString -> ByteString
BSL.toStrict (t -> ByteString
forall a. ToJSON a => a -> ByteString
encodePretty t
original)))
  case ByteString -> Either String t
forall a. FromJSON a => ByteString -> Either String a
eitherDecode ByteString
encoded of
    Left String
err ->
      Bool -> Property
forall prop. Testable prop => prop -> Property
property Bool
False
        Property -> (Property -> Property) -> Property
forall a b. a -> (a -> b) -> b
& String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample (String
"Failed decoding: \n  " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
err String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"\n" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
encodedString)
    Right t
result ->
      Expectation -> Property
forall prop. Testable prop => prop -> Property
property (t
result t -> t -> Expectation
forall a. (HasCallStack, Show a, Eq a) => a -> a -> Expectation
`shouldBe` t
original)
        Property -> (Property -> Property) -> Property
forall a b. a -> (a -> b) -> b
& String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample String
encodedString

-- | Roundtrip JSON testing for core type families.
roundTripJsonEraSpec ::
  forall era.
  ( HasCallStack
  , EraTest era
  ) =>
  Spec
roundTripJsonEraSpec :: forall era. (HasCallStack, EraTest era) => Spec
roundTripJsonEraSpec =
  String -> Spec -> Spec
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe (forall era. Era era => String
eraName @era) (Spec -> Spec) -> Spec -> Spec
forall a b. (a -> b) -> a -> b
$ do
    String -> Spec -> Spec
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"RoundTrip JSON" (Spec -> Spec) -> Spec -> Spec
forall a b. (a -> b) -> a -> b
$ do
      forall t.
(HasCallStack, Typeable t, Show t, Eq t, ToJSON t, FromJSON t,
 Arbitrary t) =>
Spec
roundTripJsonSpec @(PParams era)
      forall t.
(HasCallStack, Typeable t, Show t, Eq t, ToJSON t, FromJSON t,
 Arbitrary t) =>
Spec
roundTripJsonSpec @(TranslationContext era)

goldenJsonPParamsSpec ::
  forall era.
  EraPParams era =>
  SpecWith FilePath
goldenJsonPParamsSpec :: forall era. EraPParams era => SpecWith String
goldenJsonPParamsSpec =
  String
-> (String -> Expectation)
-> SpecWith (Arg (String -> Expectation))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"Golden JSON specs for PParams " ((String -> Expectation) -> SpecWith (Arg (String -> Expectation)))
-> (String -> Expectation)
-> SpecWith (Arg (String -> Expectation))
forall a b. (a -> b) -> a -> b
$ \String
file -> do
    Either String (PParams era)
decoded <- forall a. FromJSON a => String -> IO (Either String a)
eitherDecodeFileStrict @(PParams era) String
file
    IO (PParams era) -> Expectation
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (PParams era) -> Expectation)
-> IO (PParams era) -> Expectation
forall a b. (a -> b) -> a -> b
$ Either String (PParams era) -> IO (PParams era)
forall a b. (HasCallStack, ToExpr a) => Either a b -> IO b
expectRightExpr Either String (PParams era)
decoded

goldenJsonPParamsUpdateSpec ::
  forall era.
  EraTest era =>
  SpecWith FilePath
goldenJsonPParamsUpdateSpec :: forall era. EraTest era => SpecWith String
goldenJsonPParamsUpdateSpec =
  String
-> (String -> Expectation)
-> SpecWith (Arg (String -> Expectation))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"Golden JSON specs for PParamsUpdate" ((String -> Expectation) -> SpecWith (Arg (String -> Expectation)))
-> (String -> Expectation)
-> SpecWith (Arg (String -> Expectation))
forall a b. (a -> b) -> a -> b
$ \String
file -> do
    let ppu :: PParamsUpdate era
ppu = Int -> Int -> Gen (PParamsUpdate era) -> PParamsUpdate era
forall a. Int -> Int -> Gen a -> a
runGen Int
100 Int
100 (forall a. Arbitrary a => Gen a
arbitrary @(PParamsUpdate era))
    let encoded :: Text
encoded = ByteString -> Text
T.decodeUtf8 (ByteString -> Text) -> ByteString -> Text
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
BSL.toStrict (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ PParamsUpdate era -> ByteString
forall a. ToJSON a => a -> ByteString
encodePretty PParamsUpdate era
ppu
    Text
fileContent <- ByteString -> Text
T.decodeUtf8 (ByteString -> Text)
-> (ByteString -> ByteString) -> ByteString -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
BSL.toStrict (ByteString -> Text) -> IO ByteString -> IO Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO ByteString
BSL.readFile String
file
    Text
encoded Text -> Text -> Expectation
forall a. (HasCallStack, Show a, Eq a) => a -> a -> Expectation
`shouldBe` Text
fileContent