{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -Wno-orphans #-}

module Test.Cardano.Ledger.Core.Binary.Annotator (
  decoderEquivalenceEraSpec,
  decoderEquivalenceCoreEraTypesSpec,
  Mem,
  module Test.Cardano.Ledger.Binary.Annotator,
) where

import Cardano.Ledger.Binary
import Cardano.Ledger.Block
import Cardano.Ledger.Core
import Cardano.Ledger.Keys
import Cardano.Ledger.MemoBytes (MemoBytes)
import Cardano.Ledger.MemoBytes.Internal (mkMemoBytes)
import Cardano.Ledger.Plutus
import Data.Typeable
import Test.Cardano.Ledger.Binary (decoderEquivalenceSpec)
import Test.Cardano.Ledger.Binary.Annotator
import Test.Cardano.Ledger.Common
import Test.Cardano.Ledger.Core.Arbitrary ()

-- | Useful when deriving DecCBOR(Annotator T)
-- deriving via (Mem T) instance DecCBOR (Annotator T)
type Mem t = Annotator (MemoBytes t)

instance
  (Typeable t, DecCBOR (Annotator t)) =>
  DecCBOR (Annotator (MemoBytes t))
  where
  decCBOR :: forall s. Decoder s (Annotator (MemoBytes t))
decCBOR = do
    (Annotator FullByteString -> t
getT, Annotator FullByteString -> ByteString
getBytes) <- Decoder s (Annotator t)
-> Decoder s (Annotator t, Annotator ByteString)
forall s a. Decoder s a -> Decoder s (a, Annotator ByteString)
withSlice Decoder s (Annotator t)
forall s. Decoder s (Annotator t)
forall a s. DecCBOR a => Decoder s a
decCBOR
    Annotator (MemoBytes t) -> Decoder s (Annotator (MemoBytes t))
forall a. a -> Decoder s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((FullByteString -> MemoBytes t) -> Annotator (MemoBytes t)
forall a. (FullByteString -> a) -> Annotator a
Annotator (\FullByteString
fullbytes -> t -> ByteString -> MemoBytes t
forall t. t -> ByteString -> MemoBytes t
mkMemoBytes (FullByteString -> t
getT FullByteString
fullbytes) (FullByteString -> ByteString
getBytes FullByteString
fullbytes)))

instance DecCBOR (Annotator BootstrapWitness) where
  decCBOR :: forall s. Decoder s (Annotator BootstrapWitness)
decCBOR = BootstrapWitness -> Annotator BootstrapWitness
forall a. a -> Annotator a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (BootstrapWitness -> Annotator BootstrapWitness)
-> Decoder s BootstrapWitness
-> Decoder s (Annotator BootstrapWitness)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Decoder s BootstrapWitness
forall s. Decoder s BootstrapWitness
forall a s. DecCBOR a => Decoder s a
decCBOR

instance Typeable kr => DecCBOR (Annotator (WitVKey kr)) where
  decCBOR :: forall s. Decoder s (Annotator (WitVKey kr))
decCBOR = WitVKey kr -> Annotator (WitVKey kr)
forall a. a -> Annotator a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (WitVKey kr -> Annotator (WitVKey kr))
-> Decoder s (WitVKey kr) -> Decoder s (Annotator (WitVKey kr))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Decoder s (WitVKey kr)
forall s. Decoder s (WitVKey kr)
forall a s. DecCBOR a => Decoder s a
decCBOR

instance
  ( EraSegWits era
  , DecCBOR (Annotator h)
  , DecCBOR (Annotator (TxSeq era))
  , Typeable h
  ) =>
  DecCBOR (Annotator (Block h era))
  where
  decCBOR :: forall s. Decoder s (Annotator (Block h era))
decCBOR = Text
-> (Annotator (Block h era) -> Int)
-> Decoder s (Annotator (Block h era))
-> Decoder s (Annotator (Block h era))
forall a s. Text -> (a -> Int) -> Decoder s a -> Decoder s a
decodeRecordNamed Text
"Block" (Int -> Annotator (Block h era) -> Int
forall a b. a -> b -> a
const Int
blockSize) (Decoder s (Annotator (Block h era))
 -> Decoder s (Annotator (Block h era)))
-> Decoder s (Annotator (Block h era))
-> Decoder s (Annotator (Block h era))
forall a b. (a -> b) -> a -> b
$ do
    Annotator h
header <- Decoder s (Annotator h)
forall s. Decoder s (Annotator h)
forall a s. DecCBOR a => Decoder s a
decCBOR
    Annotator (TxSeq era)
txns <- Decoder s (Annotator (TxSeq era))
forall s. Decoder s (Annotator (TxSeq era))
forall a s. DecCBOR a => Decoder s a
decCBOR
    Annotator (Block h era) -> Decoder s (Annotator (Block h era))
forall a. a -> Decoder s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Annotator (Block h era) -> Decoder s (Annotator (Block h era)))
-> Annotator (Block h era) -> Decoder s (Annotator (Block h era))
forall a b. (a -> b) -> a -> b
$ h -> TxSeq era -> Block h era
forall h era. h -> TxSeq era -> Block h era
Block (h -> TxSeq era -> Block h era)
-> Annotator h -> Annotator (TxSeq era -> Block h era)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Annotator h
header Annotator (TxSeq era -> Block h era)
-> Annotator (TxSeq era) -> Annotator (Block h era)
forall a b. Annotator (a -> b) -> Annotator a -> Annotator b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Annotator (TxSeq era)
txns
    where
      blockSize :: Int
