{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeApplications #-}

-- | Defines reusable abstractions for testing RoundTrip properties of CBOR instances
module Test.Cardano.Ledger.Binary.RoundTrip (
  -- * Spec
  roundTripSpec,
  roundTripCborSpec,
  roundTripAnnCborSpec,
  roundTripRangeSpec,

  -- * Expectations

  -- ** Trip
  roundTripExpectation,
  roundTripRangeExpectation,
  roundTripFailureExpectation,
  roundTripRangeFailureExpectation,

  -- ** Enc/DecCBOR
  roundTripCborExpectation,
  roundTripCborRangeExpectation,
  roundTripCborFailureExpectation,
  roundTripCborRangeFailureExpectation,
  roundTripAnnExpectation,
  roundTripAnnRangeExpectation,
  roundTripAnnFailureExpectation,
  roundTripAnnRangeFailureExpectation,

  -- ** Embed
  embedTripSpec,
  embedTripExpectation,
  embedTripAnnExpectation,
  embedTripFailureExpectation,
  embedTripRangeFailureExpectation,
  roundTripTwiddledProperty,
  roundTripAnnTwiddledProperty,

  -- * Tripping failure
  RoundTripFailure (..),

  -- * Tripping definitions
  Trip (..),
  mkTrip,
  cborTrip,

  -- * Tripping functions
  roundTrip,
  roundTripTwiddled,
  roundTripAnn,
  roundTripAnnTwiddled,
  embedTrip,
  embedTripAnn,
  embedTripLabel,
  embedTripLabelExtra,
  decodeAnnExtra,
)
where

import Cardano.Ledger.Binary
import qualified Cardano.Ledger.Binary.Plain as Plain
import qualified Codec.CBOR.FlatTerm as CBOR
import Control.Monad (forM_, guard)
import Data.Bifunctor (bimap)
import qualified Data.ByteString.Lazy as BSL
import Data.Functor
import Data.Proxy
import qualified Data.Text as T
import Data.Typeable
import Test.Cardano.Ledger.Binary.Plain.RoundTrip (
  showFailedTermsWithReSerialization,
  showMaybeDecoderError,
 )
import Test.Cardano.Ledger.Binary.TreeDiff (CBORBytes (..), ansiExprString)
import Test.Cardano.Ledger.Binary.Twiddle (Twiddle (..))
import Test.Hspec
import Test.Hspec.QuickCheck (prop)
import Test.QuickCheck hiding (label)

-- =====================================================================

-- | Tests the roundtrip property using QuickCheck generators for all possible versions
-- starting with `shelleyProtVer`.
roundTripSpec ::
  forall t.
  (Show t, Eq t, Typeable t, Arbitrary t) =>
  Trip t t ->
  Spec
roundTripSpec :: forall t.
(Show t, Eq t, Typeable t, Arbitrary t) =>
Trip t t -> Spec
roundTripSpec Trip t t
trip =
  forall prop.
(HasCallStack, Testable prop) =>
String -> prop -> Spec
prop (forall a. Show a => a -> String
show (forall {k} (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> TypeRep
typeRep forall a b. (a -> b) -> a -> b
$ forall {k} (t :: k). Proxy t
Proxy @t)) forall a b. (a -> b) -> a -> b
$ forall t.
(Show t, Eq t, Typeable t, HasCallStack) =>
Trip t t -> t -> Expectation
roundTripExpectation Trip t t
trip

-- | Tests the roundtrip property using QuickCheck generators for all possible versions
-- starting with `shelleyProtVer`.
roundTripCborSpec ::
  forall t.
  (Show t, Eq t, Arbitrary t, EncCBOR t, DecCBOR t) =>
  Spec
roundTripCborSpec :: forall t. (Show t, Eq t, Arbitrary t, EncCBOR t, DecCBOR t) => Spec
roundTripCborSpec = forall t.
(Show t, Eq t, Typeable t, Arbitrary t) =>
Trip t t -> Spec
roundTripSpec (forall a b. (EncCBOR a, DecCBOR b) => Trip a b
cborTrip @t)

-- | Tests the roundtrip property using QuickCheck generators for all possible versions
-- starting with `shelleyProtVer`.
roundTripAnnCborSpec ::
  forall t.
  (Show t, Eq t, Arbitrary t, ToCBOR t, DecCBOR (Annotator t)) =>
  Spec
roundTripAnnCborSpec :: forall t.
(Show t, Eq t, Arbitrary t, ToCBOR t, DecCBOR (Annotator t)) =>
Spec
roundTripAnnCborSpec = forall prop.
(HasCallStack, Testable prop) =>
String -> prop -> Spec
prop (forall a. Show a => a -> String
show (forall {k} (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> TypeRep
typeRep forall a b. (a -> b) -> a -> b
$ forall {k} (t :: k). Proxy t
Proxy @t)) (forall t.
(Show t, Eq t, ToCBOR t, DecCBOR (Annotator t), HasCallStack) =>
t -> Expectation
roundTripAnnExpectation @t)

-- | Tests the roundtrip property using QuickCheck generators for specific range of versions
roundTripRangeSpec ::
  forall t.
  (Show t, Eq t, Typeable t, Arbitrary t) =>
  Trip t t ->
  Version ->
  Version ->
  Spec
roundTripRangeSpec :: forall t.
(Show t, Eq t, Typeable t, Arbitrary t) =>
Trip t t -> Version -> Version -> Spec
roundTripRangeSpec Trip t t
trip Version
fromVersion Version
toVersion =
  forall prop.
(HasCallStack, Testable prop) =>
String -> prop -> Spec
prop (forall a. Show a => a -> String
show (forall {k} (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> TypeRep
typeRep forall a b. (a -> b) -> a -> b
$ forall {k} (t :: k). Proxy t
Proxy @t)) forall a b. (a -> b) -> a -> b
$ forall t.
(Show t, Eq t, Typeable t, HasCallStack) =>
Trip t t -> Version -> Version -> t -> Expectation
roundTripRangeExpectation Trip t t
trip Version
fromVersion Version
toVersion

-- | Tests the embedtrip property using QuickCheck generators
embedTripSpec ::
  forall a b.
  (Show a, Typeable a, Typeable b, Arbitrary a, Eq b, HasCallStack) =>
  -- | Version for the encoder
  Version ->
  -- | Version for the decoder
  Version ->
  Trip a b ->
  (b -> a -> Expectation) ->
  Spec
embedTripSpec :: forall a b.
(Show a, Typeable a, Typeable b, Arbitrary a, Eq b,
 HasCallStack) =>
Version -> Version -> Trip a b -> (b -> a -> Expectation) -> Spec
embedTripSpec Version
encVersion Version
decVersion Trip a b
trip b -> a -> Expectation
f =
  forall prop.
(HasCallStack, Testable prop) =>
String -> prop -> Spec
prop (String
"From: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (forall {k} (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> TypeRep
typeRep forall a b. (a -> b) -> a -> b
$ forall {k} (t :: k). Proxy t
Proxy @a) forall a. [a] -> [a] -> [a]
++ String
" To " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (forall {k} (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> TypeRep
typeRep forall a b. (a -> b) -> a -> b
$ forall {k} (t :: k). Proxy t
Proxy @b)) forall a b. (a -> b) -> a -> b
$
    forall a b.
(Typeable b, Eq b, HasCallStack) =>
Version
-> Version
-> Trip a b
-> (b -> a -> Expectation)
-> a
-> Expectation
embedTripExpectation Version
encVersion Version
decVersion Trip a b
trip b -> a -> Expectation
f

-- | Verify that round triping through the binary form holds for all versions starting
-- with `shelleyProtVer`.
roundTripExpectation ::
  (Show t, Eq t, Typeable t, HasCallStack) =>
  Trip t t ->
  t ->
  Expectation
roundTripExpectation :: forall t.
(Show t, Eq t, Typeable t, HasCallStack) =>
Trip t t -> t -> Expectation
roundTripExpectation Trip t t
trip = forall t.
(Show t, Eq t, Typeable t, HasCallStack) =>
Trip t t -> Version -> Version -> t -> Expectation
roundTripRangeExpectation Trip t t
trip forall a. Bounded a => a
minBound forall a. Bounded a => a
maxBound

roundTripCborFailureExpectation ::
  forall t.
  (EncCBOR t, DecCBOR t, Eq t, HasCallStack) =>
  t ->
  Expectation
roundTripCborFailureExpectation :: forall t.
(EncCBOR t, DecCBOR t, Eq t, HasCallStack) =>
t -> Expectation
roundTripCborFailureExpectation = forall t.
(Typeable t, Eq t, HasCallStack) =>
Trip t t -> t -> Expectation
roundTripFailureExpectation (forall a b. (EncCBOR a, DecCBOR b) => Trip a b
cborTrip @t @t)

roundTripCborRangeFailureExpectation ::
  forall t.
  (EncCBOR t, DecCBOR t, Eq t, HasCallStack) =>
  -- | From Version
  Version ->
  -- | To Version
  Version ->
  t ->
  Expectation
roundTripCborRangeFailureExpectation :: forall t.
(EncCBOR t, DecCBOR t, Eq t, HasCallStack) =>
Version -> Version -> t -> Expectation
roundTripCborRangeFailureExpectation = forall t.
(Typeable t, Eq t, HasCallStack) =>
Trip t t -> Version -> Version -> t -> Expectation
roundTripRangeFailureExpectation (forall a b. (EncCBOR a, DecCBOR b) => Trip a b
cborTrip @t)

roundTripFailureExpectation ::
  (Typeable t, Eq t, HasCallStack) =>
  Trip t t ->
  t ->
  Expectation
roundTripFailureExpectation :: forall t.
(Typeable t, Eq t, HasCallStack) =>
Trip t t -> t -> Expectation
roundTripFailureExpectation Trip t t
trip = forall t.
(Typeable t, Eq t, HasCallStack) =>
Trip t t -> Version -> Version -> t -> Expectation
roundTripRangeFailureExpectation Trip t t
trip forall a. Bounded a => a
minBound forall a. Bounded a => a
maxBound

roundTripRangeFailureExpectation ::
  forall t.
  (Typeable t, Eq t, HasCallStack) =>
  Trip t t ->
  -- | From Version
  Version ->
  -- | To Version
  Version ->
  t ->
  Expectation
roundTripRangeFailureExpectation :: forall t.
(Typeable t, Eq t, HasCallStack) =>
Trip t t -> Version -> Version -> t -> Expectation
roundTripRangeFailureExpectation = forall a b.
(Typeable b, Eq b, HasCallStack) =>
Trip a b -> Version -> Version -> a -> Expectation
embedTripRangeFailureExpectation

embedTripFailureExpectation ::
  (Typeable b, Eq b, HasCallStack) =>
  Trip a b ->
  a ->
  Expectation
embedTripFailureExpectation :: forall b a.
(Typeable b, Eq b, HasCallStack) =>
Trip a b -> a -> Expectation
embedTripFailureExpectation Trip a b
trip = forall a b.
(Typeable b, Eq b, HasCallStack) =>
Trip a b -> Version -> Version -> a -> Expectation
embedTripRangeFailureExpectation Trip a b
trip forall a. Bounded a => a
minBound forall a. Bounded a => a
maxBound

embedTripRangeFailureExpectation ::
  forall a b.
  (Typeable b, Eq b, HasCallStack) =>
  Trip a b ->
  -- | From Version
  Version ->
  -- | To Version
  Version ->
  a ->
  Expectation
embedTripRangeFailureExpectation :: forall a b.
(Typeable b, Eq b, HasCallStack) =>
Trip a b -> Version -> Version -> a -> Expectation
embedTripRangeFailureExpectation Trip a b
trip Version
fromVersion Version
toVersion a
t =
  forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Version
fromVersion .. Version
toVersion] forall a b. (a -> b) -> a -> b
$ \Version
version ->
    case forall a b.
Eq b =>
Text
-> Version
-> Version
-> Trip a b
-> a
-> Either RoundTripFailure (b, Encoding, ByteString)
embedTripLabelExtra (forall t. Typeable t => Text
typeLabel @b) Version
version Version
version Trip a b
trip a
t of
      Left RoundTripFailure
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
      Right (b
_, Encoding
_, ByteString
bs) ->
        HasCallStack => String -> Expectation
expectationFailure forall a b. (a -> b) -> a -> b
$
          forall a. Monoid a => [a] -> a
mconcat
            [ String
"Should not have deserialized: <version: "
            , forall a. Show a => a -> String
show Version
version
            , String
"> "
            , forall a. ToExpr a => a -> String
ansiExprString (ByteString -> CBORBytes
CBORBytes (ByteString -> ByteString
BSL.toStrict ByteString
bs))
            ]

-- | Verify that round triping through the binary form holds for a range of versions.
--
-- In other words check that:
--
-- > deserialize version . serialize version === id
-- > serialize version . deserialize version . serialize version === serialize version
roundTripRangeExpectation ::
  forall t.
  (Show t, Eq t, Typeable t, HasCallStack) =>
  Trip t t ->
  -- | From Version
  Version ->
  -- | To Version
  Version ->
  t ->
  Expectation
roundTripRangeExpectation :: forall t.
(Show t, Eq t, Typeable t, HasCallStack) =>
Trip t t -> Version -> Version -> t -> Expectation
roundTripRangeExpectation Trip t t
trip Version
fromVersion Version
toVersion t
t =
  forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Version
fromVersion .. Version
toVersion] forall a b. (a -> b) -> a -> b
$ \Version
version ->
    case forall t.
(Eq t, Typeable t) =>
Version -> Trip t t -> t -> Either RoundTripFailure t
roundTrip Version
version Trip t t
trip t
t of
      Left RoundTripFailure
err -> HasCallStack => String -> Expectation
expectationFailure forall a b. (a -> b) -> a -> b
$ String
"Failed to deserialize encoded:\n" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show RoundTripFailure
err
      Right t
tDecoded -> t
tDecoded forall a. (HasCallStack, Show a, Eq a) => a -> a -> Expectation
`shouldBe` t
t

roundTripCborExpectation ::
  forall t.
  (Show t, Eq t, EncCBOR t, DecCBOR t, HasCallStack) =>
  t ->
  Expectation
roundTripCborExpectation :: forall t.
(Show t, Eq t, EncCBOR t, DecCBOR t, HasCallStack) =>
t -> Expectation
roundTripCborExpectation = forall t.
(Show t, Eq t, Typeable t, HasCallStack) =>
Trip t t -> t -> Expectation
roundTripExpectation (forall a b. (EncCBOR a, DecCBOR b) => Trip a b
cborTrip @t @t)

roundTripCborRangeExpectation ::
  forall t.
  (Show t, Eq t, EncCBOR t, DecCBOR t, HasCallStack) =>
  -- | From Version
  Version ->
  -- | To Version
  Version ->
  t ->
  Expectation
roundTripCborRangeExpectation :: forall t.
(Show t, Eq t, EncCBOR t, DecCBOR t, HasCallStack) =>
Version -> Version -> t -> Expectation
roundTripCborRangeExpectation = forall t.
(Show t, Eq t, Typeable t, HasCallStack) =>
Trip t t -> Version -> Version -> t -> Expectation
roundTripRangeExpectation (forall a b. (EncCBOR a, DecCBOR b) => Trip a b
cborTrip @t)

roundTripAnnExpectation ::
  (Show t, Eq t, ToCBOR t, DecCBOR (Annotator t), HasCallStack) =>
  t ->
  Expectation
roundTripAnnExpectation :: forall t.
(Show t, Eq t, ToCBOR t, DecCBOR (Annotator t), HasCallStack) =>
t -> Expectation
roundTripAnnExpectation = forall t.
(Show t, Eq t, ToCBOR t, DecCBOR (Annotator t), HasCallStack) =>
Version -> Version -> t -> Expectation
roundTripAnnRangeExpectation (forall (v :: Natural).
(KnownNat v, MinVersion <= v, v <= MaxVersion) =>
Version
natVersion @2) forall a. Bounded a => a
maxBound

roundTripAnnRangeExpectation ::
  (Show t, Eq t, ToCBOR t, DecCBOR (Annotator t), HasCallStack) =>
  Version ->
  Version ->
  t ->
  Expectation
roundTripAnnRangeExpectation :: forall t.
(Show t, Eq t, ToCBOR t, DecCBOR (Annotator t), HasCallStack) =>
Version -> Version -> t -> Expectation
roundTripAnnRangeExpectation Version
fromVersion Version
toVersion t
t =
  forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Version
fromVersion .. Version
toVersion] forall a b. (a -> b) -> a -> b
$ \Version
version ->
    case forall t.
(ToCBOR t, DecCBOR (Annotator t)) =>
Version -> t -> Either RoundTripFailure t
roundTripAnn Version
version t
t of
      Left RoundTripFailure
err -> HasCallStack => String -> Expectation
expectationFailure forall a b. (a -> b) -> a -> b
$ String
"Failed to deserialize encoded:\n" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show RoundTripFailure
err
      Right t
tDecoded -> t
tDecoded forall a. (HasCallStack, Show a, Eq a) => a -> a -> Expectation
`shouldBe` t
t

roundTripAnnFailureExpectation ::
  (ToCBOR t, DecCBOR (Annotator t), HasCallStack) =>
  t ->
  Expectation
roundTripAnnFailureExpectation :: forall t.
(ToCBOR t, DecCBOR (Annotator t), HasCallStack) =>
t -> Expectation
roundTripAnnFailureExpectation = forall t.
(ToCBOR t, DecCBOR (Annotator t), HasCallStack) =>
Version -> Version -> t -> Expectation
roundTripAnnRangeFailureExpectation (forall (v :: Natural).
(KnownNat v, MinVersion <= v, v <= MaxVersion) =>
Version
natVersion @2) forall a. Bounded a => a
maxBound

roundTripAnnRangeFailureExpectation ::
  (ToCBOR t, DecCBOR (Annotator t), HasCallStack) =>
  Version ->
  Version ->
  t ->
  Expectation
roundTripAnnRangeFailureExpectation :: forall t.
(ToCBOR t, DecCBOR (Annotator t), HasCallStack) =>
Version -> Version -> t -> Expectation
roundTripAnnRangeFailureExpectation Version
fromVersion Version
toVersion t
t =
  forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Version
fromVersion .. Version
toVersion] forall a b. (a -> b) -> a -> b
$ \Version
version ->
    case forall t.
