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

{-# OPTIONS_GHC -Wno-orphans #-}

-- | This module is the Shelley Hard Fork Combinator
module Ouroboros.Consensus.Shelley.ShelleyHFC (
    ProtocolShelley
  , ShelleyBlockHFC
  , ShelleyPartialLedgerConfig (..)
  , crossEraForecastAcrossShelley
  , forecastAcrossShelley
  , translateChainDepStateAcrossShelley
  ) where

import qualified Cardano.Ledger.Api.Era as L
import qualified Cardano.Ledger.BaseTypes as SL (mkVersion)
import qualified Cardano.Ledger.Core as SL
import qualified Cardano.Ledger.Shelley.API as SL
import qualified Cardano.Protocol.TPraos.API as SL
import           Cardano.Slotting.EpochInfo (hoistEpochInfo)
import           Control.Monad (guard)
import           Control.Monad.Except (runExcept, throwError, withExceptT)
import qualified Data.Map.Strict as Map
import           Data.SOP.BasicFunctors
import           Data.SOP.InPairs (RequiringBoth (..), ignoringBoth)
import qualified Data.Text as T (pack)
import           Data.Void (Void)
import           Data.Word
import           GHC.Generics (Generic)
import           Lens.Micro ((^.))
import           NoThunks.Class (NoThunks)
import           Ouroboros.Consensus.Block
import           Ouroboros.Consensus.Config
import           Ouroboros.Consensus.Forecast
import qualified Ouroboros.Consensus.Forecast as Forecast
import           Ouroboros.Consensus.HardFork.Combinator hiding
                     (translateChainDepState)
import           Ouroboros.Consensus.HardFork.Combinator.Serialisation.Common
import           Ouroboros.Consensus.HardFork.Combinator.State.Types
import           Ouroboros.Consensus.HardFork.History (Bound (boundSlot))
import           Ouroboros.Consensus.HardFork.Simple
import           Ouroboros.Consensus.Ledger.Abstract
import           Ouroboros.Consensus.Ledger.SupportsMempool (TxLimits)
import           Ouroboros.Consensus.Ledger.SupportsProtocol
                     (LedgerSupportsProtocol, ledgerViewForecastAt)
import           Ouroboros.Consensus.Node.NetworkProtocolVersion
import           Ouroboros.Consensus.Protocol.Abstract
import           Ouroboros.Consensus.Protocol.Praos
import           Ouroboros.Consensus.Protocol.TPraos hiding (PraosCrypto)
import           Ouroboros.Consensus.Shelley.Eras
import           Ouroboros.Consensus.Shelley.Ledger
import           Ouroboros.Consensus.Shelley.Ledger.Inspect as Shelley.Inspect
import           Ouroboros.Consensus.Shelley.Node ()
import           Ouroboros.Consensus.TypeFamilyWrappers

{-------------------------------------------------------------------------------
  Synonym for convenience
-------------------------------------------------------------------------------}

-- | Shelley as the single era in the hard fork combinator
type ShelleyBlockHFC proto era = HardForkBlock '[ShelleyBlock proto era]

{-------------------------------------------------------------------------------
  NoHardForks instance
-------------------------------------------------------------------------------}

instance ( ShelleyCompatible proto era
         , LedgerSupportsProtocol (ShelleyBlock proto era)
         , TxLimits               (ShelleyBlock proto era)
         ) => NoHardForks (ShelleyBlock proto era) where
  getEraParams :: TopLevelConfig (ShelleyBlock proto era) -> EraParams
getEraParams =
        ShelleyGenesis (EraCrypto era) -> EraParams
forall c. ShelleyGenesis c -> EraParams
shelleyEraParamsNeverHardForks
      (ShelleyGenesis (EraCrypto era) -> EraParams)
-> (TopLevelConfig (ShelleyBlock proto era)
    -> ShelleyGenesis (EraCrypto era))
-> TopLevelConfig (ShelleyBlock proto era)
-> EraParams
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShelleyLedgerConfig era -> ShelleyGenesis (EraCrypto era)
forall era.
ShelleyLedgerConfig era -> ShelleyGenesis (EraCrypto era)
shelleyLedgerGenesis
      (ShelleyLedgerConfig era -> ShelleyGenesis (EraCrypto era))
-> (TopLevelConfig (ShelleyBlock proto era)
    -> ShelleyLedgerConfig era)
-> TopLevelConfig (ShelleyBlock proto era)
-> ShelleyGenesis (EraCrypto era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TopLevelConfig (ShelleyBlock proto era)
-> LedgerConfig (ShelleyBlock proto era)
TopLevelConfig (ShelleyBlock proto era) -> ShelleyLedgerConfig era
forall blk. TopLevelConfig blk -> LedgerConfig blk
configLedger
  toPartialLedgerConfig :: forall (proxy :: * -> *).
proxy (ShelleyBlock proto era)
-> LedgerConfig (ShelleyBlock proto era)
-> PartialLedgerConfig (ShelleyBlock proto era)
toPartialLedgerConfig proxy (ShelleyBlock proto era)
_ LedgerConfig (ShelleyBlock proto era)
cfg = ShelleyPartialLedgerConfig {
        shelleyLedgerConfig :: ShelleyLedgerConfig era
shelleyLedgerConfig    = LedgerConfig (ShelleyBlock proto era)
ShelleyLedgerConfig era
cfg
      , shelleyTriggerHardFork :: TriggerHardFork
shelleyTriggerHardFork = TriggerHardFork
TriggerHardForkNotDuringThisExecution
      }

{-------------------------------------------------------------------------------
  SupportedNetworkProtocolVersion instance
-------------------------------------------------------------------------------}

-- | Forward to the ShelleyBlock instance. Only supports
-- 'HardForkNodeToNodeDisabled', which is compatible with nodes running with
-- 'ShelleyBlock'.
instance ( ShelleyCompatible proto era
         , LedgerSupportsProtocol (ShelleyBlock proto era)
         , TxLimits               (ShelleyBlock proto era)
         ) => SupportedNetworkProtocolVersion (ShelleyBlockHFC proto era) where
  supportedNodeToNodeVersions :: Proxy (ShelleyBlockHFC proto era)
-> Map
     NodeToNodeVersion
     (BlockNodeToNodeVersion (ShelleyBlockHFC proto era))
supportedNodeToNodeVersions Proxy (ShelleyBlockHFC proto era)
_ =
      (BlockNodeToNodeVersion (ShelleyBlock proto era)
 -> BlockNodeToNodeVersion (ShelleyBlockHFC proto era))
-> Map
     NodeToNodeVersion (BlockNodeToNodeVersion (ShelleyBlock proto era))
-> Map
     NodeToNodeVersion
     (BlockNodeToNodeVersion (ShelleyBlockHFC proto era))
forall a b k. (a -> b) -> Map k a -> Map k b
Map.map BlockNodeToNodeVersion (ShelleyBlock proto era)
-> BlockNodeToNodeVersion (ShelleyBlockHFC proto era)
BlockNodeToNodeVersion (ShelleyBlock proto era)
-> HardForkNodeToNodeVersion '[ShelleyBlock proto era]
forall x (xs1 :: [*]).
BlockNodeToNodeVersion x -> HardForkNodeToNodeVersion (x : xs1)
HardForkNodeToNodeDisabled (Map
   NodeToNodeVersion (BlockNodeToNodeVersion (ShelleyBlock proto era))
 -> Map
      NodeToNodeVersion
      (BlockNodeToNodeVersion (ShelleyBlockHFC proto era)))
-> Map
     NodeToNodeVersion (BlockNodeToNodeVersion (ShelleyBlock proto era))
-> Map
     NodeToNodeVersion
     (BlockNodeToNodeVersion (ShelleyBlockHFC proto era))
forall a b. (a -> b) -> a -> b
$
      Proxy (ShelleyBlock proto era)
-> Map
     NodeToNodeVersion (BlockNodeToNodeVersion (ShelleyBlock proto era))
forall blk.
SupportedNetworkProtocolVersion blk =>
Proxy blk -> Map NodeToNodeVersion (BlockNodeToNodeVersion blk)
supportedNodeToNodeVersions (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @(ShelleyBlock proto era))

  supportedNodeToClientVersions :: Proxy (ShelleyBlockHFC proto era)
-> Map
     NodeToClientVersion
     (BlockNodeToClientVersion (ShelleyBlockHFC proto era))
supportedNodeToClientVersions Proxy (ShelleyBlockHFC proto era)
_ =
      (BlockNodeToClientVersion (ShelleyBlock proto era)
 -> BlockNodeToClientVersion (ShelleyBlockHFC proto era))
-> Map
     NodeToClientVersion
     (BlockNodeToClientVersion (ShelleyBlock proto era))
-> Map
     NodeToClientVersion
     (BlockNodeToClientVersion (ShelleyBlockHFC proto era))
forall a b k. (a -> b) -> Map k a -> Map k b
Map.map BlockNodeToClientVersion (ShelleyBlock proto era)
-> BlockNodeToClientVersion (ShelleyBlockHFC proto era)
BlockNodeToClientVersion (ShelleyBlock proto era)
-> HardForkNodeToClientVersion '[ShelleyBlock proto era]
forall x (xs1 :: [*]).
BlockNodeToClientVersion x -> HardForkNodeToClientVersion (x : xs1)
HardForkNodeToClientDisabled (Map
   NodeToClientVersion
   (BlockNodeToClientVersion (ShelleyBlock proto era))
 -> Map
      NodeToClientVersion
      (BlockNodeToClientVersion (ShelleyBlockHFC proto era)))
-> Map
     NodeToClientVersion
     (BlockNodeToClientVersion (ShelleyBlock proto era))
-> Map
     NodeToClientVersion
     (BlockNodeToClientVersion (ShelleyBlockHFC proto era))
forall a b. (a -> b) -> a -> b
$
      Proxy (ShelleyBlock proto era)
-> Map
     NodeToClientVersion
     (BlockNodeToClientVersion (ShelleyBlock proto era))
forall blk.
SupportedNetworkProtocolVersion blk =>
Proxy blk -> Map NodeToClientVersion (BlockNodeToClientVersion blk)
supportedNodeToClientVersions (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @(ShelleyBlock proto era))

  latestReleasedNodeVersion :: Proxy (ShelleyBlockHFC proto era)
-> (Maybe NodeToNodeVersion, Maybe NodeToClientVersion)
latestReleasedNodeVersion = Proxy (ShelleyBlockHFC proto era)
-> (Maybe NodeToNodeVersion, Maybe NodeToClientVersion)
forall blk.
SupportedNetworkProtocolVersion blk =>
Proxy blk -> (Maybe NodeToNodeVersion, Maybe NodeToClientVersion)
latestReleasedNodeVersionDefault

{-------------------------------------------------------------------------------
  SerialiseHFC instance
-------------------------------------------------------------------------------}

-- | Use the default implementations. This means the serialisation of blocks
-- includes an era wrapper. Each block should do this from the start to be
-- prepared for future hard forks without having to do any bit twiddling.
instance ( ShelleyCompatible proto era
         , LedgerSupportsProtocol (ShelleyBlock proto era)
         , TxLimits               (ShelleyBlock proto era)
         ) => SerialiseHFC '[ShelleyBlock proto era]
instance ( ShelleyCompatible proto era
         , LedgerSupportsProtocol (ShelleyBlock proto era)
         , TxLimits               (ShelleyBlock proto era)
         ) => SerialiseConstraintsHFC (ShelleyBlock proto era)

{-------------------------------------------------------------------------------
  Protocol type definition
-------------------------------------------------------------------------------}

type ProtocolShelley = HardForkProtocol '[ ShelleyBlock (TPraos StandardCrypto) StandardShelley ]

{-------------------------------------------------------------------------------
  SingleEraBlock Shelley
-------------------------------------------------------------------------------}

shelleyTransition ::
     forall era proto. ShelleyCompatible proto era
  => PartialLedgerConfig (ShelleyBlock proto era)
  -> Word16   -- ^ Next era's initial major protocol version
  -> LedgerState (ShelleyBlock proto era)
  -> Maybe EpochNo
shelleyTransition :: forall era proto.
ShelleyCompatible proto era =>
PartialLedgerConfig (ShelleyBlock proto era)
-> Word16 -> LedgerState (ShelleyBlock proto era) -> Maybe EpochNo
shelleyTransition ShelleyPartialLedgerConfig{TriggerHardFork
ShelleyLedgerConfig era
shelleyLedgerConfig :: forall era.
ShelleyPartialLedgerConfig era -> ShelleyLedgerConfig era
shelleyTriggerHardFork :: forall era. ShelleyPartialLedgerConfig era -> TriggerHardFork
shelleyLedgerConfig :: ShelleyLedgerConfig era
shelleyTriggerHardFork :: TriggerHardFork
..}
                  Word16
transitionMajorVersionRaw
                  LedgerState (ShelleyBlock proto era)
state =
      ShelleyLedgerUpdate era -> Maybe EpochNo
isTransition
    (ShelleyLedgerUpdate era -> Maybe EpochNo)
-> (LedgerState (ShelleyBlock proto era)
    -> ShelleyLedgerUpdate era)
-> LedgerState (ShelleyBlock proto era)
-> Maybe EpochNo
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LedgerState (ShelleyBlock proto era) -> ShelleyLedgerUpdate era
forall era proto.
ShelleyBasedEra era =>
LedgerState (ShelleyBlock proto era) -> ShelleyLedgerUpdate era
Shelley.Inspect.pparamsUpdate
    (LedgerState (ShelleyBlock proto era) -> Maybe EpochNo)
-> LedgerState (ShelleyBlock proto era) -> Maybe EpochNo
forall a b. (a -> b) -> a -> b
$ LedgerState (ShelleyBlock proto era)
state
  where
    ShelleyTransitionInfo{Word32
shelleyAfterVoting :: Word32
shelleyAfterVoting :: ShelleyTransition -> Word32
..} = LedgerState (ShelleyBlock proto era) -> ShelleyTransition
forall proto era.
LedgerState (ShelleyBlock proto era) -> ShelleyTransition
shelleyLedgerTransition LedgerState (ShelleyBlock proto era)
state

    -- 'shelleyLedgerConfig' contains a dummy 'EpochInfo' but this does not
    -- matter for extracting the genesis config
    genesis :: SL.ShelleyGenesis (EraCrypto era)
    genesis :: ShelleyGenesis (EraCrypto era)
genesis = ShelleyLedgerConfig era -> ShelleyGenesis (EraCrypto era)
forall era.
ShelleyLedgerConfig era -> ShelleyGenesis (EraCrypto era)
shelleyLedgerGenesis ShelleyLedgerConfig era
shelleyLedgerConfig

    k :: Word64
    k :: Word64
k = ShelleyGenesis (ProtoCrypto proto) -> Word64
forall c. ShelleyGenesis c -> Word64
SL.sgSecurityParam ShelleyGenesis (EraCrypto era)
ShelleyGenesis (ProtoCrypto proto)
genesis

    isTransition :: ShelleyLedgerUpdate era -> Maybe EpochNo
    isTransition :: ShelleyLedgerUpdate era -> Maybe EpochNo
isTransition (ShelleyUpdatedPParams StrictMaybe (PParams era)
maybePParams EpochNo
newPParamsEpochNo) = do
         SL.SJust PParams era
pp <- StrictMaybe (PParams era) -> Maybe (StrictMaybe (PParams era))
forall a. a -> Maybe a
Just StrictMaybe (PParams era)
maybePParams
         let protVer :: ProtVer
protVer = PParams era
pp PParams era -> Getting ProtVer (PParams era) ProtVer -> ProtVer
forall s a. s -> Getting a s a -> a
^. Getting ProtVer (PParams era) ProtVer
forall era. EraPParams era => Lens' (PParams era) ProtVer
Lens' (PParams era) ProtVer
SL.ppProtocolVersionL
         Version
transitionMajorVersion <- Word16 -> Maybe Version
forall i (m :: * -> *). (Integral i, MonadFail m) => i -> m Version
SL.mkVersion Word16
transitionMajorVersionRaw
         Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Maybe ()) -> Bool -> Maybe ()
forall a b. (a -> b) -> a -> b
$ ProtVer -> Version
SL.pvMajor ProtVer
protVer Version -> Version -> Bool
forall a. Eq a => a -> a -> Bool
== Version
transitionMajorVersion
         Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Maybe ()) -> Bool -> Maybe ()
