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

module Test.Cardano.Chain.MempoolPayload.CBOR (
  tests,
)
where

import Cardano.Ledger.Binary (
  ByteSpan,
  DecCBOR (..),
  Decoder,
  EncCBOR,
  byronProtVer,
  decCBOR,
  decodeFull,
  decodeFullDecoder,
  encCBOR,
  serialize,
  slice,
 )
import Cardano.Prelude
import qualified Data.ByteString.Lazy as LBS
import GetDataFileName ((<:<))
import Hedgehog (Property, tripping)
import Test.Cardano.Chain.MempoolPayload.Example (
  exampleMempoolPayload,
  exampleMempoolPayload1,
  exampleMempoolPayload2,
  exampleMempoolPayload3,
 )
import Test.Cardano.Chain.MempoolPayload.Gen (genMempoolPayload)
import Test.Cardano.Crypto.Gen (feedPM)
import Test.Cardano.Ledger.Binary.Vintage.Helpers.GoldenRoundTrip (
  goldenTestCBOR,
  goldenTestCBORExplicit,
  roundTripsCBORShow,
 )
import Test.Cardano.Prelude
import Test.Options (TSGroup, TSProperty, concatTSGroups, eachOfTS)

--------------------------------------------------------------------------------
-- Helpers
--------------------------------------------------------------------------------

-- | Serialises @f ()@ and uses that 'ByteString' as the annotation to splice
-- in.
fillInByteString ::
  forall f.
  (DecCBOR (f ByteSpan), EncCBOR (f ()), Functor f) =>
  f () ->
  f ByteString
fillInByteString :: forall (f :: * -> *).
(DecCBOR (f ByteSpan), EncCBOR (f ()), Functor f) =>
f () -> f ByteString
fillInByteString f ()
a =
  forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall a. HasCallStack => Text -> a
panic forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall a b. (Show a, ConvertText String b) => a -> b
show) forall (cat :: * -> * -> *) a. Category cat => cat a a
identity forall a b. (a -> b) -> a -> b
$ forall a.
Version
-> Text
-> (forall s. Decoder s a)
-> ByteString
-> Either DecoderError a
decodeFullDecoder Version
byronProtVer forall a. Monoid a => a
mempty forall s. Decoder s (f ByteString)
dec ByteString
bytes
  where
    bytes :: LByteString
    bytes :: ByteString
bytes = forall a. EncCBOR a => Version -> a -> ByteString
serialize Version
byronProtVer f ()
a

    dec :: Decoder s (f ByteString)
    dec :: forall s. Decoder s (f ByteString)
dec = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (ByteString -> ByteString
LBS.toStrict forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. ByteString -> ByteSpan -> ByteString
slice ByteString
bytes) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a s. DecCBOR a => Decoder s a
decCBOR

-- | Variant of 'goldenTestCBOR' that does not use the @'EncCBOR' (f ())@
-- instance, but the @'EncCBOR' (f ByteString)@ instance. The latter instance
-- allows reusing the annotation when serialising instead of reserialising
-- from scratch.
filledInGoldenTestCBOR ::
  forall f.
  ( DecCBOR (f ())
  , EncCBOR (f ())
  , DecCBOR (f ByteSpan)
  , EncCBOR (f ByteString)
  , Functor f
  , Eq (f ())
  , Show (f ())
  , HasCallStack
  ) =>
  f () ->
  FilePath ->
  Property
filledInGoldenTestCBOR :: forall (f :: * -> *).
(DecCBOR (f ()), EncCBOR (f ()), DecCBOR (f ByteSpan),
 EncCBOR (f ByteString), Functor f, Eq (f ()), Show (f ()),
 HasCallStack) =>
f () -> String -> Property
filledInGoldenTestCBOR =
  forall a.
(Eq a, Show a, HasCallStack) =>
Text
-> (a -> Encoding)
-> (forall s. Decoder s a)
-> a
-> String
-> Property
goldenTestCBORExplicit
    (forall a. DecCBOR a => Proxy a -> Text
label forall a b. (a -> b) -> a -> b
$ forall {k} (t :: k). Proxy t
Proxy @(f ()))
    (forall a. EncCBOR a => a -> Encoding
encCBOR forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall (f :: * -> *).
(DecCBOR (f ByteSpan), EncCBOR (f ()), Functor f) =>
f () -> f ByteString
fillInByteString)
    forall a s. DecCBOR a => Decoder s a
decCBOR

--------------------------------------------------------------------------------
-- MempoolPayload
--------------------------------------------------------------------------------

goldenMempoolPayload :: Property
goldenMempoolPayload :: Property
goldenMempoolPayload =
  forall a.
(DecCBOR a, EncCBOR a, Eq a, Show a, HasCallStack) =>
a -> String -> Property
goldenTestCBOR
    MempoolPayload
exampleMempoolPayload
    (String -> Property) -> String -> Property
<:< String
"golden/cbor/mempoolpayload/MempoolPayload"

goldenMempoolPayloadFilledIn :: Property
goldenMempoolPayloadFilledIn :: Property
goldenMempoolPayloadFilledIn =
  forall (f :: * -> *).
(DecCBOR (f ()), EncCBOR (f ()), DecCBOR (f ByteSpan),
 EncCBOR (f ByteString), Functor f, Eq (f ()), Show (f ()),
 HasCallStack) =>
f () -> String -> Property
filledInGoldenTestCBOR
    MempoolPayload
exampleMempoolPayload
    (String -> Property) -> String -> Property
<:< String
"golden/cbor/mempoolpayload/MempoolPayload"

goldenMempoolPayload1 :: Property
goldenMempoolPayload1 :: Property
goldenMempoolPayload1 =
  forall a.