(ToCBOR t, DecCBOR (Annotator t)) =>
Version -> t -> Either RoundTripFailure t
roundTripAnn Version
version t
t of
      Left RoundTripFailure
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
      Right t
_ ->
        HasCallStack => String -> Expectation
expectationFailure forall a b. (a -> b) -> a -> b
$
          forall a. Monoid a => [a] -> a
mconcat
            [ String
"Should not have deserialized: <version: "
            , forall a. Show a => a -> String
show Version
version
            , String
"> "
            , forall a. ToExpr a => a -> String
ansiExprString (ByteString -> CBORBytes
CBORBytes (forall a. ToCBOR a => a -> ByteString
Plain.serialize' t
t))
            ]

roundTripTwiddledProperty ::
  (Show t, Eq t, Twiddle t, DecCBOR t) => Version -> t -> Property
roundTripTwiddledProperty :: forall t.
(Show t, Eq t, Twiddle t, DecCBOR t) =>
Version -> t -> Property
roundTripTwiddledProperty Version
version t
t = forall prop. Testable prop => prop -> Property
property forall a b. (a -> b) -> a -> b
$ do
  forall t.
(Twiddle t, DecCBOR t, Eq t) =>
Version -> t -> Gen (Either RoundTripFailure t)
roundTripTwiddled Version
version t
t forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Left RoundTripFailure
err ->
      forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall prop. Testable prop => String -> prop -> Property
