{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}

module Cardano.Ledger.Alonzo.Rules.Bbody
  ( AlonzoBBODY,
    AlonzoBbodyPredFail (..),
    AlonzoBbodyEvent (..),
    bbodyTransition,
  )
where

import Cardano.Binary (FromCBOR (..), ToCBOR (..))
import Cardano.Ledger.Alonzo.Scripts (ExUnits (..), pointWiseExUnits)
import qualified Cardano.Ledger.Alonzo.Tx as Alonzo (ValidatedTx, totExUnits)
import Cardano.Ledger.Alonzo.TxSeq (txSeqTxns)
import qualified Cardano.Ledger.Alonzo.TxSeq as Alonzo (TxSeq)
import Cardano.Ledger.Alonzo.TxWitness (TxWitness)
import Cardano.Ledger.BHeaderView (BHeaderView (..), isOverlaySlot)
import Cardano.Ledger.BaseTypes (ShelleyBase, UnitInterval, epochInfoPure)
import Cardano.Ledger.Block (Block (..))
import qualified Cardano.Ledger.Core as Core
import Cardano.Ledger.Era (Era (Crypto), SupportsSegWit (..))
import qualified Cardano.Ledger.Era as Era
import Cardano.Ledger.Keys (DSignable, Hash, coerceKeyRole)
import Cardano.Ledger.Shelley.BlockChain (bBodySize, incrBlocks)
import Cardano.Ledger.Shelley.LedgerState (LedgerState)
import Cardano.Ledger.Shelley.Rules.Bbody
  ( BbodyEnv (..),
    BbodyEvent (..),
    BbodyPredicateFailure (..),
    BbodyState (..),
  )
import Cardano.Ledger.Shelley.Rules.Ledgers (LedgersEnv (..))
import Cardano.Ledger.Shelley.TxBody (EraIndependentTxBody)
import Cardano.Ledger.Slot (epochInfoEpoch, epochInfoFirst)
import Control.Monad.Trans.Reader (asks)
import Control.State.Transition
  ( Embed (..),
    STS (..),
    TRC (..),
    TransitionRule,
    judgmentContext,
    liftSTS,
    trans,
    (?!),
  )
import Data.Coders
import Data.Kind (Type)
import Data.Sequence (Seq)
import qualified Data.Sequence.Strict as StrictSeq
import Data.Typeable
import GHC.Generics (Generic)
import GHC.Records
import NoThunks.Class (NoThunks (..))

-- =======================================
-- A new PredicateFailure type

data AlonzoBbodyPredFail era
  = ShelleyInAlonzoPredFail (BbodyPredicateFailure era)
  | TooManyExUnits
      !ExUnits
      -- ^ Computed Sum of ExUnits for all plutus scripts
      !ExUnits
      -- ^ Maximum allowed by protocal parameters
  deriving ((forall x.
 AlonzoBbodyPredFail era -> Rep (AlonzoBbodyPredFail era) x)
-> (forall x.
    Rep (AlonzoBbodyPredFail era) x -> AlonzoBbodyPredFail era)
-> Generic (AlonzoBbodyPredFail era)
forall x.
Rep (AlonzoBbodyPredFail era) x -> AlonzoBbodyPredFail era
forall x.
AlonzoBbodyPredFail era -> Rep (AlonzoBbodyPredFail era) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall era x.
Rep (AlonzoBbodyPredFail era) x -> AlonzoBbodyPredFail era
forall era x.
AlonzoBbodyPredFail era -> Rep (AlonzoBbodyPredFail era) x
$cto :: forall era x.
Rep (AlonzoBbodyPredFail era) x -> AlonzoBbodyPredFail era
$cfrom :: forall era x.
AlonzoBbodyPredFail era -> Rep (AlonzoBbodyPredFail era) x
Generic)

newtype AlonzoBbodyEvent era
  = ShelleyInAlonzoEvent (BbodyEvent era)

deriving instance
  (Era era, Show (PredicateFailure (Core.EraRule "LEDGERS" era))) =>
  Show (AlonzoBbodyPredFail era)

deriving instance
  (Era era, Eq (PredicateFailure (Core.EraRule "LEDGERS" era))) =>
  Eq (AlonzoBbodyPredFail era)

deriving anyclass instance
  (Era era, NoThunks (PredicateFailure (Core.EraRule "LEDGERS" era))) =>
  NoThunks (AlonzoBbodyPredFail era)