forall a b. (a -> b) -> a -> b
$ Word32
shelleyAfterVoting Word32 -> Word32 -> Bool
forall a. Ord a => a -> a -> Bool
>= Word64 -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
k
         EpochNo -> Maybe EpochNo
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return EpochNo
newPParamsEpochNo

instance ( ShelleyCompatible proto era
         , LedgerSupportsProtocol (ShelleyBlock proto era)
         , TxLimits               (ShelleyBlock proto era)
         ) => SingleEraBlock (ShelleyBlock proto era) where
  singleEraTransition :: PartialLedgerConfig (ShelleyBlock proto era)
-> EraParams
-> Bound
-> LedgerState (ShelleyBlock proto era)
-> Maybe EpochNo
singleEraTransition PartialLedgerConfig (ShelleyBlock proto era)
pcfg EraParams
_eraParams Bound
_eraStart LedgerState (ShelleyBlock proto era)
ledgerState =
      -- TODO: We might be evaluating 'singleEraTransition' more than once when
      -- replaying blocks. We should investigate if this is the case, and if so,
      -- whether this is the desired behaviour. If it is not, then we need to
      -- fix it.
      --
      -- For evidence of this behaviour, replace the cased-on expression by:
      -- > @traceShowId $ shelleyTriggerHardFork pcf@
      case ShelleyPartialLedgerConfig era -> TriggerHardFork