counterexample (String
"Failed to deserialize twiddled encoding:\n" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show RoundTripFailure
err) Bool
False
    Right t
tDecoded ->
      forall (f :: * -> *) a. Applicative f => a -> f a
pure (t
tDecoded forall a. (Eq a, Show a) => a -> a -> Property
=== t
t)

roundTripAnnTwiddledProperty ::
  forall t q.
  (Twiddle t, DecCBOR (Annotator t), Testable q) =>
  (t -> t -> q) ->
  Version ->
  t ->
  Property
roundTripAnnTwiddledProperty :: forall t q.
(Twiddle t, DecCBOR (Annotator t), Testable q) =>
(t -> t -> q) -> Version -> t -> Property
roundTripAnnTwiddledProperty t -> t -> q
eqProp Version
version t
t = forall prop. Testable prop => prop -> Property
property forall a b. (a -> b) -> a -> b
$ do
  forall t.
(Twiddle t, DecCBOR (Annotator t)) =>
Version -> t -> Gen (Either RoundTripFailure t)
roundTripAnnTwiddled Version
version t
t forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Left RoundTripFailure
err ->
      forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall prop. Testable prop => String -> prop -> Property
counterexample (String
"Failed to deserialize twiddled encoding:\n" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show RoundTripFailure
err) Bool
False
    Right t