instance
  ( Typeable era,
    ToCBOR (BbodyPredicateFailure era)
  ) =>
  ToCBOR (AlonzoBbodyPredFail era)
  where
  toCBOR :: AlonzoBbodyPredFail era -> Encoding
toCBOR (ShelleyInAlonzoPredFail BbodyPredicateFailure era
x) = Encode 'Open (AlonzoBbodyPredFail era) -> Encoding
forall (w :: Wrapped) t. Encode w t -> Encoding
encode ((BbodyPredicateFailure era -> AlonzoBbodyPredFail era)
-> Word
-> Encode
     'Open (BbodyPredicateFailure era -> AlonzoBbodyPredFail era)
forall t. t -> Word -> Encode 'Open t
Sum BbodyPredicateFailure era -> AlonzoBbodyPredFail era
forall era. BbodyPredicateFailure era -> AlonzoBbodyPredFail era
ShelleyInAlonzoPredFail Word
0 Encode 'Open (BbodyPredicateFailure era -> AlonzoBbodyPredFail era)
-> Encode ('Closed 'Dense) (BbodyPredicateFailure era)
-> Encode 'Open (AlonzoBbodyPredFail era)
forall (w :: Wrapped) a t (r :: Density).
Encode w (a -> t) -> Encode ('Closed r) a -> Encode w t
!> BbodyPredicateFailure era
-> Encode ('Closed 'Dense) (BbodyPredicateFailure era)
forall t. ToCBOR t => t -> Encode ('Closed 'Dense) t
To BbodyPredicateFailure era
x)
  toCBOR (TooManyExUnits ExUnits
x ExUnits
y) = Encode 'Open (AlonzoBbodyPredFail Any) -> Encoding
forall (w :: Wrapped) t. Encode w t -> Encoding
encode ((ExUnits -> ExUnits -> AlonzoBbodyPredFail Any)
-> Word
-> Encode 'Open (ExUnits -> ExUnits -> AlonzoBbodyPredFail Any)
forall t. t -> Word -> Encode 'Open t
Sum ExUnits -> ExUnits -> AlonzoBbodyPredFail Any
forall era. ExUnits -> ExUnits -> AlonzoBbodyPredFail era
TooManyExUnits Word
1 Encode 'Open (ExUnits -> ExUnits -> AlonzoBbodyPredFail Any)
-> Encode ('Closed 'Dense) ExUnits
-> Encode 'Open (ExUnits -> AlonzoBbodyPredFail Any)
forall (w :: Wrapped) a t (r :: Density).
Encode w (a -> t) -> Encode ('Closed r) a -> Encode w t
!> ExUnits -> Encode ('Closed 'Dense) ExUnits
forall t. ToCBOR t => t -> Encode ('Closed 'Dense) t
To ExUnits
x Encode 'Open (ExUnits -> AlonzoBbodyPredFail Any)
-> Encode ('Closed 'Dense) ExUnits
-> Encode 'Open (AlonzoBbodyPredFail Any)
forall (w :: Wrapped) a t (r :: Density).
Encode w (a -> t) -> Encode ('Closed r) a -> Encode w t
!> ExUnits -> Encode ('Closed 'Dense) ExUnits
forall t. ToCBOR t => t -> Encode ('Closed 'Dense) t
To ExUnits
y)

instance
  ( Typeable era,
    FromCBOR (BbodyPredicateFailure era) -- TODO why is there no FromCBOR for (BbodyPredicateFailure era)
  ) =>
  FromCBOR (AlonzoBbodyPredFail era)
  where
  fromCBOR :: Decoder s (AlonzoBbodyPredFail era)
fromCBOR = Decode ('Closed 'Dense) (AlonzoBbodyPredFail era)
-> Decoder s (AlonzoBbodyPredFail era)
forall (w :: Wrapped) t s. Decode w t -> Decoder s t
decode (String
-> (Word -> Decode 'Open (AlonzoBbodyPredFail era))
-> Decode ('Closed 'Dense) (AlonzoBbodyPredFail era)
forall t.
String -> (Word -> Decode 'Open t) -> Decode ('Closed 'Dense) t
Summands String
"AlonzoBbodyPredFail" Word -> Decode 'Open (AlonzoBbodyPredFail era)
forall era.
FromCBOR (BbodyPredicateFailure era) =>
Word -> Decode 'Open (AlonzoBbodyPredFail era)
dec)
    where
      dec :: Word -> Decode 'Open (AlonzoBbodyPredFail era)
dec Word
0 = (BbodyPredicateFailure era -> AlonzoBbodyPredFail era)
-> Decode
     'Open (BbodyPredicateFailure era -> AlonzoBbodyPredFail era)
forall t. t -> Decode 'Open t
SumD BbodyPredicateFailure era -> AlonzoBbodyPredFail era
forall era. BbodyPredicateFailure era -> AlonzoBbodyPredFail era
ShelleyInAlonzoPredFail Decode 'Open (BbodyPredicateFailure era -> AlonzoBbodyPredFail era)
-> Decode ('Closed Any) (BbodyPredicateFailure era)
-> Decode 'Open (AlonzoBbodyPredFail era)
forall (w1 :: Wrapped) a t (w :: Density).
Decode w1 (a -> t) -> Decode ('Closed w) a -> Decode w1 t
<! Decode ('Closed Any) (BbodyPredicateFailure era)
forall t (w :: Wrapped). FromCBOR t => Decode w t
From
      dec Word
1 = (ExUnits -> ExUnits -> AlonzoBbodyPredFail era)
-> Decode 'Open (ExUnits -> ExUnits -> AlonzoBbodyPredFail era)
forall t. t -> Decode 'Open t
SumD ExUnits -> ExUnits -> AlonzoBbodyPredFail era
forall era. ExUnits -> ExUnits -> AlonzoBbodyPredFail era
TooManyExUnits Decode 'Open (ExUnits -> ExUnits -> AlonzoBbodyPredFail era)
-> Decode ('Closed Any) ExUnits
-> Decode 'Open (ExUnits -> AlonzoBbodyPredFail era)
forall (w1 :: Wrapped) a t (w :: Density).
Decode w1 (a -> t) -> Decode ('Closed w) a -> Decode w1 t
<! Decode ('Closed Any) ExUnits
forall t (w :: Wrapped). FromCBOR t => Decode w t
From Decode 'Open (ExUnits -> AlonzoBbodyPredFail era)
-> Decode ('Closed Any) ExUnits
-> Decode 'Open (AlonzoBbodyPredFail era)
forall (w1 :: Wrapped) a t (w :: Density).
Decode w1 (a -> t) -> Decode ('Closed w) a -> Decode w1 t
<! Decode ('Closed Any) ExUnits
forall t (w :: Wrapped). FromCBOR t => Decode w t
From
      dec Word
n = Word -> Decode 'Open (AlonzoBbodyPredFail era)
forall (w :: Wrapped) t. Word -> Decode w t
Invalid Word
n

-- ========================================
-- The STS instance

-- | The uninhabited type that marks the STS Alonzo Era instance.
data AlonzoBBODY era

bbodyTransition ::
  forall (someBBODY :: Type -> Type) era.
  ( -- Conditions that the Abstract someBBODY must meet
    STS (someBBODY era),
    Signal (someBBODY era) ~ Block (BHeaderView (Crypto era)) era,
    PredicateFailure (someBBODY era) ~ AlonzoBbodyPredFail era,
    BaseM (someBBODY era) ~ ShelleyBase,
    State (someBBODY era) ~ BbodyState era,
    Environment (someBBODY era) ~ BbodyEnv era,
    -- Conditions to be an instance of STS
    Embed (Core.EraRule "LEDGERS" era) (someBBODY era),
    Environment (Core.EraRule "LEDGERS" era) ~ LedgersEnv era,
    State (Core.EraRule "LEDGERS" era) ~ LedgerState era,
    Signal (Core.EraRule "LEDGERS" era) ~ Seq (Core.Tx era),
    -- Conditions to define the rule in this Era
    HasField "_d" (Core.PParams era) UnitInterval,
    HasField "_maxBlockExUnits" (Core.PParams era) ExUnits,
    Era era, -- supplies WellFormed HasField, and Crypto constraints
    Era.TxSeq era ~ Alonzo.TxSeq era,
    Core.Tx era ~ Alonzo.ValidatedTx era,
    Core.Witnesses era ~ TxWitness era
  ) =>
  TransitionRule (someBBODY era)
bbodyTransition :: TransitionRule (someBBODY era)
bbodyTransition =
  F (Clause (someBBODY era) 'Transition) (TRC (someBBODY era))
forall sts (rtype :: RuleType).
Rule sts rtype (RuleContext rtype sts)
judgmentContext
    F (Clause (someBBODY era) 'Transition) (TRC (someBBODY era))
-> (TRC (someBBODY era)
    -> F (Clause (someBBODY era) 'Transition) (BbodyState era))
-> F (Clause (someBBODY era) 'Transition) (BbodyState era)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \( TRC
             ( BbodyEnv pp account,
               BbodyState ls b,
               UnserialisedBlock bh txsSeq
               )
           ) -> do
        let txs :: StrictSeq (ValidatedTx era)
txs = TxSeq era -> StrictSeq (ValidatedTx era)
forall era. TxSeq era -> StrictSeq (ValidatedTx era)
txSeqTxns TxSeq era
TxSeq era
txsSeq
            actualBodySize :: Int
actualBodySize = TxSeq era -> Int
forall txSeq. ToCBORGroup txSeq => txSeq -> Int
bBodySize TxSeq era
TxSeq era
txsSeq
            actualBodyHash :: Hash (HASH (Crypto era)) EraIndependentBlockBody
actualBodyHash = TxSeq era -> Hash (HASH (Crypto era)) EraIndependentBlockBody
forall era.
SupportsSegWit era =>
TxSeq era -> Hash (HASH (Crypto era)) EraIndependentBlockBody
hashTxSeq @era TxSeq era
txsSeq

        Int
actualBodySize Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Natural -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (BHeaderView (Crypto era) -> Natural
forall crypto. BHeaderView crypto -> Natural
bhviewBSize BHeaderView (Crypto era)
bh)
          Bool
-> PredicateFailure (someBBODY era)
-> Rule (someBBODY era) 'Transition ()
forall sts (ctx :: RuleType).
Bool -> PredicateFailure sts -> Rule sts ctx ()
?! BbodyPredicateFailure era -> AlonzoBbodyPredFail era
forall era. BbodyPredicateFailure era -> AlonzoBbodyPredFail era
ShelleyInAlonzoPredFail
            ( Int -> Int -> BbodyPredicateFailure era
forall era. Int -> Int -> BbodyPredicateFailure era
WrongBlockBodySizeBBODY Int
actualBodySize (Natural -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Natural -> Int) -> Natural -> Int
forall a b. (a -> b) -> a -> b
$ BHeaderView (Crypto era) -> Natural
forall crypto. BHeaderView crypto -> Natural
bhviewBSize BHeaderView (Crypto era)
bh)
            )

        Hash (HASH (Crypto era)) EraIndependentBlockBody
actualBodyHash Hash (HASH (Crypto era)) EraIndependentBlockBody
-> Hash (HASH (Crypto era)) EraIndependentBlockBody -> Bool
forall a. Eq a => a -> a -> Bool
== BHeaderView (Crypto era)
-> Hash (HASH (Crypto era)) EraIndependentBlockBody
forall crypto.
BHeaderView crypto -> Hash crypto EraIndependentBlockBody
bhviewBHash BHeaderView (Crypto era)
bh
          Bool
-> PredicateFailure (someBBODY era)
-> Rule (someBBODY era) 'Transition ()
forall sts (ctx :: RuleType).
Bool -> PredicateFailure sts -> Rule sts ctx ()
?! BbodyPredicateFailure era -> AlonzoBbodyPredFail era
forall era. BbodyPredicateFailure era -> AlonzoBbodyPredFail era
ShelleyInAlonzoPredFail
            ( Hash (HASH (Crypto era)) EraIndependentBlockBody
-> Hash (HASH (Crypto era)) EraIndependentBlockBody
-> BbodyPredicateFailure era
forall era.
Hash (Crypto era) EraIndependentBlockBody
-> Hash (Crypto era) EraIndependentBlockBody
-> BbodyPredicateFailure era
InvalidBodyHashBBODY @era Hash (HASH (Crypto era)) EraIndependentBlockBody
actualBodyHash (BHeaderView (Crypto era)
-> Hash (HASH (Crypto era)) EraIndependentBlockBody
forall crypto.
BHeaderView crypto -> Hash crypto EraIndependentBlockBody
bhviewBHash BHeaderView (Crypto era)
bh)
            )

        LedgerState era
ls' <-
          forall sub super (rtype :: RuleType).
Embed sub super =>
RuleContext rtype sub -> Rule super rtype (State sub)
forall super (rtype :: RuleType).
Embed (EraRule "LEDGERS" era) super =>
RuleContext rtype (EraRule "LEDGERS" era)
-> Rule super rtype (State (EraRule "LEDGERS" era))
trans @(Core.EraRule "LEDGERS" era) (RuleContext 'Transition (EraRule "LEDGERS" era)
 -> Rule
      (someBBODY era) 'Transition (State (EraRule "LEDGERS" era)))
-> RuleContext 'Transition (EraRule "LEDGERS" era)
-> Rule (someBBODY era) 'Transition (State (EraRule "LEDGERS" era))
forall a b. (a -> b) -> a -> b
$
            (Environment (EraRule "LEDGERS" era),
 State (EraRule "LEDGERS" era), Signal (EraRule "LEDGERS" era))
-> TRC (EraRule "LEDGERS" era)
forall sts. (Environment sts, State sts, Signal sts) -> TRC sts
TRC (SlotNo -> PParams era -> AccountState -> LedgersEnv era
forall era. SlotNo -> PParams era -> AccountState -> LedgersEnv era
LedgersEnv (BHeaderView (Crypto era) -> SlotNo
forall crypto. BHeaderView crypto -> SlotNo
bhviewSlot BHeaderView (Crypto era)
bh) PParams era
pp AccountState
account, LedgerState era
State (EraRule "LEDGERS" era)
ls, StrictSeq (ValidatedTx era) -> Seq (ValidatedTx era)
forall a. StrictSeq a -> Seq a
StrictSeq.fromStrict StrictSeq (ValidatedTx era)
txs)

        -- Note that this may not actually be a stake pool - it could be a
        -- genesis key delegate. However, this would only entail an overhead of
        -- 7 counts, and it's easier than differentiating here.
        --
        -- TODO move this computation inside 'incrBlocks' where it belongs. Here
        -- we make an assumption that 'incrBlocks' must enforce, better for it
        -- to be done in 'incrBlocks' where we can see that the assumption is
        -- enforced.
        let hkAsStakePool :: KeyHash 'StakePool (Crypto era)
hkAsStakePool = KeyHash 'BlockIssuer (Crypto era)
-> KeyHash 'StakePool (Crypto era)
forall (a :: KeyRole -> * -> *) (r :: KeyRole) crypto
       (r' :: KeyRole).
HasKeyRole a =>
a r crypto -> a r' crypto
coerceKeyRole (KeyHash 'BlockIssuer (Crypto era)
 -> KeyHash 'StakePool (Crypto era))
-> (BHeaderView (Crypto era) -> KeyHash 'BlockIssuer (Crypto era))
-> BHeaderView (Crypto era)
-> KeyHash 'StakePool (Crypto era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BHeaderView (Crypto era) -> KeyHash 'BlockIssuer (Crypto era)
forall crypto. BHeaderView crypto -> KeyHash 'BlockIssuer crypto
bhviewID (BHeaderView (Crypto era) -> KeyHash 'StakePool (Crypto era))
-> BHeaderView (Crypto era) -> KeyHash 'StakePool (Crypto era)
forall a b. (a -> b) -> a -> b
$ BHeaderView (Crypto era)
bh
            slot :: SlotNo
slot = BHeaderView (Crypto era) -> SlotNo
forall crypto. BHeaderView crypto -> SlotNo
bhviewSlot BHeaderView (Crypto era)
bh
        SlotNo
firstSlotNo <- BaseM (someBBODY era) SlotNo
-> Rule (someBBODY era) 'Transition SlotNo
forall sts a (ctx :: RuleType).
STS sts =>
BaseM sts a -> Rule sts ctx a
liftSTS (BaseM (someBBODY era) SlotNo
 -> Rule (someBBODY era) 'Transition SlotNo)
-> BaseM (someBBODY era) SlotNo
-> Rule (someBBODY era) 'Transition SlotNo
forall a b. (a -> b) -> a -> b
$ do
          EpochInfo Identity
ei <- (Globals -> EpochInfo Identity)
-> ReaderT Globals Identity (EpochInfo Identity)
forall (m :: * -> *) r a. Monad m => (r -> a) -> ReaderT r m a
asks Globals -> EpochInfo Identity
epochInfoPure
          EpochNo
e <- HasCallStack => EpochInfo Identity -> SlotNo -> ShelleyBase EpochNo
EpochInfo Identity -> SlotNo -> ShelleyBase EpochNo
epochInfoEpoch EpochInfo Identity
ei SlotNo
slot
          HasCallStack => EpochInfo Identity -> EpochNo -> ShelleyBase SlotNo
EpochInfo Identity -> EpochNo -> ShelleyBase SlotNo
epochInfoFirst EpochInfo Identity
ei EpochNo
e

        {- ∑(tx ∈ txs)(totExunits tx) ≤ maxBlockExUnits pp  -}
        let txTotal, ppMax :: ExUnits
            txTotal :: ExUnits
txTotal = (ValidatedTx era -> ExUnits)
-> StrictSeq (ValidatedTx era) -> ExUnits
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap ValidatedTx era -> ExUnits
forall era.
(HasField "wits" (Tx era) (Witnesses era),
 HasField "txrdmrs" (Witnesses era) (Redeemers era)) =>
Tx era -> ExUnits
Alonzo.totExUnits StrictSeq (ValidatedTx era)
txs
            ppMax :: ExUnits
ppMax = PParams era -> ExUnits
forall k (x :: k) r a. HasField x r a => r -> a
getField @"_maxBlockExUnits" PParams era
pp
        (Natural -> Natural -> Bool) -> ExUnits -> ExUnits -> Bool
pointWiseExUnits Natural -> Natural -> Bool
forall a. Ord a => a -> a -> Bool
(<=) ExUnits
txTotal ExUnits
ppMax Bool
-> PredicateFailure (someBBODY era)
-> Rule (someBBODY era) 'Transition ()
forall sts (ctx :: RuleType).
Bool -> PredicateFailure sts -> Rule sts ctx ()
?! ExUnits -> ExUnits -> AlonzoBbodyPredFail era
forall era. ExUnits -> ExUnits -> AlonzoBbodyPredFail era
TooManyExUnits ExUnits
txTotal ExUnits
ppMax

        BbodyState era
-> F (Clause (someBBODY era) 'Transition) (BbodyState era)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (BbodyState era
 -> F (Clause (someBBODY era) 'Transition) (BbodyState era))
-> BbodyState era
-> F (Clause (someBBODY era) 'Transition) (BbodyState era)
forall a b. (a -> b) -> a -> b
$
          LedgerState era -> BlocksMade (Crypto era) -> BbodyState era
forall era.
LedgerState era -> BlocksMade (Crypto era) -> BbodyState era
BbodyState @era
            LedgerState era
ls'
            ( Bool
-> KeyHash 'StakePool (Crypto era)
-> BlocksMade (Crypto era)
-> BlocksMade (Crypto era)
forall crypto.
Bool
-> KeyHash 'StakePool crypto
-> BlocksMade crypto
-> BlocksMade crypto
incrBlocks
                (SlotNo -> UnitInterval -> SlotNo -> Bool
isOverlaySlot SlotNo
firstSlotNo (PParams era -> UnitInterval
forall k (x :: k) r a. HasField x r a => r -> a
getField @"_d" PParams era
pp) SlotNo
slot)
                KeyHash 'StakePool (Crypto era)
hkAsStakePool
                BlocksMade (Crypto era)
b
            )

instance
  ( DSignable (Crypto era) (Hash (Crypto era) EraIndependentTxBody),
    Embed (Core.EraRule "LEDGERS" era) (AlonzoBBODY era),
    Environment (Core.EraRule "LEDGERS" era) ~ LedgersEnv era,
    State (Core.EraRule "LEDGERS" era) ~ LedgerState era,
    Signal (Core.EraRule "LEDGERS" era) ~ Seq (Alonzo.ValidatedTx era),
    Era era,
    Core.Tx era ~ Alonzo.ValidatedTx era,
    HasField "_d" (Core.PParams era) UnitInterval,
    HasField "_maxBlockExUnits" (Core.PParams era) ExUnits,
    Era.TxSeq era ~ Alonzo.TxSeq era,
    Core.Tx era ~ Alonzo.ValidatedTx era,
    Core.Witnesses era ~ TxWitness era,
    SupportsSegWit era
  ) =>
  STS (AlonzoBBODY era)
  where
  type
    State (AlonzoBBODY era) =
      BbodyState era

  type
    Signal (AlonzoBBODY era) =
      (Block (BHeaderView (Crypto era)) era)

  type Environment (AlonzoBBODY era) = BbodyEnv era

  type BaseM (AlonzoBBODY era) = ShelleyBase

  type PredicateFailure (AlonzoBBODY era) = AlonzoBbodyPredFail era
  type Event (AlonzoBBODY era) = AlonzoBbodyEvent era

  initialRules :: [InitialRule (AlonzoBBODY era)]
initialRules = []
  transitionRules :: [TransitionRule (AlonzoBBODY era)]
transitionRules = [forall era.
(STS (AlonzoBBODY era),
 Signal (AlonzoBBODY era) ~ Block (BHeaderView (Crypto era)) era,
 PredicateFailure (AlonzoBBODY era) ~ AlonzoBbodyPredFail era,
 BaseM (AlonzoBBODY era) ~ ShelleyBase,
 State (AlonzoBBODY era) ~ BbodyState era,
 Environment (AlonzoBBODY era) ~ BbodyEnv era,
 Embed (EraRule "LEDGERS" era) (AlonzoBBODY era),
 Environment (EraRule "LEDGERS" era) ~ LedgersEnv era,
 State (EraRule "LEDGERS" era) ~ LedgerState era,
 Signal (EraRule "LEDGERS" era) ~ Seq (Tx era),
 HasField "_d" (PParams era) UnitInterval,
 HasField "_maxBlockExUnits" (PParams era) ExUnits, Era era,
 TxSeq era ~ TxSeq era, Tx era ~ ValidatedTx era,
 Witnesses era ~ TxWitness era) =>
TransitionRule (AlonzoBBODY era)
forall (someBBODY :: * -> *) era.
(STS (someBBODY era),
 Signal (someBBODY era) ~ Block (BHeaderView (Crypto era)) era,
 PredicateFailure (someBBODY era) ~ AlonzoBbodyPredFail era,
 BaseM (someBBODY era) ~ ShelleyBase,
 State (someBBODY era) ~ BbodyState era,
 Environment (someBBODY era) ~ BbodyEnv era,
 Embed (EraRule "LEDGERS" era) (someBBODY era),
 Environment (EraRule "LEDGERS" era) ~ LedgersEnv era,
 State (EraRule "LEDGERS" era) ~ LedgerState era,
 Signal (EraRule "LEDGERS" era) ~ Seq (Tx era),
 HasField "_d" (PParams era) UnitInterval,
 HasField "_maxBlockExUnits" (PParams era) ExUnits, Era era,
 TxSeq era ~ TxSeq era, Tx era ~ ValidatedTx era,
 Witnesses era ~ TxWitness era) =>
TransitionRule (someBBODY era)
bbodyTransition @AlonzoBBODY]

instance
  ( Era era,
    BaseM ledgers ~ ShelleyBase,
    ledgers ~ Core.EraRule "LEDGERS" era,
    STS ledgers,
    DSignable (Crypto era) (Hash (Crypto era) EraIndependentTxBody),
    Era era
  ) =>
  Embed ledgers (AlonzoBBODY era)
  where
  wrapFailed :: PredicateFailure ledgers -> PredicateFailure (AlonzoBBODY era)
wrapFailed = BbodyPredicateFailure era -> AlonzoBbodyPredFail era
forall era. BbodyPredicateFailure era -> AlonzoBbodyPredFail era
ShelleyInAlonzoPredFail (BbodyPredicateFailure era -> AlonzoBbodyPredFail era)
-> (PredicateFailure ledgers -> BbodyPredicateFailure era)
-> PredicateFailure ledgers
-> AlonzoBbodyPredFail era
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PredicateFailure ledgers -> BbodyPredicateFailure era
forall era.
PredicateFailure (EraRule "LEDGERS" era)
-> BbodyPredicateFailure era
LedgersFailure
  wrapEvent :: Event ledgers -> Event (AlonzoBBODY era)
wrapEvent = BbodyEvent era -> AlonzoBbodyEvent era
forall era. BbodyEvent era -> AlonzoBbodyEvent era
ShelleyInAlonzoEvent (BbodyEvent era -> AlonzoBbodyEvent era)
-> (Event ledgers -> BbodyEvent era)
-> Event ledgers
-> AlonzoBbodyEvent era
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Event ledgers -> BbodyEvent era
forall era. Event (EraRule "LEDGERS" era) -> BbodyEvent era
LedgersEvent