{-# LANGUAGE CPP #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE DisambiguateRecordFields #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -Wno-orphans #-}

module Ouroboros.Consensus.Shelley.Ledger.Ledger
  ( LedgerState (..)
  , LedgerTables (..)
  , ShelleyBasedEra
  , ShelleyTip (..)
  , ShelleyTransition (..)
  , Ticked (..)
  , castShelleyTip
  , shelleyLedgerTipPoint
  , shelleyTipToPoint

    -- * Ledger config
  , ShelleyLedgerConfig (..)
  , ShelleyPartialLedgerConfig (..)
  , mkShelleyLedgerConfig
  , shelleyEraParams
  , shelleyEraParamsNeverHardForks
  , shelleyLedgerGenesis

    -- * Auxiliary
  , ShelleyLedgerEvent (..)
  , ShelleyReapplyException (..)
  , getPParams

    -- * Serialisation
  , decodeShelleyAnnTip
  , decodeShelleyLedgerState
  , encodeShelleyAnnTip
  , encodeShelleyHeaderState
  , encodeShelleyLedgerState

    -- * Low-level UTxO manipulations
  , slUtxoL
  ) where

import qualified Cardano.Ledger.BHeaderView as SL (BHeaderView)
import qualified Cardano.Ledger.BaseTypes as SL (epochInfoPure)
import Cardano.Ledger.BaseTypes.NonZero (unNonZero)
import Cardano.Ledger.Binary.Decoding
  ( decShareCBOR
  , decodeMap
  , decodeMemPack
  , internsFromMap
  )
import Cardano.Ledger.Binary.Encoding
  ( encodeMap
  , encodeMemPack
  , toPlainEncoding
  )
import Cardano.Ledger.Binary.Plain
  ( FromCBOR (..)
  , ToCBOR (..)
  , enforceSize
  )
import qualified Cardano.Ledger.Block as Core
import Cardano.Ledger.Core
  ( Era
  , eraDecoder
  , ppMaxBHSizeL
  , ppMaxTxSizeL
  )
import qualified Cardano.Ledger.Core as Core
import qualified Cardano.Ledger.Shelley.API as SL
import qualified Cardano.Ledger.Shelley.Governance as SL
import qualified Cardano.Ledger.Shelley.LedgerState as SL
import qualified Cardano.Ledger.UMap as SL
import Cardano.Slotting.EpochInfo
import Codec.CBOR.Decoding (Decoder)
import qualified Codec.CBOR.Decoding as CBOR
import Codec.CBOR.Encoding (Encoding)
import qualified Codec.CBOR.Encoding as CBOR
import Codec.Serialise (decode, encode)
import Control.Arrow (left, second)
import qualified Control.Exception as Exception
import Control.Monad.Except
import qualified Control.State.Transition.Extended as STS
import Data.Coerce (coerce)
import Data.Functor.Identity
import Data.MemPack
import qualified Data.Text as T
import qualified Data.Text as Text
import Data.Word
import GHC.Generics (Generic)
import Lens.Micro
import Lens.Micro.Extras (view)
import NoThunks.Class (NoThunks (..))
import Ouroboros.Consensus.Block
import Ouroboros.Consensus.BlockchainTime.WallClock.Types
import Ouroboros.Consensus.Config
import Ouroboros.Consensus.HardFork.Abstract
import Ouroboros.Consensus.HardFork.Combinator.PartialConfig
import qualified Ouroboros.Consensus.HardFork.History as HardFork
import Ouroboros.Consensus.HardFork.History.Util
import Ouroboros.Consensus.HardFork.Simple
import Ouroboros.Consensus.HeaderValidation
import Ouroboros.Consensus.Ledger.Abstract
import Ouroboros.Consensus.Ledger.CommonProtocolParams
import Ouroboros.Consensus.Ledger.Extended
import Ouroboros.Consensus.Ledger.Tables.Utils
import Ouroboros.Consensus.Protocol.Ledger.Util (isNewEpoch)
import Ouroboros.Consensus.Shelley.Ledger.Block
import Ouroboros.Consensus.Shelley.Ledger.Config
import Ouroboros.Consensus.Shelley.Ledger.Protocol ()
import Ouroboros.Consensus.Shelley.Protocol.Abstract
  ( EnvelopeCheckError
  , envelopeChecks
  , mkHeaderView
  )
import Ouroboros.Consensus.Storage.LedgerDB
import Ouroboros.Consensus.Util.CBOR
  ( decodeWithOrigin
  , encodeWithOrigin
  )
import Ouroboros.Consensus.Util.IndexedMemPack
import Ouroboros.Consensus.Util.Versioned

{-------------------------------------------------------------------------------
  Config
-------------------------------------------------------------------------------}

data ShelleyLedgerConfig era = ShelleyLedgerConfig
  { forall era. ShelleyLedgerConfig era -> CompactGenesis
shelleyLedgerCompactGenesis :: !CompactGenesis
  , forall era. ShelleyLedgerConfig era -> Globals
shelleyLedgerGlobals :: !SL.Globals
  -- ^ Derived from 'shelleyLedgerGenesis' but we store a cached version
  -- because it used very often.
  , forall era. ShelleyLedgerConfig era -> TranslationContext era
shelleyLedgerTranslationContext :: !(Core.TranslationContext era)
  }
  deriving (forall x.
 ShelleyLedgerConfig era -> Rep (ShelleyLedgerConfig era) x)
-> (forall x.
    Rep (ShelleyLedgerConfig era) x -> ShelleyLedgerConfig era)
-> Generic (ShelleyLedgerConfig era)
forall x.
Rep (ShelleyLedgerConfig era) x -> ShelleyLedgerConfig era
forall x.
ShelleyLedgerConfig era -> Rep (ShelleyLedgerConfig era) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall era x.
Rep (ShelleyLedgerConfig era) x -> ShelleyLedgerConfig era
forall era x.
ShelleyLedgerConfig era -> Rep (ShelleyLedgerConfig era) x
$cfrom :: forall era x.
ShelleyLedgerConfig era -> Rep (ShelleyLedgerConfig era) x
from :: forall x.
ShelleyLedgerConfig era -> Rep (ShelleyLedgerConfig era) x
$cto :: forall era x.
Rep (ShelleyLedgerConfig era) x -> ShelleyLedgerConfig era
to :: forall x.
Rep (ShelleyLedgerConfig era) x -> ShelleyLedgerConfig era
Generic

deriving instance
  (NoThunks (Core.TranslationContext era), Era era) =>
  NoThunks (ShelleyLedgerConfig era)

deriving instance Show (Core.TranslationContext era) => Show (ShelleyLedgerConfig era)

shelleyLedgerGenesis :: ShelleyLedgerConfig era -> SL.ShelleyGenesis
shelleyLedgerGenesis :: forall era. ShelleyLedgerConfig era -> ShelleyGenesis
shelleyLedgerGenesis = CompactGenesis -> ShelleyGenesis
getCompactGenesis (CompactGenesis -> ShelleyGenesis)
-> (ShelleyLedgerConfig era -> CompactGenesis)
-> ShelleyLedgerConfig era
-> ShelleyGenesis
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShelleyLedgerConfig era -> CompactGenesis
forall era. ShelleyLedgerConfig era -> CompactGenesis
shelleyLedgerCompactGenesis

shelleyEraParams ::
  SL.ShelleyGenesis ->
  HardFork.EraParams
shelleyEraParams :: ShelleyGenesis -> EraParams
shelleyEraParams ShelleyGenesis
genesis =
  HardFork.EraParams
    { eraEpochSize :: EpochSize
eraEpochSize = ShelleyGenesis -> EpochSize
SL.sgEpochLength ShelleyGenesis
genesis
    , eraSlotLength :: SlotLength
eraSlotLength = NominalDiffTime -> SlotLength
mkSlotLength (NominalDiffTime -> SlotLength) -> NominalDiffTime -> SlotLength
forall a b. (a -> b) -> a -> b
$ NominalDiffTimeMicro -> NominalDiffTime
SL.fromNominalDiffTimeMicro (NominalDiffTimeMicro -> NominalDiffTime)
-> NominalDiffTimeMicro -> NominalDiffTime
forall a b. (a -> b) -> a -> b
$ ShelleyGenesis -> NominalDiffTimeMicro
SL.sgSlotLength ShelleyGenesis
genesis
    , eraSafeZone :: SafeZone
eraSafeZone = Word64 -> SafeZone
HardFork.StandardSafeZone Word64
stabilityWindow
    , eraGenesisWin :: GenesisWindow
eraGenesisWin = Word64 -> GenesisWindow
GenesisWindow Word64
stabilityWindow
    }
 where
  stabilityWindow :: Word64
stabilityWindow =
    Word64 -> ActiveSlotCoeff -> Word64
SL.computeStabilityWindow
      (NonZero Word64 -> Word64
forall a. NonZero a -> a
unNonZero (NonZero Word64 -> Word64) -> NonZero Word64 -> Word64
forall a b. (a -> b) -> a -> b
$ ShelleyGenesis -> NonZero Word64
SL.sgSecurityParam ShelleyGenesis
genesis)
      (ShelleyGenesis -> ActiveSlotCoeff
SL.sgActiveSlotCoeff ShelleyGenesis
genesis)

-- | Separate variant of 'shelleyEraParams' to be used for a Shelley-only chain.
shelleyEraParamsNeverHardForks :: SL.ShelleyGenesis -> HardFork.EraParams
shelleyEraParamsNeverHardForks :: ShelleyGenesis -> EraParams
shelleyEraParamsNeverHardForks ShelleyGenesis
genesis =
  HardFork.EraParams
    { eraEpochSize :: EpochSize
eraEpochSize = ShelleyGenesis -> EpochSize
SL.sgEpochLength ShelleyGenesis
genesis
    , eraSlotLength :: SlotLength
eraSlotLength = NominalDiffTime -> SlotLength
mkSlotLength (NominalDiffTime -> SlotLength) -> NominalDiffTime -> SlotLength
forall a b. (a -> b) -> a -> b
$ NominalDiffTimeMicro -> NominalDiffTime
SL.fromNominalDiffTimeMicro (NominalDiffTimeMicro -> NominalDiffTime)
-> NominalDiffTimeMicro -> NominalDiffTime
forall a b. (a -> b) -> a -> b
$ ShelleyGenesis -> NominalDiffTimeMicro
SL.sgSlotLength ShelleyGenesis
genesis
    , eraSafeZone :: SafeZone
eraSafeZone = SafeZone
HardFork.UnsafeIndefiniteSafeZone
    , eraGenesisWin :: GenesisWindow
eraGenesisWin = Word64 -> GenesisWindow
GenesisWindow Word64
stabilityWindow
    }
 where
  stabilityWindow :: Word64
stabilityWindow =
    Word64 -> ActiveSlotCoeff -> Word64
SL.computeStabilityWindow
      (NonZero Word64 -> Word64
forall a. NonZero a -> a
unNonZero (NonZero Word64 -> Word64) -> NonZero Word64 -> Word64
forall a b. (a -> b) -> a -> b
$ ShelleyGenesis -> NonZero Word64
SL.sgSecurityParam ShelleyGenesis
genesis)
      (ShelleyGenesis -> ActiveSlotCoeff
SL.sgActiveSlotCoeff ShelleyGenesis
genesis)

mkShelleyLedgerConfig ::
  SL.ShelleyGenesis ->
  Core.TranslationContext era ->
  EpochInfo (Except HardFork.PastHorizonException) ->
  ShelleyLedgerConfig era
mkShelleyLedgerConfig :: forall era.
ShelleyGenesis
-> TranslationContext era
-> EpochInfo (Except PastHorizonException)
-> ShelleyLedgerConfig era
mkShelleyLedgerConfig ShelleyGenesis
genesis TranslationContext era
transCtxt EpochInfo (Except PastHorizonException)
epochInfo =
  ShelleyLedgerConfig
    { shelleyLedgerCompactGenesis :: CompactGenesis
shelleyLedgerCompactGenesis = ShelleyGenesis -> CompactGenesis
compactGenesis ShelleyGenesis
genesis
    , shelleyLedgerGlobals :: Globals
shelleyLedgerGlobals =
        ShelleyGenesis -> EpochInfo (Either Text) -> Globals
SL.mkShelleyGlobals
          ShelleyGenesis
genesis
          ((forall a. Except PastHorizonException a -> Either Text a)
-> EpochInfo (Except PastHorizonException)
-> EpochInfo (Either Text)
forall (m :: * -> *) (n :: * -> *).
(forall a. m a -> n a) -> EpochInfo m -> EpochInfo n
hoistEpochInfo ((PastHorizonException -> Text)
-> Either PastHorizonException a -> Either Text a
forall b c d. (b -> c) -> Either b d -> Either c d
forall (a :: * -> * -> *) b c d.
ArrowChoice a =>
a b c -> a (Either b d) (Either c d)
left (String -> Text
Text.pack (String -> Text)
-> (PastHorizonException -> String) -> PastHorizonException -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PastHorizonException -> String
forall a. Show a => a -> String
show) (Either PastHorizonException a -> Either Text a)
-> (Except PastHorizonException a -> Either PastHorizonException a)
-> Except PastHorizonException a
-> Either Text a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Except PastHorizonException a -> Either PastHorizonException a
forall e a. Except e a -> Either e a
runExcept) EpochInfo (Except PastHorizonException)
epochInfo)
    , shelleyLedgerTranslationContext :: TranslationContext era
shelleyLedgerTranslationContext = TranslationContext era
transCtxt
    }

type instance LedgerCfg (LedgerState (ShelleyBlock proto era)) = ShelleyLedgerConfig era

data ShelleyPartialLedgerConfig era = ShelleyPartialLedgerConfig
  { forall era.
ShelleyPartialLedgerConfig era -> ShelleyLedgerConfig era
shelleyLedgerConfig :: !(ShelleyLedgerConfig era)
  -- ^ We cache the non-partial ledger config containing a dummy
  -- 'EpochInfo' that needs to be replaced with the correct one.
  --
  -- We do this to avoid recomputing the ledger config each time
  -- 'completeLedgerConfig' is called, as 'mkShelleyLedgerConfig' does
  -- some rather expensive computations that shouldn't be repeated too
  -- often (e.g., 'sgActiveSlotCoeff').
  , forall era. ShelleyPartialLedgerConfig era -> TriggerHardFork
shelleyTriggerHardFork :: !TriggerHardFork
  }
  deriving (forall x.
 ShelleyPartialLedgerConfig era
 -> Rep (ShelleyPartialLedgerConfig era) x)
-> (forall x.
    Rep (ShelleyPartialLedgerConfig era) x
    -> ShelleyPartialLedgerConfig era)
-> Generic (ShelleyPartialLedgerConfig era)
forall x.
Rep (ShelleyPartialLedgerConfig era) x
-> ShelleyPartialLedgerConfig era
forall x.
ShelleyPartialLedgerConfig era
-> Rep (ShelleyPartialLedgerConfig era) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall era x.
Rep (ShelleyPartialLedgerConfig era) x
-> ShelleyPartialLedgerConfig era
forall era x.
ShelleyPartialLedgerConfig era
-> Rep (ShelleyPartialLedgerConfig era) x
$cfrom :: forall era x.
ShelleyPartialLedgerConfig era
-> Rep (ShelleyPartialLedgerConfig era) x
from :: forall x.
ShelleyPartialLedgerConfig era
-> Rep (ShelleyPartialLedgerConfig era) x
$cto :: forall era x.
Rep (ShelleyPartialLedgerConfig era) x
-> ShelleyPartialLedgerConfig era
to :: forall x.
Rep (ShelleyPartialLedgerConfig era) x
-> ShelleyPartialLedgerConfig era
Generic

deriving instance Show (ShelleyLedgerConfig era) => Show (ShelleyPartialLedgerConfig era)

deriving instance
  (NoThunks (Core.TranslationContext era), Core.Era era) =>
  NoThunks (ShelleyPartialLedgerConfig era)

instance ShelleyCompatible proto era => HasPartialLedgerConfig (ShelleyBlock proto era) where
  type PartialLedgerConfig (ShelleyBlock proto era) = ShelleyPartialLedgerConfig era

  -- Replace the dummy 'EpochInfo' with the real one
  completeLedgerConfig :: forall (proxy :: * -> *).
proxy (ShelleyBlock proto era)
-> EpochInfo (Except PastHorizonException)
-> PartialLedgerConfig (ShelleyBlock proto era)
-> LedgerConfig (ShelleyBlock proto era)
completeLedgerConfig proxy (ShelleyBlock proto era)
_ EpochInfo (Except PastHorizonException)
epochInfo (ShelleyPartialLedgerConfig ShelleyLedgerConfig era
cfg TriggerHardFork
_) =
    ShelleyLedgerConfig era
cfg
      { shelleyLedgerGlobals =
          (shelleyLedgerGlobals cfg)
            { SL.epochInfo =
                hoistEpochInfo
                  (runExcept . withExceptT (T.pack . show))
                  epochInfo
            }
      }

{-------------------------------------------------------------------------------
  LedgerState
-------------------------------------------------------------------------------}

data ShelleyTip proto era = ShelleyTip
  { forall proto era. ShelleyTip proto era -> SlotNo
shelleyTipSlotNo :: !SlotNo
  , forall proto era. ShelleyTip proto era -> BlockNo
shelleyTipBlockNo :: !BlockNo
  , forall proto era.
ShelleyTip proto era -> HeaderHash (ShelleyBlock proto era)
shelleyTipHash :: !(HeaderHash (ShelleyBlock proto era))
  }
  deriving (ShelleyTip proto era -> ShelleyTip proto era -> Bool
(ShelleyTip proto era -> ShelleyTip proto era -> Bool)
-> (ShelleyTip proto era -> ShelleyTip proto era -> Bool)
-> Eq (ShelleyTip proto era)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall proto era.
ShelleyTip proto era -> ShelleyTip proto era -> Bool
$c== :: forall proto era.
ShelleyTip proto era -> ShelleyTip proto era -> Bool
== :: ShelleyTip proto era -> ShelleyTip proto era -> Bool
$c/= :: forall proto era.
ShelleyTip proto era -> ShelleyTip proto era -> Bool
/= :: ShelleyTip proto era -> ShelleyTip proto era -> Bool
Eq, Int -> ShelleyTip proto era -> ShowS
[ShelleyTip proto era] -> ShowS
ShelleyTip proto era -> String
(Int -> ShelleyTip proto era -> ShowS)
-> (ShelleyTip proto era -> String)
-> ([ShelleyTip proto era] -> ShowS)
-> Show (ShelleyTip proto era)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall proto era. Int -> ShelleyTip proto era -> ShowS
forall proto era. [ShelleyTip proto era] -> ShowS
forall proto era. ShelleyTip proto era -> String
$cshowsPrec :: forall proto era. Int -> ShelleyTip proto era -> ShowS
showsPrec :: Int -> ShelleyTip proto era -> ShowS
$cshow :: forall proto era. ShelleyTip proto era -> String
show :: ShelleyTip proto era -> String
$cshowList :: forall proto era. [ShelleyTip proto era] -> ShowS
showList :: [ShelleyTip proto era] -> ShowS
Show, (forall x. ShelleyTip proto era -> Rep (ShelleyTip proto era) x)
-> (forall x. Rep (ShelleyTip proto era) x -> ShelleyTip proto era)
-> Generic (ShelleyTip proto era)
forall x. Rep (ShelleyTip proto era) x -> ShelleyTip proto era
forall x. ShelleyTip proto era -> Rep (ShelleyTip proto era) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall proto era x.
Rep (ShelleyTip proto era) x -> ShelleyTip proto era
forall proto era x.
ShelleyTip proto era -> Rep (ShelleyTip proto era) x
$cfrom :: forall proto era x.
ShelleyTip proto era -> Rep (ShelleyTip proto era) x
from :: forall x. ShelleyTip proto era -> Rep (ShelleyTip proto era) x
$cto :: forall proto era x.
Rep (ShelleyTip proto era) x -> ShelleyTip proto era
to :: forall x. Rep (ShelleyTip proto era) x -> ShelleyTip proto era
Generic, Context -> ShelleyTip proto era -> IO (Maybe ThunkInfo)
Proxy (ShelleyTip proto era) -> String
(Context -> ShelleyTip proto era -> IO (Maybe ThunkInfo))
-> (Context -> ShelleyTip proto era -> IO (Maybe ThunkInfo))
-> (Proxy (ShelleyTip proto era) -> String)
-> NoThunks (ShelleyTip proto era)
forall a.
(Context -> a -> IO (Maybe ThunkInfo))
-> (Context -> a -> IO (Maybe ThunkInfo))
-> (Proxy a -> String)
-> NoThunks a
forall proto era.
Context -> ShelleyTip proto era -> IO (Maybe ThunkInfo)
forall proto era. Proxy (ShelleyTip proto era) -> String
$cnoThunks :: forall proto era.
Context -> ShelleyTip proto era -> IO (Maybe ThunkInfo)
noThunks :: Context -> ShelleyTip proto era -> IO (Maybe ThunkInfo)
$cwNoThunks :: forall proto era.
Context -> ShelleyTip proto era -> IO (Maybe ThunkInfo)
wNoThunks :: Context -> ShelleyTip proto era -> IO (Maybe ThunkInfo)
$cshowTypeOf :: forall proto era. Proxy (ShelleyTip proto era) -> String
showTypeOf :: Proxy (ShelleyTip proto era) -> String
NoThunks)

shelleyTipToPoint :: WithOrigin (ShelleyTip proto era) -> Point (ShelleyBlock proto era)
shelleyTipToPoint :: forall proto era.
WithOrigin (ShelleyTip proto era) -> Point (ShelleyBlock proto era)
shelleyTipToPoint WithOrigin (ShelleyTip proto era)
Origin = Point (ShelleyBlock proto era)
forall {k} (block :: k). Point block
GenesisPoint
shelleyTipToPoint (NotOrigin ShelleyTip proto era
tip) =
  SlotNo
-> HeaderHash (ShelleyBlock proto era)
-> Point (ShelleyBlock proto era)
forall {k} (block :: k). SlotNo -> HeaderHash block -> Point block
BlockPoint
    (ShelleyTip proto era -> SlotNo
forall proto era. ShelleyTip proto era -> SlotNo
shelleyTipSlotNo ShelleyTip proto era
tip)
    (ShelleyTip proto era -> HeaderHash (ShelleyBlock proto era)
forall proto era.
ShelleyTip proto era -> HeaderHash (ShelleyBlock proto era)
shelleyTipHash ShelleyTip proto era
tip)

castShelleyTip :: ShelleyTip proto era -> ShelleyTip proto' era'
castShelleyTip :: forall proto era proto' era'.
ShelleyTip proto era -> ShelleyTip proto' era'
castShelleyTip (ShelleyTip SlotNo
sn BlockNo
bn HeaderHash (ShelleyBlock proto era)
hh) =
  ShelleyTip
    { shelleyTipSlotNo :: SlotNo
shelleyTipSlotNo = SlotNo
sn
    , shelleyTipBlockNo :: BlockNo
shelleyTipBlockNo = BlockNo
bn
    , shelleyTipHash :: HeaderHash (ShelleyBlock proto' era')
shelleyTipHash = ShelleyHash -> ShelleyHash
forall a b. Coercible a b => a -> b
coerce HeaderHash (ShelleyBlock proto era)
ShelleyHash
hh
    }

data instance LedgerState (ShelleyBlock proto era) mk = ShelleyLedgerState
  { forall proto era (mk :: * -> * -> *).
LedgerState (ShelleyBlock proto era) mk
-> WithOrigin (ShelleyTip proto era)
shelleyLedgerTip :: !(WithOrigin (ShelleyTip proto era))
  , forall proto era (mk :: * -> * -> *).
LedgerState (ShelleyBlock proto era) mk -> NewEpochState era
shelleyLedgerState :: !(SL.NewEpochState era)
  , forall proto era (mk :: * -> * -> *).
LedgerState (ShelleyBlock proto era) mk -> ShelleyTransition
shelleyLedgerTransition :: !ShelleyTransition
  , forall proto era (mk :: * -> * -> *).
LedgerState (ShelleyBlock proto era) mk
-> LedgerTables (LedgerState (ShelleyBlock proto era)) mk
shelleyLedgerTables :: !(LedgerTables (LedgerState (ShelleyBlock proto era)) mk)
  }
  deriving (forall x.
 LedgerState (ShelleyBlock proto era) mk
 -> Rep (LedgerState (ShelleyBlock proto era) mk) x)
-> (forall x.
    Rep (LedgerState (ShelleyBlock proto era) mk) x
    -> LedgerState (ShelleyBlock proto era) mk)
-> Generic (LedgerState (ShelleyBlock proto era) mk)
forall x.
Rep (LedgerState (ShelleyBlock proto era) mk) x
-> LedgerState (ShelleyBlock proto era) mk
forall x.
LedgerState (ShelleyBlock proto era) mk
-> Rep (LedgerState (ShelleyBlock proto era) mk) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall proto era (mk :: * -> * -> *) x.
Rep (LedgerState (ShelleyBlock proto era) mk) x
-> LedgerState (ShelleyBlock proto era) mk
forall proto era (mk :: * -> * -> *) x.
LedgerState (ShelleyBlock proto era) mk
-> Rep (LedgerState (ShelleyBlock proto era) mk) x
$cfrom :: forall proto era (mk :: * -> * -> *) x.
LedgerState (ShelleyBlock proto era) mk
-> Rep (LedgerState (ShelleyBlock proto era) mk) x
from :: forall x.
LedgerState (ShelleyBlock proto era) mk
-> Rep (LedgerState (ShelleyBlock proto era) mk) x
$cto :: forall proto era (mk :: * -> * -> *) x.
Rep (LedgerState (ShelleyBlock proto era) mk) x
-> LedgerState (ShelleyBlock proto era) mk
to :: forall x.
Rep (LedgerState (ShelleyBlock proto era) mk) x
-> LedgerState (ShelleyBlock proto era) mk
Generic

deriving instance
  (ShelleyBasedEra era, EqMK mk) =>
  Eq (LedgerState (ShelleyBlock proto era) mk)
deriving instance
  (ShelleyBasedEra era, NoThunksMK mk) =>
  NoThunks (LedgerState (ShelleyBlock proto era) mk)
deriving instance
  (ShelleyBasedEra era, ShowMK mk) =>
  Show (LedgerState (ShelleyBlock proto era) mk)

-- | Information required to determine the hard fork point from Shelley to the
-- next ledger
newtype ShelleyTransition = ShelleyTransitionInfo
  { ShelleyTransition -> Word32
shelleyAfterVoting :: Word32
  -- ^ The number of blocks in this epoch past the voting deadline
  --
  -- We record this to make sure that we can tell the HFC about hard forks
  -- if and only if we are certain:
  --
  -- 1. Blocks that came in within an epoch after the 4k/f voting deadline
  --    are not relevant (10k/f - 2 * 3k/f).
  -- 2. Since there are slots between blocks, we are probably only sure that
  --    there will be no more relevant block when we have seen the first
  --    block after the deadline.
  -- 3. If we count how many blocks we have seen post deadline, and we have
  --    reached k of them, we know that that last pre-deadline block won't
  --    be rolled back anymore.
  -- 4. At this point we can look at the ledger state and see if there is
  --    a new protocol version update scheduled on the next epoch boundary,
  --    and notify the HFC that we need to transition into a new era at that
  --    point.
  }
  deriving stock (ShelleyTransition -> ShelleyTransition -> Bool
(ShelleyTransition -> ShelleyTransition -> Bool)
-> (ShelleyTransition -> ShelleyTransition -> Bool)
-> Eq ShelleyTransition
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ShelleyTransition -> ShelleyTransition -> Bool
== :: ShelleyTransition -> ShelleyTransition -> Bool
$c/= :: ShelleyTransition -> ShelleyTransition -> Bool
/= :: ShelleyTransition -> ShelleyTransition -> Bool
Eq, Int -> ShelleyTransition -> ShowS
[ShelleyTransition] -> ShowS
ShelleyTransition -> String
(Int -> ShelleyTransition -> ShowS)
-> (ShelleyTransition -> String)
-> ([ShelleyTransition] -> ShowS)
-> Show ShelleyTransition
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ShelleyTransition -> ShowS
showsPrec :: Int -> ShelleyTransition -> ShowS
$cshow :: ShelleyTransition -> String
show :: ShelleyTransition -> String
$cshowList :: [ShelleyTransition] -> ShowS
showList :: [ShelleyTransition] -> ShowS
Show, (forall x. ShelleyTransition -> Rep ShelleyTransition x)
-> (forall x. Rep ShelleyTransition x -> ShelleyTransition)
-> Generic ShelleyTransition
forall x. Rep ShelleyTransition x -> ShelleyTransition
forall x. ShelleyTransition -> Rep ShelleyTransition x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. ShelleyTransition -> Rep ShelleyTransition x
from :: forall x. ShelleyTransition -> Rep ShelleyTransition x
$cto :: forall x. Rep ShelleyTransition x -> ShelleyTransition
to :: forall x. Rep ShelleyTransition x -> ShelleyTransition
Generic)
  deriving newtype Context -> ShelleyTransition -> IO (Maybe ThunkInfo)
Proxy ShelleyTransition -> String
(Context -> ShelleyTransition -> IO (Maybe ThunkInfo))
-> (Context -> ShelleyTransition -> IO (Maybe ThunkInfo))
-> (Proxy ShelleyTransition -> String)
-> NoThunks ShelleyTransition
forall a.
(Context -> a -> IO (Maybe ThunkInfo))
-> (Context -> a -> IO (Maybe ThunkInfo))
-> (Proxy a -> String)
-> NoThunks a
$cnoThunks :: Context -> ShelleyTransition -> IO (Maybe ThunkInfo)
noThunks :: Context -> ShelleyTransition -> IO (Maybe ThunkInfo)
$cwNoThunks :: Context -> ShelleyTransition -> IO (Maybe ThunkInfo)
wNoThunks :: Context -> ShelleyTransition -> IO (Maybe ThunkInfo)
$cshowTypeOf :: Proxy ShelleyTransition -> String
showTypeOf :: Proxy ShelleyTransition -> String
NoThunks

shelleyLedgerTipPoint ::
  LedgerState (ShelleyBlock proto era) mk ->
  Point (ShelleyBlock proto era)
shelleyLedgerTipPoint :: forall proto era (mk :: * -> * -> *).
LedgerState (ShelleyBlock proto era) mk
-> Point (ShelleyBlock proto era)
shelleyLedgerTipPoint = WithOrigin (ShelleyTip proto era) -> Point (ShelleyBlock proto era)
forall proto era.
WithOrigin (ShelleyTip proto era) -> Point (ShelleyBlock proto era)
shelleyTipToPoint (WithOrigin (ShelleyTip proto era)
 -> Point (ShelleyBlock proto era))
-> (LedgerState (ShelleyBlock proto era) mk
    -> WithOrigin (ShelleyTip proto era))
-> LedgerState (ShelleyBlock proto era) mk
-> Point (ShelleyBlock proto era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LedgerState (ShelleyBlock proto era) mk
-> WithOrigin (ShelleyTip proto era)
forall proto era (mk :: * -> * -> *).
LedgerState (ShelleyBlock proto era) mk
-> WithOrigin (ShelleyTip proto era)
shelleyLedgerTip

instance ShelleyCompatible proto era => UpdateLedger (ShelleyBlock proto era)

type instance TxIn (LedgerState (ShelleyBlock proto era)) = SL.TxIn
type instance TxOut (LedgerState (ShelleyBlock proto era)) = Core.TxOut era

instance
  (txout ~ Core.TxOut era, MemPack txout) =>
  IndexedMemPack (LedgerState (ShelleyBlock proto era) EmptyMK) txout
  where
  indexedTypeName :: LedgerState (ShelleyBlock proto era) EmptyMK -> String
indexedTypeName LedgerState (ShelleyBlock proto era) EmptyMK
_ = forall a. MemPack a => String
typeName @txout
  indexedPackedByteCount :: LedgerState (ShelleyBlock proto era) EmptyMK -> txout -> Int
indexedPackedByteCount LedgerState (ShelleyBlock proto era) EmptyMK
_ = txout -> Int
forall a. MemPack a => a -> Int
packedByteCount
  indexedPackM :: forall s.
LedgerState (ShelleyBlock proto era) EmptyMK -> txout -> Pack s ()
indexedPackM LedgerState (ShelleyBlock proto era) EmptyMK
_ = txout -> Pack s ()
forall s. txout -> Pack s ()
forall a s. MemPack a => a -> Pack s ()
packM
  indexedUnpackM :: forall b.
Buffer b =>
LedgerState (ShelleyBlock proto era) EmptyMK -> Unpack b txout
indexedUnpackM LedgerState (ShelleyBlock proto era) EmptyMK
_ = Unpack b txout
forall a b. (MemPack a, Buffer b) => Unpack b a
forall b. Buffer b => Unpack b txout
unpackM

instance
  ShelleyCompatible proto era =>
  SerializeTablesWithHint (LedgerState (ShelleyBlock proto era))
  where
  encodeTablesWithHint :: SerializeTablesHint
  (LedgerTables (LedgerState (ShelleyBlock proto era)) ValuesMK)
-> LedgerTables (LedgerState (ShelleyBlock proto era)) ValuesMK
-> Encoding
encodeTablesWithHint SerializeTablesHint
  (LedgerTables (LedgerState (ShelleyBlock proto era)) ValuesMK)
_ (LedgerTables (ValuesMK Map
  (TxIn (LedgerState (ShelleyBlock proto era)))
  (TxOut (LedgerState (ShelleyBlock proto era)))
tbs)) =
    Version -> Encoding -> Encoding
toPlainEncoding (forall era. Era era => Version
Core.eraProtVerLow @era) (Encoding -> Encoding) -> Encoding -> Encoding
forall a b. (a -> b) -> a -> b
$ (TxIn -> Encoding)
-> (TxOut era -> Encoding) -> Map TxIn (TxOut era) -> Encoding
forall k v.
(k -> Encoding) -> (v -> Encoding) -> Map k v -> Encoding
encodeMap TxIn -> Encoding
forall a. MemPack a => a -> Encoding
encodeMemPack TxOut era -> Encoding
forall a. MemPack a => a -> Encoding
encodeMemPack Map TxIn (TxOut era)
Map
  (TxIn (LedgerState (ShelleyBlock proto era)))
  (TxOut (LedgerState (ShelleyBlock proto era)))
tbs
  decodeTablesWithHint :: forall s.
SerializeTablesHint
  (LedgerTables (LedgerState (ShelleyBlock proto era)) ValuesMK)
-> Decoder
     s (LedgerTables (LedgerState (ShelleyBlock proto era)) ValuesMK)
decodeTablesWithHint SerializeTablesHint
  (LedgerTables (LedgerState (ShelleyBlock proto era)) ValuesMK)
st =
    let certInterns :: Interns (Credential 'Staking)
certInterns =
          Map (Credential 'Staking) UMElem -> Interns (Credential 'Staking)
forall k a. Ord k => Map k a -> Interns k
internsFromMap (Map (Credential 'Staking) UMElem -> Interns (Credential 'Staking))
-> Map (Credential 'Staking) UMElem
-> Interns (Credential 'Staking)
forall a b. (a -> b) -> a -> b
$
            LedgerState (ShelleyBlock proto era) EmptyMK -> NewEpochState era
forall proto era (mk :: * -> * -> *).
LedgerState (ShelleyBlock proto era) mk -> NewEpochState era
shelleyLedgerState SerializeTablesHint
  (LedgerTables (LedgerState (ShelleyBlock proto era)) ValuesMK)
LedgerState (ShelleyBlock proto era) EmptyMK
st
              NewEpochState era
-> Getting
     (Map (Credential 'Staking) UMElem)
     (NewEpochState era)
     (Map (Credential 'Staking) UMElem)
-> Map (Credential 'Staking) UMElem
forall s a. s -> Getting a s a -> a
^. (EpochState era
 -> Const (Map (Credential 'Staking) UMElem) (EpochState era))
-> NewEpochState era
-> Const (Map (Credential 'Staking) UMElem) (NewEpochState era)
forall era (f :: * -> *).
Functor f =>
(EpochState era -> f (EpochState era))
-> NewEpochState era -> f (NewEpochState era)
SL.nesEsL
                ((EpochState era
  -> Const (Map (Credential 'Staking) UMElem) (EpochState era))
 -> NewEpochState era
 -> Const (Map (Credential 'Staking) UMElem) (NewEpochState era))
-> ((Map (Credential 'Staking) UMElem
     -> Const
          (Map (Credential 'Staking) UMElem)
          (Map (Credential 'Staking) UMElem))
    -> EpochState era
    -> Const (Map (Credential 'Staking) UMElem) (EpochState era))
-> Getting
     (Map (Credential 'Staking) UMElem)
     (NewEpochState era)
     (Map (Credential 'Staking) UMElem)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (LedgerState era
 -> Const (Map (Credential 'Staking) UMElem) (LedgerState era))
-> EpochState era
-> Const (Map (Credential 'Staking) UMElem) (EpochState era)
forall era (f :: * -> *).
Functor f =>
(LedgerState era -> f (LedgerState era))
-> EpochState era -> f (EpochState era)
SL.esLStateL
                ((LedgerState era
  -> Const (Map (Credential 'Staking) UMElem) (LedgerState era))
 -> EpochState era
 -> Const (Map (Credential 'Staking) UMElem) (EpochState era))
-> ((Map (Credential 'Staking) UMElem
     -> Const
          (Map (Credential 'Staking) UMElem)
          (Map (Credential 'Staking) UMElem))
    -> LedgerState era
    -> Const (Map (Credential 'Staking) UMElem) (LedgerState era))
-> (Map (Credential 'Staking) UMElem
    -> Const
         (Map (Credential 'Staking) UMElem)
         (Map (Credential 'Staking) UMElem))
-> EpochState era
-> Const (Map (Credential 'Staking) UMElem) (EpochState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (CertState era
 -> Const (Map (Credential 'Staking) UMElem) (CertState era))
-> LedgerState era
-> Const (Map (Credential 'Staking) UMElem) (LedgerState era)
forall era (f :: * -> *).
Functor f =>
(CertState era -> f (CertState era))
-> LedgerState era -> f (LedgerState era)
SL.lsCertStateL
                ((CertState era
  -> Const (Map (Credential 'Staking) UMElem) (CertState era))
 -> LedgerState era
 -> Const (Map (Credential 'Staking) UMElem) (LedgerState era))
-> ((Map (Credential 'Staking) UMElem
     -> Const
          (Map (Credential 'Staking) UMElem)
          (Map (Credential 'Staking) UMElem))
    -> CertState era
    -> Const (Map (Credential 'Staking) UMElem) (CertState era))
-> (Map (Credential 'Staking) UMElem
    -> Const
         (Map (Credential 'Staking) UMElem)
         (Map (Credential 'Staking) UMElem))
-> LedgerState era
-> Const (Map (Credential 'Staking) UMElem) (LedgerState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (DState era
 -> Const (Map (Credential 'Staking) UMElem) (DState era))
-> CertState era
-> Const (Map (Credential 'Staking) UMElem) (CertState era)
forall era. EraCertState era => Lens' (CertState era) (DState era)
Lens' (CertState era) (DState era)
SL.certDStateL
                ((DState era
  -> Const (Map (Credential 'Staking) UMElem) (DState era))
 -> CertState era
 -> Const (Map (Credential 'Staking) UMElem) (CertState era))
-> ((Map (Credential 'Staking) UMElem
     -> Const
          (Map (Credential 'Staking) UMElem)
          (Map (Credential 'Staking) UMElem))
    -> DState era
    -> Const (Map (Credential 'Staking) UMElem) (DState era))
-> (Map (Credential 'Staking) UMElem
    -> Const
         (Map (Credential 'Staking) UMElem)
         (Map (Credential 'Staking) UMElem))
-> CertState era
-> Const (Map (Credential 'Staking) UMElem) (CertState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (UMap -> Const (Map (Credential 'Staking) UMElem) UMap)
-> DState era
-> Const (Map (Credential 'Staking) UMElem) (DState era)
forall era (f :: * -> *).
Functor f =>
(UMap -> f UMap) -> DState era -> f (DState era)
SL.dsUnifiedL
                ((UMap -> Const (Map (Credential 'Staking) UMElem) UMap)
 -> DState era
 -> Const (Map (Credential 'Staking) UMElem) (DState era))
-> ((Map (Credential 'Staking) UMElem
     -> Const
          (Map (Credential 'Staking) UMElem)
          (Map (Credential 'Staking) UMElem))
    -> UMap -> Const (Map (Credential 'Staking) UMElem) UMap)
-> (Map (Credential 'Staking) UMElem
    -> Const
         (Map (Credential 'Staking) UMElem)
         (Map (Credential 'Staking) UMElem))
-> DState era
-> Const (Map (Credential 'Staking) UMElem) (DState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Map (Credential 'Staking) UMElem
 -> Const
      (Map (Credential 'Staking) UMElem)
      (Map (Credential 'Staking) UMElem))
-> UMap -> Const (Map (Credential 'Staking) UMElem) UMap
Lens' UMap (Map (Credential 'Staking) UMElem)
SL.umElemsL
     in ValuesMK TxIn (TxOut era)
-> LedgerTables (LedgerState (ShelleyBlock proto era)) ValuesMK
ValuesMK
  (TxIn (LedgerState (ShelleyBlock proto era)))
  (TxOut (LedgerState (ShelleyBlock proto era)))
-> LedgerTables (LedgerState (ShelleyBlock proto era)) ValuesMK
forall (l :: LedgerStateKind) (mk :: * -> * -> *).
mk (TxIn l) (TxOut l) -> LedgerTables l mk
LedgerTables (ValuesMK TxIn (TxOut era)
 -> LedgerTables (LedgerState (ShelleyBlock proto era)) ValuesMK)
-> (Map TxIn (TxOut era) -> ValuesMK TxIn (TxOut era))
-> Map TxIn (TxOut era)
-> LedgerTables (LedgerState (ShelleyBlock proto era)) ValuesMK
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map TxIn (TxOut era) -> ValuesMK TxIn (TxOut era)
forall k v. Map k v -> ValuesMK k v
ValuesMK (Map TxIn (TxOut era)
 -> LedgerTables (LedgerState (ShelleyBlock proto era)) ValuesMK)
-> Decoder s (Map TxIn (TxOut era))
-> Decoder
     s (LedgerTables (LedgerState (ShelleyBlock proto era)) ValuesMK)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall era t s. Era era => Decoder s t -> Decoder s t
eraDecoder @era (Decoder s (Map TxIn (TxOut era))
 -> Decoder s (Map TxIn (TxOut era)))
-> Decoder s (Map TxIn (TxOut era))
-> Decoder s (Map TxIn (TxOut era))
forall a b. (a -> b) -> a -> b
$ Decoder s TxIn
-> Decoder s (TxOut era) -> Decoder s (Map TxIn (TxOut era))
forall k s v.
Ord k =>
Decoder s k -> Decoder s v -> Decoder s (Map k v)
decodeMap Decoder s TxIn
forall a s. MemPack a => Decoder s a
decodeMemPack (Share (TxOut era) -> Decoder s (TxOut era)
forall a s. DecShareCBOR a => Share a -> Decoder s a
forall s. Share (TxOut era) -> Decoder s (TxOut era)
decShareCBOR Share (TxOut era)
Interns (Credential 'Staking)
certInterns))

instance
  ShelleyBasedEra era =>
  HasLedgerTables (LedgerState (ShelleyBlock proto era))
  where
  projectLedgerTables :: forall (mk :: * -> * -> *).
(CanMapMK mk, CanMapKeysMK mk, ZeroableMK mk) =>
LedgerState (ShelleyBlock proto era) mk
-> LedgerTables (LedgerState (ShelleyBlock proto era)) mk
projectLedgerTables = LedgerState (ShelleyBlock proto era) mk
-> LedgerTables (LedgerState (ShelleyBlock proto era)) mk
forall proto era (mk :: * -> * -> *).
LedgerState (ShelleyBlock proto era) mk
-> LedgerTables (LedgerState (ShelleyBlock proto era)) mk
shelleyLedgerTables
  withLedgerTables :: forall (mk :: * -> * -> *) (any :: * -> * -> *).
(CanMapMK mk, CanMapKeysMK mk, ZeroableMK mk) =>
LedgerState (ShelleyBlock proto era) any
-> LedgerTables (LedgerState (ShelleyBlock proto era)) mk
-> LedgerState (ShelleyBlock proto era) mk
withLedgerTables LedgerState (ShelleyBlock proto era) any
st LedgerTables (LedgerState (ShelleyBlock proto era)) mk
tables =
    ShelleyLedgerState
      { WithOrigin (ShelleyTip proto era)
shelleyLedgerTip :: WithOrigin (ShelleyTip proto era)
shelleyLedgerTip :: WithOrigin (ShelleyTip proto era)
shelleyLedgerTip
      , NewEpochState era
shelleyLedgerState :: NewEpochState era
shelleyLedgerState :: NewEpochState era
shelleyLedgerState
      , ShelleyTransition
shelleyLedgerTransition :: ShelleyTransition
shelleyLedgerTransition :: ShelleyTransition
shelleyLedgerTransition
      , shelleyLedgerTables :: LedgerTables (LedgerState (ShelleyBlock proto era)) mk
shelleyLedgerTables = LedgerTables (LedgerState (ShelleyBlock proto era)) mk
tables
      }
   where
    ShelleyLedgerState
      { WithOrigin (ShelleyTip proto era)
shelleyLedgerTip :: forall proto era (mk :: * -> * -> *).
LedgerState (ShelleyBlock proto era) mk
-> WithOrigin (ShelleyTip proto era)
shelleyLedgerTip :: WithOrigin (ShelleyTip proto era)
shelleyLedgerTip
      , NewEpochState era
shelleyLedgerState :: forall proto era (mk :: * -> * -> *).
LedgerState (ShelleyBlock proto era) mk -> NewEpochState era
shelleyLedgerState :: NewEpochState era
shelleyLedgerState
      , ShelleyTransition
shelleyLedgerTransition :: forall proto era (mk :: * -> * -> *).
LedgerState (ShelleyBlock proto era) mk -> ShelleyTransition
shelleyLedgerTransition :: ShelleyTransition
shelleyLedgerTransition
      } = LedgerState (ShelleyBlock proto era) any
st

instance
  ShelleyBasedEra era =>
  HasLedgerTables (Ticked (LedgerState (ShelleyBlock proto era)))
  where
  projectLedgerTables :: forall (mk :: * -> * -> *).
(CanMapMK mk, CanMapKeysMK mk, ZeroableMK mk) =>
Ticked (LedgerState (ShelleyBlock proto era)) mk
-> LedgerTables (Ticked (LedgerState (ShelleyBlock proto era))) mk
projectLedgerTables = LedgerTables (LedgerState (ShelleyBlock proto era)) mk
-> LedgerTables (Ticked (LedgerState (ShelleyBlock proto era))) mk
forall (l :: LedgerStateKind) (l' :: LedgerStateKind)
       (mk :: * -> * -> *).
SameUtxoTypes l l' =>
LedgerTables l mk -> LedgerTables l' mk
castLedgerTables (LedgerTables (LedgerState (ShelleyBlock proto era)) mk
 -> LedgerTables (Ticked (LedgerState (ShelleyBlock proto era))) mk)
-> (Ticked (LedgerState (ShelleyBlock proto era)) mk
    -> LedgerTables (LedgerState (ShelleyBlock proto era)) mk)
-> Ticked (LedgerState (ShelleyBlock proto era)) mk
-> LedgerTables (Ticked (LedgerState (ShelleyBlock proto era))) mk
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ticked (LedgerState (ShelleyBlock proto era)) mk
-> LedgerTables (LedgerState (ShelleyBlock proto era)) mk
forall proto era (mk :: * -> * -> *).
Ticked (LedgerState (ShelleyBlock proto era)) mk
-> LedgerTables (LedgerState (ShelleyBlock proto era)) mk
tickedShelleyLedgerTables
  withLedgerTables :: forall (mk :: * -> * -> *) (any :: * -> * -> *).
(CanMapMK mk, CanMapKeysMK mk, ZeroableMK mk) =>
Ticked (LedgerState (ShelleyBlock proto era)) any
-> LedgerTables (Ticked (LedgerState (ShelleyBlock proto era))) mk
-> Ticked (LedgerState (ShelleyBlock proto era)) mk
withLedgerTables Ticked (LedgerState (ShelleyBlock proto era)) any
st LedgerTables (Ticked (LedgerState (ShelleyBlock proto era))) mk
tables =
    TickedShelleyLedgerState
      { WithOrigin (ShelleyTip proto era)
untickedShelleyLedgerTip :: WithOrigin (ShelleyTip proto era)
untickedShelleyLedgerTip :: WithOrigin (ShelleyTip proto era)
untickedShelleyLedgerTip
      , ShelleyTransition
tickedShelleyLedgerTransition :: ShelleyTransition
tickedShelleyLedgerTransition :: ShelleyTransition
tickedShelleyLedgerTransition
      , NewEpochState era
tickedShelleyLedgerState :: NewEpochState era
tickedShelleyLedgerState :: NewEpochState era
tickedShelleyLedgerState
      , tickedShelleyLedgerTables :: LedgerTables (LedgerState (ShelleyBlock proto era)) mk
tickedShelleyLedgerTables = LedgerTables (Ticked (LedgerState (ShelleyBlock proto era))) mk
-> LedgerTables (LedgerState (ShelleyBlock proto era)) mk
forall (l :: LedgerStateKind) (l' :: LedgerStateKind)
       (mk :: * -> * -> *).
SameUtxoTypes l l' =>
LedgerTables l mk -> LedgerTables l' mk
castLedgerTables LedgerTables (Ticked (LedgerState (ShelleyBlock proto era))) mk
tables
      }
   where
    TickedShelleyLedgerState
      { WithOrigin (ShelleyTip proto era)
untickedShelleyLedgerTip :: WithOrigin (ShelleyTip proto era)
untickedShelleyLedgerTip :: forall proto era (mk :: * -> * -> *).
Ticked (LedgerState (ShelleyBlock proto era)) mk
-> WithOrigin (ShelleyTip proto era)
untickedShelleyLedgerTip
      , ShelleyTransition
tickedShelleyLedgerTransition :: ShelleyTransition
tickedShelleyLedgerTransition :: forall proto era (mk :: * -> * -> *).
Ticked (LedgerState (ShelleyBlock proto era)) mk
-> ShelleyTransition
tickedShelleyLedgerTransition
      , NewEpochState era
tickedShelleyLedgerState :: NewEpochState era
tickedShelleyLedgerState :: forall proto era (mk :: * -> * -> *).
Ticked (LedgerState (ShelleyBlock proto era)) mk
-> NewEpochState era
tickedShelleyLedgerState
      } = Ticked (LedgerState (ShelleyBlock proto era)) any
st

instance
  ShelleyBasedEra era =>
  CanStowLedgerTables (LedgerState (ShelleyBlock proto era))
  where
  stowLedgerTables :: LedgerState (ShelleyBlock proto era) ValuesMK
-> LedgerState (ShelleyBlock proto era) EmptyMK
stowLedgerTables LedgerState (ShelleyBlock proto era) ValuesMK
st =
    ShelleyLedgerState
      { shelleyLedgerTip :: WithOrigin (ShelleyTip proto era)
shelleyLedgerTip = WithOrigin (ShelleyTip proto era)
shelleyLedgerTip
      , shelleyLedgerState :: NewEpochState era
shelleyLedgerState = NewEpochState era
shelleyLedgerState'
      , shelleyLedgerTransition :: ShelleyTransition
shelleyLedgerTransition = ShelleyTransition
shelleyLedgerTransition
      , shelleyLedgerTables :: LedgerTables (LedgerState (ShelleyBlock proto era)) EmptyMK
shelleyLedgerTables = LedgerTables (LedgerState (ShelleyBlock proto era)) EmptyMK
forall (mk :: * -> * -> *) (l :: LedgerStateKind).
(ZeroableMK mk, LedgerTableConstraints l) =>
LedgerTables l mk
emptyLedgerTables
      }
   where
    (UTxO era
_, NewEpochState era
shelleyLedgerState') = NewEpochState era
shelleyLedgerState NewEpochState era -> UTxO era -> (UTxO era, NewEpochState era)
forall era.
NewEpochState era -> UTxO era -> (UTxO era, NewEpochState era)
`slUtxoL` Map TxIn (TxOut era) -> UTxO era
forall era. Map TxIn (TxOut era) -> UTxO era
SL.UTxO Map TxIn (TxOut era)
m
    ShelleyLedgerState
      { WithOrigin (ShelleyTip proto era)
shelleyLedgerTip :: forall proto era (mk :: * -> * -> *).
LedgerState (ShelleyBlock proto era) mk
-> WithOrigin (ShelleyTip proto era)
shelleyLedgerTip :: WithOrigin (ShelleyTip proto era)
shelleyLedgerTip
      , NewEpochState era
shelleyLedgerState :: forall proto era (mk :: * -> * -> *).
LedgerState (ShelleyBlock proto era) mk -> NewEpochState era
shelleyLedgerState :: NewEpochState era
shelleyLedgerState
      , ShelleyTransition
shelleyLedgerTransition :: forall proto era (mk :: * -> * -> *).
LedgerState (ShelleyBlock proto era) mk -> ShelleyTransition
shelleyLedgerTransition :: ShelleyTransition
shelleyLedgerTransition
      , shelleyLedgerTables :: forall proto era (mk :: * -> * -> *).
LedgerState (ShelleyBlock proto era) mk
-> LedgerTables (LedgerState (ShelleyBlock proto era)) mk
shelleyLedgerTables = LedgerTables (ValuesMK Map TxIn (TxOut era)
m)
      } = LedgerState (ShelleyBlock proto era) ValuesMK
st
  unstowLedgerTables :: LedgerState (ShelleyBlock proto era) EmptyMK
-> LedgerState (ShelleyBlock proto era) ValuesMK
unstowLedgerTables LedgerState (ShelleyBlock proto era) EmptyMK
st =
    ShelleyLedgerState
      { shelleyLedgerTip :: WithOrigin (ShelleyTip proto era)
shelleyLedgerTip = WithOrigin (ShelleyTip proto era)
shelleyLedgerTip
      , shelleyLedgerState :: NewEpochState era
shelleyLedgerState = NewEpochState era
shelleyLedgerState'
      , shelleyLedgerTransition :: ShelleyTransition
shelleyLedgerTransition = ShelleyTransition
shelleyLedgerTransition
      , shelleyLedgerTables :: LedgerTables (LedgerState (ShelleyBlock proto era)) ValuesMK
shelleyLedgerTables = ValuesMK
  (TxIn (LedgerState (ShelleyBlock proto era)))
  (TxOut (LedgerState (ShelleyBlock proto era)))
-> LedgerTables (LedgerState (ShelleyBlock proto era)) ValuesMK
forall (l :: LedgerStateKind) (mk :: * -> * -> *).
mk (TxIn l) (TxOut l) -> LedgerTables l mk
LedgerTables (Map TxIn (TxOut era) -> ValuesMK TxIn (TxOut era)
forall k v. Map k v -> ValuesMK k v
ValuesMK (UTxO era -> Map TxIn (TxOut era)
forall era. UTxO era -> Map TxIn (TxOut era)
SL.unUTxO UTxO era
tbs))
      }
   where
    (UTxO era
tbs, NewEpochState era
shelleyLedgerState') = NewEpochState era
shelleyLedgerState NewEpochState era -> UTxO era -> (UTxO era, NewEpochState era)
forall era.
NewEpochState era -> UTxO era -> (UTxO era, NewEpochState era)
`slUtxoL` UTxO era
forall a. Monoid a => a
mempty
    ShelleyLedgerState
      { WithOrigin (ShelleyTip proto era)
shelleyLedgerTip :: forall proto era (mk :: * -> * -> *).
LedgerState (ShelleyBlock proto era) mk
-> WithOrigin (ShelleyTip proto era)
shelleyLedgerTip :: WithOrigin (ShelleyTip proto era)
shelleyLedgerTip
      , NewEpochState era
shelleyLedgerState :: forall proto era (mk :: * -> * -> *).
LedgerState (ShelleyBlock proto era) mk -> NewEpochState era
shelleyLedgerState :: NewEpochState era
shelleyLedgerState
      , ShelleyTransition
shelleyLedgerTransition :: forall proto era (mk :: * -> * -> *).
LedgerState (ShelleyBlock proto era) mk -> ShelleyTransition
shelleyLedgerTransition :: ShelleyTransition
shelleyLedgerTransition
      } = LedgerState (ShelleyBlock proto era) EmptyMK
st

instance
  ShelleyBasedEra era =>
  CanStowLedgerTables (Ticked (LedgerState (ShelleyBlock proto era)))
  where
  stowLedgerTables :: Ticked (LedgerState (ShelleyBlock proto era)) ValuesMK
-> Ticked (LedgerState (ShelleyBlock proto era)) EmptyMK
stowLedgerTables Ticked (LedgerState (ShelleyBlock proto era)) ValuesMK
st =
    TickedShelleyLedgerState
      { untickedShelleyLedgerTip :: WithOrigin (ShelleyTip proto era)
untickedShelleyLedgerTip = WithOrigin (ShelleyTip proto era)
untickedShelleyLedgerTip
      , tickedShelleyLedgerTransition :: ShelleyTransition
tickedShelleyLedgerTransition = ShelleyTransition
tickedShelleyLedgerTransition
      , tickedShelleyLedgerState :: NewEpochState era
tickedShelleyLedgerState = NewEpochState era
tickedShelleyLedgerState'
      , tickedShelleyLedgerTables :: LedgerTables (LedgerState (ShelleyBlock proto era)) EmptyMK
tickedShelleyLedgerTables = LedgerTables (LedgerState (ShelleyBlock proto era)) EmptyMK
forall (mk :: * -> * -> *) (l :: LedgerStateKind).
(ZeroableMK mk, LedgerTableConstraints l) =>
LedgerTables l mk
emptyLedgerTables
      }
   where
    (UTxO era
_, NewEpochState era
tickedShelleyLedgerState') =
      NewEpochState era
tickedShelleyLedgerState NewEpochState era -> UTxO era -> (UTxO era, NewEpochState era)
forall era.
NewEpochState era -> UTxO era -> (UTxO era, NewEpochState era)
`slUtxoL` Map TxIn (TxOut era) -> UTxO era
forall era. Map TxIn (TxOut era) -> UTxO era
SL.UTxO Map TxIn (TxOut era)
tbs
    TickedShelleyLedgerState
      { WithOrigin (ShelleyTip proto era)
untickedShelleyLedgerTip :: forall proto era (mk :: * -> * -> *).
Ticked (LedgerState (ShelleyBlock proto era)) mk
-> WithOrigin (ShelleyTip proto era)
untickedShelleyLedgerTip :: WithOrigin (ShelleyTip proto era)
untickedShelleyLedgerTip
      , ShelleyTransition
tickedShelleyLedgerTransition :: forall proto era (mk :: * -> * -> *).
Ticked (LedgerState (ShelleyBlock proto era)) mk
-> ShelleyTransition
tickedShelleyLedgerTransition :: ShelleyTransition
tickedShelleyLedgerTransition
      , NewEpochState era
tickedShelleyLedgerState :: forall proto era (mk :: * -> * -> *).
Ticked (LedgerState (ShelleyBlock proto era)) mk
-> NewEpochState era
tickedShelleyLedgerState :: NewEpochState era
tickedShelleyLedgerState
      , tickedShelleyLedgerTables :: forall proto era (mk :: * -> * -> *).
Ticked (LedgerState (ShelleyBlock proto era)) mk
-> LedgerTables (LedgerState (ShelleyBlock proto era)) mk
tickedShelleyLedgerTables = LedgerTables (ValuesMK Map TxIn (TxOut era)
tbs)
      } = Ticked (LedgerState (ShelleyBlock proto era)) ValuesMK
st

  unstowLedgerTables :: Ticked (LedgerState (ShelleyBlock proto era)) EmptyMK
-> Ticked (LedgerState (ShelleyBlock proto era)) ValuesMK
unstowLedgerTables Ticked (LedgerState (ShelleyBlock proto era)) EmptyMK
st =
    TickedShelleyLedgerState
      { untickedShelleyLedgerTip :: WithOrigin (ShelleyTip proto era)
untickedShelleyLedgerTip = WithOrigin (ShelleyTip proto era)
untickedShelleyLedgerTip
      , tickedShelleyLedgerTransition :: ShelleyTransition
tickedShelleyLedgerTransition = ShelleyTransition
tickedShelleyLedgerTransition
      , tickedShelleyLedgerState :: NewEpochState era
tickedShelleyLedgerState = NewEpochState era
tickedShelleyLedgerState'
      , tickedShelleyLedgerTables :: LedgerTables (LedgerState (ShelleyBlock proto era)) ValuesMK
tickedShelleyLedgerTables = ValuesMK
  (TxIn (LedgerState (ShelleyBlock proto era)))
  (TxOut (LedgerState (ShelleyBlock proto era)))
-> LedgerTables (LedgerState (ShelleyBlock proto era)) ValuesMK
forall (l :: LedgerStateKind) (mk :: * -> * -> *).
mk (TxIn l) (TxOut l) -> LedgerTables l mk
LedgerTables (Map TxIn (TxOut era) -> ValuesMK TxIn (TxOut era)
forall k v. Map k v -> ValuesMK k v
ValuesMK (UTxO era -> Map TxIn (TxOut era)
forall era. UTxO era -> Map TxIn (TxOut era)
SL.unUTxO UTxO era
tbs))
      }
   where
    (UTxO era
tbs, NewEpochState era
tickedShelleyLedgerState') = NewEpochState era
tickedShelleyLedgerState NewEpochState era -> UTxO era -> (UTxO era, NewEpochState era)
forall era.
NewEpochState era -> UTxO era -> (UTxO era, NewEpochState era)
`slUtxoL` UTxO era
forall a. Monoid a => a
mempty
    TickedShelleyLedgerState
      { WithOrigin (ShelleyTip proto era)
untickedShelleyLedgerTip :: forall proto era (mk :: * -> * -> *).
Ticked (LedgerState (ShelleyBlock proto era)) mk
-> WithOrigin (ShelleyTip proto era)
untickedShelleyLedgerTip :: WithOrigin (ShelleyTip proto era)
untickedShelleyLedgerTip
      , ShelleyTransition
tickedShelleyLedgerTransition :: forall proto era (mk :: * -> * -> *).
Ticked (LedgerState (ShelleyBlock proto era)) mk
-> ShelleyTransition
tickedShelleyLedgerTransition :: ShelleyTransition
tickedShelleyLedgerTransition
      , NewEpochState era
tickedShelleyLedgerState :: forall proto era (mk :: * -> * -> *).
Ticked (LedgerState (ShelleyBlock proto era)) mk
-> NewEpochState era
tickedShelleyLedgerState :: NewEpochState era
tickedShelleyLedgerState
      } = Ticked (LedgerState (ShelleyBlock proto era)) EmptyMK
st

slUtxoL :: SL.NewEpochState era -> SL.UTxO era -> (SL.UTxO era, SL.NewEpochState era)
slUtxoL :: forall era.
NewEpochState era -> UTxO era -> (UTxO era, NewEpochState era)
slUtxoL NewEpochState era
st UTxO era
vals =
  NewEpochState era
st
    NewEpochState era
-> (NewEpochState era -> (UTxO era, NewEpochState era))
-> (UTxO era, NewEpochState era)
forall a b. a -> (a -> b) -> b
& (EpochState era -> (UTxO era, EpochState era))
-> NewEpochState era -> (UTxO era, NewEpochState era)
forall era (f :: * -> *).
Functor f =>
(EpochState era -> f (EpochState era))
-> NewEpochState era -> f (NewEpochState era)
SL.nesEsL
      ((EpochState era -> (UTxO era, EpochState era))
 -> NewEpochState era -> (UTxO era, NewEpochState era))
-> ((UTxO era -> (UTxO era, UTxO era))
    -> EpochState era -> (UTxO era, EpochState era))
-> (UTxO era -> (UTxO era, UTxO era))
-> NewEpochState era
-> (UTxO era, NewEpochState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (LedgerState era -> (UTxO era, LedgerState era))
-> EpochState era -> (UTxO era, EpochState era)
forall era (f :: * -> *).
Functor f =>
(LedgerState era -> f (LedgerState era))
-> EpochState era -> f (EpochState era)
SL.esLStateL
      ((LedgerState era -> (UTxO era, LedgerState era))
 -> EpochState era -> (UTxO era, EpochState era))
-> ((UTxO era -> (UTxO era, UTxO era))
    -> LedgerState era -> (UTxO era, LedgerState era))
-> (UTxO era -> (UTxO era, UTxO era))
-> EpochState era
-> (UTxO era, EpochState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (UTxOState era -> (UTxO era, UTxOState era))
-> LedgerState era -> (UTxO era, LedgerState era)
forall era (f :: * -> *).
Functor f =>
(UTxOState era -> f (UTxOState era))
-> LedgerState era -> f (LedgerState era)
SL.lsUTxOStateL
      ((UTxOState era -> (UTxO era, UTxOState era))
 -> LedgerState era -> (UTxO era, LedgerState era))
-> ((UTxO era -> (UTxO era, UTxO era))
    -> UTxOState era -> (UTxO era, UTxOState era))
-> (UTxO era -> (UTxO era, UTxO era))
-> LedgerState era
-> (UTxO era, LedgerState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (UTxO era -> (UTxO era, UTxO era))
-> UTxOState era -> (UTxO era, UTxOState era)
forall era. Lens' (UTxOState era) (UTxO era)
forall (t :: * -> *) era. CanSetUTxO t => Lens' (t era) (UTxO era)
SL.utxoL
      ((UTxO era -> (UTxO era, UTxO era))
 -> NewEpochState era -> (UTxO era, NewEpochState era))
-> UTxO era -> NewEpochState era -> (UTxO era, NewEpochState era)
forall a s t b. LensLike ((,) a) s t a b -> b -> s -> (a, t)
<<.~ UTxO era
vals

{-------------------------------------------------------------------------------
  GetTip
-------------------------------------------------------------------------------}

instance GetTip (LedgerState (ShelleyBlock proto era)) where
  getTip :: forall (mk :: * -> * -> *).
LedgerState (ShelleyBlock proto era) mk
-> Point (LedgerState (ShelleyBlock proto era))
getTip = Point (ShelleyBlock proto era)
-> Point (LedgerState (ShelleyBlock proto era))
forall {k1} {k2} (b :: k1) (b' :: k2).
Coercible (HeaderHash b) (HeaderHash b') =>
Point b -> Point b'
castPoint (Point (ShelleyBlock proto era)
 -> Point (LedgerState (ShelleyBlock proto era)))
-> (LedgerState (ShelleyBlock proto era) mk
    -> Point (ShelleyBlock proto era))
-> LedgerState (ShelleyBlock proto era) mk
-> Point (LedgerState (ShelleyBlock proto era))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LedgerState (ShelleyBlock proto era) mk
-> Point (ShelleyBlock proto era)
forall proto era (mk :: * -> * -> *).
LedgerState (ShelleyBlock proto era) mk
-> Point (ShelleyBlock proto era)
shelleyLedgerTipPoint

instance GetTip (Ticked (LedgerState (ShelleyBlock proto era))) where
  getTip :: forall (mk :: * -> * -> *).
Ticked (LedgerState (ShelleyBlock proto era)) mk
-> Point (Ticked (LedgerState (ShelleyBlock proto era)))
getTip = Point (ShelleyBlock proto era)
-> Point (Ticked (LedgerState (ShelleyBlock proto era)))
forall {k1} {k2} (b :: k1) (b' :: k2).
Coercible (HeaderHash b) (HeaderHash b') =>
Point b -> Point b'
castPoint (Point (ShelleyBlock proto era)
 -> Point (Ticked (LedgerState (ShelleyBlock proto era))))
-> (Ticked (LedgerState (ShelleyBlock proto era)) mk
    -> Point (ShelleyBlock proto era))
-> Ticked (LedgerState (ShelleyBlock proto era)) mk
-> Point (Ticked (LedgerState (ShelleyBlock proto era)))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ticked (LedgerState (ShelleyBlock proto era)) mk
-> Point (ShelleyBlock proto era)
forall proto era (mk :: * -> * -> *).
TickedLedgerState (ShelleyBlock proto era) mk
-> Point (ShelleyBlock proto era)
untickedShelleyLedgerTipPoint

{-------------------------------------------------------------------------------
  Ticking
-------------------------------------------------------------------------------}

-- | Ticking only affects the state itself
data instance Ticked (LedgerState (ShelleyBlock proto era)) mk = TickedShelleyLedgerState
  { forall proto era (mk :: * -> * -> *).
Ticked (LedgerState (ShelleyBlock proto era)) mk
-> WithOrigin (ShelleyTip proto era)
untickedShelleyLedgerTip :: !(WithOrigin (ShelleyTip proto era))
  , forall proto era (mk :: * -> * -> *).
Ticked (LedgerState (ShelleyBlock proto era)) mk
-> ShelleyTransition
tickedShelleyLedgerTransition :: !ShelleyTransition
  -- ^ We are counting blocks within an epoch, this means:
  --
  -- 1. We are only incrementing this when /applying/ a block, not when ticking.
  -- 2. However, we count within an epoch, which is slot-based. So the count
  --    must be reset when /ticking/, not when applying a block.
  , forall proto era (mk :: * -> * -> *).
Ticked (LedgerState (ShelleyBlock proto era)) mk
-> NewEpochState era
tickedShelleyLedgerState :: !(SL.NewEpochState era)
  , forall proto era (mk :: * -> * -> *).
Ticked (LedgerState (ShelleyBlock proto era)) mk
-> LedgerTables (LedgerState (ShelleyBlock proto era)) mk
tickedShelleyLedgerTables ::
      !(LedgerTables (LedgerState (ShelleyBlock proto era)) mk)
  }
  deriving (forall x.
 Ticked (LedgerState (ShelleyBlock proto era)) mk
 -> Rep (Ticked (LedgerState (ShelleyBlock proto era)) mk) x)
-> (forall x.
    Rep (Ticked (LedgerState (ShelleyBlock proto era)) mk) x
    -> Ticked (LedgerState (ShelleyBlock proto era)) mk)
-> Generic (Ticked (LedgerState (ShelleyBlock proto era)) mk)
forall x.
Rep (Ticked (LedgerState (ShelleyBlock proto era)) mk) x
-> Ticked (LedgerState (ShelleyBlock proto era)) mk
forall x.
Ticked (LedgerState (ShelleyBlock proto era)) mk
-> Rep (Ticked (LedgerState (ShelleyBlock proto era)) mk) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall proto era (mk :: * -> * -> *) x.
Rep (Ticked (LedgerState (ShelleyBlock proto era)) mk) x
-> Ticked (LedgerState (ShelleyBlock proto era)) mk
forall proto era (mk :: * -> * -> *) x.
Ticked (LedgerState (ShelleyBlock proto era)) mk
-> Rep (Ticked (LedgerState (ShelleyBlock proto era)) mk) x
$cfrom :: forall proto era (mk :: * -> * -> *) x.
Ticked (LedgerState (ShelleyBlock proto era)) mk
-> Rep (Ticked (LedgerState (ShelleyBlock proto era)) mk) x
from :: forall x.
Ticked (LedgerState (ShelleyBlock proto era)) mk
-> Rep (Ticked (LedgerState (ShelleyBlock proto era)) mk) x
$cto :: forall proto era (mk :: * -> * -> *) x.
Rep (Ticked (LedgerState (ShelleyBlock proto era)) mk) x
-> Ticked (LedgerState (ShelleyBlock proto era)) mk
to :: forall x.
Rep (Ticked (LedgerState (ShelleyBlock proto era)) mk) x
-> Ticked (LedgerState (ShelleyBlock proto era)) mk
Generic

untickedShelleyLedgerTipPoint ::
  TickedLedgerState (ShelleyBlock proto era) mk ->
  Point (ShelleyBlock proto era)
untickedShelleyLedgerTipPoint :: forall proto era (mk :: * -> * -> *).
TickedLedgerState (ShelleyBlock proto era) mk
-> Point (ShelleyBlock proto era)
untickedShelleyLedgerTipPoint = WithOrigin (ShelleyTip proto era) -> Point (ShelleyBlock proto era)
forall proto era.
WithOrigin (ShelleyTip proto era) -> Point (ShelleyBlock proto era)
shelleyTipToPoint (WithOrigin (ShelleyTip proto era)
 -> Point (ShelleyBlock proto era))
-> (TickedLedgerState (ShelleyBlock proto era) mk
    -> WithOrigin (ShelleyTip proto era))
-> TickedLedgerState (ShelleyBlock proto era) mk
-> Point (ShelleyBlock proto era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TickedLedgerState (ShelleyBlock proto era) mk
-> WithOrigin (ShelleyTip proto era)
forall proto era (mk :: * -> * -> *).
Ticked (LedgerState (ShelleyBlock proto era)) mk
-> WithOrigin (ShelleyTip proto era)
untickedShelleyLedgerTip

instance ShelleyBasedEra era => IsLedger (LedgerState (ShelleyBlock proto era)) where
  type LedgerErr (LedgerState (ShelleyBlock proto era)) = SL.BlockTransitionError era

  type AuxLedgerEvent (LedgerState (ShelleyBlock proto era)) = ShelleyLedgerEvent era

  applyChainTickLedgerResult :: ComputeLedgerEvents
-> LedgerCfg (LedgerState (ShelleyBlock proto era))
-> SlotNo
-> LedgerState (ShelleyBlock proto era) EmptyMK
-> LedgerResult
     (LedgerState (ShelleyBlock proto era))
     (Ticked (LedgerState (ShelleyBlock proto era)) DiffMK)
applyChainTickLedgerResult
    ComputeLedgerEvents
evs
    LedgerCfg (LedgerState (ShelleyBlock proto era))
cfg
    SlotNo
slotNo
    ShelleyLedgerState
      { WithOrigin (ShelleyTip proto era)
shelleyLedgerTip :: forall proto era (mk :: * -> * -> *).
LedgerState (ShelleyBlock proto era) mk
-> WithOrigin (ShelleyTip proto era)
shelleyLedgerTip :: WithOrigin (ShelleyTip proto era)
shelleyLedgerTip
      , NewEpochState era
shelleyLedgerState :: forall proto era (mk :: * -> * -> *).
LedgerState (ShelleyBlock proto era) mk -> NewEpochState era
shelleyLedgerState :: NewEpochState era
shelleyLedgerState
      , ShelleyTransition
shelleyLedgerTransition :: forall proto era (mk :: * -> * -> *).
LedgerState (ShelleyBlock proto era) mk -> ShelleyTransition
shelleyLedgerTransition :: ShelleyTransition
shelleyLedgerTransition
      } =
      Globals
-> NewEpochState era
-> SlotNo
-> LedgerResult
     (LedgerState (ShelleyBlock proto era)) (NewEpochState era)
appTick Globals
globals NewEpochState era
shelleyLedgerState SlotNo
slotNo LedgerResult
  (LedgerState (ShelleyBlock proto era)) (NewEpochState era)
-> (NewEpochState era
    -> Ticked (LedgerState (ShelleyBlock proto era)) DiffMK)
-> LedgerResult
     (LedgerState (ShelleyBlock proto era))
     (Ticked (LedgerState (ShelleyBlock proto era)) DiffMK)
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \NewEpochState era
l' ->
        TickedShelleyLedgerState
          { untickedShelleyLedgerTip :: WithOrigin (ShelleyTip proto era)
untickedShelleyLedgerTip = WithOrigin (ShelleyTip proto era)
shelleyLedgerTip
          , tickedShelleyLedgerTransition :: ShelleyTransition
tickedShelleyLedgerTransition =
              -- The voting resets each epoch
              if EpochInfo Identity -> WithOrigin SlotNo -> SlotNo -> Bool
isNewEpoch EpochInfo Identity
ei (ShelleyTip proto era -> SlotNo
forall proto era. ShelleyTip proto era -> SlotNo
shelleyTipSlotNo (ShelleyTip proto era -> SlotNo)
-> WithOrigin (ShelleyTip proto era) -> WithOrigin SlotNo
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> WithOrigin (ShelleyTip proto era)
shelleyLedgerTip) SlotNo
slotNo
                then
                  ShelleyTransitionInfo{shelleyAfterVoting :: Word32
shelleyAfterVoting = Word32
0}
                else
                  ShelleyTransition
shelleyLedgerTransition
          , tickedShelleyLedgerState :: NewEpochState era
tickedShelleyLedgerState = NewEpochState era
l'
          , -- The UTxO set is only mutated by block/transaction execution and
            -- era translations, that is why we put empty tables here.
            tickedShelleyLedgerTables :: LedgerTables (LedgerState (ShelleyBlock proto era)) DiffMK
tickedShelleyLedgerTables = LedgerTables (LedgerState (ShelleyBlock proto era)) DiffMK
forall (mk :: * -> * -> *) (l :: LedgerStateKind).
(ZeroableMK mk, LedgerTableConstraints l) =>
LedgerTables l mk
emptyLedgerTables
          }
     where
      globals :: Globals
globals = ShelleyLedgerConfig era -> Globals
forall era. ShelleyLedgerConfig era -> Globals
shelleyLedgerGlobals LedgerCfg (LedgerState (ShelleyBlock proto era))
ShelleyLedgerConfig era
cfg

      ei :: EpochInfo Identity
      ei :: EpochInfo Identity
ei = Globals -> EpochInfo Identity
SL.epochInfoPure Globals
globals

      appTick :: Globals
-> NewEpochState era
-> SlotNo
-> LedgerResult
     (LedgerState (ShelleyBlock proto era)) (NewEpochState era)
appTick =
        (NewEpochState era
 -> [ShelleyLedgerEvent era]
 -> LedgerResult
      (LedgerState (ShelleyBlock proto era)) (NewEpochState era))
-> (NewEpochState era, [ShelleyLedgerEvent era])
-> LedgerResult
     (LedgerState (ShelleyBlock proto era)) (NewEpochState era)
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (([ShelleyLedgerEvent era]
 -> NewEpochState era
 -> LedgerResult
      (LedgerState (ShelleyBlock proto era)) (NewEpochState era))
-> NewEpochState era
-> [ShelleyLedgerEvent era]
-> LedgerResult
     (LedgerState (ShelleyBlock proto era)) (NewEpochState era)
forall a b c. (a -> b -> c) -> b -> a -> c
flip [AuxLedgerEvent (LedgerState (ShelleyBlock proto era))]
-> NewEpochState era
-> LedgerResult
     (LedgerState (ShelleyBlock proto era)) (NewEpochState era)
[ShelleyLedgerEvent era]
-> NewEpochState era
-> LedgerResult
     (LedgerState (ShelleyBlock proto era)) (NewEpochState era)
forall (l :: LedgerStateKind) a.
[AuxLedgerEvent l] -> a -> LedgerResult l a
LedgerResult) ((NewEpochState era, [ShelleyLedgerEvent era])
 -> LedgerResult
      (LedgerState (ShelleyBlock proto era)) (NewEpochState era))
-> (Globals
    -> NewEpochState era
    -> SlotNo
    -> (NewEpochState era, [ShelleyLedgerEvent era]))
-> Globals
-> NewEpochState era
-> SlotNo
-> LedgerResult
     (LedgerState (ShelleyBlock proto era)) (NewEpochState era)
forall y z x0 x1 x2.
(y -> z) -> (x0 -> x1 -> x2 -> y) -> x0 -> x1 -> x2 -> z
..: case ComputeLedgerEvents
evs of
          ComputeLedgerEvents
ComputeLedgerEvents ->
            ([Event (EraRule "TICK" era)] -> [ShelleyLedgerEvent era])
-> (NewEpochState era, [Event (EraRule "TICK" era)])
-> (NewEpochState era, [ShelleyLedgerEvent era])
forall b c d. (b -> c) -> (d, b) -> (d, c)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second ((Event (EraRule "TICK" era) -> ShelleyLedgerEvent era)
-> [Event (EraRule "TICK" era)] -> [ShelleyLedgerEvent era]
forall a b. (a -> b) -> [a] -> [b]
map Event (EraRule "TICK" era) -> ShelleyLedgerEvent era
forall era. Event (EraRule "TICK" era) -> ShelleyLedgerEvent era
ShelleyLedgerEventTICK)
              ((NewEpochState era, [Event (EraRule "TICK" era)])
 -> (NewEpochState era, [ShelleyLedgerEvent era]))
-> (Globals
    -> NewEpochState era
    -> SlotNo
    -> (NewEpochState era, [Event (EraRule "TICK" era)]))
-> Globals
-> NewEpochState era
-> SlotNo
-> (NewEpochState era, [ShelleyLedgerEvent era])
forall y z x0 x1 x2.
(y -> z) -> (x0 -> x1 -> x2 -> y) -> x0 -> x1 -> x2 -> z
..: SingEP 'EventPolicyReturn
-> Globals
-> NewEpochState era
-> SlotNo
-> (NewEpochState era, [Event (EraRule "TICK" era)])
forall era (ep :: EventPolicy).
ApplyBlock era =>
SingEP ep
-> Globals
-> NewEpochState era
-> SlotNo
-> (NewEpochState era, [Event (EraRule "TICK" era)])
forall (ep :: EventPolicy).
SingEP ep
-> Globals
-> NewEpochState era
-> SlotNo
-> (NewEpochState era, [Event (EraRule "TICK" era)])
SL.applyTick SingEP 'EventPolicyReturn
STS.EPReturn
          ComputeLedgerEvents
OmitLedgerEvents ->
            (,[]) (NewEpochState era
 -> (NewEpochState era, [ShelleyLedgerEvent era]))
-> (Globals -> NewEpochState era -> SlotNo -> NewEpochState era)
-> Globals
-> NewEpochState era
-> SlotNo
-> (NewEpochState era, [ShelleyLedgerEvent era])
forall y z x0 x1 x2.
(y -> z) -> (x0 -> x1 -> x2 -> y) -> x0 -> x1 -> x2 -> z
..: Globals -> NewEpochState era -> SlotNo -> NewEpochState era
forall era.
ApplyBlock era =>
Globals -> NewEpochState era -> SlotNo -> NewEpochState era
SL.applyTickNoEvents

-- | All events emitted by the Shelley ledger API
data ShelleyLedgerEvent era
  = -- | An event emitted when (re)applying a block
    ShelleyLedgerEventBBODY (STS.Event (Core.EraRule "BBODY" era))
  | -- | An event emitted during the chain tick
    ShelleyLedgerEventTICK (STS.Event (Core.EraRule "TICK" era))

instance
  ShelleyCompatible proto era =>
  ApplyBlock (LedgerState (ShelleyBlock proto era)) (ShelleyBlock proto era)
  where
  -- Note: in the Shelley ledger, the @CHAIN@ rule is used to apply a whole
  -- block. In consensus, we split up the application of a block to the ledger
  -- into separate steps that are performed together by 'applyExtLedgerState':
  --
  -- + 'applyChainTickLedgerResult': executes the @TICK@ transition
  -- + 'validateHeader':
  --    - 'validateEnvelope': executes the @chainChecks@
  --    - 'updateChainDepState': executes the @PRTCL@ transition
  -- + 'applyBlockLedgerResult': executes the @BBODY@ transition
  --
  applyBlockLedgerResultWithValidation :: HasCallStack =>
ValidationPolicy
-> ComputeLedgerEvents
-> LedgerCfg (LedgerState (ShelleyBlock proto era))
-> ShelleyBlock proto era
-> Ticked (LedgerState (ShelleyBlock proto era)) ValuesMK
-> Except
     (LedgerErr (LedgerState (ShelleyBlock proto era)))
     (LedgerResult
        (LedgerState (ShelleyBlock proto era))
        (LedgerState (ShelleyBlock proto era) DiffMK))
applyBlockLedgerResultWithValidation ValidationPolicy
doValidate ComputeLedgerEvents
evs =
    Either
  (BlockTransitionError era)
  (LedgerResult
     (LedgerState (ShelleyBlock proto era))
     (LedgerState (ShelleyBlock proto era) DiffMK))
-> ExceptT
     (BlockTransitionError era)
     Identity
     (LedgerResult
        (LedgerState (ShelleyBlock proto era))
        (LedgerState (ShelleyBlock proto era) DiffMK))
forall e (m :: * -> *) a. MonadError e m => Either e a -> m a
liftEither (Either
   (BlockTransitionError era)
   (LedgerResult
      (LedgerState (ShelleyBlock proto era))
      (LedgerState (ShelleyBlock proto era) DiffMK))
 -> ExceptT
      (BlockTransitionError era)
      Identity
      (LedgerResult
         (LedgerState (ShelleyBlock proto era))
         (LedgerState (ShelleyBlock proto era) DiffMK)))
-> (ShelleyLedgerConfig era
    -> ShelleyBlock proto era
    -> Ticked (LedgerState (ShelleyBlock proto era)) ValuesMK
    -> Either
         (BlockTransitionError era)
         (LedgerResult
            (LedgerState (ShelleyBlock proto era))
            (LedgerState (ShelleyBlock proto era) DiffMK)))
-> ShelleyLedgerConfig era
-> ShelleyBlock proto era
-> Ticked (LedgerState (ShelleyBlock proto era)) ValuesMK
-> ExceptT
     (BlockTransitionError era)
     Identity
     (LedgerResult
        (LedgerState (ShelleyBlock proto era))
        (LedgerState (ShelleyBlock proto era) DiffMK))
forall y z x0 x1 x2.
(y -> z) -> (x0 -> x1 -> x2 -> y) -> x0 -> x1 -> x2 -> z
..: (Globals
 -> NewEpochState era
 -> Block BHeaderView era
 -> Either
      (BlockTransitionError era)
      (LedgerResult
         (LedgerState (ShelleyBlock proto era)) (NewEpochState era)))
-> LedgerCfg (LedgerState (ShelleyBlock proto era))
-> ShelleyBlock proto era
-> Ticked (LedgerState (ShelleyBlock proto era)) ValuesMK
-> Either
     (BlockTransitionError era)
     (LedgerResult
        (LedgerState (ShelleyBlock proto era))
        (LedgerState (ShelleyBlock proto era) DiffMK))
forall proto era.
ShelleyCompatible proto era =>
(Globals
 -> NewEpochState era
 -> Block BHeaderView era
 -> Either
      (BlockTransitionError era)
      (LedgerResult
         (LedgerState (ShelleyBlock proto era)) (NewEpochState era)))
-> LedgerConfig (ShelleyBlock proto era)
-> ShelleyBlock proto era
-> Ticked (LedgerState (ShelleyBlock proto era)) ValuesMK
-> Either
     (BlockTransitionError era)
     (LedgerResult
        (LedgerState (ShelleyBlock proto era))
        (LedgerState (ShelleyBlock proto era) DiffMK))
applyHelper Globals
-> NewEpochState era
-> Block BHeaderView era
-> Either
     (BlockTransitionError era)
     (LedgerResult
        (LedgerState (ShelleyBlock proto era)) (NewEpochState era))
appBlk
   where
    -- Apply the BBODY transition using the ticked state
    appBlk :: Globals
-> NewEpochState era
-> Block BHeaderView era
-> Either
     (BlockTransitionError era)
     (LedgerResult
        (LedgerState (ShelleyBlock proto era)) (NewEpochState era))
appBlk =
      ((NewEpochState era, [ShelleyLedgerEvent era])
 -> LedgerResult
      (LedgerState (ShelleyBlock proto era)) (NewEpochState era))
-> Either
     (BlockTransitionError era)
     (NewEpochState era, [ShelleyLedgerEvent era])
-> Either
     (BlockTransitionError era)
     (LedgerResult
        (LedgerState (ShelleyBlock proto era)) (NewEpochState era))
forall a b.
(a -> b)
-> Either (BlockTransitionError era) a
-> Either (BlockTransitionError era) b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((NewEpochState era
 -> [ShelleyLedgerEvent era]
 -> LedgerResult
      (LedgerState (ShelleyBlock proto era)) (NewEpochState era))
-> (NewEpochState era, [ShelleyLedgerEvent era])
-> LedgerResult
     (LedgerState (ShelleyBlock proto era)) (NewEpochState era)
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (([ShelleyLedgerEvent era]
 -> NewEpochState era
 -> LedgerResult
      (LedgerState (ShelleyBlock proto era)) (NewEpochState era))
-> NewEpochState era
-> [ShelleyLedgerEvent era]
-> LedgerResult
     (LedgerState (ShelleyBlock proto era)) (NewEpochState era)
forall a b c. (a -> b -> c) -> b -> a -> c
flip [AuxLedgerEvent (LedgerState (ShelleyBlock proto era))]
-> NewEpochState era
-> LedgerResult
     (LedgerState (ShelleyBlock proto era)) (NewEpochState era)
[ShelleyLedgerEvent era]
-> NewEpochState era
-> LedgerResult
     (LedgerState (ShelleyBlock proto era)) (NewEpochState era)
forall (l :: LedgerStateKind) a.
[AuxLedgerEvent l] -> a -> LedgerResult l a
LedgerResult)) (Either
   (BlockTransitionError era)
   (NewEpochState era, [ShelleyLedgerEvent era])
 -> Either
      (BlockTransitionError era)
      (LedgerResult
         (LedgerState (ShelleyBlock proto era)) (NewEpochState era)))
-> (Globals
    -> NewEpochState era
    -> Block BHeaderView era
    -> Either
         (BlockTransitionError era)
         (NewEpochState era, [ShelleyLedgerEvent era]))
-> Globals
-> NewEpochState era
-> Block BHeaderView era
-> Either
     (BlockTransitionError era)
     (LedgerResult
        (LedgerState (ShelleyBlock proto era)) (NewEpochState era))
forall y z x0 x1 x2.
(y -> z) -> (x0 -> x1 -> x2 -> y) -> x0 -> x1 -> x2 -> z
..: case ComputeLedgerEvents
evs of
        ComputeLedgerEvents
ComputeLedgerEvents ->
          ((NewEpochState era, [Event (EraRule "BBODY" era)])
 -> (NewEpochState era, [ShelleyLedgerEvent era]))
-> Either
     (BlockTransitionError era)
     (NewEpochState era, [Event (EraRule "BBODY" era)])
-> Either
     (BlockTransitionError era)
     (NewEpochState era, [ShelleyLedgerEvent era])
forall a b.
(a -> b)
-> Either (BlockTransitionError era) a
-> Either (BlockTransitionError era) b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (([Event (EraRule "BBODY" era)] -> [ShelleyLedgerEvent era])
-> (NewEpochState era, [Event (EraRule "BBODY" era)])
-> (NewEpochState era, [ShelleyLedgerEvent era])
forall b c d. (b -> c) -> (d, b) -> (d, c)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second ((Event (EraRule "BBODY" era) -> ShelleyLedgerEvent era)
-> [Event (EraRule "BBODY" era)] -> [ShelleyLedgerEvent era]
forall a b. (a -> b) -> [a] -> [b]
map Event (EraRule "BBODY" era) -> ShelleyLedgerEvent era
forall era. Event (EraRule "BBODY" era) -> ShelleyLedgerEvent era
ShelleyLedgerEventBBODY))
            (Either
   (BlockTransitionError era)
   (NewEpochState era, [Event (EraRule "BBODY" era)])
 -> Either
      (BlockTransitionError era)
      (NewEpochState era, [ShelleyLedgerEvent era]))
-> (Globals
    -> NewEpochState era
    -> Block BHeaderView era
    -> Either
         (BlockTransitionError era)
         (NewEpochState era, [Event (EraRule "BBODY" era)]))
-> Globals
-> NewEpochState era
-> Block BHeaderView era
-> Either
     (BlockTransitionError era)
     (NewEpochState era, [ShelleyLedgerEvent era])
forall y z x0 x1 x2.
(y -> z) -> (x0 -> x1 -> x2 -> y) -> x0 -> x1 -> x2 -> z
..: SingEP 'EventPolicyReturn
-> ValidationPolicy
-> Globals
-> NewEpochState era
-> Block BHeaderView era
-> Either
     (BlockTransitionError era)
     (NewEpochState era, [Event (EraRule "BBODY" era)])
forall era (ep :: EventPolicy).
ApplyBlock era =>
SingEP ep
-> ValidationPolicy
-> Globals
-> NewEpochState era
-> Block BHeaderView era
-> Either
     (BlockTransitionError era)
     (NewEpochState era, [Event (EraRule "BBODY" era)])
SL.applyBlockEither SingEP 'EventPolicyReturn
STS.EPReturn ValidationPolicy
doValidate
        ComputeLedgerEvents
OmitLedgerEvents ->
          (NewEpochState era
 -> (NewEpochState era, [ShelleyLedgerEvent era]))
-> Either (BlockTransitionError era) (NewEpochState era)
-> Either
     (BlockTransitionError era)
     (NewEpochState era, [ShelleyLedgerEvent era])
forall a b.
(a -> b)
-> Either (BlockTransitionError era) a
-> Either (BlockTransitionError era) b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (,[])
            (Either (BlockTransitionError era) (NewEpochState era)
 -> Either
      (BlockTransitionError era)
      (NewEpochState era, [ShelleyLedgerEvent era]))
-> (Globals
    -> NewEpochState era
    -> Block BHeaderView era
    -> Either (BlockTransitionError era) (NewEpochState era))
-> Globals
-> NewEpochState era
-> Block BHeaderView era
-> Either
     (BlockTransitionError era)
     (NewEpochState era, [ShelleyLedgerEvent era])
forall y z x0 x1 x2.
(y -> z) -> (x0 -> x1 -> x2 -> y) -> x0 -> x1 -> x2 -> z
..: ValidationPolicy
-> Globals
-> NewEpochState era
-> Block BHeaderView era
-> Either (BlockTransitionError era) (NewEpochState era)
forall era.
ApplyBlock era =>
ValidationPolicy
-> Globals
-> NewEpochState era
-> Block BHeaderView era
-> Either (BlockTransitionError era) (NewEpochState era)
SL.applyBlockEitherNoEvents ValidationPolicy
doValidate

  applyBlockLedgerResult :: HasCallStack =>
ComputeLedgerEvents
-> LedgerCfg (LedgerState (ShelleyBlock proto era))
-> ShelleyBlock proto era
-> Ticked (LedgerState (ShelleyBlock proto era)) ValuesMK
-> Except
     (LedgerErr (LedgerState (ShelleyBlock proto era)))
     (LedgerResult
        (LedgerState (ShelleyBlock proto era))
        (LedgerState (ShelleyBlock proto era) DiffMK))
applyBlockLedgerResult = ComputeLedgerEvents
-> LedgerCfg (LedgerState (ShelleyBlock proto era))
-> ShelleyBlock proto era
-> Ticked (LedgerState (ShelleyBlock proto era)) ValuesMK
-> Except
     (LedgerErr (LedgerState (ShelleyBlock proto era)))
     (LedgerResult
        (LedgerState (ShelleyBlock proto era))
        (LedgerState (ShelleyBlock proto era) DiffMK))
forall (l :: LedgerStateKind) blk.
(HasCallStack, ApplyBlock l blk) =>
ComputeLedgerEvents
-> LedgerCfg l
-> blk
-> Ticked l ValuesMK
-> Except (LedgerErr l) (LedgerResult l (l DiffMK))
defaultApplyBlockLedgerResult

  reapplyBlockLedgerResult :: HasCallStack =>
ComputeLedgerEvents
-> LedgerCfg (LedgerState (ShelleyBlock proto era))
-> ShelleyBlock proto era
-> Ticked (LedgerState (ShelleyBlock proto era)) ValuesMK
-> LedgerResult
     (LedgerState (ShelleyBlock proto era))
     (LedgerState (ShelleyBlock proto era) DiffMK)
reapplyBlockLedgerResult =
    (LedgerErr (LedgerState (ShelleyBlock proto era))
 -> LedgerResult
      (LedgerState (ShelleyBlock proto era))
      (LedgerState (ShelleyBlock proto era) DiffMK))
-> ComputeLedgerEvents
-> LedgerCfg (LedgerState (ShelleyBlock proto era))
-> ShelleyBlock proto era
-> Ticked (LedgerState (ShelleyBlock proto era)) ValuesMK
-> LedgerResult
     (LedgerState (ShelleyBlock proto era))
     (LedgerState (ShelleyBlock proto era) DiffMK)
forall (l :: LedgerStateKind) blk.
(HasCallStack, ApplyBlock l blk) =>
(LedgerErr l -> LedgerResult l (l DiffMK))
-> ComputeLedgerEvents
-> LedgerCfg l
-> blk
-> Ticked l ValuesMK
-> LedgerResult l (l DiffMK)
defaultReapplyBlockLedgerResult (\LedgerErr (LedgerState (ShelleyBlock proto era))
err -> ShelleyReapplyException
-> LedgerResult
     (LedgerState (ShelleyBlock proto era))
     (LedgerState (ShelleyBlock proto era) DiffMK)
forall a e. (HasCallStack, Exception e) => e -> a
Exception.throw (ShelleyReapplyException
 -> LedgerResult
      (LedgerState (ShelleyBlock proto era))
      (LedgerState (ShelleyBlock proto era) DiffMK))
-> ShelleyReapplyException
-> LedgerResult
     (LedgerState (ShelleyBlock proto era))
     (LedgerState (ShelleyBlock proto era) DiffMK)
forall a b. (a -> b) -> a -> b
$! forall era.
Show (BlockTransitionError era) =>
BlockTransitionError era -> ShelleyReapplyException
ShelleyReapplyException @era BlockTransitionError era
LedgerErr (LedgerState (ShelleyBlock proto era))
err)

  getBlockKeySets :: ShelleyBlock proto era
-> LedgerTables (LedgerState (ShelleyBlock proto era)) KeysMK
getBlockKeySets =
    KeysMK TxIn (TxOut era)
-> LedgerTables (LedgerState (ShelleyBlock proto era)) KeysMK
KeysMK
  (TxIn (LedgerState (ShelleyBlock proto era)))
  (TxOut (LedgerState (ShelleyBlock proto era)))
-> LedgerTables (LedgerState (ShelleyBlock proto era)) KeysMK
forall (l :: LedgerStateKind) (mk :: * -> * -> *).
mk (TxIn l) (TxOut l) -> LedgerTables l mk
LedgerTables
      (KeysMK TxIn (TxOut era)
 -> LedgerTables (LedgerState (ShelleyBlock proto era)) KeysMK)
-> (ShelleyBlock proto era -> KeysMK TxIn (TxOut era))
-> ShelleyBlock proto era
-> LedgerTables (LedgerState (ShelleyBlock proto era)) KeysMK
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Set TxIn -> KeysMK TxIn (TxOut era)
forall k v. Set k -> KeysMK k v
KeysMK
      (Set TxIn -> KeysMK TxIn (TxOut era))
-> (ShelleyBlock proto era -> Set TxIn)
-> ShelleyBlock proto era
-> KeysMK TxIn (TxOut era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Block (ShelleyProtocolHeader proto) era -> Set TxIn
forall h era. EraSegWits era => Block h era -> Set TxIn
Core.neededTxInsForBlock
      (Block (ShelleyProtocolHeader proto) era -> Set TxIn)
-> (ShelleyBlock proto era
    -> Block (ShelleyProtocolHeader proto) era)
-> ShelleyBlock proto era
-> Set TxIn
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

data ShelleyReapplyException
  = forall era.
    Show (SL.BlockTransitionError era) =>
    ShelleyReapplyException (SL.BlockTransitionError era)

instance Show ShelleyReapplyException where
  show :: ShelleyReapplyException -> String
show (ShelleyReapplyException BlockTransitionError era
err) = String
"(ShelleyReapplyException " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> BlockTransitionError era -> String
forall a. Show a => a -> String
show BlockTransitionError era
err String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
")"

instance Exception.Exception ShelleyReapplyException

applyHelper ::
  forall proto era.
  ShelleyCompatible proto era =>
  ( SL.Globals ->
    SL.NewEpochState era ->
    SL.Block SL.BHeaderView era ->
    Either
      (SL.BlockTransitionError era)
      ( LedgerResult
          (LedgerState (ShelleyBlock proto era))
          (SL.NewEpochState era)
      )
  ) ->
  LedgerConfig (ShelleyBlock proto era) ->
  ShelleyBlock proto era ->
  Ticked (LedgerState (ShelleyBlock proto era)) ValuesMK ->
  Either
    (SL.BlockTransitionError era)
    ( LedgerResult
        (LedgerState (ShelleyBlock proto era))
        (LedgerState (ShelleyBlock proto era) DiffMK)
    )
applyHelper :: forall proto era.
ShelleyCompatible proto era =>
(Globals
 -> NewEpochState era
 -> Block BHeaderView era
 -> Either
      (BlockTransitionError era)
      (LedgerResult
         (LedgerState (ShelleyBlock proto era)) (NewEpochState era)))
-> LedgerConfig (ShelleyBlock proto era)
-> ShelleyBlock proto era
-> Ticked (LedgerState (ShelleyBlock proto era)) ValuesMK
-> Either
     (BlockTransitionError era)
     (LedgerResult
        (LedgerState (ShelleyBlock proto era))
        (LedgerState (ShelleyBlock proto era) DiffMK))
applyHelper Globals
-> NewEpochState era
-> Block BHeaderView era
-> Either
     (BlockTransitionError era)
     (LedgerResult
        (LedgerState (ShelleyBlock proto era)) (NewEpochState era))
f LedgerConfig (ShelleyBlock proto era)
cfg ShelleyBlock proto era
blk Ticked (LedgerState (ShelleyBlock proto era)) ValuesMK
stBefore = do
  let TickedShelleyLedgerState
        { ShelleyTransition
tickedShelleyLedgerTransition :: forall proto era (mk :: * -> * -> *).
Ticked (LedgerState (ShelleyBlock proto era)) mk
-> ShelleyTransition
tickedShelleyLedgerTransition :: ShelleyTransition
tickedShelleyLedgerTransition
        , NewEpochState era
tickedShelleyLedgerState :: forall proto era (mk :: * -> * -> *).
Ticked (LedgerState (ShelleyBlock proto era)) mk
-> NewEpochState era
tickedShelleyLedgerState :: NewEpochState era
tickedShelleyLedgerState
        } = Ticked (LedgerState (ShelleyBlock proto era)) ValuesMK
-> Ticked (LedgerState (ShelleyBlock proto era)) EmptyMK
forall (l :: LedgerStateKind).
CanStowLedgerTables l =>
l ValuesMK -> l EmptyMK
stowLedgerTables Ticked (LedgerState (ShelleyBlock proto era)) ValuesMK
stBefore

  ledgerResult <-
    Globals
-> NewEpochState era
-> Block BHeaderView era
-> Either
     (BlockTransitionError era)
     (LedgerResult
        (LedgerState (ShelleyBlock proto era)) (NewEpochState era))
f
      Globals
globals
      NewEpochState era
tickedShelleyLedgerState
      ( let b :: Block (ShelleyProtocolHeader proto) era
b = ShelleyBlock proto era -> Block (ShelleyProtocolHeader proto) era
forall proto era.
ShelleyBlock proto era -> Block (ShelleyProtocolHeader proto) era
shelleyBlockRaw ShelleyBlock proto era
blk
            h' :: BHeaderView
h' = ShelleyProtocolHeader proto -> BHeaderView
forall proto.
ProtocolHeaderSupportsLedger proto =>
ShelleyProtocolHeader proto -> BHeaderView
mkHeaderView (Block (ShelleyProtocolHeader proto) era
-> ShelleyProtocolHeader proto
forall h era. Block h era -> h
SL.bheader Block (ShelleyProtocolHeader proto) era
b)
         in -- Jared Corduan explains that the " Unsafe " here ultimately only
            -- means the value must not be serialized. We're only passing it to
            -- 'STS.applyBlockOpts', which does not serialize it. So this is a
            -- safe use.
            BHeaderView -> TxSeq era -> Block BHeaderView era
forall h era. h -> TxSeq era -> Block h era
SL.UnsafeUnserialisedBlock BHeaderView
h' (Block (ShelleyProtocolHeader proto) era -> TxSeq era
forall h era. Block h era -> TxSeq era
SL.bbody Block (ShelleyProtocolHeader proto) era
b)
      )

  let track ::
        LedgerState (ShelleyBlock proto era) ValuesMK ->
        LedgerState (ShelleyBlock proto era) TrackingMK
      track = Ticked (LedgerState (ShelleyBlock proto era)) ValuesMK
-> LedgerState (ShelleyBlock proto era) ValuesMK
-> LedgerState (ShelleyBlock proto era) TrackingMK
forall (l :: LedgerStateKind) (l' :: LedgerStateKind).
(SameUtxoTypes l l', HasLedgerTables l, HasLedgerTables l') =>
l ValuesMK -> l' ValuesMK -> l' TrackingMK
calculateDifference Ticked (LedgerState (ShelleyBlock proto era)) ValuesMK
stBefore

  return $
    ledgerResult <&> \NewEpochState era
newNewEpochState ->
      LedgerState (ShelleyBlock proto era) TrackingMK
-> LedgerState (ShelleyBlock proto era) DiffMK
forall (l :: LedgerStateKind).
(HasLedgerTables l, LedgerTableConstraints l) =>
l TrackingMK -> l DiffMK
trackingToDiffs (LedgerState (ShelleyBlock proto era) TrackingMK
 -> LedgerState (ShelleyBlock proto era) DiffMK)
-> LedgerState (ShelleyBlock proto era) TrackingMK
-> LedgerState (ShelleyBlock proto era) DiffMK
forall a b. (a -> b) -> a -> b
$
        LedgerState (ShelleyBlock proto era) ValuesMK
-> LedgerState (ShelleyBlock proto era) TrackingMK
track (LedgerState (ShelleyBlock proto era) ValuesMK
 -> LedgerState (ShelleyBlock proto era) TrackingMK)
-> LedgerState (ShelleyBlock proto era) ValuesMK
-> LedgerState (ShelleyBlock proto era) TrackingMK
forall a b. (a -> b) -> a -> b
$
          LedgerState (ShelleyBlock proto era) EmptyMK
-> LedgerState (ShelleyBlock proto era) ValuesMK
forall (l :: LedgerStateKind).
CanStowLedgerTables l =>
l EmptyMK -> l ValuesMK
unstowLedgerTables (LedgerState (ShelleyBlock proto era) EmptyMK
 -> LedgerState (ShelleyBlock proto era) ValuesMK)
-> LedgerState (ShelleyBlock proto era) EmptyMK
-> LedgerState (ShelleyBlock proto era) ValuesMK
forall a b. (a -> b) -> a -> b
$
            ShelleyLedgerState
              { shelleyLedgerTip :: WithOrigin (ShelleyTip proto era)
shelleyLedgerTip =
                  ShelleyTip proto era -> WithOrigin (ShelleyTip proto era)
forall t. t -> WithOrigin t
NotOrigin
                    ShelleyTip
                      { shelleyTipBlockNo :: BlockNo
shelleyTipBlockNo = ShelleyBlock proto era -> BlockNo
forall b. HasHeader b => b -> BlockNo
blockNo ShelleyBlock proto era
blk
                      , shelleyTipSlotNo :: SlotNo
shelleyTipSlotNo = ShelleyBlock proto era -> SlotNo
forall b. HasHeader b => b -> SlotNo
blockSlot ShelleyBlock proto era
blk
                      , shelleyTipHash :: HeaderHash (ShelleyBlock proto era)
shelleyTipHash = ShelleyBlock proto era -> HeaderHash (ShelleyBlock proto era)
forall b. HasHeader b => b -> HeaderHash b
blockHash ShelleyBlock proto era
blk
                      }
              , shelleyLedgerState :: NewEpochState era
shelleyLedgerState =
                  NewEpochState era
newNewEpochState
              , shelleyLedgerTransition :: ShelleyTransition
shelleyLedgerTransition =
                  ShelleyTransitionInfo
                    { shelleyAfterVoting :: Word32
shelleyAfterVoting =
                        -- We count the number of blocks that have been applied after the
                        -- voting deadline has passed.
                        (if ShelleyBlock proto era -> SlotNo
forall b. HasHeader b => b -> SlotNo
blockSlot ShelleyBlock proto era
blk SlotNo -> SlotNo -> Bool
forall a. Ord a => a -> a -> Bool
>= SlotNo
votingDeadline then Word32 -> Word32
forall a. Enum a => a -> a
succ else Word32 -> Word32
forall a. a -> a
id) (Word32 -> Word32) -> Word32 -> Word32
forall a b. (a -> b) -> a -> b
$
                          ShelleyTransition -> Word32
shelleyAfterVoting ShelleyTransition
tickedShelleyLedgerTransition
                    }
              , shelleyLedgerTables :: LedgerTables (LedgerState (ShelleyBlock proto era)) EmptyMK
shelleyLedgerTables = LedgerTables (LedgerState (ShelleyBlock proto era)) EmptyMK
forall (mk :: * -> * -> *) (l :: LedgerStateKind).
(ZeroableMK mk, LedgerTableConstraints l) =>
LedgerTables l mk
emptyLedgerTables
              }
 where
  globals :: Globals
globals = ShelleyLedgerConfig era -> Globals
forall era. ShelleyLedgerConfig era -> Globals
shelleyLedgerGlobals LedgerConfig (ShelleyBlock proto era)
ShelleyLedgerConfig era
cfg
  swindow :: Word64
swindow = Globals -> Word64
SL.stabilityWindow Globals
globals

  ei :: EpochInfo Identity
  ei :: EpochInfo Identity
ei = Globals -> EpochInfo Identity
SL.epochInfoPure Globals
globals

  -- The start of the next epoch is within the safe zone, always.
  startOfNextEpoch :: SlotNo
  startOfNextEpoch :: SlotNo
startOfNextEpoch = Identity SlotNo -> SlotNo
forall a. Identity a -> a
runIdentity (Identity SlotNo -> SlotNo) -> Identity SlotNo -> SlotNo
forall a b. (a -> b) -> a -> b
$ do
    blockEpoch <- EpochInfo Identity -> SlotNo -> Identity EpochNo
forall (m :: * -> *).
HasCallStack =>
EpochInfo m -> SlotNo -> m EpochNo
epochInfoEpoch EpochInfo Identity
ei (ShelleyBlock proto era -> SlotNo
forall b. HasHeader b => b -> SlotNo
blockSlot ShelleyBlock proto era
blk)
    let nextEpoch = EpochNo -> EpochNo
forall a. Enum a => a -> a
succ EpochNo
blockEpoch
    epochInfoFirst ei nextEpoch

  -- The block must come in strictly before the voting deadline
  -- See Fig 13, "Protocol Parameter Update Inference Rules", of the
  -- Shelley specification.
  votingDeadline :: SlotNo
  votingDeadline :: SlotNo
votingDeadline = Word64 -> SlotNo -> SlotNo
subSlots (Word64
2 Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
* Word64
swindow) SlotNo
startOfNextEpoch

instance HasHardForkHistory (ShelleyBlock proto era) where
  type HardForkIndices (ShelleyBlock proto era) = '[ShelleyBlock proto era]
  hardForkSummary :: forall (mk :: * -> * -> *).
LedgerConfig (ShelleyBlock proto era)
-> LedgerState (ShelleyBlock proto era) mk
-> Summary (HardForkIndices (ShelleyBlock proto era))
hardForkSummary =
    (LedgerConfig (ShelleyBlock proto era) -> EraParams)
-> LedgerConfig (ShelleyBlock proto era)
-> LedgerState (ShelleyBlock proto era) mk
-> Summary '[ShelleyBlock proto era]
forall blk (mk :: * -> * -> *).
(LedgerConfig blk -> EraParams)
-> LedgerConfig blk -> LedgerState blk mk -> Summary '[blk]
neverForksHardForkSummary ((LedgerConfig (ShelleyBlock proto era) -> EraParams)
 -> LedgerConfig (ShelleyBlock proto era)
 -> LedgerState (ShelleyBlock proto era) mk
 -> Summary '[ShelleyBlock proto era])
-> (LedgerConfig (ShelleyBlock proto era) -> EraParams)
-> LedgerConfig (ShelleyBlock proto era)
-> LedgerState (ShelleyBlock proto era) mk
-> Summary '[ShelleyBlock proto era]
forall a b. (a -> b) -> a -> b
$
      ShelleyGenesis -> EraParams
shelleyEraParamsNeverHardForks (ShelleyGenesis -> EraParams)
-> (ShelleyLedgerConfig era -> ShelleyGenesis)
-> ShelleyLedgerConfig era
-> EraParams
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShelleyLedgerConfig era -> ShelleyGenesis
forall era. ShelleyLedgerConfig era -> ShelleyGenesis
shelleyLedgerGenesis

instance
  ShelleyCompatible proto era =>
  CommonProtocolParams (ShelleyBlock proto era)
  where
  maxHeaderSize :: forall (mk :: * -> * -> *).
LedgerState (ShelleyBlock proto era) mk -> Word32
maxHeaderSize = Word16 -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word16 -> Word32)
-> (LedgerState (ShelleyBlock proto era) mk -> Word16)
-> LedgerState (ShelleyBlock proto era) mk
-> Word32
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Getting Word16 (PParams era) Word16 -> PParams era -> Word16
forall a s. Getting a s a -> s -> a
view Getting Word16 (PParams era) Word16
forall era. EraPParams era => Lens' (PParams era) Word16
Lens' (PParams era) Word16
ppMaxBHSizeL (PParams era -> Word16)
-> (LedgerState (ShelleyBlock proto era) mk -> PParams era)
-> LedgerState (ShelleyBlock proto era) mk
-> Word16
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NewEpochState era -> PParams era
forall era. EraGov era => NewEpochState era -> PParams era
getPParams (NewEpochState era -> PParams era)
-> (LedgerState (ShelleyBlock proto era) mk -> NewEpochState era)
-> LedgerState (ShelleyBlock proto era) mk
-> PParams era
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LedgerState (ShelleyBlock proto era) mk -> NewEpochState era
forall proto era (mk :: * -> * -> *).
LedgerState (ShelleyBlock proto era) mk -> NewEpochState era
shelleyLedgerState
  maxTxSize :: forall (mk :: * -> * -> *).
LedgerState (ShelleyBlock proto era) mk -> Word32
maxTxSize = Getting Word32 (PParams era) Word32 -> PParams era -> Word32
forall a s. Getting a s a -> s -> a
view Getting Word32 (PParams era) Word32
forall era. EraPParams era => Lens' (PParams era) Word32
Lens' (PParams era) Word32
ppMaxTxSizeL (PParams era -> Word32)
-> (LedgerState (ShelleyBlock proto era) mk -> PParams era)
-> LedgerState (ShelleyBlock proto era) mk
-> Word32
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NewEpochState era -> PParams era
forall era. EraGov era => NewEpochState era -> PParams era
getPParams (NewEpochState era -> PParams era)
-> (LedgerState (ShelleyBlock proto era) mk -> NewEpochState era)
-> LedgerState (ShelleyBlock proto era) mk
-> PParams era
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LedgerState (ShelleyBlock proto era) mk -> NewEpochState era
forall proto era (mk :: * -> * -> *).
LedgerState (ShelleyBlock proto era) mk -> NewEpochState era
shelleyLedgerState

{-------------------------------------------------------------------------------
  ValidateEnvelope
-------------------------------------------------------------------------------}

instance ShelleyCompatible proto era => BasicEnvelopeValidation (ShelleyBlock proto era)

-- defaults all OK

instance ShelleyCompatible proto era => ValidateEnvelope (ShelleyBlock proto era) where
  type
    OtherHeaderEnvelopeError (ShelleyBlock proto era) =
      EnvelopeCheckError proto

  additionalEnvelopeChecks :: TopLevelConfig (ShelleyBlock proto era)
-> LedgerView (BlockProtocol (ShelleyBlock proto era))
-> Header (ShelleyBlock proto era)
-> Except (OtherHeaderEnvelopeError (ShelleyBlock proto era)) ()
additionalEnvelopeChecks TopLevelConfig (ShelleyBlock proto era)
cfg LedgerView (BlockProtocol (ShelleyBlock proto era))
lv Header (ShelleyBlock proto era)
hdr =
    ConsensusConfig proto
-> LedgerView proto
-> ShelleyProtocolHeader proto
-> Except (EnvelopeCheckError proto) ()
forall proto.
ProtocolHeaderSupportsEnvelope proto =>
ConsensusConfig proto
-> LedgerView proto
-> ShelleyProtocolHeader proto
-> Except (EnvelopeCheckError proto) ()
envelopeChecks (TopLevelConfig (ShelleyBlock proto era)
-> ConsensusConfig (BlockProtocol (ShelleyBlock proto era))
forall blk.
TopLevelConfig blk -> ConsensusConfig (BlockProtocol blk)
configConsensus TopLevelConfig (ShelleyBlock proto era)
cfg) LedgerView proto
LedgerView (BlockProtocol (ShelleyBlock proto era))
lv (Header (ShelleyBlock proto era) -> ShelleyProtocolHeader proto
forall proto era.
Header (ShelleyBlock proto era) -> ShelleyProtocolHeader proto
shelleyHeaderRaw Header (ShelleyBlock proto era)
hdr)

{-------------------------------------------------------------------------------
  Auxiliary
-------------------------------------------------------------------------------}

getPParams :: SL.EraGov era => SL.NewEpochState era -> Core.PParams era
getPParams :: forall era. EraGov era => NewEpochState era -> PParams era
getPParams = Getting (PParams era) (NewEpochState era) (PParams era)
-> NewEpochState era -> PParams era
forall a s. Getting a s a -> s -> a
view (Getting (PParams era) (NewEpochState era) (PParams era)
 -> NewEpochState era -> PParams era)
-> Getting (PParams era) (NewEpochState era) (PParams era)
-> NewEpochState era
-> PParams era
forall a b. (a -> b) -> a -> b
$ (GovState era -> Const (PParams era) (GovState era))
-> NewEpochState era -> Const (PParams era) (NewEpochState era)
forall era (f :: * -> *).
Functor f =>
(GovState era -> f (GovState era))
-> NewEpochState era -> f (NewEpochState era)
SL.newEpochStateGovStateL ((GovState era -> Const (PParams era) (GovState era))
 -> NewEpochState era -> Const (PParams era) (NewEpochState era))
-> ((PParams era -> Const (PParams era) (PParams era))
    -> GovState era -> Const (PParams era) (GovState era))
-> Getting (PParams era) (NewEpochState era) (PParams era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PParams era -> Const (PParams era) (PParams era))
-> GovState era -> Const (PParams era) (GovState era)
forall era. EraGov era => Lens' (GovState era) (PParams era)
Lens' (GovState era) (PParams era)
SL.curPParamsGovStateL

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

-- | Current version
--
-- o 'serialisationFormatVersion0' used to include the 'LedgerViewHistory', but
--   since we had to break binary backwards compatibility of the 'TPraosState',
--   we dropped backwards compatibility with 'serialisationFormatVersion0' too.
-- o 'serialisationFormatVersion1' did not include a 'BlockNo' at the tip of
--   the ledger, which was introduced in version 2. Again, since we broke
--   compat anyway, we dropped support for version 1.
serialisationFormatVersion2 :: VersionNumber
serialisationFormatVersion2 :: VersionNumber
serialisationFormatVersion2 = VersionNumber
2

encodeShelleyAnnTip :: AnnTip (ShelleyBlock proto era) -> Encoding
encodeShelleyAnnTip :: forall proto era. AnnTip (ShelleyBlock proto era) -> Encoding
encodeShelleyAnnTip = (HeaderHash (ShelleyBlock proto era) -> Encoding)
-> AnnTip (ShelleyBlock proto era) -> Encoding
forall blk.
(TipInfo blk ~ HeaderHash blk) =>
(HeaderHash blk -> Encoding) -> AnnTip blk -> Encoding
defaultEncodeAnnTip HeaderHash (ShelleyBlock proto era) -> Encoding
ShelleyHash -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR

decodeShelleyAnnTip :: Decoder s (AnnTip (ShelleyBlock proto era))
decodeShelleyAnnTip :: forall s proto era. Decoder s (AnnTip (ShelleyBlock proto era))
decodeShelleyAnnTip = (forall s. Decoder s (HeaderHash (ShelleyBlock proto era)))
-> forall s. Decoder s (AnnTip (ShelleyBlock proto era))
forall blk.
(TipInfo blk ~ HeaderHash blk) =>
(forall s. Decoder s (HeaderHash blk))
-> forall s. Decoder s (AnnTip blk)
defaultDecodeAnnTip Decoder s (HeaderHash (ShelleyBlock proto era))
Decoder s ShelleyHash
forall s. Decoder s (HeaderHash (ShelleyBlock proto era))
forall s. Decoder s ShelleyHash
forall a s. FromCBOR a => Decoder s a
fromCBOR

encodeShelleyHeaderState ::
  ShelleyCompatible proto era =>
  HeaderState (ShelleyBlock proto era) ->
  Encoding
encodeShelleyHeaderState :: forall proto era.
ShelleyCompatible proto era =>
HeaderState (ShelleyBlock proto era) -> Encoding
encodeShelleyHeaderState =
  (ChainDepState (BlockProtocol (ShelleyBlock proto era))
 -> Encoding)
-> (AnnTip (ShelleyBlock proto era) -> Encoding)
-> HeaderState (ShelleyBlock proto era)
-> Encoding
forall blk.
(ChainDepState (BlockProtocol blk) -> Encoding)
-> (AnnTip blk -> Encoding) -> HeaderState blk -> Encoding
encodeHeaderState
    ChainDepState proto -> Encoding
ChainDepState (BlockProtocol (ShelleyBlock proto era)) -> Encoding
forall a. Serialise a => a -> Encoding
encode
    AnnTip (ShelleyBlock proto era) -> Encoding
forall proto era. AnnTip (ShelleyBlock proto era) -> Encoding
encodeShelleyAnnTip

encodeShelleyTip :: ShelleyTip proto era -> Encoding
encodeShelleyTip :: forall proto era. ShelleyTip proto era -> Encoding
encodeShelleyTip
  ShelleyTip
    { SlotNo
shelleyTipSlotNo :: forall proto era. ShelleyTip proto era -> SlotNo
shelleyTipSlotNo :: SlotNo
shelleyTipSlotNo
    , BlockNo
shelleyTipBlockNo :: forall proto era. ShelleyTip proto era -> BlockNo
shelleyTipBlockNo :: BlockNo
shelleyTipBlockNo
    , HeaderHash (ShelleyBlock proto era)
shelleyTipHash :: forall proto era.
ShelleyTip proto era -> HeaderHash (ShelleyBlock proto era)
shelleyTipHash :: HeaderHash (ShelleyBlock proto era)
shelleyTipHash
    } =
    [Encoding] -> Encoding
forall a. Monoid a => [a] -> a
mconcat
      [ Word -> Encoding
CBOR.encodeListLen Word
3
      , SlotNo -> Encoding
forall a. Serialise a => a -> Encoding
encode SlotNo
shelleyTipSlotNo
      , BlockNo -> Encoding
forall a. Serialise a => a -> Encoding
encode BlockNo
shelleyTipBlockNo
      , ShelleyHash -> Encoding
forall a. Serialise a => a -> Encoding
encode HeaderHash (ShelleyBlock proto era)
ShelleyHash
shelleyTipHash
      ]

decodeShelleyTip :: Decoder s (ShelleyTip proto era)
decodeShelleyTip :: forall s proto era. Decoder s (ShelleyTip proto era)
decodeShelleyTip = do
  Text -> Int -> Decoder s ()
forall s. Text -> Int -> Decoder s ()
enforceSize Text
"ShelleyTip" Int
3
  shelleyTipSlotNo <- Decoder s SlotNo
forall s. Decoder s SlotNo
forall a s. Serialise a => Decoder s a
decode
  shelleyTipBlockNo <- decode
  shelleyTipHash <- decode
  return
    ShelleyTip
      { shelleyTipSlotNo
      , shelleyTipBlockNo
      , shelleyTipHash
      }

encodeShelleyTransition :: ShelleyTransition -> Encoding
encodeShelleyTransition :: ShelleyTransition -> Encoding
encodeShelleyTransition ShelleyTransitionInfo{Word32
shelleyAfterVoting :: ShelleyTransition -> Word32
shelleyAfterVoting :: Word32
shelleyAfterVoting} =
  [Encoding] -> Encoding
forall a. Monoid a => [a] -> a
mconcat
    [ Word32 -> Encoding
CBOR.encodeWord32 Word32
shelleyAfterVoting
    ]

decodeShelleyTransition :: Decoder s ShelleyTransition
decodeShelleyTransition :: forall s. Decoder s ShelleyTransition
decodeShelleyTransition = do
  shelleyAfterVoting <- Decoder s Word32
forall s. Decoder s Word32
CBOR.decodeWord32
  return ShelleyTransitionInfo{shelleyAfterVoting}

encodeShelleyLedgerState ::
  ShelleyCompatible proto era =>
  LedgerState (ShelleyBlock proto era) EmptyMK ->
  Encoding
encodeShelleyLedgerState :: forall proto era.
ShelleyCompatible proto era =>
LedgerState (ShelleyBlock proto era) EmptyMK -> Encoding
encodeShelleyLedgerState
  ShelleyLedgerState
    { WithOrigin (ShelleyTip proto era)
shelleyLedgerTip :: forall proto era (mk :: * -> * -> *).
LedgerState (ShelleyBlock proto era) mk
-> WithOrigin (ShelleyTip proto era)
shelleyLedgerTip :: WithOrigin (ShelleyTip proto era)
shelleyLedgerTip
    , NewEpochState era
shelleyLedgerState :: forall proto era (mk :: * -> * -> *).
LedgerState (ShelleyBlock proto era) mk -> NewEpochState era
shelleyLedgerState :: NewEpochState era
shelleyLedgerState
    , ShelleyTransition
shelleyLedgerTransition :: forall proto era (mk :: * -> * -> *).
LedgerState (ShelleyBlock proto era) mk -> ShelleyTransition
shelleyLedgerTransition :: ShelleyTransition
shelleyLedgerTransition
    } =
    VersionNumber -> Encoding -> Encoding
encodeVersion VersionNumber
serialisationFormatVersion2 (Encoding -> Encoding) -> Encoding -> Encoding
forall a b. (a -> b) -> a -> b
$
      [Encoding] -> Encoding
forall a. Monoid a => [a] -> a
mconcat
        [ Word -> Encoding
CBOR.encodeListLen Word
3
        , (ShelleyTip proto era -> Encoding)
-> WithOrigin (ShelleyTip proto era) -> Encoding
forall a. (a -> Encoding) -> WithOrigin a -> Encoding
encodeWithOrigin ShelleyTip proto era -> Encoding
forall proto era. ShelleyTip proto era -> Encoding
encodeShelleyTip WithOrigin (ShelleyTip proto era)
shelleyLedgerTip
        , NewEpochState era -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR NewEpochState era
shelleyLedgerState
        , ShelleyTransition -> Encoding
encodeShelleyTransition ShelleyTransition
shelleyLedgerTransition
        ]

decodeShelleyLedgerState ::
  forall era proto s.
  ShelleyCompatible proto era =>
  Decoder s (LedgerState (ShelleyBlock proto era) EmptyMK)
decodeShelleyLedgerState :: forall era proto s.
ShelleyCompatible proto era =>
Decoder s (LedgerState (ShelleyBlock proto era) EmptyMK)
decodeShelleyLedgerState =
  [(VersionNumber,
  VersionDecoder (LedgerState (ShelleyBlock proto era) EmptyMK))]
-> forall s.
   Decoder s (LedgerState (ShelleyBlock proto era) EmptyMK)
forall a.
[(VersionNumber, VersionDecoder a)] -> forall s. Decoder s a
decodeVersion
    [ (VersionNumber
serialisationFormatVersion2, (forall s.
 Decoder s (LedgerState (ShelleyBlock proto era) EmptyMK))
-> VersionDecoder (LedgerState (ShelleyBlock proto era) EmptyMK)
forall a. (forall s. Decoder s a) -> VersionDecoder a
Decode Decoder s (LedgerState (ShelleyBlock proto era) EmptyMK)
forall s. Decoder s (LedgerState (ShelleyBlock proto era) EmptyMK)
decodeShelleyLedgerState2)
    ]
 where
  decodeShelleyLedgerState2 :: Decoder s' (LedgerState (ShelleyBlock proto era) EmptyMK)
  decodeShelleyLedgerState2 :: forall s. Decoder s (LedgerState (ShelleyBlock proto era) EmptyMK)
decodeShelleyLedgerState2 = do
    Text -> Int -> Decoder s' ()
forall s. Text -> Int -> Decoder s ()
enforceSize Text
"LedgerState ShelleyBlock" Int
3
    shelleyLedgerTip <- Decoder s' (ShelleyTip proto era)
-> Decoder s' (WithOrigin (ShelleyTip proto era))
forall s a. Decoder s a -> Decoder s (WithOrigin a)
decodeWithOrigin Decoder s' (ShelleyTip proto era)
forall s proto era. Decoder s (ShelleyTip proto era)
decodeShelleyTip
    shelleyLedgerState <- fromCBOR
    shelleyLedgerTransition <- decodeShelleyTransition
    return
      ShelleyLedgerState
        { shelleyLedgerTip
        , shelleyLedgerState
        , shelleyLedgerTransition
        , shelleyLedgerTables = emptyLedgerTables
        }

instance CanUpgradeLedgerTables (LedgerState (ShelleyBlock proto era)) where
  upgradeTables :: forall (mk1 :: * -> * -> *) (mk2 :: * -> * -> *).
LedgerState (ShelleyBlock proto era) mk1
-> LedgerState (ShelleyBlock proto era) mk2
-> LedgerTables (LedgerState (ShelleyBlock proto era)) ValuesMK
-> LedgerTables (LedgerState (ShelleyBlock proto era)) ValuesMK
upgradeTables LedgerState (ShelleyBlock proto era) mk1
_ LedgerState (ShelleyBlock proto era) mk2
_ = LedgerTables (LedgerState (ShelleyBlock proto era)) ValuesMK
-> LedgerTables (LedgerState (ShelleyBlock proto era)) ValuesMK
forall a. a -> a
id