tDecoded ->
      forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall prop. Testable prop => prop -> Property
property (t
tDecoded t -> t -> q
`eqProp` t
t)

embedTripExpectation ::
  forall a b.
  (Typeable b, Eq b, HasCallStack) =>
  -- | Version for the encoder
  Version ->
  -- | Version for the decoder
  Version ->
  Trip a b ->
  (b -> a -> Expectation) ->
  a ->
  Expectation
embedTripExpectation :: forall a b.
(Typeable b, Eq b, HasCallStack) =>
Version
-> Version
-> Trip a b
-> (b -> a -> Expectation)
-> a
-> Expectation
embedTripExpectation Version
encVersion Version
decVersion Trip a b
trip b -> a -> Expectation
f a
t =
  case forall a b.
(Eq b, Typeable b) =>
Version -> Version -> Trip a b -> a -> Either RoundTripFailure b
embedTrip Version
encVersion Version
decVersion Trip a b
trip a
t of
    Left RoundTripFailure
err -> HasCallStack => String -> Expectation
expectationFailure forall a b. (a -> b) -> a -> b
$ String
"Failed to deserialize encoded:\n" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show RoundTripFailure
err
    Right b
tDecoded -> b -> a -> Expectation
f b
tDecoded a
t

-- | This is just like `roundTripAnnExpectation`, except it allows for source and target
-- types to be different. This is very useful to test translation of the same type family
-- from one era to another.
embedTripAnnExpectation ::
  forall a b.
  (ToCBOR a, DecCBOR (Annotator b), HasCallStack) =>
  -- | Version for the encoder
  Version ->
  -- | Version for the decoder
  Version ->
  (b -> a -> Expectation) ->
  a ->
  Expectation
