{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}

module Test.Cardano.Ledger.Shelley.LaxBlock where

import Cardano.Ledger.Binary (
  Annotator (..),
  DecCBOR (decCBOR),
  Decoder,
  ToCBOR,
  annotatorSlice,
  decodeRecordNamed,
 )
import Cardano.Ledger.Block (Block (..))
import Cardano.Ledger.Core (Era, EraSegWits (TxSeq), EraTx)
import Cardano.Ledger.Shelley.BlockChain (ShelleyTxSeq, txSeqDecoder)
import Data.Typeable (Typeable)

-- | A block in which we do not validate the matched
--   encoding of parts of the segwit.
--   This is only for testing.
newtype LaxBlock h era = LaxBlock (Block h era)
  deriving (LaxBlock h era -> Encoding
(forall t. ToCBOR t => Proxy t -> Size)
-> Proxy [LaxBlock h era] -> Size
(forall t. ToCBOR t => Proxy t -> Size)
-> Proxy (LaxBlock h era) -> Size
forall a.
Typeable a
-> (a -> Encoding)
-> ((forall t. ToCBOR t => Proxy t -> Size) -> Proxy a -> Size)
-> ((forall t. ToCBOR t => Proxy t -> Size) -> Proxy [a] -> Size)
-> ToCBOR a
forall {h} {era}.
(EraTx era, Typeable h) =>
Typeable (LaxBlock h era)
forall h era. (EraTx era, Typeable h) => LaxBlock h era -> Encoding
forall h era.
(EraTx era, Typeable h) =>
(forall t. ToCBOR t => Proxy t -> Size)
-> Proxy [LaxBlock h era] -> Size
forall h era.
(EraTx era, Typeable h) =>
(forall t. ToCBOR t => Proxy t -> Size)
-> Proxy (LaxBlock h era) -> Size
encodedListSizeExpr :: (forall t. ToCBOR t => Proxy t -> Size)
-> Proxy [LaxBlock h era] -> Size
$cencodedListSizeExpr :: forall h era.
(EraTx era, Typeable h) =>
(forall t. ToCBOR t => Proxy t -> Size)
-> Proxy [LaxBlock h era] -> Size
encodedSizeExpr :: (forall t. ToCBOR t => Proxy t -> Size)
-> Proxy (LaxBlock h era) -> Size
$cencodedSizeExpr :: forall h era.
(EraTx era, Typeable h) =>
(forall t. ToCBOR t => Proxy t -> Size)
-> Proxy (LaxBlock h era) -> Size
toCBOR :: LaxBlock h era -> Encoding
$ctoCBOR :: forall h era. (EraTx era, Typeable h) => LaxBlock h era -> Encoding
ToCBOR)

blockDecoder ::
  ( EraTx era
  , TxSeq era ~ ShelleyTxSeq era
  , DecCBOR (Annotator h)
  ) =>
  Bool ->
  forall s.
  Decoder s (Annotator (Block h era))
blockDecoder :: forall era h.
(EraTx era, TxSeq era ~ ShelleyTxSeq era, DecCBOR (Annotator h)) =>
Bool -> forall s. Decoder s (Annotator (Block h era))
blockDecoder Bool
lax = forall s a.
Decoder s (Annotator (ByteString -> a)) -> Decoder s (Annotator a)
annotatorSlice forall a b. (a -> b) -> a -> b
$
  forall a s. Text -> (a -> Int) -> Decoder s a -> Decoder s a
decodeRecordNamed Text
"Block" (forall a b. a -> b -> a
const Int
4) forall a b. (a -> b) -> a -> b
$ do
    Annotator h
header <- forall a s. DecCBOR a => Decoder s a
decCBOR
    Annotator (ShelleyTxSeq era)
txns <- forall era.
EraTx era =>
Bool -> forall s. Decoder s (Annotator (ShelleyTxSeq era))
txSeqDecoder Bool
lax
    forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall h era. h -> TxSeq era -> ByteString -> Block h era
Block' forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Annotator h
header forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Annotator (ShelleyTxSeq era)
txns

deriving stock instance (Era era, Show (TxSeq era), Show h) => Show (LaxBlock h era)

instance
  ( EraTx era
  , Typeable h
  , TxSeq era ~ ShelleyTxSeq era
  , DecCBOR (Annotator h)
  ) =>
  DecCBOR (Annotator (LaxBlock h era))
  where
  decCBOR :: forall s. Decoder s (Annotator (LaxBlock h era))
decCBOR = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall h era. Block h era -> LaxBlock h era
LaxBlock forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall era h.
(EraTx era, TxSeq era ~ ShelleyTxSeq era, DecCBOR (Annotator h)) =>
Bool -> forall s. Decoder s (Annotator (Block h era))
blockDecoder Bool
True