blockSize = Int
1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (forall era. EraSegWits era => Word64
numSegComponents @era)

instance DecCBOR (Annotator PlutusBinary) where
  decCBOR :: forall s. Decoder s (Annotator PlutusBinary)
decCBOR = PlutusBinary -> Annotator PlutusBinary
forall a. a -> Annotator a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PlutusBinary -> Annotator PlutusBinary)
-> Decoder s PlutusBinary -> Decoder s (Annotator PlutusBinary)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Decoder s PlutusBinary
forall s. Decoder s PlutusBinary
forall a s. DecCBOR a => Decoder s a
decCBOR

instance Typeable era => DecCBOR (Annotator (PlutusData era)) where
  decCBOR :: forall s. Decoder s (Annotator (PlutusData era))
decCBOR = PlutusData era -> Annotator (PlutusData era)
forall a. a -> Annotator a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PlutusData era -> Annotator (PlutusData era))
-> Decoder s (PlutusData era)
-> Decoder s (Annotator (PlutusData era))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Decoder s (PlutusData era)
forall s. Decoder s (PlutusData era)
forall a s. DecCBOR a => Decoder s a
decCBOR

instance Era era => DecCBOR (Annotator (Data era)) where
  decCBOR :: forall s. Decoder s (Annotator (Data era))
decCBOR = (MemoBytes (PlutusData era) -> Data era)
-> Annotator (MemoBytes (PlutusData era)) -> Annotator (Data era)
forall a b. (a -> b) -> Annotator a -> Annotator b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap MemoBytes (PlutusData era) -> Data era
forall era. MemoBytes (PlutusData era) -> Data era
MkData (Annotator (MemoBytes (PlutusData era)) -> Annotator (Data era))
-> Decoder s (Annotator (MemoBytes (PlutusData era)))
-> Decoder s (Annotator (Data era))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Decoder s (Annotator (MemoBytes (PlutusData era)))
forall s. Decoder s (Annotator (MemoBytes (PlutusData era)))
forall a s. DecCBOR a => Decoder s a
decCBOR

decoderEquivalenceEraSpec ::
  forall era t.
  ( Era era
  , Eq t
  , ToCBOR t
  , DecCBOR (Annotator t)
  , Arbitrary t
  , Show t
  ) =>
  Spec
decoderEquivalenceEraSpec :: forall era t.
(Era era, Eq t, ToCBOR t, DecCBOR (Annotator t), Arbitrary t,
 Show t) =>
Spec
decoderEquivalenceEraSpec = forall t.
(Eq t, ToCBOR t, DecCBOR (Annotator t), Arbitrary t, Show t) =>
Version -> Version -> Spec
decoderEquivalenceSpec @t (forall era. Era era => Version
eraProtVerLow @era) (forall era. Era era => Version
eraProtVerHigh @era)

decoderEquivalenceCoreEraTypesSpec ::
  forall era.
  ( EraTx era
  , Arbitrary (Tx era)
  , Arbitrary (TxBody era)
  , Arbitrary (TxWits era)
  , Arbitrary (TxAuxData era)
  , Arbitrary (Script era)
  , DecCBOR (Annotator (Tx era))
  , DecCBOR (Annotator (TxBody era))
  , DecCBOR (Annotator (TxWits era))
  , DecCBOR (Annotator (TxAuxData era))
  , DecCBOR (Annotator (Script era))
  , HasCallStack
  ) =>
  Spec
decoderEquivalenceCoreEraTypesSpec :: forall era.
(EraTx era, Arbitrary (Tx era), Arbitrary (TxBody era),
 Arbitrary (TxWits era), Arbitrary (TxAuxData era),
 Arbitrary (Script era), DecCBOR (Annotator (Tx era)),
 DecCBOR (Annotator (TxBody era)), DecCBOR (Annotator (TxWits era)),
 DecCBOR (Annotator (TxAuxData era)),
 DecCBOR (Annotator (Script era)), HasCallStack) =>
Spec
decoderEquivalenceCoreEraTypesSpec =
  String -> Spec -> Spec
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"DecCBOR instances equivalence" (Spec -> Spec) -> Spec -> Spec
forall a b. (a -> b) -> a -> b
$ do
    forall era t.
(Era era, Eq t, ToCBOR t, DecCBOR (Annotator t), Arbitrary t,
 Show t) =>
Spec
decoderEquivalenceEraSpec @era @(Data era)
    forall era t.
(Era era, Eq t, ToCBOR t, DecCBOR (Annotator t), Arbitrary t,
 Show t) =>
Spec
decoderEquivalenceEraSpec @era @(Script era)
    forall era t.
(Era era, Eq t, ToCBOR t, DecCBOR (Annotator t), Arbitrary t,
 Show t) =>
Spec
decoderEquivalenceEraSpec @era @(TxAuxData era)
    forall era t.
(Era era, Eq t, ToCBOR t, DecCBOR (Annotator t), Arbitrary t,
 Show t) =>
Spec
decoderEquivalenceEraSpec @era @(TxWits era)
    forall era t.
(Era era, Eq t, ToCBOR t, DecCBOR (Annotator t), Arbitrary t,
 Show t) =>
Spec
decoderEquivalenceEraSpec @era @(TxBody era)
    forall era t.
(Era era, Eq t, ToCBOR t, DecCBOR (Annotator t), Arbitrary t,
 Show t) =>
Spec
decoderEquivalenceEraSpec @era @(Tx era)