forall era. ShelleyPartialLedgerConfig era -> TriggerHardFork
shelleyTriggerHardFork PartialLedgerConfig (ShelleyBlock proto era)
ShelleyPartialLedgerConfig era
pcfg of
        TriggerHardFork
TriggerHardForkNotDuringThisExecution        -> Maybe EpochNo
forall a. Maybe a
Nothing
        TriggerHardForkAtEpoch   EpochNo
epoch               -> EpochNo -> Maybe EpochNo
forall a. a -> Maybe a
Just EpochNo
epoch
        TriggerHardForkAtVersion Word16
shelleyMajorVersion ->
            PartialLedgerConfig (ShelleyBlock proto era)
-> Word16 -> LedgerState (ShelleyBlock proto era) -> Maybe EpochNo
forall era proto.
ShelleyCompatible proto era =>
PartialLedgerConfig (ShelleyBlock proto era)
-> Word16 -> LedgerState (ShelleyBlock proto era) -> Maybe EpochNo
shelleyTransition
              PartialLedgerConfig (ShelleyBlock proto era)
pcfg
              Word16
shelleyMajorVersion
              LedgerState (ShelleyBlock proto era)
ledgerState

  singleEraInfo :: forall (proxy :: * -> *).
proxy (ShelleyBlock proto era)
-> SingleEraInfo (ShelleyBlock proto era)
singleEraInfo proxy (ShelleyBlock proto era)
_ = SingleEraInfo {
      singleEraName :: Text
singleEraName = String -> Text
T.pack (forall era. Era era => String
L.eraName @era)
    }

instance PraosCrypto c => HasPartialConsensusConfig (Praos c) where
  type PartialConsensusConfig (Praos c) = PraosParams

  completeConsensusConfig :: forall (proxy :: * -> *).
