{-# LANGUAGE DataKinds                  #-}
{-# LANGUAGE DeriveAnyClass             #-}
{-# LANGUAGE DeriveGeneric              #-}
{-# LANGUAGE DerivingStrategies         #-}
{-# LANGUAGE DerivingVia                #-}
{-# LANGUAGE DisambiguateRecordFields   #-}
{-# LANGUAGE FlexibleContexts           #-}
{-# LANGUAGE FlexibleInstances          #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase                 #-}
{-# LANGUAGE NamedFieldPuns             #-}
{-# LANGUAGE OverloadedStrings          #-}
{-# LANGUAGE Rank2Types                 #-}
{-# LANGUAGE ScopedTypeVariables        #-}
{-# LANGUAGE StandaloneDeriving         #-}
{-# LANGUAGE TypeApplications           #-}
{-# LANGUAGE TypeFamilies               #-}
{-# LANGUAGE UndecidableInstances       #-}
{-# OPTIONS_GHC -Wno-orphans #-}

-- | Shelley mempool integration
module Ouroboros.Consensus.Shelley.Ledger.Mempool (
    GenTx (..)
  , SL.ApplyTxError (..)
  , TxId (..)
  , Validated (..)
  , WithTop (..)
  , fixedBlockBodyOverhead
  , mkShelleyTx
  , mkShelleyValidatedTx
  , perTxOverhead
    -- * Exported for tests
  , AlonzoMeasure (..)
  , fromExUnits
  ) where

import           Control.Monad.Except (Except)
import           Control.Monad.Identity (Identity (..))
import           Data.Foldable (toList)
import           Data.Typeable (Typeable)
import           GHC.Generics (Generic)
import           GHC.Natural (Natural)
import           GHC.Records
import           NoThunks.Class (NoThunks (..))

import           Cardano.Binary (Annotator (..), FromCBOR (..),
                     FullByteString (..), ToCBOR (..))
import           Data.DerivingVia (InstantiatedAt (..))
import           Data.Measure (BoundedMeasure, Measure)
import qualified Data.Measure as Measure

import           Ouroboros.Network.Block (unwrapCBORinCBOR, wrapCBORinCBOR)

import           Cardano.Ledger.Alonzo.Scripts (ExUnits, ExUnits',
                     unWrapExUnits)
import           Ouroboros.Consensus.Block
import           Ouroboros.Consensus.Ledger.Abstract
import           Ouroboros.Consensus.Ledger.SupportsMempool
import           Ouroboros.Consensus.Mempool.TxLimits
import           Ouroboros.Consensus.Util (ShowProxy (..))
import           Ouroboros.Consensus.Util.Condense

import           Cardano.Ledger.Alonzo.PParams
import           Cardano.Ledger.Alonzo.Tx (totExUnits)
import           Cardano.Ledger.Babbage.PParams
import qualified Cardano.Ledger.Core as Core (Tx)
import qualified Cardano.Ledger.Era as SL (TxSeq, fromTxSeq)
import qualified Cardano.Ledger.Shelley.API as SL
import qualified Cardano.Ledger.TxIn as SL (txid)

import           Cardano.Ledger.Crypto (Crypto)
import           Ouroboros.Consensus.Shelley.Eras
import           Ouroboros.Consensus.Shelley.Ledger.Block
import           Ouroboros.Consensus.Shelley.Ledger.Ledger
                     (ShelleyLedgerConfig (shelleyLedgerGlobals),
                     Ticked (TickedShelleyLedgerState, tickedShelleyLedgerState),
                     getPParams)

data instance GenTx (ShelleyBlock proto era) = ShelleyTx !(SL.TxId (EraCrypto era)) !(Core.Tx era)
  deriving stock    ((forall x.
 GenTx (ShelleyBlock proto era)
 -> Rep (GenTx (ShelleyBlock proto era)) x)
-> (forall x.
    Rep (GenTx (ShelleyBlock proto era)) x
    -> GenTx (ShelleyBlock proto era))
-> Generic (GenTx (ShelleyBlock proto era))
forall x.
Rep (GenTx (ShelleyBlock proto era)) x
-> GenTx (ShelleyBlock proto era)
forall x.
GenTx (ShelleyBlock proto era)
-> Rep (GenTx (ShelleyBlock proto era)) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall proto era x.
Rep (GenTx (ShelleyBlock proto era)) x
-> GenTx (ShelleyBlock proto era)
forall proto era x.
GenTx (ShelleyBlock proto era)
-> Rep (GenTx (ShelleyBlock proto era)) x
$cto :: forall proto era x.
Rep (GenTx (ShelleyBlock proto era)) x
-> GenTx (ShelleyBlock proto era)
$cfrom :: forall proto era x.
GenTx (ShelleyBlock proto era)
-> Rep (GenTx (ShelleyBlock proto era)) x
Generic)

deriving instance ShelleyBasedEra era => NoThunks (GenTx (ShelleyBlock proto era))

deriving instance ShelleyBasedEra era => Eq (GenTx (ShelleyBlock proto era))

instance (Typeable era, Typeable proto)
  => ShowProxy (GenTx (ShelleyBlock proto era)) where

data instance Validated (GenTx (ShelleyBlock proto era)) =
    ShelleyValidatedTx
      !(SL.TxId (EraCrypto era))
      !(SL.Validated (Core.Tx era))
  deriving stock ((forall x.
 Validated (GenTx (ShelleyBlock proto era))
 -> Rep (Validated (GenTx (ShelleyBlock proto era))) x)
-> (forall x.
    Rep (Validated (GenTx (ShelleyBlock proto era))) x
    -> Validated (GenTx (ShelleyBlock proto era)))
-> Generic (Validated (GenTx (ShelleyBlock proto era)))
forall x.
Rep (Validated (GenTx (ShelleyBlock proto era))) x
-> Validated (GenTx (ShelleyBlock proto era))
forall x.
Validated (GenTx (ShelleyBlock proto era))
-> Rep (Validated (GenTx (ShelleyBlock proto era))) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall proto era x.
Rep (Validated (GenTx (ShelleyBlock proto era))) x
-> Validated (GenTx (ShelleyBlock proto era))
forall proto era x.
Validated (GenTx (ShelleyBlock proto era))
-> Rep (Validated (GenTx (ShelleyBlock proto era))) x
$cto :: forall proto era x.
Rep (Validated (GenTx (ShelleyBlock proto era))) x
-> Validated (GenTx (ShelleyBlock proto era))
$cfrom :: forall proto era x.
Validated (GenTx (ShelleyBlock proto era))
-> Rep (Validated (GenTx (ShelleyBlock proto era))) x
Generic)

deriving instance ShelleyBasedEra era => NoThunks (Validated (GenTx (ShelleyBlock proto era)))

deriving instance ShelleyBasedEra era => Eq (Validated (GenTx (ShelleyBlock proto era)))

deriving instance ShelleyBasedEra era => Show (Validated (GenTx (ShelleyBlock proto era)))

instance (Typeable era, Typeable proto)
  => ShowProxy (Validated (GenTx (ShelleyBlock proto era))) where

type instance ApplyTxErr (ShelleyBlock proto era) = SL.ApplyTxError era

-- orphaned instance
instance Typeable era => ShowProxy (SL.ApplyTxError era) where


-- |'txInBlockSize' is used to estimate how many transactions we can grab from
-- the Mempool to put into the block we are going to forge without exceeding
-- the maximum block body size according to the ledger. If we exceed that
-- limit, we will have forged a block that is invalid according to the ledger.
-- We ourselves won't even adopt it, causing us to lose our slot, something we
-- must try to avoid.
--
-- For this reason it is better to overestimate the size of a transaction than
-- to underestimate. The only downside is that we maybe could have put one (or
-- more?) transactions extra in that block.
--
-- As the sum of the serialised transaction sizes is not equal to the size of
-- the serialised block body ('SL.TxSeq') consisting of those transactions
-- (see cardano-node#1545 for an example), we account for some extra overhead
-- per transaction as a safety margin.
--
-- Also see 'perTxOverhead'.
fixedBlockBodyOverhead :: Num a => a
fixedBlockBodyOverhead :: a
fixedBlockBodyOverhead = a
1024

-- | See 'fixedBlockBodyOverhead'.
perTxOverhead :: Num a => a
perTxOverhead :: a
perTxOverhead = a
4

instance ShelleyCompatible proto era
      => LedgerSupportsMempool (ShelleyBlock proto era) where
  txInvariant :: GenTx (ShelleyBlock proto era) -> Bool
txInvariant = Bool -> GenTx (ShelleyBlock proto era) -> Bool
forall a b. a -> b -> a
const Bool
True

  applyTx :: LedgerConfig (ShelleyBlock proto era)
-> WhetherToIntervene
-> SlotNo
-> GenTx (ShelleyBlock proto era)
-> Ticked (LedgerState (ShelleyBlock proto era))
-> Except
     (ApplyTxErr (ShelleyBlock proto era))
     (Ticked (LedgerState (ShelleyBlock proto era)),
      Validated (GenTx (ShelleyBlock proto era)))
applyTx = LedgerConfig (ShelleyBlock proto era)
-> WhetherToIntervene
-> SlotNo
-> GenTx (ShelleyBlock proto era)
-> Ticked (LedgerState (ShelleyBlock proto era))
-> Except
     (ApplyTxErr (ShelleyBlock proto era))
     (Ticked (LedgerState (ShelleyBlock proto era)),
      Validated (GenTx (ShelleyBlock proto era)))
forall era proto.
ShelleyBasedEra era =>
LedgerConfig (ShelleyBlock proto era)
-> WhetherToIntervene
-> SlotNo
-> GenTx (ShelleyBlock proto era)
-> TickedLedgerState (ShelleyBlock proto era)
-> Except
     (ApplyTxErr (ShelleyBlock proto era))
     (TickedLedgerState (ShelleyBlock proto era),
      Validated (GenTx (ShelleyBlock proto era)))
applyShelleyTx

  reapplyTx :: LedgerConfig (ShelleyBlock proto era)
-> SlotNo
-> Validated (GenTx (ShelleyBlock proto era))
-> Ticked (LedgerState (ShelleyBlock proto era))
-> Except
     (ApplyTxErr (ShelleyBlock proto era))
     (Ticked (LedgerState (ShelleyBlock proto era)))
reapplyTx = LedgerConfig (ShelleyBlock proto era)
-> SlotNo
-> Validated (GenTx (ShelleyBlock proto era))
-> Ticked (LedgerState (ShelleyBlock proto era))
-> Except
     (ApplyTxErr (ShelleyBlock proto era))
     (Ticked (LedgerState (ShelleyBlock proto era)))
forall era proto.
ShelleyBasedEra era =>
LedgerConfig (ShelleyBlock proto era)
-> SlotNo
-> Validated (GenTx (ShelleyBlock proto era))
-> TickedLedgerState (ShelleyBlock proto era)
-> Except
     (ApplyTxErr (ShelleyBlock proto era))
     (TickedLedgerState (ShelleyBlock proto era))
reapplyShelleyTx

  txsMaxBytes :: Ticked (LedgerState (ShelleyBlock proto era)) -> Word32
txsMaxBytes TickedShelleyLedgerState { tickedShelleyLedgerState = shelleyState } =
      Natural -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Natural
maxBlockBodySize Word32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
- Word32
forall a. Num a => a
fixedBlockBodyOverhead
    where
      maxBlockBodySize :: Natural
maxBlockBodySize = forall k (x :: k) r a. HasField x r a => r -> a
forall r a. HasField "_maxBBSize" r a => r -> a
getField @"_maxBBSize" (PParams era -> Natural) -> PParams era -> Natural
forall a b. (a -> b) -> a -> b
$ NewEpochState era -> PParams era
forall era. NewEpochState era -> PParams era
getPParams NewEpochState era
shelleyState

  txInBlockSize :: GenTx (ShelleyBlock proto era) -> Word32
txInBlockSize (ShelleyTx _ tx) = Word32
txSize Word32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
+ Word32
forall a. Num a => a
perTxOverhead
    where
      txSize :: Word32
txSize = Integer -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Integer -> Word32) -> Integer -> Word32
forall a b. (a -> b) -> a -> b
$ Tx era -> Integer
forall k (x :: k) r a. HasField x r a => r -> a
getField @"txsize" Tx era
tx

  txForgetValidated :: Validated (GenTx (ShelleyBlock proto era))
-> GenTx (ShelleyBlock proto era)
txForgetValidated (ShelleyValidatedTx txid vtx) = TxId (EraCrypto era) -> Tx era -> GenTx (ShelleyBlock proto era)
forall proto era.
TxId (EraCrypto era) -> Tx era -> GenTx (ShelleyBlock proto era)
ShelleyTx TxId (EraCrypto era)
txid (Validated (Tx era) -> Tx era
forall tx. Validated tx -> tx
SL.extractTx Validated (Tx era)
vtx)

mkShelleyTx :: forall era proto. ShelleyBasedEra era => Core.Tx era -> GenTx (ShelleyBlock proto era)
mkShelleyTx :: Tx era -> GenTx (ShelleyBlock proto era)
mkShelleyTx Tx era
tx = TxId (EraCrypto era) -> Tx era -> GenTx (ShelleyBlock proto era)
forall proto era.
TxId (EraCrypto era) -> Tx era -> GenTx (ShelleyBlock proto era)
ShelleyTx (TxBody era -> TxId (EraCrypto era)
forall era c.
(HashAlgorithm (HASH c),
 HashAnnotated (TxBody era) EraIndependentTxBody c) =>
TxBody era -> TxId c
SL.txid @era (Tx era -> TxBody era
forall k (x :: k) r a. HasField x r a => r -> a
getField @"body" Tx era
tx)) Tx era
tx

mkShelleyValidatedTx :: forall era proto.
     ShelleyBasedEra era
  => SL.Validated (Core.Tx era)
  -> Validated (GenTx (ShelleyBlock proto era))
mkShelleyValidatedTx :: Validated (Tx era) -> Validated (GenTx (ShelleyBlock proto era))
mkShelleyValidatedTx Validated (Tx era)
vtx = TxId (EraCrypto era)
-> Validated (Tx era) -> Validated (GenTx (ShelleyBlock proto era))
forall proto era.
TxId (EraCrypto era)
-> Validated (Tx era) -> Validated (GenTx (ShelleyBlock proto era))
ShelleyValidatedTx TxId (EraCrypto era)
txid Validated (Tx era)
vtx
  where
    txid :: TxId (EraCrypto era)
txid = TxBody era -> TxId (EraCrypto era)
forall era c.
(HashAlgorithm (HASH c),
 HashAnnotated (TxBody era) EraIndependentTxBody c) =>
TxBody era -> TxId c
SL.txid @era (Tx era -> TxBody era
forall k (x :: k) r a. HasField x r a => r -> a
getField @"body" (Validated (Tx era) -> Tx era
forall tx. Validated tx -> tx
SL.extractTx Validated (Tx era)
vtx))

newtype instance TxId (GenTx (ShelleyBlock proto era)) = ShelleyTxId (SL.TxId (EraCrypto era))
  deriving newtype (TxId (GenTx (ShelleyBlock proto era))
-> TxId (GenTx (ShelleyBlock proto era)) -> Bool
(TxId (GenTx (ShelleyBlock proto era))
 -> TxId (GenTx (ShelleyBlock proto era)) -> Bool)
-> (TxId (GenTx (ShelleyBlock proto era))
    -> TxId (GenTx (ShelleyBlock proto era)) -> Bool)
-> Eq (TxId (GenTx (ShelleyBlock proto era)))
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall proto era.
TxId (GenTx (ShelleyBlock proto era))
-> TxId (GenTx (ShelleyBlock proto era)) -> Bool
/= :: TxId (GenTx (ShelleyBlock proto era))
-> TxId (GenTx (ShelleyBlock proto era)) -> Bool
$c/= :: forall proto era.
TxId (GenTx (ShelleyBlock proto era))
-> TxId (GenTx (ShelleyBlock proto era)) -> Bool
== :: TxId (GenTx (ShelleyBlock proto era))
-> TxId (GenTx (ShelleyBlock proto era)) -> Bool
$c== :: forall proto era.
TxId (GenTx (ShelleyBlock proto era))
-> TxId (GenTx (ShelleyBlock proto era)) -> Bool
Eq, Eq (TxId (GenTx (ShelleyBlock proto era)))
Eq (TxId (GenTx (ShelleyBlock proto era)))
-> (TxId (GenTx (ShelleyBlock proto era))
    -> TxId (GenTx (ShelleyBlock proto era)) -> Ordering)
-> (TxId (GenTx (ShelleyBlock proto era))
    -> TxId (GenTx (ShelleyBlock proto era)) -> Bool)
-> (TxId (GenTx (ShelleyBlock proto era))
    -> TxId (GenTx (ShelleyBlock proto era)) -> Bool)
-> (TxId (GenTx (ShelleyBlock proto era))
    -> TxId (GenTx (ShelleyBlock proto era)) -> Bool)
-> (TxId (GenTx (ShelleyBlock proto era))
    -> TxId (GenTx (ShelleyBlock proto era)) -> Bool)
-> (TxId (GenTx (ShelleyBlock proto era))
    -> TxId (GenTx (ShelleyBlock proto era))
    -> TxId (GenTx (ShelleyBlock proto era)))
-> (TxId (GenTx (ShelleyBlock proto era))
    -> TxId (GenTx (ShelleyBlock proto era))
    -> TxId (GenTx (ShelleyBlock proto era)))
-> Ord (TxId (GenTx (ShelleyBlock proto era)))
TxId (GenTx (ShelleyBlock proto era))
-> TxId (GenTx (ShelleyBlock proto era)) -> Bool
TxId (GenTx (ShelleyBlock proto era))
-> TxId (GenTx (ShelleyBlock proto era)) -> Ordering
TxId (GenTx (ShelleyBlock proto era))
-> TxId (GenTx (ShelleyBlock proto era))
-> TxId (GenTx (ShelleyBlock proto era))
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
forall proto era. Eq (TxId (GenTx (ShelleyBlock proto era)))
forall proto era.
TxId (GenTx (ShelleyBlock proto era))
-> TxId (GenTx (ShelleyBlock proto era)) -> Bool
forall proto era.
TxId (GenTx (ShelleyBlock proto era))
-> TxId (GenTx (ShelleyBlock proto era)) -> Ordering
forall proto era.
TxId (GenTx (ShelleyBlock proto era))
-> TxId (GenTx (ShelleyBlock proto era))
-> TxId (GenTx (ShelleyBlock proto era))
min :: TxId (GenTx (ShelleyBlock proto era))
-> TxId (GenTx (ShelleyBlock proto era))
-> TxId (GenTx (ShelleyBlock proto era))
$cmin :: forall proto era.
TxId (GenTx (ShelleyBlock proto era))
-> TxId (GenTx (ShelleyBlock proto era))
-> TxId (GenTx (ShelleyBlock proto era))
max :: TxId (GenTx (ShelleyBlock proto era))
-> TxId (GenTx (ShelleyBlock proto era))
-> TxId (GenTx (ShelleyBlock proto era))
$cmax :: forall proto era.
TxId (GenTx (ShelleyBlock proto era))
-> TxId (GenTx (ShelleyBlock proto era))
-> TxId (GenTx (ShelleyBlock proto era))
>= :: TxId (GenTx (ShelleyBlock proto era))
-> TxId (GenTx (ShelleyBlock proto era)) -> Bool
$c>= :: forall proto era.
TxId (GenTx (ShelleyBlock proto era))
-> TxId (GenTx (ShelleyBlock proto era)) -> Bool
> :: TxId (GenTx (ShelleyBlock proto era))
-> TxId (GenTx (ShelleyBlock proto era)) -> Bool
$c> :: forall proto era.
TxId (GenTx (ShelleyBlock proto era))
-> TxId (GenTx (ShelleyBlock proto era)) -> Bool
<= :: TxId (GenTx (ShelleyBlock proto era))
-> TxId (GenTx (ShelleyBlock proto era)) -> Bool
$c<= :: forall proto era.
TxId (GenTx (ShelleyBlock proto era))
-> TxId (GenTx (ShelleyBlock proto era)) -> Bool
< :: TxId (GenTx (ShelleyBlock proto era))
-> TxId (GenTx (ShelleyBlock proto era)) -> Bool
$c< :: forall proto era.
TxId (GenTx (ShelleyBlock proto era))
-> TxId (GenTx (ShelleyBlock proto era)) -> Bool
compare :: TxId (GenTx (ShelleyBlock proto era))
-> TxId (GenTx (ShelleyBlock proto era)) -> Ordering
$ccompare :: forall proto era.
TxId (GenTx (ShelleyBlock proto era))
-> TxId (GenTx (ShelleyBlock proto era)) -> Ordering
$cp1Ord :: forall proto era. Eq (TxId (GenTx (ShelleyBlock proto era)))
Ord, Context
-> TxId (GenTx (ShelleyBlock proto era)) -> IO (Maybe ThunkInfo)
Proxy (TxId (GenTx (ShelleyBlock proto era))) -> String
(Context
 -> TxId (GenTx (ShelleyBlock proto era)) -> IO (Maybe ThunkInfo))
-> (Context
    -> TxId (GenTx (ShelleyBlock proto era)) -> IO (Maybe ThunkInfo))
-> (Proxy (TxId (GenTx (ShelleyBlock proto era))) -> String)
-> NoThunks (TxId (GenTx (ShelleyBlock proto era)))
forall a.
(Context -> a -> IO (Maybe ThunkInfo))
-> (Context -> a -> IO (Maybe ThunkInfo))
-> (Proxy a -> String)
-> NoThunks a
forall proto era.
Context
-> TxId (GenTx (ShelleyBlock proto era)) -> IO (Maybe ThunkInfo)
forall proto era.
Proxy (TxId (GenTx (ShelleyBlock proto era))) -> String
showTypeOf :: Proxy (TxId (GenTx (ShelleyBlock proto era))) -> String
$cshowTypeOf :: forall proto era.
Proxy (TxId (GenTx (ShelleyBlock proto era))) -> String
wNoThunks :: Context
-> TxId (GenTx (ShelleyBlock proto era)) -> IO (Maybe ThunkInfo)
$cwNoThunks :: forall proto era.
Context
-> TxId (GenTx (ShelleyBlock proto era)) -> IO (Maybe ThunkInfo)
noThunks :: Context
-> TxId (GenTx (ShelleyBlock proto era)) -> IO (Maybe ThunkInfo)
$cnoThunks :: forall proto era.
Context
-> TxId (GenTx (ShelleyBlock proto era)) -> IO (Maybe ThunkInfo)
NoThunks)

deriving newtype instance (Crypto (EraCrypto era), Typeable era, Typeable proto)
                       => ToCBOR (TxId (GenTx (ShelleyBlock proto era)))
deriving newtype instance (Crypto (EraCrypto era), Typeable era, Typeable proto)
                       => FromCBOR (TxId (GenTx (ShelleyBlock proto era)))

instance (Typeable era, Typeable proto)
  => ShowProxy (TxId (GenTx (ShelleyBlock proto era))) where

instance ShelleyBasedEra era => HasTxId (GenTx (ShelleyBlock proto era)) where
  txId :: GenTx (ShelleyBlock proto era)
-> TxId (GenTx (ShelleyBlock proto era))
txId (ShelleyTx i _) = TxId (EraCrypto era) -> TxId (GenTx (ShelleyBlock proto era))
forall proto era.
TxId (EraCrypto era) -> TxId (GenTx (ShelleyBlock proto era))
ShelleyTxId TxId (EraCrypto era)
i

instance ShelleyBasedEra era => HasTxs (ShelleyBlock proto era) where
  extractTxs :: ShelleyBlock proto era -> [GenTx (ShelleyBlock proto era)]
extractTxs =
        (Tx era -> GenTx (ShelleyBlock proto era))
-> [Tx era] -> [GenTx (ShelleyBlock proto era)]
forall a b. (a -> b) -> [a] -> [b]
map Tx era -> GenTx (ShelleyBlock proto era)
forall era proto.
ShelleyBasedEra era =>
Tx era -> GenTx (ShelleyBlock proto era)
mkShelleyTx
      ([Tx era] -> [GenTx (ShelleyBlock proto era)])
-> (ShelleyBlock proto era -> [Tx era])
-> ShelleyBlock proto era
-> [GenTx (ShelleyBlock proto era)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TxSeq era -> [Tx era]
txSeqToList
      (TxSeq era -> [Tx era])
-> (ShelleyBlock proto era -> TxSeq era)
-> ShelleyBlock proto era
-> [Tx era]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Block (ShelleyProtocolHeader proto) era -> TxSeq era
forall h era. Block h era -> TxSeq era
SL.bbody
      (Block (ShelleyProtocolHeader proto) era -> TxSeq era)
-> (ShelleyBlock proto era
    -> Block (ShelleyProtocolHeader proto) era)
-> ShelleyBlock proto era
-> TxSeq era
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShelleyBlock proto era -> Block (ShelleyProtocolHeader proto) era
forall proto era.
ShelleyBlock proto era -> Block (ShelleyProtocolHeader proto) era
shelleyBlockRaw
    where
      txSeqToList :: SL.TxSeq era -> [Core.Tx era]
      txSeqToList :: TxSeq era -> [Tx era]
txSeqToList = StrictSeq (Tx era) -> [Tx era]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (StrictSeq (Tx era) -> [Tx era])
-> (TxSeq era -> StrictSeq (Tx era)) -> TxSeq era -> [Tx era]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SupportsSegWit era => TxSeq era -> StrictSeq (Tx era)
forall era. SupportsSegWit era => TxSeq era -> StrictSeq (Tx era)
SL.fromTxSeq @era

{-------------------------------------------------------------------------------
  Serialisation
-------------------------------------------------------------------------------}

instance ShelleyCompatible proto era => ToCBOR (GenTx (ShelleyBlock proto era)) where
  -- No need to encode the 'TxId', it's just a hash of the 'SL.TxBody' inside
  -- 'SL.Tx', so it can be recomputed.
  toCBOR :: GenTx (ShelleyBlock proto era) -> Encoding
toCBOR (ShelleyTx _txid tx) = (Tx era -> Encoding) -> Tx era -> Encoding
forall a. (a -> Encoding) -> a -> Encoding
wrapCBORinCBOR Tx era -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR Tx era
tx

instance ShelleyCompatible proto era => FromCBOR (GenTx (ShelleyBlock proto era)) where
  fromCBOR :: Decoder s (GenTx (ShelleyBlock proto era))
fromCBOR = (Tx era -> GenTx (ShelleyBlock proto era))
-> Decoder s (Tx era) -> Decoder s (GenTx (ShelleyBlock proto era))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Tx era -> GenTx (ShelleyBlock proto era)
forall era proto.
ShelleyBasedEra era =>
Tx era -> GenTx (ShelleyBlock proto era)
mkShelleyTx (Decoder s (Tx era) -> Decoder s (GenTx (ShelleyBlock proto era)))
-> Decoder s (Tx era) -> Decoder s (GenTx (ShelleyBlock proto era))
forall a b. (a -> b) -> a -> b
$ (forall s. Decoder s (ByteString -> Tx era))
-> forall s. Decoder s (Tx era)
forall a.
(forall s. Decoder s (ByteString -> a)) -> forall s. Decoder s a
unwrapCBORinCBOR
    ((forall s. Decoder s (ByteString -> Tx era))
 -> forall s. Decoder s (Tx era))
-> (forall s. Decoder s (ByteString -> Tx era))
-> forall s. Decoder s (Tx era)
forall a b. (a -> b) -> a -> b
$ ((FullByteString -> Tx era)
-> (ByteString -> FullByteString) -> ByteString -> Tx era
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> FullByteString
Full) ((FullByteString -> Tx era) -> ByteString -> Tx era)
-> (Annotator (Tx era) -> FullByteString -> Tx era)
-> Annotator (Tx era)
-> ByteString
-> Tx era
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Annotator (Tx era) -> FullByteString -> Tx era
forall a. Annotator a -> FullByteString -> a
runAnnotator (Annotator (Tx era) -> ByteString -> Tx era)
-> Decoder s (Annotator (Tx era))
-> Decoder s (ByteString -> Tx era)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Decoder s (Annotator (Tx era))
forall a s. FromCBOR a => Decoder s a
fromCBOR

{-------------------------------------------------------------------------------
  Pretty-printing
-------------------------------------------------------------------------------}

instance ShelleyBasedEra era => Condense (GenTx (ShelleyBlock proto era)) where
  condense :: GenTx (ShelleyBlock proto era) -> String
condense (ShelleyTx _ tx ) = Tx era -> String
forall a. Show a => a -> String
show Tx era
tx

instance Condense (GenTxId (ShelleyBlock proto era)) where
  condense :: GenTxId (ShelleyBlock proto era) -> String
condense (ShelleyTxId i) = String
"txid: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> TxId (Crypto era) -> String
forall a. Show a => a -> String
show TxId (Crypto era)
i

instance ShelleyBasedEra era => Show (GenTx (ShelleyBlock proto era)) where
  show :: GenTx (ShelleyBlock proto era) -> String
show = GenTx (ShelleyBlock proto era) -> String
forall a. Condense a => a -> String
condense

instance Show (GenTxId (ShelleyBlock proto era)) where
  show :: GenTxId (ShelleyBlock proto era) -> String
show = GenTxId (ShelleyBlock proto era) -> String
forall a. Condense a => a -> String
condense

{-------------------------------------------------------------------------------
  Applying transactions
-------------------------------------------------------------------------------}

applyShelleyTx :: forall era proto.
     ShelleyBasedEra era
  => LedgerConfig (ShelleyBlock proto era)
  -> WhetherToIntervene
  -> SlotNo
  -> GenTx (ShelleyBlock proto era)
  -> TickedLedgerState (ShelleyBlock proto era)
  -> Except (ApplyTxErr (ShelleyBlock proto era))
       ( TickedLedgerState (ShelleyBlock proto era)
       , Validated (GenTx (ShelleyBlock proto era))
       )
applyShelleyTx :: LedgerConfig (ShelleyBlock proto era)
-> WhetherToIntervene
-> SlotNo
-> GenTx (ShelleyBlock proto era)
-> TickedLedgerState (ShelleyBlock proto era)
-> Except
     (ApplyTxErr (ShelleyBlock proto era))
     (TickedLedgerState (ShelleyBlock proto era),
      Validated (GenTx (ShelleyBlock proto era)))
applyShelleyTx LedgerConfig (ShelleyBlock proto era)
cfg WhetherToIntervene
wti SlotNo
slot (ShelleyTx _ tx) TickedLedgerState (ShelleyBlock proto era)
st = do
    (MempoolState era
mempoolState', Validated (Tx era)
vtx) <-
       Globals
-> LedgerEnv era
-> MempoolState era
-> WhetherToIntervene
-> Tx era
-> ExceptT
     (ApplyTxError era) Identity (MempoolState era, Validated (Tx era))
forall era.
ShelleyBasedEra era =>
Globals
-> LedgerEnv era
-> MempoolState era
-> WhetherToIntervene
-> Tx era
-> Except (ApplyTxError era) (MempoolState era, Validated (Tx era))
applyShelleyBasedTx
         (ShelleyLedgerConfig era -> Globals
forall era. ShelleyLedgerConfig era -> Globals
shelleyLedgerGlobals LedgerConfig (ShelleyBlock proto era)
ShelleyLedgerConfig era
cfg)
         (NewEpochState era -> SlotNo -> LedgerEnv era
forall era. NewEpochState era -> SlotNo -> MempoolEnv era
SL.mkMempoolEnv   NewEpochState era
innerSt SlotNo
slot)
         (NewEpochState era -> MempoolState era
forall era. NewEpochState era -> MempoolState era
SL.mkMempoolState NewEpochState era
innerSt)
         WhetherToIntervene
wti
         Tx era
tx

    let st' :: TickedLedgerState (ShelleyBlock proto era)
st' = (forall (f :: * -> *).
 Applicative f =>
 (MempoolState era -> f (MempoolState era))
 -> TickedLedgerState (ShelleyBlock proto era)
 -> f (TickedLedgerState (ShelleyBlock proto era)))
-> MempoolState era
-> TickedLedgerState (ShelleyBlock proto era)
-> TickedLedgerState (ShelleyBlock proto era)
forall a b s t.
(forall (f :: * -> *). Applicative f => (a -> f b) -> s -> f t)
-> b -> s -> t
set forall (f :: * -> *).
Applicative f =>
(MempoolState era -> f (MempoolState era))
-> TickedLedgerState (ShelleyBlock proto era)
-> f (TickedLedgerState (ShelleyBlock proto era))
forall (f :: * -> *) era proto.
Functor f =>
(LedgerState era -> f (LedgerState era))
-> TickedLedgerState (ShelleyBlock proto era)
-> f (TickedLedgerState (ShelleyBlock proto era))
theLedgerLens MempoolState era
mempoolState' TickedLedgerState (ShelleyBlock proto era)
st

    (TickedLedgerState (ShelleyBlock proto era),
 Validated (GenTx (ShelleyBlock proto era)))
-> ExceptT
     (ApplyTxError era)
     Identity
     (TickedLedgerState (ShelleyBlock proto era),
      Validated (GenTx (ShelleyBlock proto era)))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TickedLedgerState (ShelleyBlock proto era)
st', Validated (Tx era) -> Validated (GenTx (ShelleyBlock proto era))
forall era proto.
ShelleyBasedEra era =>
Validated (Tx era) -> Validated (GenTx (ShelleyBlock proto era))
mkShelleyValidatedTx Validated (Tx era)
vtx)
  where
    innerSt :: NewEpochState era
innerSt = TickedLedgerState (ShelleyBlock proto era) -> NewEpochState era
forall proto era.
Ticked (LedgerState (ShelleyBlock proto era)) -> NewEpochState era
tickedShelleyLedgerState TickedLedgerState (ShelleyBlock proto era)
st

reapplyShelleyTx ::
     ShelleyBasedEra era
  => LedgerConfig (ShelleyBlock proto era)
  -> SlotNo
  -> Validated (GenTx (ShelleyBlock proto era))
  -> TickedLedgerState (ShelleyBlock proto era)
  -> Except (ApplyTxErr (ShelleyBlock proto era)) (TickedLedgerState (ShelleyBlock proto era))
reapplyShelleyTx :: LedgerConfig (ShelleyBlock proto era)
-> SlotNo
-> Validated (GenTx (ShelleyBlock proto era))
-> TickedLedgerState (ShelleyBlock proto era)
-> Except
     (ApplyTxErr (ShelleyBlock proto era))
     (TickedLedgerState (ShelleyBlock proto era))
reapplyShelleyTx LedgerConfig (ShelleyBlock proto era)
cfg SlotNo
slot Validated (GenTx (ShelleyBlock proto era))
vgtx TickedLedgerState (ShelleyBlock proto era)
st = do
    MempoolState era
mempoolState' <-
        Globals
-> MempoolEnv era
-> MempoolState era
-> Validated (Tx era)
-> ExceptT (ApplyTxError era) Identity (MempoolState era)
forall era (m :: * -> *).
(ApplyTx era, MonadError (ApplyTxError era) m) =>
Globals
-> MempoolEnv era
-> MempoolState era
-> Validated (Tx era)
-> m (MempoolState era)
SL.reapplyTx
          (ShelleyLedgerConfig era -> Globals
forall era. ShelleyLedgerConfig era -> Globals
shelleyLedgerGlobals LedgerConfig (ShelleyBlock proto era)
ShelleyLedgerConfig era
cfg)
          (NewEpochState era -> SlotNo -> MempoolEnv era
forall era. NewEpochState era -> SlotNo -> MempoolEnv era
SL.mkMempoolEnv   NewEpochState era
innerSt SlotNo
slot)
          (NewEpochState era -> MempoolState era
forall era. NewEpochState era -> MempoolState era
SL.mkMempoolState NewEpochState era
innerSt)
          Validated (Tx era)
vtx

    TickedLedgerState (ShelleyBlock proto era)
-> ExceptT
     (ApplyTxError era)
     Identity
     (TickedLedgerState (ShelleyBlock proto era))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TickedLedgerState (ShelleyBlock proto era)
 -> ExceptT
      (ApplyTxError era)
      Identity
      (TickedLedgerState (ShelleyBlock proto era)))
-> TickedLedgerState (ShelleyBlock proto era)
-> ExceptT
     (ApplyTxError era)
     Identity
     (TickedLedgerState (ShelleyBlock proto era))
forall a b. (a -> b) -> a -> b
$ (forall (f :: * -> *).
 Applicative f =>
 (MempoolState era -> f (MempoolState era))
 -> TickedLedgerState (ShelleyBlock proto era)
 -> f (TickedLedgerState (ShelleyBlock proto era)))
-> MempoolState era
-> TickedLedgerState (ShelleyBlock proto era)
-> TickedLedgerState (ShelleyBlock proto era)
forall a b s t.
(forall (f :: * -> *). Applicative f => (a -> f b) -> s -> f t)
-> b -> s -> t
set forall (f :: * -> *).
Applicative f =>
(MempoolState era -> f (MempoolState era))
-> TickedLedgerState (ShelleyBlock proto era)
-> f (TickedLedgerState (ShelleyBlock proto era))
forall (f :: * -> *) era proto.
Functor f =>
(LedgerState era -> f (LedgerState era))
-> TickedLedgerState (ShelleyBlock proto era)
-> f (TickedLedgerState (ShelleyBlock proto era))
theLedgerLens MempoolState era
mempoolState' TickedLedgerState (ShelleyBlock proto era)
st
  where
    ShelleyValidatedTx _txid vtx = Validated (GenTx (ShelleyBlock proto era))
vgtx

    innerSt :: NewEpochState era
innerSt = TickedLedgerState (ShelleyBlock proto era) -> NewEpochState era
forall proto era.
Ticked (LedgerState (ShelleyBlock proto era)) -> NewEpochState era
tickedShelleyLedgerState TickedLedgerState (ShelleyBlock proto era)
st

-- | The lens combinator
set ::
     (forall f. Applicative f => (a -> f b) -> s -> f t)
  -> b -> s -> t
set :: (forall (f :: * -> *). Applicative f => (a -> f b) -> s -> f t)
-> b -> s -> t
set forall (f :: * -> *). Applicative f => (a -> f b) -> s -> f t
lens b
inner s
outer =
    Identity t -> t
forall a. Identity a -> a
runIdentity (Identity t -> t) -> Identity t -> t
forall a b. (a -> b) -> a -> b
$ (a -> Identity b) -> s -> Identity t
forall (f :: * -> *). Applicative f => (a -> f b) -> s -> f t
lens (\a
_ -> b -> Identity b
forall a. a -> Identity a
Identity b
inner) s
outer

theLedgerLens ::
     Functor f
  => (SL.LedgerState era -> f (SL.LedgerState era))
  -> TickedLedgerState (ShelleyBlock proto era)
  -> f (TickedLedgerState (ShelleyBlock proto era))
theLedgerLens :: (LedgerState era -> f (LedgerState era))
-> TickedLedgerState (ShelleyBlock proto era)
-> f (TickedLedgerState (ShelleyBlock proto era))
theLedgerLens LedgerState era -> f (LedgerState era)
f TickedLedgerState (ShelleyBlock proto era)
x =
        (\NewEpochState era
y -> TickedLedgerState (ShelleyBlock proto era)
R:TickedLedgerState proto era
x{tickedShelleyLedgerState :: NewEpochState era
tickedShelleyLedgerState = NewEpochState era
y})
    (NewEpochState era -> TickedLedgerState (ShelleyBlock proto era))
-> f (NewEpochState era)
-> f (TickedLedgerState (ShelleyBlock proto era))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (LedgerState era -> f (LedgerState era))
-> NewEpochState era -> f (NewEpochState era)
forall (f :: * -> *) era.
Functor f =>
(MempoolState era -> f (MempoolState era))
-> NewEpochState era -> f (NewEpochState era)
SL.overNewEpochState LedgerState era -> f (LedgerState era)
f (TickedLedgerState (ShelleyBlock proto era) -> NewEpochState era
forall proto era.
Ticked (LedgerState (ShelleyBlock proto era)) -> NewEpochState era
tickedShelleyLedgerState TickedLedgerState (ShelleyBlock proto era)
x)

{-------------------------------------------------------------------------------
  Tx Limits
-------------------------------------------------------------------------------}

instance ShelleyCompatible p (ShelleyEra c) => TxLimits (ShelleyBlock p (ShelleyEra c)) where
  type TxMeasure (ShelleyBlock p (ShelleyEra c)) = ByteSize
  txMeasure :: Validated (GenTx (ShelleyBlock p (ShelleyEra c)))
-> TxMeasure (ShelleyBlock p (ShelleyEra c))
txMeasure        = Word32 -> ByteSize
ByteSize (Word32 -> ByteSize)
-> (Validated (GenTx (ShelleyBlock p (ShelleyEra c))) -> Word32)
-> Validated (GenTx (ShelleyBlock p (ShelleyEra c)))
-> ByteSize
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenTx (ShelleyBlock p (ShelleyEra c)) -> Word32
forall blk. LedgerSupportsMempool blk => GenTx blk -> Word32
txInBlockSize (GenTx (ShelleyBlock p (ShelleyEra c)) -> Word32)
-> (Validated (GenTx (ShelleyBlock p (ShelleyEra c)))
    -> GenTx (ShelleyBlock p (ShelleyEra c)))
-> Validated (GenTx (ShelleyBlock p (ShelleyEra c)))
-> Word32
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Validated (GenTx (ShelleyBlock p (ShelleyEra c)))
-> GenTx (ShelleyBlock p (ShelleyEra c))
forall blk.
LedgerSupportsMempool blk =>
Validated (GenTx blk) -> GenTx blk
txForgetValidated
  txsBlockCapacity :: Ticked (LedgerState (ShelleyBlock p (ShelleyEra c)))
-> TxMeasure (ShelleyBlock p (ShelleyEra c))
txsBlockCapacity = Word32 -> ByteSize
ByteSize (Word32 -> ByteSize)
-> (Ticked (LedgerState (ShelleyBlock p (ShelleyEra c))) -> Word32)
-> Ticked (LedgerState (ShelleyBlock p (ShelleyEra c)))
-> ByteSize
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ticked (LedgerState (ShelleyBlock p (ShelleyEra c))) -> Word32
forall blk.
LedgerSupportsMempool blk =>
Ticked (LedgerState blk) -> Word32
txsMaxBytes

instance ShelleyCompatible p (AllegraEra c) => TxLimits (ShelleyBlock p (AllegraEra c)) where
  type TxMeasure (ShelleyBlock p (AllegraEra c)) = ByteSize
  txMeasure :: Validated (GenTx (ShelleyBlock p (AllegraEra c)))
-> TxMeasure (ShelleyBlock p (AllegraEra c))
txMeasure        = Word32 -> ByteSize
ByteSize (Word32 -> ByteSize)
-> (Validated (GenTx (ShelleyBlock p (AllegraEra c))) -> Word32)
-> Validated (GenTx (ShelleyBlock p (AllegraEra c)))
-> ByteSize
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenTx (ShelleyBlock p (AllegraEra c)) -> Word32
forall blk. LedgerSupportsMempool blk => GenTx blk -> Word32
txInBlockSize (GenTx (ShelleyBlock p (AllegraEra c)) -> Word32)
-> (Validated (GenTx (ShelleyBlock p (AllegraEra c)))
    -> GenTx (ShelleyBlock p (AllegraEra c)))
-> Validated (GenTx (ShelleyBlock p (AllegraEra c)))
-> Word32
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Validated (GenTx (ShelleyBlock p (AllegraEra c)))
-> GenTx (ShelleyBlock p (AllegraEra c))
forall blk.
LedgerSupportsMempool blk =>
Validated (GenTx blk) -> GenTx blk
txForgetValidated
  txsBlockCapacity :: Ticked (LedgerState (ShelleyBlock p (AllegraEra c)))
-> TxMeasure (ShelleyBlock p (AllegraEra c))
txsBlockCapacity = Word32 -> ByteSize
ByteSize (Word32 -> ByteSize)
-> (Ticked (LedgerState (ShelleyBlock p (AllegraEra c))) -> Word32)
-> Ticked (LedgerState (ShelleyBlock p (AllegraEra c)))
-> ByteSize
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ticked (LedgerState (ShelleyBlock p (AllegraEra c))) -> Word32
forall blk.
LedgerSupportsMempool blk =>
Ticked (LedgerState blk) -> Word32
txsMaxBytes

instance ShelleyCompatible p (MaryEra c) => TxLimits (ShelleyBlock p (MaryEra c)) where
  type TxMeasure (ShelleyBlock p (MaryEra c)) = ByteSize
  txMeasure :: Validated (GenTx (ShelleyBlock p (MaryEra c)))
-> TxMeasure (ShelleyBlock p (MaryEra c))
txMeasure        = Word32 -> ByteSize
ByteSize (Word32 -> ByteSize)
-> (Validated (GenTx (ShelleyBlock p (MaryEra c))) -> Word32)
-> Validated (GenTx (ShelleyBlock p (MaryEra c)))
-> ByteSize
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenTx (ShelleyBlock p (MaryEra c)) -> Word32
forall blk. LedgerSupportsMempool blk => GenTx blk -> Word32
txInBlockSize (GenTx (ShelleyBlock p (MaryEra c)) -> Word32)
-> (Validated (GenTx (ShelleyBlock p (MaryEra c)))
    -> GenTx (ShelleyBlock p (MaryEra c)))
-> Validated (GenTx (ShelleyBlock p (MaryEra c)))
-> Word32
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Validated (GenTx (ShelleyBlock p (MaryEra c)))
-> GenTx (ShelleyBlock p (MaryEra c))
forall blk.
LedgerSupportsMempool blk =>
Validated (GenTx blk) -> GenTx blk
txForgetValidated
  txsBlockCapacity :: Ticked (LedgerState (ShelleyBlock p (MaryEra c)))
-> TxMeasure (ShelleyBlock p (MaryEra c))
txsBlockCapacity = Word32 -> ByteSize
ByteSize (Word32 -> ByteSize)
-> (Ticked (LedgerState (ShelleyBlock p (MaryEra c))) -> Word32)
-> Ticked (LedgerState (ShelleyBlock p (MaryEra c)))
-> ByteSize
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ticked (LedgerState (ShelleyBlock p (MaryEra c))) -> Word32
forall blk.
LedgerSupportsMempool blk =>
Ticked (LedgerState blk) -> Word32
txsMaxBytes

instance ( ShelleyCompatible p (AlonzoEra c)
         ) => TxLimits (ShelleyBlock p (AlonzoEra c)) where

  type TxMeasure (ShelleyBlock p (AlonzoEra c)) = AlonzoMeasure

  txMeasure :: Validated (GenTx (ShelleyBlock p (AlonzoEra c)))
-> TxMeasure (ShelleyBlock p (AlonzoEra c))
txMeasure (ShelleyValidatedTx _txid vtx) =
    AlonzoMeasure :: ByteSize -> ExUnits' (WithTop Natural) -> AlonzoMeasure
AlonzoMeasure {
        byteSize :: ByteSize
byteSize = Word32 -> ByteSize
ByteSize (Word32 -> ByteSize) -> Word32 -> ByteSize
forall a b. (a -> b) -> a -> b
$ GenTx (ShelleyBlock p (AlonzoEra c)) -> Word32
forall blk. LedgerSupportsMempool blk => GenTx blk -> Word32
txInBlockSize (Tx (AlonzoEra c) -> GenTx (ShelleyBlock p (AlonzoEra c))
forall era proto.
ShelleyBasedEra era =>
Tx era -> GenTx (ShelleyBlock proto era)
mkShelleyTx @(AlonzoEra c) @p (Validated (ValidatedTx (AlonzoEra c)) -> ValidatedTx (AlonzoEra c)
forall tx. Validated tx -> tx
SL.extractTx Validated (Tx (AlonzoEra c))
Validated (ValidatedTx (AlonzoEra c))
vtx))
      , exUnits :: ExUnits' (WithTop Natural)
exUnits  = ExUnits -> ExUnits' (WithTop Natural)
fromExUnits (ExUnits -> ExUnits' (WithTop Natural))
-> ExUnits -> ExUnits' (WithTop Natural)
forall a b. (a -> b) -> a -> b
$ Tx (AlonzoEra c) -> ExUnits
forall era.
(HasField "wits" (Tx era) (Witnesses era),
 HasField "txrdmrs" (Witnesses era) (Redeemers era)) =>
Tx era -> ExUnits
totExUnits (Validated (ValidatedTx (AlonzoEra c)) -> ValidatedTx (AlonzoEra c)
forall tx. Validated tx -> tx
SL.extractTx Validated (Tx (AlonzoEra c))
Validated (ValidatedTx (AlonzoEra c))
vtx)
      }

  txsBlockCapacity :: Ticked (LedgerState (ShelleyBlock p (AlonzoEra c)))
-> TxMeasure (ShelleyBlock p (AlonzoEra c))
txsBlockCapacity Ticked (LedgerState (ShelleyBlock p (AlonzoEra c)))
ledgerState =
      AlonzoMeasure :: ByteSize -> ExUnits' (WithTop Natural) -> AlonzoMeasure
AlonzoMeasure {
          byteSize :: ByteSize
byteSize = Word32 -> ByteSize
ByteSize (Word32 -> ByteSize) -> Word32 -> ByteSize
forall a b. (a -> b) -> a -> b
$ Ticked (LedgerState (ShelleyBlock p (AlonzoEra c))) -> Word32
forall blk.
LedgerSupportsMempool blk =>
Ticked (LedgerState blk) -> Word32
txsMaxBytes Ticked (LedgerState (ShelleyBlock p (AlonzoEra c)))
ledgerState
        , exUnits :: ExUnits' (WithTop Natural)
exUnits  = ExUnits -> ExUnits' (WithTop Natural)
fromExUnits (ExUnits -> ExUnits' (WithTop Natural))
-> ExUnits -> ExUnits' (WithTop Natural)
forall a b. (a -> b) -> a -> b
$ PParams (AlonzoEra c) -> ExUnits
forall k (x :: k) r a. HasField x r a => r -> a
getField @"_maxBlockExUnits" PParams (AlonzoEra c)
PParams (AlonzoEra c)
pparams
        }
    where
      pparams :: PParams (AlonzoEra c)
pparams = NewEpochState (AlonzoEra c) -> PParams (AlonzoEra c)
forall era. NewEpochState era -> PParams era
getPParams (NewEpochState (AlonzoEra c) -> PParams (AlonzoEra c))
-> NewEpochState (AlonzoEra c) -> PParams (AlonzoEra c)
forall a b. (a -> b) -> a -> b
$ Ticked (LedgerState (ShelleyBlock p (AlonzoEra c)))
-> NewEpochState (AlonzoEra c)
forall proto era.
Ticked (LedgerState (ShelleyBlock proto era)) -> NewEpochState era
tickedShelleyLedgerState Ticked (LedgerState (ShelleyBlock p (AlonzoEra c)))
ledgerState

data AlonzoMeasure = AlonzoMeasure {
    AlonzoMeasure -> ByteSize
byteSize :: !ByteSize
  , AlonzoMeasure -> ExUnits' (WithTop Natural)
exUnits  :: !(ExUnits' (WithTop Natural))
  } deriving stock (AlonzoMeasure -> AlonzoMeasure -> Bool
(AlonzoMeasure -> AlonzoMeasure -> Bool)
-> (AlonzoMeasure -> AlonzoMeasure -> Bool) -> Eq AlonzoMeasure
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: AlonzoMeasure -> AlonzoMeasure -> Bool
$c/= :: AlonzoMeasure -> AlonzoMeasure -> Bool
== :: AlonzoMeasure -> AlonzoMeasure -> Bool
$c== :: AlonzoMeasure -> AlonzoMeasure -> Bool
Eq, (forall x. AlonzoMeasure -> Rep AlonzoMeasure x)
-> (forall x. Rep AlonzoMeasure x -> AlonzoMeasure)
-> Generic AlonzoMeasure
forall x. Rep AlonzoMeasure x -> AlonzoMeasure
forall x. AlonzoMeasure -> Rep AlonzoMeasure x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep AlonzoMeasure x -> AlonzoMeasure
$cfrom :: forall x. AlonzoMeasure -> Rep AlonzoMeasure x
Generic, Int -> AlonzoMeasure -> ShowS
[AlonzoMeasure] -> ShowS
AlonzoMeasure -> String
(Int -> AlonzoMeasure -> ShowS)
-> (AlonzoMeasure -> String)
-> ([AlonzoMeasure] -> ShowS)
-> Show AlonzoMeasure
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [AlonzoMeasure] -> ShowS
$cshowList :: [AlonzoMeasure] -> ShowS
show :: AlonzoMeasure -> String
$cshow :: AlonzoMeasure -> String
showsPrec :: Int -> AlonzoMeasure -> ShowS
$cshowsPrec :: Int -> AlonzoMeasure -> ShowS
Show)
    deriving (Measure AlonzoMeasure
AlonzoMeasure
Measure AlonzoMeasure
-> AlonzoMeasure -> BoundedMeasure AlonzoMeasure
forall a. Measure a -> a -> BoundedMeasure a
maxBound :: AlonzoMeasure
$cmaxBound :: AlonzoMeasure
$cp1BoundedMeasure :: Measure AlonzoMeasure
BoundedMeasure, Eq AlonzoMeasure
AlonzoMeasure
Eq AlonzoMeasure
-> AlonzoMeasure
-> (AlonzoMeasure -> AlonzoMeasure -> AlonzoMeasure)
-> (AlonzoMeasure -> AlonzoMeasure -> AlonzoMeasure)
-> (AlonzoMeasure -> AlonzoMeasure -> AlonzoMeasure)
-> Measure AlonzoMeasure
AlonzoMeasure -> AlonzoMeasure -> AlonzoMeasure
forall a.
Eq a
-> a
-> (a -> a -> a)
-> (a -> a -> a)
-> (a -> a -> a)
-> Measure a
max :: AlonzoMeasure -> AlonzoMeasure -> AlonzoMeasure
$cmax :: AlonzoMeasure -> AlonzoMeasure -> AlonzoMeasure
min :: AlonzoMeasure -> AlonzoMeasure -> AlonzoMeasure
$cmin :: AlonzoMeasure -> AlonzoMeasure -> AlonzoMeasure
plus :: AlonzoMeasure -> AlonzoMeasure -> AlonzoMeasure
$cplus :: AlonzoMeasure -> AlonzoMeasure -> AlonzoMeasure
zero :: AlonzoMeasure
$czero :: AlonzoMeasure
$cp1Measure :: Eq AlonzoMeasure
Measure)
         via (InstantiatedAt Generic AlonzoMeasure)

fromExUnits :: ExUnits -> ExUnits' (WithTop Natural)
fromExUnits :: ExUnits -> ExUnits' (WithTop Natural)
fromExUnits = (Natural -> WithTop Natural)
-> ExUnits' Natural -> ExUnits' (WithTop Natural)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Natural -> WithTop Natural
forall a. a -> WithTop a
NotTop (ExUnits' Natural -> ExUnits' (WithTop Natural))
-> (ExUnits -> ExUnits' Natural)
-> ExUnits
-> ExUnits' (WithTop Natural)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ExUnits -> ExUnits' Natural
unWrapExUnits

instance ( ShelleyCompatible p (BabbageEra c)
         ) => TxLimits (ShelleyBlock p (BabbageEra c)) where

  type TxMeasure (ShelleyBlock p (BabbageEra c)) = AlonzoMeasure

  txMeasure :: Validated (GenTx (ShelleyBlock p (BabbageEra c)))
-> TxMeasure (ShelleyBlock p (BabbageEra c))
txMeasure (ShelleyValidatedTx _txid vtx) =
    AlonzoMeasure :: ByteSize -> ExUnits' (WithTop Natural) -> AlonzoMeasure
AlonzoMeasure {
        byteSize :: ByteSize
byteSize = Word32 -> ByteSize
ByteSize (Word32 -> ByteSize) -> Word32 -> ByteSize
forall a b. (a -> b) -> a -> b
$ GenTx (ShelleyBlock p (BabbageEra c)) -> Word32
forall blk. LedgerSupportsMempool blk => GenTx blk -> Word32
txInBlockSize (Tx (BabbageEra c) -> GenTx (ShelleyBlock p (BabbageEra c))
forall era proto.
ShelleyBasedEra era =>
Tx era -> GenTx (ShelleyBlock proto era)
mkShelleyTx @(BabbageEra c) @p (Validated (ValidatedTx (BabbageEra c))
-> ValidatedTx (BabbageEra c)
forall tx. Validated tx -> tx
SL.extractTx Validated (Tx (BabbageEra c))
Validated (ValidatedTx (BabbageEra c))
vtx))
      , exUnits :: ExUnits' (WithTop Natural)
exUnits  = ExUnits -> ExUnits' (WithTop Natural)
fromExUnits (ExUnits -> ExUnits' (WithTop Natural))
-> ExUnits -> ExUnits' (WithTop Natural)
forall a b. (a -> b) -> a -> b
$ Tx (BabbageEra c) -> ExUnits
forall era.
(HasField "wits" (Tx era) (Witnesses era),
 HasField "txrdmrs" (Witnesses era) (Redeemers era)) =>
Tx era -> ExUnits
totExUnits (Validated (ValidatedTx (BabbageEra c))
-> ValidatedTx (BabbageEra c)
forall tx. Validated tx -> tx
SL.extractTx Validated (Tx (BabbageEra c))
Validated (ValidatedTx (BabbageEra c))
vtx)
      }

  txsBlockCapacity :: Ticked (LedgerState (ShelleyBlock p (BabbageEra c)))
-> TxMeasure (ShelleyBlock p (BabbageEra c))
txsBlockCapacity Ticked (LedgerState (ShelleyBlock p (BabbageEra c)))
ledgerState =
      AlonzoMeasure :: ByteSize -> ExUnits' (WithTop Natural) -> AlonzoMeasure
AlonzoMeasure {
          byteSize :: ByteSize
byteSize = Word32 -> ByteSize
ByteSize (Word32 -> ByteSize) -> Word32 -> ByteSize
forall a b. (a -> b) -> a -> b
$ Ticked (LedgerState (ShelleyBlock p (BabbageEra c))) -> Word32
forall blk.
LedgerSupportsMempool blk =>
Ticked (LedgerState blk) -> Word32
txsMaxBytes Ticked (LedgerState (ShelleyBlock p (BabbageEra c)))
ledgerState
        , exUnits :: ExUnits' (WithTop Natural)
exUnits  = ExUnits -> ExUnits' (WithTop Natural)
fromExUnits (ExUnits -> ExUnits' (WithTop Natural))
-> ExUnits -> ExUnits' (WithTop Natural)
forall a b. (a -> b) -> a -> b
$ PParams (BabbageEra c) -> ExUnits
forall k (x :: k) r a. HasField x r a => r -> a
getField @"_maxBlockExUnits" PParams (BabbageEra c)
PParams (BabbageEra c)
pparams
        }
    where
      pparams :: PParams (BabbageEra c)
pparams = NewEpochState (BabbageEra c) -> PParams (BabbageEra c)
forall era. NewEpochState era -> PParams era
getPParams (NewEpochState (BabbageEra c) -> PParams (BabbageEra c))
-> NewEpochState (BabbageEra c) -> PParams (BabbageEra c)
forall a b. (a -> b) -> a -> b
$ Ticked (LedgerState (ShelleyBlock p (BabbageEra c)))
-> NewEpochState (BabbageEra c)
forall proto era.
Ticked (LedgerState (ShelleyBlock proto era)) -> NewEpochState era
tickedShelleyLedgerState Ticked (LedgerState (ShelleyBlock p (BabbageEra c)))
ledgerState

{-------------------------------------------------------------------------------
  WithTop
-------------------------------------------------------------------------------}

-- | Add a unique top element to a lattice.
--
-- TODO This should be relocated to `cardano-base:Data.Measure'.
data WithTop a = NotTop a | Top
  deriving (WithTop a -> WithTop a -> Bool
(WithTop a -> WithTop a -> Bool)
-> (WithTop a -> WithTop a -> Bool) -> Eq (WithTop a)
forall a. Eq a => WithTop a -> WithTop a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: WithTop a -> WithTop a -> Bool
$c/= :: forall a. Eq a => WithTop a -> WithTop a -> Bool
== :: WithTop a -> WithTop a -> Bool
$c== :: forall a. Eq a => WithTop a -> WithTop a -> Bool
Eq, (forall x. WithTop a -> Rep (WithTop a) x)
-> (forall x. Rep (WithTop a) x -> WithTop a)
-> Generic (WithTop a)
forall x. Rep (WithTop a) x -> WithTop a
forall x. WithTop a -> Rep (WithTop a) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall a x. Rep (WithTop a) x -> WithTop a
forall a x. WithTop a -> Rep (WithTop a) x
$cto :: forall a x. Rep (WithTop a) x -> WithTop a
$cfrom :: forall a x. WithTop a -> Rep (WithTop a) x
Generic, Int -> WithTop a -> ShowS
[WithTop a] -> ShowS
WithTop a -> String
(Int -> WithTop a -> ShowS)
-> (WithTop a -> String)
-> ([WithTop a] -> ShowS)
-> Show (WithTop a)
forall a. Show a => Int -> WithTop a -> ShowS
forall a. Show a => [WithTop a] -> ShowS
forall a. Show a => WithTop a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [WithTop a] -> ShowS
$cshowList :: forall a. Show a => [WithTop a] -> ShowS
show :: WithTop a -> String
$cshow :: forall a. Show a => WithTop a -> String
showsPrec :: Int -> WithTop a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> WithTop a -> ShowS
Show)

instance Ord a => Ord (WithTop a) where
  compare :: WithTop a -> WithTop a -> Ordering
compare = ((WithTop a, WithTop a) -> Ordering)
-> WithTop a -> WithTop a -> Ordering
forall a b c. ((a, b) -> c) -> a -> b -> c
curry (((WithTop a, WithTop a) -> Ordering)
 -> WithTop a -> WithTop a -> Ordering)
-> ((WithTop a, WithTop a) -> Ordering)
-> WithTop a
-> WithTop a
-> Ordering
forall a b. (a -> b) -> a -> b
$ \case
    (WithTop a
Top     , WithTop a
Top     ) -> Ordering
EQ
    (WithTop a
Top     , WithTop a
_       ) -> Ordering
GT
    (WithTop a
_       , WithTop a
Top     ) -> Ordering
LT
    (NotTop a
l, NotTop a
r) -> a -> a -> Ordering
forall a. Ord a => a -> a -> Ordering
compare a
l a
r

instance Measure a => Measure (WithTop a) where
  zero :: WithTop a
zero = a -> WithTop a
forall a. a -> WithTop a
NotTop a
forall a. Measure a => a
Measure.zero
  plus :: WithTop a -> WithTop a -> WithTop a
plus = ((WithTop a, WithTop a) -> WithTop a)
-> WithTop a -> WithTop a -> WithTop a
forall a b c. ((a, b) -> c) -> a -> b -> c
curry (((WithTop a, WithTop a) -> WithTop a)
 -> WithTop a -> WithTop a -> WithTop a)
-> ((WithTop a, WithTop a) -> WithTop a)
-> WithTop a
-> WithTop a
-> WithTop a
forall a b. (a -> b) -> a -> b
$ \case
    (WithTop a
Top     , WithTop a
_       ) -> WithTop a
forall a. WithTop a
Top
    (WithTop a
_       , WithTop a
Top     ) -> WithTop a
forall a. WithTop a
Top
    (NotTop a
l, NotTop a
r) -> a -> WithTop a
forall a. a -> WithTop a
NotTop (a -> WithTop a) -> a -> WithTop a
forall a b. (a -> b) -> a -> b
$ a -> a -> a
forall a. Measure a => a -> a -> a
Measure.plus a
l a
r
  min :: WithTop a -> WithTop a -> WithTop a
min  = ((WithTop a, WithTop a) -> WithTop a)
-> WithTop a -> WithTop a -> WithTop a
forall a b c. ((a, b) -> c) -> a -> b -> c
curry (((WithTop a, WithTop a) -> WithTop a)
 -> WithTop a -> WithTop a -> WithTop a)
-> ((WithTop a, WithTop a) -> WithTop a)
-> WithTop a
-> WithTop a
-> WithTop a
forall a b. (a -> b) -> a -> b
$ \case
    (WithTop a
Top     , WithTop a
r       ) -> WithTop a
r
    (WithTop a
l       , WithTop a
Top     ) -> WithTop a
l
    (NotTop a
l, NotTop a
r) -> a -> WithTop a
forall a. a -> WithTop a
NotTop (a -> WithTop a) -> a -> WithTop a
forall a b. (a -> b) -> a -> b
$ a -> a -> a
forall a. Measure a => a -> a -> a
Measure.min a
l a
r
  max :: WithTop a -> WithTop a -> WithTop a
max  = ((WithTop a, WithTop a) -> WithTop a)
-> WithTop a -> WithTop a -> WithTop a
forall a b c. ((a, b) -> c) -> a -> b -> c
curry (((WithTop a, WithTop a) -> WithTop a)
 -> WithTop a -> WithTop a -> WithTop a)
-> ((WithTop a, WithTop a) -> WithTop a)
-> WithTop a
-> WithTop a
-> WithTop a
forall a b. (a -> b) -> a -> b
$ \case
    (WithTop a
Top     , WithTop a
_       ) -> WithTop a
forall a. WithTop a
Top
    (WithTop a
_       , WithTop a
Top     ) -> WithTop a
forall a. WithTop a
Top
    (NotTop a
l, NotTop a
r) -> a -> WithTop a
forall a. a -> WithTop a
NotTop (a -> WithTop a) -> a -> WithTop a
forall a b. (a -> b) -> a -> b
$ a -> a -> a
forall a. Measure a => a -> a -> a
Measure.max a
l a
r

instance Measure a => BoundedMeasure (WithTop a) where
  maxBound :: WithTop a
maxBound = WithTop a
forall a. WithTop a
Top