embedTripAnnExpectation :: forall a b.
(ToCBOR a, DecCBOR (Annotator b), HasCallStack) =>
Version -> Version -> (b -> a -> Expectation) -> a -> Expectation
embedTripAnnExpectation Version
encVersion Version
decVersion b -> a -> Expectation
f a
a =
  case forall a b.
(ToCBOR a, DecCBOR (Annotator b)) =>
Version -> Version -> a -> Either RoundTripFailure b
embedTripAnn Version
encVersion Version
decVersion a
a of
    Left RoundTripFailure
err -> HasCallStack => String -> Expectation
expectationFailure forall a b. (a -> b) -> a -> b
$ String
"Failed to deserialize encoded:\n" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show RoundTripFailure
err
    Right b
b -> b
b b -> a -> Expectation
`f` a
a

-- =====================================================================

data RoundTripFailure = RoundTripFailure
  { RoundTripFailure -> Version
rtfEncoderVersion :: Version
  -- ^ Version that was used during encoding
  , RoundTripFailure -> Version
rtfDecoderVersion :: Version
  -- ^ Version that was used during decoding
  , RoundTripFailure -> Encoding
rtfEncoding :: Plain.Encoding
  -- ^ Produced plain encoding
  , RoundTripFailure -> ByteString
rtfEncodedBytes :: BSL.ByteString
  -- ^ Serialized encoding using the version in this failure
  , RoundTripFailure -> Maybe ByteString
rtfReEncodedBytes :: Maybe BSL.ByteString
  -- ^ Re-serialized bytes, if there was a mismatch between the binary form and the
  -- reserialization of the data type.
  , RoundTripFailure -> Maybe String
rtfConformanceError :: Maybe String
  -- ^ Roundtripping through FlatTerm
  , RoundTripFailure -> Maybe DecoderError
rtfDropperError :: Maybe DecoderError
  -- ^ Error received while decoding the produced bytes and dropping the value. Normally
  -- it will be `Nothing`, unless the error produced did not match the
  -- `rtfDecoderError`, in which case it will be `Just` the error.
  , RoundTripFailure -> Maybe DecoderError
rtfDecoderError :: Maybe DecoderError
  -- ^ Error received while decoding the produced bytes. It is possible for a dropper to
  -- produce an error, while decoder going through successfully, which constitues a test
  -- failure. In such a case this field will be `Nothing`, however `rtfDropperError`
  -- will be set to `Just`. Whenever both `rtfDropperError` and `rtfDecoderError` are
  -- `Nothing` it means that the decoding went though just fine, but there was a
  -- mismatch in the binary format, i.e. reserialization produced a mismatched result,
  -- in which case `rtfReEncodedBytes` will be set to `Just`
  }

instance Show RoundTripFailure where
  show :: RoundTripFailure -> String
show RoundTripFailure {Maybe String
Maybe ByteString
Maybe DecoderError
ByteString
Encoding
Version
rtfDecoderError :: Maybe DecoderError
rtfDropperError :: Maybe DecoderError
rtfConformanceError :: Maybe String
rtfReEncodedBytes :: Maybe ByteString
rtfEncodedBytes :: ByteString
rtfEncoding :: Encoding
rtfDecoderVersion :: Version
rtfEncoderVersion :: Version
rtfDecoderError :: RoundTripFailure -> Maybe DecoderError
rtfDropperError :: RoundTripFailure -> Maybe DecoderError
rtfConformanceError :: RoundTripFailure -> Maybe String
rtfReEncodedBytes :: RoundTripFailure -> Maybe ByteString
rtfEncodedBytes :: RoundTripFailure -> ByteString
rtfEncoding :: RoundTripFailure -> Encoding
rtfDecoderVersion :: RoundTripFailure -> Version
rtfEncoderVersion :: RoundTripFailure -> Version
..} =
    [String] -> String
unlines forall a b. (a -> b) -> a -> b
$
      [ String
"Encoder Version: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Version
rtfEncoderVersion
      , String
"Decoder Version: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Version
rtfDecoderVersion
      , forall b. Buildable b => String -> Maybe b -> String
showMaybeDecoderError String
"Decoder" Maybe DecoderError
rtfDecoderError
      , forall b. Buildable b => String -> Maybe b -> String
showMaybeDecoderError String
"Dropper" Maybe DecoderError
rtfDropperError
      , forall b. Buildable b => String -> Maybe b -> String
showMaybeDecoderError String
"Conformance" Maybe String
rtfConformanceError
      ]
        forall a. [a] -> [a] -> [a]
++ [ String
"Original did not match the reserialization (see below)."
           | Just ByteString
_ <- forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe ByteString
rtfReEncodedBytes
           ]
        forall a. [a] -> [a] -> [a]
++ ByteString -> Maybe ByteString -> [String]
showFailedTermsWithReSerialization ByteString
rtfEncodedBytes Maybe ByteString
rtfReEncodedBytes

-- | A definition of a CBOR trip through binary representation of one type to
-- another. In this module this is called an embed. When a source and target type is the
-- exact same one then it would be a dual and is expected to round trip.
data Trip a b = Trip
  { forall a b. Trip a b -> a -> Encoding
tripEncoder :: a -> Encoding
  , forall a b. Trip a b -> forall s. Decoder s b
tripDecoder :: forall s. Decoder s b
  , forall a b. Trip a b -> forall s. Decoder s ()
tripDropper :: forall s. Decoder s ()
  }