proxy (Praos c)
-> EpochInfo (Except PastHorizonException)
-> PartialConsensusConfig (Praos c)
-> ConsensusConfig (Praos c)
completeConsensusConfig proxy (Praos c)
_ EpochInfo (Except PastHorizonException)
praosEpochInfo PartialConsensusConfig (Praos c)
praosParams = PraosConfig {EpochInfo (Except PastHorizonException)
PartialConsensusConfig (Praos c)
PraosParams
praosEpochInfo :: EpochInfo (Except PastHorizonException)
praosParams :: PartialConsensusConfig (Praos c)
praosParams :: PraosParams
praosEpochInfo :: EpochInfo (Except PastHorizonException)
..}

  toPartialConsensusConfig :: forall (proxy :: * -> *).
proxy (Praos c)
-> ConsensusConfig (Praos c) -> PartialConsensusConfig (Praos c)
toPartialConsensusConfig proxy (Praos c)
_ = ConsensusConfig (Praos c) -> PartialConsensusConfig (Praos c)
ConsensusConfig (Praos c) -> PraosParams
forall c. ConsensusConfig (Praos c) -> PraosParams
praosParams

instance SL.PraosCrypto c => HasPartialConsensusConfig (TPraos c) where
  type PartialConsensusConfig (TPraos c) = TPraosParams

  completeConsensusConfig :: forall (proxy :: * -> *).
proxy (TPraos c)
-> EpochInfo (Except PastHorizonException)
-> PartialConsensusConfig (TPraos c)
-> ConsensusConfig (TPraos c)
completeConsensusConfig proxy (TPraos c)
_ EpochInfo (Except PastHorizonException)
tpraosEpochInfo PartialConsensusConfig (TPraos c)
tpraosParams = TPraosConfig {EpochInfo (Except PastHorizonException)
PartialConsensusConfig (TPraos c)
TPraosParams
tpraosEpochInfo :: EpochInfo (Except PastHorizonException)
tpraosParams :: PartialConsensusConfig (TPraos c)
tpraosParams :: TPraosParams
tpraosEpochInfo :: EpochInfo (Except PastHorizonException)
..}

  toPartialConsensusConfig :: forall (proxy :: * -> *).
proxy (TPraos c)
-> ConsensusConfig (TPraos c) -> PartialConsensusConfig (TPraos c)
toPartialConsensusConfig proxy (TPraos c)
_ = ConsensusConfig (TPraos c) -> PartialConsensusConfig (TPraos c)
ConsensusConfig (TPraos c) -> TPraosParams
forall c. ConsensusConfig (TPraos c) -> TPraosParams
tpraosParams

data ShelleyPartialLedgerConfig era = ShelleyPartialLedgerConfig {
      -- | 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 -> ShelleyLedgerConfig era
shelleyLedgerConfig    :: !(ShelleyLedgerConfig era)
    , 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 (NoThunks (SL.TranslationContext era), SL.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
            }
        }

-- | Forecast from a Shelley-based era to the next Shelley-based era.
forecastAcrossShelley ::
     forall protoFrom protoTo eraFrom eraTo.
     ( TranslateProto protoFrom protoTo
     , LedgerSupportsProtocol (ShelleyBlock protoFrom eraFrom)
     )
  => ShelleyLedgerConfig eraFrom
  -> ShelleyLedgerConfig eraTo
  -> Bound  -- ^ Transition between the two eras
  -> SlotNo -- ^ Forecast for this slot
  -> LedgerState (ShelleyBlock protoFrom eraFrom)
  -> Except OutsideForecastRange (WrapLedgerView (ShelleyBlock protoTo eraTo))
forecastAcrossShelley :: forall protoFrom protoTo eraFrom eraTo.
(TranslateProto protoFrom protoTo,
 LedgerSupportsProtocol (ShelleyBlock protoFrom eraFrom)) =>
ShelleyLedgerConfig eraFrom
-> ShelleyLedgerConfig eraTo
-> Bound
-> SlotNo
-> LedgerState (ShelleyBlock protoFrom eraFrom)
-> Except
     OutsideForecastRange (WrapLedgerView (ShelleyBlock protoTo eraTo))
forecastAcrossShelley ShelleyLedgerConfig eraFrom
cfgFrom ShelleyLedgerConfig eraTo
cfgTo Bound
transition SlotNo
forecastFor LedgerState (ShelleyBlock protoFrom eraFrom)
ledgerStateFrom
    | SlotNo
forecastFor SlotNo -> SlotNo -> Bool
forall a. Ord a => a -> a -> Bool
< SlotNo
maxFor
    = WrapLedgerView (ShelleyBlock protoTo eraTo)
-> ExceptT
     OutsideForecastRange
     Identity
     (WrapLedgerView (ShelleyBlock protoTo eraTo))
forall a. a -> ExceptT OutsideForecastRange Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (WrapLedgerView (ShelleyBlock protoTo eraTo)
 -> ExceptT
      OutsideForecastRange
      Identity
      (WrapLedgerView (ShelleyBlock protoTo eraTo)))
-> WrapLedgerView (ShelleyBlock protoTo eraTo)
-> ExceptT
     OutsideForecastRange
     Identity
     (WrapLedgerView (ShelleyBlock protoTo eraTo))
forall a b. (a -> b) -> a -> b
$ SlotNo -> WrapLedgerView (ShelleyBlock protoTo eraTo)
forall era. SlotNo -> WrapLedgerView (ShelleyBlock protoTo era)
futureLedgerView SlotNo
forecastFor
    | Bool
otherwise
    = OutsideForecastRange
-> ExceptT
     OutsideForecastRange
     Identity
     (WrapLedgerView (ShelleyBlock protoTo eraTo))
forall a.
OutsideForecastRange -> ExceptT OutsideForecastRange Identity a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (OutsideForecastRange
 -> ExceptT
      OutsideForecastRange
      Identity
      (WrapLedgerView (ShelleyBlock protoTo eraTo)))
-> OutsideForecastRange
-> ExceptT
     OutsideForecastRange
     Identity
     (WrapLedgerView (ShelleyBlock protoTo eraTo))
forall a b. (a -> b) -> a -> b
$ OutsideForecastRange {
          outsideForecastAt :: WithOrigin SlotNo
outsideForecastAt     = LedgerState (ShelleyBlock protoFrom eraFrom) -> WithOrigin SlotNo
forall blk.
UpdateLedger blk =>
LedgerState blk -> WithOrigin SlotNo
ledgerTipSlot LedgerState (ShelleyBlock protoFrom eraFrom)
ledgerStateFrom
        , outsideForecastMaxFor :: SlotNo
outsideForecastMaxFor = SlotNo
maxFor
        , outsideForecastFor :: SlotNo
outsideForecastFor    = SlotNo
forecastFor
        }
  where
    -- | 'SL.futureLedgerView' imposes its own bounds. Those bounds could
    -- /exceed/ the 'maxFor' we have computed, but should never be /less/.
    futureLedgerView :: SlotNo -> WrapLedgerView (ShelleyBlock protoTo era)
    futureLedgerView :: forall era. SlotNo -> WrapLedgerView (ShelleyBlock protoTo era)