(DecCBOR a, EncCBOR a, Eq a, Show a, HasCallStack) =>
a -> String -> Property
goldenTestCBOR
    MempoolPayload
exampleMempoolPayload1
    (String -> Property) -> String -> Property
<:< String
"golden/cbor/mempoolpayload/MempoolPayload1"

goldenMempoolPayload1FilledIn :: Property
goldenMempoolPayload1FilledIn :: Property
goldenMempoolPayload1FilledIn =
  forall (f :: * -> *).
(DecCBOR (f ()), EncCBOR (f ()), DecCBOR (f ByteSpan),
 EncCBOR (f ByteString), Functor f, Eq (f ()), Show (f ()),
 HasCallStack) =>
f () -> String -> Property
filledInGoldenTestCBOR
    MempoolPayload
exampleMempoolPayload1
    (String -> Property) -> String -> Property
<:< String
"golden/cbor/mempoolpayload/MempoolPayload1"

goldenMempoolPayload2 :: Property
goldenMempoolPayload2 :: Property
goldenMempoolPayload2 =
  forall a.
(DecCBOR a, EncCBOR a, Eq a, Show a, HasCallStack) =>
a -> String -> Property
goldenTestCBOR
    MempoolPayload
exampleMempoolPayload2
    (String -> Property) -> String -> Property
<:< String
"golden/cbor/mempoolpayload/MempoolPayload2"

goldenMempoolPayload2FilledIn :: Property
goldenMempoolPayload2FilledIn :: Property
goldenMempoolPayload2FilledIn =
  forall (f :: * -> *).
(DecCBOR (f ()), EncCBOR (f ()), DecCBOR (f ByteSpan),
 EncCBOR (f ByteString), Functor f, Eq (f ()), Show (f ()),
 HasCallStack) =>
f () -> String -> Property
filledInGoldenTestCBOR
    MempoolPayload
exampleMempoolPayload2
    (String -> Property) -> String -> Property
<:< String
"golden/cbor/mempoolpayload/MempoolPayload2"

goldenMempoolPayload3 :: Property
goldenMempoolPayload3 :: Property
goldenMempoolPayload3 =
  forall a.
(DecCBOR a, EncCBOR a, Eq a, Show a, HasCallStack) =>
a -> String -> Property
goldenTestCBOR
    MempoolPayload
exampleMempoolPayload3
    (String -> Property) -> String -> Property
<:< String
"golden/cbor/mempoolpayload/MempoolPayload3"

goldenMempoolPayload3FilledIn :: Property
goldenMempoolPayload3FilledIn :: Property
goldenMempoolPayload3FilledIn =
  forall (f :: * -> *).
(DecCBOR (f ()), EncCBOR (f ()), DecCBOR (f ByteSpan),
 EncCBOR (f ByteString), Functor f, Eq (f ()), Show (f ()),
 HasCallStack) =>
f () -> String -> Property
filledInGoldenTestCBOR
    MempoolPayload
exampleMempoolPayload3
    (String -> Property) -> String -> Property
<:< String
"golden/cbor/mempoolpayload/MempoolPayload3"

ts_roundTripMempoolPayload :: TSProperty
ts_roundTripMempoolPayload :: TSProperty
ts_roundTripMempoolPayload =
  forall a.
(Show a, HasCallStack) =>
TestLimit -> Gen a -> (a -> PropertyT IO ()) -> TSProperty
eachOfTS TestLimit
200 (forall a. (ProtocolMagicId -> Gen a) -> Gen a
feedPM ProtocolMagicId -> Gen MempoolPayload
genMempoolPayload) forall a (m :: * -> *).
(DecCBOR a, EncCBOR a, Eq a, MonadTest m, Show a, HasCallStack) =>
a -> m ()
roundTripsCBORShow

ts_roundTripMempoolPayloadFilledIn :: TSProperty
ts_roundTripMempoolPayloadFilledIn :: TSProperty
ts_roundTripMempoolPayloadFilledIn =
  forall a.
(Show a, HasCallStack) =>
TestLimit -> Gen a -> (a -> PropertyT IO ()) -> TSProperty
eachOfTS TestLimit
200 (forall a. (ProtocolMagicId -> Gen a) -> Gen a
feedPM ProtocolMagicId -> Gen MempoolPayload
genMempoolPayload) forall a b. (a -> b) -> a -> b
$ \MempoolPayload
x ->
    forall (m :: * -> *) (f :: * -> *) b a.
(MonadTest m, Applicative f, Show b, Show (f a), Eq (f a),
 HasCallStack) =>
a -> (a -> b) -> (b -> f a) -> m ()
tripping MempoolPayload
x (forall a. EncCBOR a => Version -> a -> ByteString
serialize Version
byronProtVer forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall (f :: * -> *).
(DecCBOR (f ByteSpan), EncCBOR (f ()), Functor f) =>
f () -> f ByteString
fillInByteString) (forall a.
DecCBOR a =>
Version -> ByteString -> Either DecoderError a
decodeFull Version
byronProtVer)

tests :: TSGroup
tests :: TSGroup
tests = [TSGroup] -> TSGroup
concatTSGroups [forall a b. a -> b -> a
const $$String
[(PropertyName, Property)]
Property
String -> PropertyName
String -> GroupName
GroupName -> [(PropertyName, Property)] -> Group
goldenMempoolPayload3FilledIn :: Property
goldenMempoolPayload3 :: Property
goldenMempoolPayload2FilledIn :: Property
goldenMempoolPayload2 :: Property
goldenMempoolPayload1FilledIn :: Property
goldenMempoolPayload1 :: Property
goldenMempoolPayloadFilledIn :: Property
goldenMempoolPayload :: Property
discoverGolden, $$discoverRoundTripArg]