cborTrip :: forall a b. (EncCBOR a, DecCBOR b) => Trip a b
cborTrip :: forall a b. (EncCBOR a, DecCBOR b) => Trip a b
cborTrip = forall a b.
(a -> Encoding)
-> (forall s. Decoder s b) -> (forall s. Decoder s ()) -> Trip a b
Trip forall a. EncCBOR a => a -> Encoding
encCBOR forall a s. DecCBOR a => Decoder s a
decCBOR (forall a s. DecCBOR a => Proxy a -> Decoder s ()
dropCBOR (forall {k} (t :: k). Proxy t
Proxy @b))

-- | Construct a `Trip` using encoder and decoder, with dropper set to the decoder which
-- drops the value
mkTrip :: forall a b. (a -> Encoding) -> (forall s. Decoder s b) -> Trip a b
mkTrip :: forall a b. (a -> Encoding) -> (forall s. Decoder s b) -> Trip a b
mkTrip a -> Encoding
encoder forall s. Decoder s b
decoder = forall a b.
(a -> Encoding)
-> (forall s. Decoder s b) -> (forall s. Decoder s ()) -> Trip a b
Trip a -> Encoding
encoder forall s. Decoder s b
decoder (() forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ forall s. Decoder s b
decoder)

-- | Check that serialization followed by deserialization of the value produces the same
-- value back. We also check that re-serialization is idempotent. In other words, we
-- ensure that deserialization does not modify the decoded value in a way that its binary
-- representation has changed. Dropper is checked as well.
roundTrip ::
  forall t.
  (Eq t, Typeable t) =>
  Version ->
  Trip t t ->
  t ->
  Either RoundTripFailure t
roundTrip :: forall t.
(Eq t, Typeable t) =>
Version -> Trip t t -> t -> Either RoundTripFailure t
roundTrip Version
version Trip t t
trip t
val = do
  (t
val', Encoding
encoding, ByteString
encodedBytes) <- forall a b.
Eq b =>
Text
-> Version
-> Version
-> Trip a b
-> a
-> Either RoundTripFailure (b, Encoding, ByteString)
embedTripLabelExtra (forall t. Typeable t => Text
typeLabel @t) Version
version Version
version Trip t t
trip t
val
  let reserialized :: ByteString
reserialized = forall a. EncCBOR a => Version -> a -> ByteString
serialize Version
version (forall a b. Trip a b -> a -> Encoding
tripEncoder Trip t t
trip t
val')
  if ByteString
reserialized forall a. Eq a => a -> a -> Bool
/= ByteString
encodedBytes
    then
      forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$
        Version
-> Version
-> Encoding
-> ByteString
-> Maybe ByteString
-> Maybe String
-> Maybe DecoderError
-> Maybe DecoderError
-> RoundTripFailure
RoundTripFailure Version
version Version
version Encoding
encoding ByteString
encodedBytes (forall a. a -> Maybe a
Just ByteString
reserialized) forall a. Maybe a
Nothing forall a. Maybe a
Nothing forall a. Maybe a
Nothing
    else forall a b. b -> Either a b
Right t
val'

roundTripTwiddled ::
  forall t.
  (Twiddle t, DecCBOR t, Eq t) =>
  Version ->
  t ->
  Gen (Either RoundTripFailure t)
roundTripTwiddled :: forall t.
(Twiddle t, DecCBOR t, Eq t) =>
Version -> t -> Gen (Either RoundTripFailure t)
roundTripTwiddled Version
version t
x = do
  Term
tw <- forall a. Twiddle a => Version -> a -> Gen Term
twiddle Version
version t
x
  forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall t.
(Eq t, Typeable t) =>
Version -> Trip t t -> t -> Either RoundTripFailure t
roundTrip Version
version (forall a b.
(a -> Encoding)
-> (forall s. Decoder s b) -> (forall s. Decoder s ()) -> Trip a b
Trip (forall a b. a -> b -> a
const (Term -> Encoding
encodeTerm Term
tw)) forall a s. DecCBOR a => Decoder s a
decCBOR (forall a s. DecCBOR a => Proxy a -> Decoder s ()
dropCBOR (forall {k} (t :: k). Proxy t
Proxy @t))) t
x)

roundTripAnn :: (ToCBOR t, DecCBOR (Annotator t)) => Version -> t -> Either RoundTripFailure t
roundTripAnn :: forall t.
(ToCBOR t, DecCBOR (Annotator t)) =>
Version -> t -> Either RoundTripFailure t
roundTripAnn Version
v = forall a b.
(ToCBOR a, DecCBOR (Annotator b)) =>
Version -> Version -> a -> Either RoundTripFailure b
embedTripAnn Version
v Version
v

roundTripAnnTwiddled ::
  (Twiddle t, DecCBOR (Annotator t)) => Version -> t -> Gen (Either RoundTripFailure t)
roundTripAnnTwiddled :: forall t.
(Twiddle t, DecCBOR (Annotator t)) =>
Version -> t -> Gen (Either RoundTripFailure t)
roundTripAnnTwiddled Version
version t
x = do
  Term
tw <- forall a. Twiddle a => Version -> a -> Gen Term
twiddle Version
version t
x
  forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall t.
DecCBOR (Annotator t) =>
Version -> Version -> Encoding -> Either RoundTripFailure t
decodeAnn Version
version Version
version (Version -> Encoding -> Encoding
toPlainEncoding Version
version (Term -> Encoding
encodeTerm Term
tw)))

decodeAnn ::
  forall t.
  DecCBOR (Annotator t) =>
  -- | Version for the encoder
  Version ->
  -- | Version for the decoder
  Version ->
  Plain.Encoding ->
  Either RoundTripFailure t
decodeAnn :: forall t.
DecCBOR (Annotator t) =>
Version -> Version -> Encoding -> Either RoundTripFailure t
decodeAnn Version
encVersion Version
decVersion Encoding
encoding =
  forall a b. (a, b) -> a