futureLedgerView =
          LedgerView protoTo -> WrapLedgerView (ShelleyBlock protoTo era)
LedgerView (BlockProtocol (ShelleyBlock protoTo era))
-> WrapLedgerView (ShelleyBlock protoTo era)
forall blk. LedgerView (BlockProtocol blk) -> WrapLedgerView blk
WrapLedgerView
        (LedgerView protoTo -> WrapLedgerView (ShelleyBlock protoTo era))
-> (SlotNo -> LedgerView protoTo)
-> SlotNo
-> WrapLedgerView (ShelleyBlock protoTo era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (OutsideForecastRange -> LedgerView protoTo)
-> (LedgerView protoFrom -> LedgerView protoTo)
-> Either OutsideForecastRange (LedgerView protoFrom)
-> LedgerView protoTo
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either
            (\OutsideForecastRange
e -> String -> LedgerView protoTo
forall a. HasCallStack => String -> a
error (String
"futureLedgerView failed: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> OutsideForecastRange -> String
forall a. Show a => a -> String
show OutsideForecastRange
e))
            (Proxy (protoFrom, protoTo)
-> LedgerView protoFrom -> LedgerView protoTo
forall protoFrom protoTo.
TranslateProto protoFrom protoTo =>
Proxy (protoFrom, protoTo)
-> LedgerView protoFrom -> LedgerView protoTo
translateLedgerView (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @(protoFrom, protoTo)))
        (Either OutsideForecastRange (LedgerView protoFrom)
 -> LedgerView protoTo)
-> (SlotNo -> Either OutsideForecastRange (LedgerView protoFrom))
-> SlotNo
-> LedgerView protoTo
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Except OutsideForecastRange (LedgerView protoFrom)
-> Either OutsideForecastRange (LedgerView protoFrom)
forall e a. Except e a -> Either e a
runExcept
        (Except OutsideForecastRange (LedgerView protoFrom)
 -> Either OutsideForecastRange (LedgerView protoFrom))
-> (SlotNo -> Except OutsideForecastRange (LedgerView protoFrom))
-> SlotNo
-> Either OutsideForecastRange (LedgerView protoFrom)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Forecast (LedgerView protoFrom)
-> SlotNo -> Except OutsideForecastRange (LedgerView protoFrom)
forall a. Forecast a -> SlotNo -> Except OutsideForecastRange a
Forecast.forecastFor (LedgerConfig (ShelleyBlock protoFrom eraFrom)
-> LedgerState (ShelleyBlock protoFrom eraFrom)
-> Forecast
     (LedgerView (BlockProtocol (ShelleyBlock protoFrom eraFrom)))
forall blk.
(LedgerSupportsProtocol blk, HasCallStack) =>
LedgerConfig blk
-> LedgerState blk -> Forecast (LedgerView (BlockProtocol blk))
ledgerViewForecastAt LedgerConfig (ShelleyBlock protoFrom eraFrom)
ShelleyLedgerConfig eraFrom
cfgFrom LedgerState (ShelleyBlock protoFrom eraFrom)
ledgerStateFrom)

    -- Exclusive upper bound
    maxFor :: SlotNo
    maxFor :: SlotNo
maxFor = WithOrigin SlotNo -> SlotNo -> Word64 -> Word64 -> SlotNo
crossEraForecastBound
               (LedgerState (ShelleyBlock protoFrom eraFrom) -> WithOrigin SlotNo
forall blk.
UpdateLedger blk =>
LedgerState blk -> WithOrigin SlotNo
ledgerTipSlot LedgerState (ShelleyBlock protoFrom eraFrom)
ledgerStateFrom)
               (Bound -> SlotNo
boundSlot Bound
transition)
               (Globals -> Word64
SL.stabilityWindow (ShelleyLedgerConfig eraFrom -> Globals
forall era. ShelleyLedgerConfig era -> Globals
shelleyLedgerGlobals ShelleyLedgerConfig eraFrom
cfgFrom))
               (Globals -> Word64
SL.stabilityWindow (ShelleyLedgerConfig eraTo -> Globals
forall era. ShelleyLedgerConfig era -> Globals
shelleyLedgerGlobals ShelleyLedgerConfig eraTo
cfgTo))

translateChainDepStateAcrossShelley ::
     forall eraFrom eraTo protoFrom protoTo.
     ( TranslateProto protoFrom protoTo
     )
  => RequiringBoth
       WrapConsensusConfig
       (Translate WrapChainDepState)
       (ShelleyBlock protoFrom eraFrom)
       (ShelleyBlock protoTo eraTo)
translateChainDepStateAcrossShelley :: forall eraFrom eraTo protoFrom protoTo.
TranslateProto protoFrom protoTo =>
RequiringBoth
  WrapConsensusConfig
  (Translate WrapChainDepState)
  (ShelleyBlock protoFrom eraFrom)
  (ShelleyBlock protoTo eraTo)
translateChainDepStateAcrossShelley =
    Translate
  WrapChainDepState
  (ShelleyBlock protoFrom eraFrom)
  (ShelleyBlock protoTo eraTo)
-> RequiringBoth
     WrapConsensusConfig
     (Translate WrapChainDepState)
     (ShelleyBlock protoFrom eraFrom)
     (ShelleyBlock protoTo eraTo)
forall {k} (f :: k -> k -> *) (x :: k) (y :: k) (h :: k -> *).
f x y -> RequiringBoth h f x y
ignoringBoth (Translate
   WrapChainDepState
   (ShelleyBlock protoFrom eraFrom)
   (ShelleyBlock protoTo eraTo)
 -> RequiringBoth
      WrapConsensusConfig
      (Translate WrapChainDepState)
      (ShelleyBlock protoFrom eraFrom)
      (ShelleyBlock protoTo eraTo))
-> Translate
     WrapChainDepState
     (ShelleyBlock protoFrom eraFrom)
     (ShelleyBlock protoTo eraTo)
-> RequiringBoth
     WrapConsensusConfig
     (Translate WrapChainDepState)
     (ShelleyBlock protoFrom eraFrom)
     (ShelleyBlock protoTo eraTo)
forall a b. (a -> b) -> a -> b
$
      (EpochNo
 -> WrapChainDepState (ShelleyBlock protoFrom eraFrom)
 -> WrapChainDepState (ShelleyBlock protoTo eraTo))
-> Translate
     WrapChainDepState
     (ShelleyBlock protoFrom eraFrom)
     (ShelleyBlock protoTo eraTo)
forall (f :: * -> *) x y.
(EpochNo -> f x -> f y) -> Translate f x y
Translate ((EpochNo
  -> WrapChainDepState (ShelleyBlock protoFrom eraFrom)
  -> WrapChainDepState (ShelleyBlock protoTo eraTo))
 -> Translate
      WrapChainDepState
      (ShelleyBlock protoFrom eraFrom)
      (ShelleyBlock protoTo eraTo))
-> (EpochNo
    -> WrapChainDepState (ShelleyBlock protoFrom eraFrom)
    -> WrapChainDepState (ShelleyBlock protoTo eraTo))
-> Translate
     WrapChainDepState
     (ShelleyBlock protoFrom eraFrom)
     (ShelleyBlock protoTo eraTo)
forall a b. (a -> b) -> a -> b
$ \EpochNo
_epochNo (WrapChainDepState ChainDepState (BlockProtocol (ShelleyBlock protoFrom eraFrom))
chainDepState) ->
        -- Same protocol, same 'ChainDepState'. Note that we don't have to apply
        -- any changes related to an epoch transition, this is already done when
        -- ticking the state.
        ChainDepState (BlockProtocol (ShelleyBlock protoTo eraTo))
-> WrapChainDepState (ShelleyBlock protoTo eraTo)
forall blk.
ChainDepState (BlockProtocol blk) -> WrapChainDepState blk
WrapChainDepState (ChainDepState (BlockProtocol (ShelleyBlock protoTo eraTo))
 -> WrapChainDepState (ShelleyBlock protoTo eraTo))
-> ChainDepState (BlockProtocol (ShelleyBlock protoTo eraTo))
-> WrapChainDepState (ShelleyBlock protoTo eraTo)
forall a b. (a -> b) -> a -> b
$ Proxy (protoFrom, protoTo)
-> ChainDepState protoFrom -> ChainDepState protoTo
forall protoFrom protoTo.
TranslateProto protoFrom protoTo =>
Proxy (protoFrom, protoTo)
-> ChainDepState protoFrom -> ChainDepState protoTo
translateChainDepState (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @(protoFrom, protoTo)) ChainDepState protoFrom
ChainDepState (BlockProtocol (ShelleyBlock protoFrom eraFrom))
chainDepState

crossEraForecastAcrossShelley ::
     forall eraFrom eraTo protoFrom protoTo.
     ( TranslateProto protoFrom protoTo
     , LedgerSupportsProtocol (ShelleyBlock protoFrom eraFrom)
     )
  => RequiringBoth
       WrapLedgerConfig
       (CrossEraForecaster LedgerState WrapLedgerView)
       (ShelleyBlock protoFrom eraFrom)
       (ShelleyBlock protoTo eraTo)
crossEraForecastAcrossShelley :: forall eraFrom eraTo protoFrom protoTo.
(TranslateProto protoFrom protoTo,
 LedgerSupportsProtocol (ShelleyBlock protoFrom eraFrom)) =>
RequiringBoth
  WrapLedgerConfig
  (CrossEraForecaster LedgerState WrapLedgerView)
  (ShelleyBlock protoFrom eraFrom)
  (ShelleyBlock protoTo eraTo)
crossEraForecastAcrossShelley =
    (WrapLedgerConfig (ShelleyBlock protoFrom eraFrom)
 -> WrapLedgerConfig (ShelleyBlock protoTo eraTo)
 -> CrossEraForecaster
      LedgerState
      WrapLedgerView
      (ShelleyBlock protoFrom eraFrom)
      (ShelleyBlock protoTo eraTo))
-> RequiringBoth
     WrapLedgerConfig
     (CrossEraForecaster LedgerState WrapLedgerView)
     (ShelleyBlock protoFrom eraFrom)
     (ShelleyBlock protoTo eraTo)
forall {k} (h :: k -> *) (f :: k -> k -> *) (x :: k) (y :: k).
(h x -> h y -> f x y) -> RequiringBoth h f x y
RequireBoth ((WrapLedgerConfig (ShelleyBlock protoFrom eraFrom)
  -> WrapLedgerConfig (ShelleyBlock protoTo eraTo)
  -> CrossEraForecaster
       LedgerState
       WrapLedgerView
       (ShelleyBlock protoFrom eraFrom)
       (ShelleyBlock protoTo eraTo))
 -> RequiringBoth
      WrapLedgerConfig
      (CrossEraForecaster LedgerState WrapLedgerView)
      (ShelleyBlock protoFrom eraFrom)
      (ShelleyBlock protoTo eraTo))
-> (WrapLedgerConfig (ShelleyBlock protoFrom eraFrom)
    -> WrapLedgerConfig (ShelleyBlock protoTo eraTo)
    -> CrossEraForecaster
         LedgerState
         WrapLedgerView
         (ShelleyBlock protoFrom eraFrom)
         (ShelleyBlock protoTo eraTo))
-> RequiringBoth
     WrapLedgerConfig
     (CrossEraForecaster LedgerState WrapLedgerView)
     (ShelleyBlock protoFrom eraFrom)
     (ShelleyBlock protoTo eraTo)
forall a b. (a -> b) -> a -> b
$ \(WrapLedgerConfig LedgerConfig (ShelleyBlock protoFrom eraFrom)
cfgFrom)
                   (WrapLedgerConfig LedgerConfig (ShelleyBlock protoTo eraTo)
cfgTo) ->
      (Bound
 -> SlotNo
 -> LedgerState (ShelleyBlock protoFrom eraFrom)
 -> Except
      OutsideForecastRange (WrapLedgerView (ShelleyBlock protoTo eraTo)))
-> CrossEraForecaster
     LedgerState
     WrapLedgerView
     (ShelleyBlock protoFrom eraFrom)
     (ShelleyBlock protoTo eraTo)
forall (state :: * -> *) (view :: * -> *) x y.
(Bound
 -> SlotNo -> state x -> Except OutsideForecastRange (view y))
-> CrossEraForecaster state view x y
CrossEraForecaster ((Bound
  -> SlotNo
  -> LedgerState (ShelleyBlock protoFrom eraFrom)
  -> Except
       OutsideForecastRange (WrapLedgerView (ShelleyBlock protoTo eraTo)))
 -> CrossEraForecaster
      LedgerState
      WrapLedgerView
      (ShelleyBlock protoFrom eraFrom)
      (ShelleyBlock protoTo eraTo))
-> (Bound
    -> SlotNo
    -> LedgerState (ShelleyBlock protoFrom eraFrom)
    -> Except
         OutsideForecastRange (WrapLedgerView (ShelleyBlock protoTo eraTo)))
-> CrossEraForecaster
     LedgerState
     WrapLedgerView
     (ShelleyBlock protoFrom eraFrom)
     (ShelleyBlock protoTo eraTo)
forall a b. (a -> b) -> a -> b
$ ShelleyLedgerConfig eraFrom
-> ShelleyLedgerConfig eraTo
-> Bound
-> SlotNo
-> LedgerState (ShelleyBlock protoFrom eraFrom)
-> Except
     OutsideForecastRange (WrapLedgerView (ShelleyBlock protoTo eraTo))
forall protoFrom protoTo eraFrom eraTo.
(TranslateProto protoFrom protoTo,
 LedgerSupportsProtocol (ShelleyBlock protoFrom eraFrom)) =>
ShelleyLedgerConfig eraFrom
-> ShelleyLedgerConfig eraTo
-> Bound
-> SlotNo
-> LedgerState (ShelleyBlock protoFrom eraFrom)
-> Except
     OutsideForecastRange (WrapLedgerView (ShelleyBlock protoTo eraTo))
forecastAcrossShelley LedgerConfig (ShelleyBlock protoFrom eraFrom)
ShelleyLedgerConfig eraFrom
cfgFrom LedgerConfig (ShelleyBlock protoTo eraTo)
ShelleyLedgerConfig eraTo
cfgTo

{-------------------------------------------------------------------------------
  Translation from one Shelley-based era to another Shelley-based era
-------------------------------------------------------------------------------}

instance ( ShelleyBasedEra era
         , ShelleyBasedEra (SL.PreviousEra era)
         , SL.Era (SL.PreviousEra era)
         , EraCrypto (SL.PreviousEra era) ~ EraCrypto era
         ) => SL.TranslateEra era (ShelleyTip proto) where
  translateEra :: TranslationContext era
-> ShelleyTip proto (PreviousEra era)
-> Except
     (TranslationError era (ShelleyTip proto)) (ShelleyTip proto era)
translateEra TranslationContext era
_ (ShelleyTip SlotNo
sno BlockNo
bno (ShelleyHash Hash (ProtoCrypto proto) EraIndependentBlockHeader
hash)) =
      ShelleyTip proto era
-> Except
     (TranslationError era (ShelleyTip proto)) (ShelleyTip proto era)
forall a.
a -> ExceptT (TranslationError era (ShelleyTip proto)) Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (ShelleyTip proto era
 -> Except
      (TranslationError era (ShelleyTip proto)) (ShelleyTip proto era))
-> ShelleyTip proto era
-> Except
     (TranslationError era (ShelleyTip proto)) (ShelleyTip proto era)
forall a b. (a -> b) -> a -> b
$ SlotNo
-> BlockNo
-> HeaderHash (ShelleyBlock proto era)
-> ShelleyTip proto era
forall proto era.
SlotNo
-> BlockNo
-> HeaderHash (ShelleyBlock proto era)
-> ShelleyTip proto era
ShelleyTip SlotNo
sno BlockNo
bno (Hash (ProtoCrypto proto) EraIndependentBlockHeader
-> ShelleyHash (ProtoCrypto proto)
forall crypto.
Hash crypto EraIndependentBlockHeader -> ShelleyHash crypto
ShelleyHash Hash (ProtoCrypto proto) EraIndependentBlockHeader
hash)

instance ( ShelleyBasedEra era
         , SL.TranslateEra era (ShelleyTip proto)
         , SL.TranslateEra era SL.NewEpochState
         , SL.TranslationError era SL.NewEpochState ~ Void
         ) => SL.TranslateEra era (LedgerState :.: ShelleyBlock proto) where
  translateEra :: TranslationContext era
-> (:.:) LedgerState (ShelleyBlock proto) (PreviousEra era)
-> Except
     (TranslationError era (LedgerState :.: ShelleyBlock proto))
     ((:.:) LedgerState (ShelleyBlock proto) era)
translateEra TranslationContext era
ctxt (Comp (ShelleyLedgerState WithOrigin (ShelleyTip proto (PreviousEra era))
tip NewEpochState (PreviousEra era)
state ShelleyTransition
_transition)) = do
      WithOrigin (ShelleyTip proto era)
tip'   <- (ShelleyTip proto (PreviousEra era)
 -> ExceptT Void Identity (ShelleyTip proto era))
