{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -Wno-orphans #-}

module Cardano.Ledger.Conway.BlockBody where

import Cardano.Ledger.Alonzo.BlockBody
import Cardano.Ledger.BaseTypes (ProtVer (..))
import Cardano.Ledger.Binary (
  Annotator,
  DecCBOR (decCBOR),
  EncCBOR (..),
  EncCBORGroup (..),
  decodeRecordNamed,
  encodeListLen,
  serialize',
  toPlainEncoding,
 )
import qualified Cardano.Ledger.Binary.Plain as Plain
import Cardano.Ledger.Block (Block (..), PraosEraBlockHeader)
import Cardano.Ledger.Conway.Era
import Cardano.Ledger.Conway.Tx ()
import Cardano.Ledger.Core
import Cardano.Ledger.Plutus.ExUnits (ExUnits)
import Control.DeepSeq (NFData)
import qualified Data.ByteString as BS
import Data.Typeable (Typeable)
import Data.Word (Word32)
import GHC.Generics (Generic)

data ConwayBlockBodyLimits era = ConwayBlockBodyLimits
  { forall era. ConwayBlockBodyLimits era -> Word32
cbblTxsSize :: !Word32
  , forall era. ConwayBlockBodyLimits era -> ExUnits
cbblExUnits :: !ExUnits
  , forall era. ConwayBlockBodyLimits era -> Int
cbblRefScriptsSize :: !Int
  }
  deriving stock (ConwayBlockBodyLimits era -> ConwayBlockBodyLimits era -> Bool
(ConwayBlockBodyLimits era -> ConwayBlockBodyLimits era -> Bool)
-> (ConwayBlockBodyLimits era -> ConwayBlockBodyLimits era -> Bool)
-> Eq (ConwayBlockBodyLimits era)
forall era.
ConwayBlockBodyLimits era -> ConwayBlockBodyLimits era -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall era.
ConwayBlockBodyLimits era -> ConwayBlockBodyLimits era -> Bool
== :: ConwayBlockBodyLimits era -> ConwayBlockBodyLimits era -> Bool
$c/= :: forall era.
ConwayBlockBodyLimits era -> ConwayBlockBodyLimits era -> Bool
/= :: ConwayBlockBodyLimits era -> ConwayBlockBodyLimits era -> Bool
Eq, Int -> ConwayBlockBodyLimits era -> ShowS
[ConwayBlockBodyLimits era] -> ShowS
ConwayBlockBodyLimits era -> String
(Int -> ConwayBlockBodyLimits era -> ShowS)
-> (ConwayBlockBodyLimits era -> String)
-> ([ConwayBlockBodyLimits era] -> ShowS)
-> Show (ConwayBlockBodyLimits era)
forall era. Int -> ConwayBlockBodyLimits era -> ShowS
forall era. [ConwayBlockBodyLimits era] -> ShowS
forall era. ConwayBlockBodyLimits era -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall era. Int -> ConwayBlockBodyLimits era -> ShowS
showsPrec :: Int -> ConwayBlockBodyLimits era -> ShowS
$cshow :: forall era. ConwayBlockBodyLimits era -> String
show :: ConwayBlockBodyLimits era -> String
$cshowList :: forall era. [ConwayBlockBodyLimits era] -> ShowS
showList :: [ConwayBlockBodyLimits era] -> ShowS
Show, (forall x.
 ConwayBlockBodyLimits era -> Rep (ConwayBlockBodyLimits era) x)
-> (forall x.
    Rep (ConwayBlockBodyLimits era) x -> ConwayBlockBodyLimits era)
-> Generic (ConwayBlockBodyLimits era)
forall x.
Rep (ConwayBlockBodyLimits era) x -> ConwayBlockBodyLimits era
forall x.
ConwayBlockBodyLimits era -> Rep (ConwayBlockBodyLimits era) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall era x.
Rep (ConwayBlockBodyLimits era) x -> ConwayBlockBodyLimits era
forall era x.
ConwayBlockBodyLimits era -> Rep (ConwayBlockBodyLimits era) x
$cfrom :: forall era x.
ConwayBlockBodyLimits era -> Rep (ConwayBlockBodyLimits era) x
from :: forall x.
ConwayBlockBodyLimits era -> Rep (ConwayBlockBodyLimits era) x
$cto :: forall era x.
Rep (ConwayBlockBodyLimits era) x -> ConwayBlockBodyLimits era
to :: forall x.
Rep (ConwayBlockBodyLimits era) x -> ConwayBlockBodyLimits era
Generic)

instance NFData (ConwayBlockBodyLimits era)

instance Semigroup (ConwayBlockBodyLimits era) where
  ConwayBlockBodyLimits Word32
s1 ExUnits
ex1 Int
rss1 <> :: ConwayBlockBodyLimits era
-> ConwayBlockBodyLimits era -> ConwayBlockBodyLimits era
<> ConwayBlockBodyLimits Word32
s2 ExUnits
ex2 Int
rss2 =
    Word32 -> ExUnits -> Int -> ConwayBlockBodyLimits era
forall era. Word32 -> ExUnits -> Int -> ConwayBlockBodyLimits era
ConwayBlockBodyLimits (Word32
s1 Word32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
+ Word32
s2) (ExUnits
ex1 ExUnits -> ExUnits -> ExUnits
forall a. Semigroup a => a -> a -> a
<> ExUnits
ex2) (Int
rss1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
rss2)

instance Monoid (ConwayBlockBodyLimits era) where
  mempty :: ConwayBlockBodyLimits era
mempty = Word32 -> ExUnits -> Int -> ConwayBlockBodyLimits era
forall era. Word32 -> ExUnits -> Int -> ConwayBlockBodyLimits era
ConwayBlockBodyLimits Word32
0 ExUnits
forall a. Monoid a => a
mempty Int
0

instance EraBlockBody ConwayEra where
  type BlockBody ConwayEra = AlonzoBlockBody ConwayEra
  type BlockBodyLimits ConwayEra = ConwayBlockBodyLimits ConwayEra
  type ProtocolEraBlockHeader h ConwayEra = PraosEraBlockHeader h ConwayEra
  mkBasicBlockBody :: BlockBody ConwayEra
mkBasicBlockBody = BlockBody ConwayEra
forall era.
(SafeToHash (TxWits era), BlockBody era ~ AlonzoBlockBody era,
 AlonzoEraTx era) =>
BlockBody era
mkBasicBlockBodyAlonzo
  txSeqBlockBodyL :: Lens' (BlockBody ConwayEra) (StrictSeq (Tx TopTx ConwayEra))
txSeqBlockBodyL = (StrictSeq (Tx TopTx ConwayEra)
 -> f (StrictSeq (Tx TopTx ConwayEra)))
-> BlockBody ConwayEra -> f (BlockBody ConwayEra)
forall era.
(SafeToHash (TxWits era), BlockBody era ~ AlonzoBlockBody era,
 AlonzoEraTx era) =>
Lens' (BlockBody era) (StrictSeq (Tx TopTx era))
Lens' (BlockBody ConwayEra) (StrictSeq (Tx TopTx ConwayEra))
txSeqBlockBodyAlonzoL
  hashBlockBody :: BlockBody ConwayEra -> Hash HASH EraIndependentBlockBody
hashBlockBody = BlockBody ConwayEra -> Hash HASH EraIndependentBlockBody
AlonzoBlockBody ConwayEra -> Hash HASH EraIndependentBlockBody
forall era.
AlonzoBlockBody era -> Hash HASH EraIndependentBlockBody
alonzoBlockBodyHash
  blockBodySize :: ProtVer -> BlockBody ConwayEra -> Int
blockBodySize (ProtVer Version
v Word32
_) = ByteString -> Int
BS.length (ByteString -> Int)
-> (AlonzoBlockBody ConwayEra -> ByteString)
-> AlonzoBlockBody ConwayEra
-> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Version -> Encoding -> ByteString
forall a. EncCBOR a => Version -> a -> ByteString
serialize' Version
v (Encoding -> ByteString)
-> (AlonzoBlockBody ConwayEra -> Encoding)
-> AlonzoBlockBody ConwayEra
-> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AlonzoBlockBody ConwayEra -> Encoding
forall a. EncCBORGroup a => a -> Encoding
encCBORGroup

instance EncCBOR h => EncCBOR (Block h ConwayEra) where
  encCBOR :: Block h ConwayEra -> Encoding
encCBOR (Block h
h BlockBody ConwayEra
txns) =
    Word -> Encoding
encodeListLen Word
5 Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> h -> Encoding
forall a. EncCBOR a => a -> Encoding
encCBOR h
h Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> AlonzoBlockBody ConwayEra -> Encoding
forall a. EncCBORGroup a => a -> Encoding
encCBORGroup BlockBody ConwayEra
AlonzoBlockBody ConwayEra
txns

instance (EncCBOR h, Typeable h) => Plain.ToCBOR (Block h ConwayEra) where
  toCBOR :: Block h ConwayEra -> Encoding
toCBOR = Version -> Encoding -> Encoding
toPlainEncoding (forall era. Era era => Version
eraProtVerLow @ConwayEra) (Encoding -> Encoding)
-> (Block h ConwayEra -> Encoding) -> Block h ConwayEra -> Encoding
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Block h ConwayEra -> Encoding
forall a. EncCBOR a => a -> Encoding
encCBOR

instance
  (DecCBOR (Annotator h), Typeable h) =>
  DecCBOR (Annotator (Block h ConwayEra))
  where
  decCBOR :: forall s. Decoder s (Annotator (Block h ConwayEra))
decCBOR =
    Text
-> (Annotator (Block h ConwayEra) -> Int)
-> Decoder s (Annotator (Block h ConwayEra))
-> Decoder s (Annotator (Block h ConwayEra))
forall a s. Text -> (a -> Int) -> Decoder s a -> Decoder s a
decodeRecordNamed Text
"Block" (Int -> Annotator (Block h ConwayEra) -> Int
forall a b. a -> b -> a
const Int
5) (Decoder s (Annotator (Block h ConwayEra))
 -> Decoder s (Annotator (Block h ConwayEra)))
-> Decoder s (Annotator (Block h ConwayEra))
-> Decoder s (Annotator (Block h ConwayEra))
forall a b. (a -> b) -> a -> b
$ do
      header <- Decoder s (Annotator h)
forall s. Decoder s (Annotator h)
forall a s. DecCBOR a => Decoder s a
decCBOR
      txns <- decCBOR
      pure $ Block <$> header <*> txns