fst forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall t.
Text
-> Version
-> Version
-> (forall s. Decoder s (Annotator t))
-> Encoding
-> Either RoundTripFailure (t, ByteString)
decodeAnnExtra (forall a. DecCBOR a => Proxy a -> Text
label (forall {k} (t :: k). Proxy t
Proxy @(Annotator t))) Version
encVersion Version
decVersion forall a s. DecCBOR a => Decoder s a
decCBOR Encoding
encoding

decodeAnnExtra ::
  forall t.
  T.Text ->
  -- | Version for the encoder
  Version ->
  -- | Version for the decoder
  Version ->
  (forall s. Decoder s (Annotator t)) ->
  Plain.Encoding ->
  Either RoundTripFailure (t, BSL.ByteString)
decodeAnnExtra :: forall t.
Text
-> Version
-> Version
-> (forall s. Decoder s (Annotator t))
-> Encoding
-> Either RoundTripFailure (t, ByteString)
decodeAnnExtra Text
lbl Version
encVersion Version
decVersion forall s. Decoder s (Annotator t)
decoder Encoding
encoding
  | FlatTerm -> Bool
CBOR.validFlatTerm FlatTerm
flatTerm =
      forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap (Maybe ByteString
-> Maybe String
-> Maybe DecoderError
-> Maybe DecoderError
-> RoundTripFailure
mkRoundTripFailure forall a. Maybe a
Nothing forall a. Maybe a
Nothing forall a. Maybe a
Nothing forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> Maybe a
Just) (,ByteString
encodedBytes) forall a b. (a -> b) -> a -> b
$
        forall a.
Version
-> Text
-> (forall s. Decoder s (Annotator a))
-> ByteString
-> Either DecoderError a
decodeFullAnnotator Version
decVersion Text
lbl forall s. Decoder s (Annotator t)
decoder ByteString
encodedBytes
  | Bool
otherwise =
      forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ Maybe ByteString
-> Maybe String
-> Maybe DecoderError
-> Maybe DecoderError
-> RoundTripFailure
mkRoundTripFailure (forall a. a -> Maybe a
Just ByteString
"FlatTerm encoding is invalid") forall a. Maybe a
Nothing forall a. Maybe a
Nothing forall a. Maybe a
Nothing
  where
    mkRoundTripFailure :: Maybe ByteString
-> Maybe String
-> Maybe DecoderError
-> Maybe DecoderError
-> RoundTripFailure
mkRoundTripFailure = Version
-> Version
-> Encoding
-> ByteString
-> Maybe ByteString
-> Maybe String
-> Maybe DecoderError
-> Maybe DecoderError
-> RoundTripFailure
RoundTripFailure Version
encVersion Version
decVersion Encoding
encoding ByteString
encodedBytes
    encodedBytes :: ByteString
encodedBytes = forall a. ToCBOR a => a -> ByteString
Plain.serialize Encoding
encoding
    flatTerm :: FlatTerm
flatTerm = Encoding -> FlatTerm
CBOR.toFlatTerm Encoding
encoding

embedTripLabel ::
  forall a b.
  Eq b =>
  T.Text ->
  -- | Version for the encoder
  Version ->
  -- | Version for the decoder
  Version ->
  Trip a b ->
  a ->
  Either RoundTripFailure b
embedTripLabel :: forall a b.
Eq b =>
Text
-> Version -> Version -> Trip a b -> a -> Either RoundTripFailure b
embedTripLabel Text
lbl Version
encVersion Version
decVersion Trip a b
trip a
s =
  forall a b.
Eq b =>
Text
-> Version
-> Version
-> Trip a b
-> a
-> Either RoundTripFailure (b, Encoding, ByteString)
embedTripLabelExtra Text
lbl Version
encVersion Version
decVersion Trip a b
trip a
s forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \case
    (b
res, Encoding
_, ByteString
_) -> b
res

embedTripLabelExtra ::
  forall a b.
  Eq b =>
  T.Text ->
  -- | Version for the encoder
  Version ->
  -- | Version for the decoder
  Version ->
  Trip a b ->
  a ->
  Either RoundTripFailure (b, Plain.Encoding, BSL.ByteString)
embedTripLabelExtra :: forall a b.
Eq b =>
Text
-> Version
-> Version
-> Trip a b
-> a
-> Either RoundTripFailure (b, Encoding, ByteString)
embedTripLabelExtra Text
lbl Version
encVersion Version
decVersion (Trip a -> Encoding
encoder forall s. Decoder s b
decoder forall s. Decoder s ()
dropper) a
s = Either RoundTripFailure (b, Encoding, ByteString)
result
  where
    mkFailure :: Maybe String
-> Maybe DecoderError -> Maybe DecoderError -> RoundTripFailure
mkFailure = Version
-> Version
-> Encoding
-> ByteString
-> Maybe ByteString
-> Maybe String
-> Maybe DecoderError
-> Maybe DecoderError
-> RoundTripFailure
RoundTripFailure Version
encVersion Version
decVersion Encoding
encoding ByteString
encodedBytes forall a. Maybe a
Nothing
    result :: Either RoundTripFailure (b, Encoding, ByteString)
result =
      case forall a.
Version
-> Text
-> (forall s. Decoder s a)
-> ByteString
-> Either DecoderError a
decodeFullDecoder Version
decVersion Text
lbl forall s. Decoder s b
decoder ByteString
encodedBytes of
        Right b
val
          | Maybe DecoderError
Nothing <- Maybe DecoderError
mDropperError ->
              let flatTerm :: FlatTerm
flatTerm = Encoding -> FlatTerm
CBOR.toFlatTerm Encoding
encoding
                  plainDecoder :: Decoder s b