-> WithOrigin (ShelleyTip proto (PreviousEra era))
-> ExceptT Void Identity (WithOrigin (ShelleyTip proto era))
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> WithOrigin a -> m (WithOrigin b)
mapM (TranslationContext era
-> ShelleyTip proto (PreviousEra era)
-> Except
     (TranslationError era (ShelleyTip proto)) (ShelleyTip proto era)
forall era (f :: * -> *).
TranslateEra era f =>
TranslationContext era
-> f (PreviousEra era) -> Except (TranslationError era f) (f era)
SL.translateEra TranslationContext era
ctxt) WithOrigin (ShelleyTip proto (PreviousEra era))
tip
      NewEpochState era
state' <- TranslationContext era
-> NewEpochState (PreviousEra era)
-> Except (TranslationError era NewEpochState) (NewEpochState era)
forall era (f :: * -> *).
TranslateEra era f =>
TranslationContext era
-> f (PreviousEra era) -> Except (TranslationError era f) (f era)
SL.translateEra TranslationContext era
ctxt NewEpochState (PreviousEra era)
state
      (:.:) LedgerState (ShelleyBlock proto) era
-> ExceptT
     Void Identity ((:.:) LedgerState (ShelleyBlock proto) era)
forall a. a -> ExceptT Void Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return ((:.:) LedgerState (ShelleyBlock proto) era
 -> ExceptT
      Void Identity ((:.:) LedgerState (ShelleyBlock proto) era))
-> (:.:) LedgerState (ShelleyBlock proto) era
-> ExceptT
     Void Identity ((:.:) LedgerState (ShelleyBlock proto) era)
forall a b. (a -> b) -> a -> b
$ LedgerState (ShelleyBlock proto era)
-> (:.:) LedgerState (ShelleyBlock proto) era
forall l k (f :: l -> *) (g :: k -> l) (p :: k).
f (g p) -> (:.:) f g p
Comp (LedgerState (ShelleyBlock proto era)
 -> (:.:) LedgerState (ShelleyBlock proto) era)
-> LedgerState (ShelleyBlock proto era)
-> (:.:) LedgerState (ShelleyBlock proto) era
forall a b. (a -> b) -> a -> b
$ ShelleyLedgerState {
          shelleyLedgerTip :: WithOrigin (ShelleyTip proto era)
shelleyLedgerTip        = WithOrigin (ShelleyTip proto era)
tip'
        , shelleyLedgerState :: NewEpochState era
shelleyLedgerState      = NewEpochState era
state'
        , shelleyLedgerTransition :: ShelleyTransition
shelleyLedgerTransition = Word32 -> ShelleyTransition
ShelleyTransitionInfo Word32
0
        }

instance ( ShelleyBasedEra era
         , SL.TranslateEra era WrapTx
         ) => SL.TranslateEra era (GenTx :.: ShelleyBlock proto) where
  type TranslationError era (GenTx :.: ShelleyBlock proto) = SL.TranslationError era WrapTx
  translateEra :: TranslationContext era