plainDecoder = forall s a.
Maybe ByteString -> Version -> Decoder s a -> Decoder s a
toPlainDecoder (forall a. a -> Maybe a
Just ByteString
encodedBytes) Version
decVersion forall s. Decoder s b
decoder
               in case forall a. (forall s. Decoder s a) -> FlatTerm -> Either String a
CBOR.fromFlatTerm forall {s}. Decoder s b
plainDecoder FlatTerm
flatTerm of
                    Left String
_err ->
                      -- Until we switch to a release of cborg that includes a fix for this issue:
                      -- https://github.com/well-typed/cborg/issues/324
                      -- We can't rely on FlatTerm decoding
                      -- Left $ mkFailure (Just $ "fromFlatTerm error:" <> err) Nothing Nothing
                      forall a b. b -> Either a b
Right (b
val, Encoding
encoding, ByteString
encodedBytes)
                    Right b
valFromFlatTerm
                      | b
val forall a. Eq a => a -> a -> Bool
/= b
valFromFlatTerm ->
                          let errMsg :: String
errMsg =
                                String
"Deserializing through FlatTerm produced a different "
                                  forall a. [a] -> [a] -> [a]
++ String
"value then the regular deserializer did"
                           in forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ Maybe String
-> Maybe DecoderError -> Maybe DecoderError -> RoundTripFailure
mkFailure (forall a. a -> Maybe a
Just String
errMsg) forall a. Maybe a
Nothing forall a. Maybe a
Nothing
                      | Bool -> Bool
not (FlatTerm -> Bool
CBOR.validFlatTerm FlatTerm
flatTerm) ->
                          let errMsg :: String
errMsg =
                                String
"Despite successful deserialization the produced "
                                  forall a. [a] -> [a] -> [a]
++ String
"FlatTerm for the type is not valid"
                           in forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ Maybe String
-> Maybe DecoderError -> Maybe DecoderError -> RoundTripFailure
mkFailure (forall a. a -> Maybe a
Just String
errMsg) forall a. Maybe a
Nothing forall a. Maybe a
Nothing
                      | Bool
otherwise -> forall a b. b -> Either a b
Right (b
val, Encoding
encoding, ByteString
encodedBytes)
          --  else Left $ mkFailure Nothing Nothing
          | Just DecoderError
err <- Maybe DecoderError
mDropperError -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ Maybe String
-> Maybe DecoderError -> Maybe DecoderError -> RoundTripFailure
mkFailure forall a. Maybe a
Nothing (forall a. a -> Maybe a
Just DecoderError
err) forall a. Maybe a
Nothing
        Left DecoderError
err ->
          -- In case of failure we only record dropper error if it differs from the
          -- decoder failure:
          let mErr :: Maybe DecoderError
mErr = do
                DecoderError
dropperError <- Maybe DecoderError
mDropperError
                DecoderError
dropperError forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ forall (f :: * -> *). Alternative f => Bool -> f ()
guard (DecoderError
dropperError forall a. Eq a => a -> a -> Bool
/= DecoderError
err)
           in forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ Maybe String
-> Maybe DecoderError -> Maybe DecoderError -> RoundTripFailure
mkFailure forall a. Maybe a
Nothing Maybe DecoderError
mErr (forall a. a -> Maybe a
Just DecoderError
err)
    encoding :: Encoding
encoding = Version -> Encoding -> Encoding
toPlainEncoding Version
encVersion (a -> Encoding
encoder a
s)
    encodedBytes :: ByteString
encodedBytes = forall a. ToCBOR a => a -> ByteString
Plain.serialize Encoding
encoding
    mDropperError :: Maybe DecoderError
mDropperError =
      case forall a.
Version
-> Text
-> (forall s. Decoder s a)
-> ByteString
-> Either DecoderError a
decodeFullDecoder Version
decVersion Text
lbl forall s. Decoder s ()
dropper ByteString
encodedBytes of
        Left DecoderError
err -> forall a. a -> Maybe a
Just DecoderError
err
        Right () -> forall a. Maybe a
Nothing

-- | Can we serialise a type, and then deserialise it as something else?
embedTrip ::
  forall a b.
  (Eq b, Typeable b) =>
  -- | Version for the encoder
  Version ->
  -- | Version for the decoder
  Version ->
  Trip a b ->
  a ->
  Either RoundTripFailure b
embedTrip :: forall a b.
(Eq b, Typeable b) =>
Version -> Version -> Trip a b -> a -> Either RoundTripFailure b
embedTrip = forall a b.
Eq b =>
Text
-> Version -> Version -> Trip a b -> a -> Either RoundTripFailure b
embedTripLabel (String -> Text
T.pack (forall a. Show a => a -> String
show (forall {k} (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> TypeRep
typeRep forall a b. (a -> b) -> a -> b
$ forall {k} (t :: k). Proxy t
Proxy @b)))

embedTripAnn ::
  forall a b.
  (ToCBOR a, DecCBOR (Annotator b)) =>
  -- | Encoder version for test failure reporting
  Version ->
  -- | Decoder version
  Version ->
  a ->
  Either RoundTripFailure b
embedTripAnn :: forall a b.
(ToCBOR a, DecCBOR (Annotator b)) =>
Version -> Version -> a -> Either RoundTripFailure b
embedTripAnn Version
encVersion Version
decVersion = forall t.
DecCBOR (Annotator t) =>
Version -> Version -> Encoding -> Either RoundTripFailure t
decodeAnn Version
encVersion Version
decVersion forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. ToCBOR a => a -> Encoding
toCBOR

typeLabel :: forall t. Typeable t => T.Text
typeLabel :: forall t. Typeable t => Text
typeLabel = String -> Text
T.pack (forall a. Show a => a -> String
show (forall {k} (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> TypeRep
typeRep forall a b. (a -> b) -> a -> b
$ forall {k} (t :: k). Proxy t
Proxy @t))