-> (:.:) GenTx (ShelleyBlock proto) (PreviousEra era)
-> Except
     (TranslationError era (GenTx :.: ShelleyBlock proto))
     ((:.:) GenTx (ShelleyBlock proto) era)
translateEra TranslationContext era
ctxt (Comp (ShelleyTx TxId (EraCrypto (PreviousEra era))
_txId Tx (PreviousEra era)
tx)) =
        GenTx (ShelleyBlock proto era)
-> (:.:) GenTx (ShelleyBlock proto) era
forall l k (f :: l -> *) (g :: k -> l) (p :: k).
f (g p) -> (:.:) f g p
Comp (GenTx (ShelleyBlock proto era)
 -> (:.:) GenTx (ShelleyBlock proto) era)
-> (WrapTx era -> GenTx (ShelleyBlock proto era))
-> WrapTx era
-> (:.:) GenTx (ShelleyBlock proto) era
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tx era -> GenTx (ShelleyBlock proto era)
forall era proto.
ShelleyBasedEra era =>
Tx era -> GenTx (ShelleyBlock proto era)
mkShelleyTx (Tx era -> GenTx (ShelleyBlock proto era))
-> (WrapTx era -> Tx era)
-> WrapTx era
-> GenTx (ShelleyBlock proto era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. WrapTx era -> Tx era
unwrapTx @era
    (WrapTx era -> (:.:) GenTx (ShelleyBlock proto) era)
-> ExceptT (TranslationError era WrapTx) Identity (WrapTx era)
-> ExceptT
     (TranslationError era WrapTx)
     Identity
     ((:.:) GenTx (ShelleyBlock proto) era)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TranslationContext era
-> WrapTx (PreviousEra era)
-> ExceptT (TranslationError era WrapTx) Identity (WrapTx era)
forall era (f :: * -> *).
TranslateEra era f =>
TranslationContext era
-> f (PreviousEra era) -> Except (TranslationError era f) (f era)
SL.translateEra TranslationContext era
ctxt (forall era. Tx era -> WrapTx era
WrapTx @(SL.PreviousEra era) Tx (PreviousEra era)
tx)

instance ( ShelleyBasedEra era
         , SL.TranslateEra era WrapTx
         ) => SL.TranslateEra era (WrapValidatedGenTx :.: ShelleyBlock proto) where
  type TranslationError era (WrapValidatedGenTx :.: ShelleyBlock proto) = SL.TranslationError era WrapTx
  translateEra :: TranslationContext era
-> (:.:) WrapValidatedGenTx (ShelleyBlock proto) (PreviousEra era)
-> Except
     (TranslationError era (WrapValidatedGenTx :.: ShelleyBlock proto))
     ((:.:) WrapValidatedGenTx (ShelleyBlock proto) era)
translateEra TranslationContext era
ctxt (Comp (WrapValidatedGenTx (ShelleyValidatedTx TxId (EraCrypto (PreviousEra era))
_txId Validated (Tx (PreviousEra era))
vtx))) =
        WrapValidatedGenTx (ShelleyBlock proto era)
-> (:.:) WrapValidatedGenTx (ShelleyBlock proto) era
forall l k (f :: l -> *) (g :: k -> l) (p :: k).
f (g p) -> (:.:) f g p
Comp (WrapValidatedGenTx (ShelleyBlock proto era)
 -> (:.:) WrapValidatedGenTx (ShelleyBlock proto) era)
-> (Validated (WrapTx era)
    -> WrapValidatedGenTx (ShelleyBlock proto era))
-> Validated (WrapTx era)
-> (:.:) WrapValidatedGenTx (ShelleyBlock proto) era
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Validated (GenTx (ShelleyBlock proto era))
-> WrapValidatedGenTx (ShelleyBlock proto era)
forall blk. Validated (GenTx blk) -> WrapValidatedGenTx blk
WrapValidatedGenTx
      (Validated (GenTx (ShelleyBlock proto era))
 -> WrapValidatedGenTx (ShelleyBlock proto era))
-> (Validated (WrapTx era)
    -> Validated (GenTx (ShelleyBlock proto era)))
-> Validated (WrapTx era)
-> WrapValidatedGenTx (ShelleyBlock proto era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Validated (Tx era) -> Validated (GenTx (ShelleyBlock proto era))
forall era proto.
ShelleyBasedEra era =>
Validated (Tx era) -> Validated (GenTx (ShelleyBlock proto era))
mkShelleyValidatedTx (Validated (Tx era) -> Validated (GenTx (ShelleyBlock proto era)))
-> (Validated (WrapTx era) -> Validated (Tx era))
-> Validated (WrapTx era)
-> Validated (GenTx (ShelleyBlock proto era))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Validated (WrapTx era) -> Validated (Tx era)
forall a b. Coercible a b => Validated a -> Validated b
SL.coerceValidated
    (Validated (WrapTx era)
 -> (:.:) WrapValidatedGenTx (ShelleyBlock proto) era)
-> ExceptT
     (TranslationError era WrapTx) Identity (Validated (WrapTx era))
-> ExceptT
     (TranslationError era WrapTx)
     Identity
     ((:.:) WrapValidatedGenTx (ShelleyBlock proto) era)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall era (f :: * -> *).
TranslateEra era f =>
TranslationContext era
-> Validated (f (PreviousEra era))
-> Except (TranslationError era f) (Validated (f era))
SL.translateValidated @era @WrapTx TranslationContext era
ctxt (Validated (Tx (PreviousEra era))
-> Validated (WrapTx (PreviousEra era))
forall a b. Coercible a b => Validated a -> Validated b
SL.coerceValidated Validated (Tx (PreviousEra era))
vtx)