{-# LANGUAGE DataKinds             #-}
{-# LANGUAGE DeriveAnyClass        #-}
{-# LANGUAGE DeriveGeneric         #-}
{-# LANGUAGE FlexibleContexts      #-}
{-# LANGUAGE FlexibleInstances     #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RecordWildCards       #-}
{-# LANGUAGE ScopedTypeVariables   #-}
{-# 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 (..)
  , forecastAcrossShelley
  , translateChainDepStateAcrossShelley
  , translateLedgerViewAcrossShelley
  ) where

import           Control.Monad (guard)
import           Control.Monad.Except (runExcept, throwError, withExceptT)
import qualified Data.Map.Strict as Map
import           Data.Maybe
import           Data.SOP.Strict
import qualified Data.Text as T (pack)
import           Data.Void (Void)
import           Data.Word
import           GHC.Generics (Generic)
import           NoThunks.Class (NoThunks)

import           Cardano.Slotting.EpochInfo (hoistEpochInfo)

import           Ouroboros.Consensus.Block
import           Ouroboros.Consensus.Config
import           Ouroboros.Consensus.Forecast
import           Ouroboros.Consensus.HardFork.Combinator
import           Ouroboros.Consensus.HardFork.Combinator.Serialisation.Common
import           Ouroboros.Consensus.HardFork.Combinator.State.Types
import           Ouroboros.Consensus.HardFork.Combinator.Util.InPairs
                     (RequiringBoth (..), ignoringBoth)
import           Ouroboros.Consensus.HardFork.History (Bound (boundSlot))
import           Ouroboros.Consensus.HardFork.Simple
import           Ouroboros.Consensus.Ledger.Abstract
import           Ouroboros.Consensus.Node.NetworkProtocolVersion
import           Ouroboros.Consensus.TypeFamilyWrappers

import qualified Cardano.Ledger.Era as SL
import qualified Cardano.Ledger.Shelley.API as SL

import qualified Cardano.Protocol.TPraos.API as SL
import qualified Ouroboros.Consensus.Forecast as Forecast
import           Ouroboros.Consensus.Ledger.SupportsProtocol
                     (LedgerSupportsProtocol, ledgerViewForecastAt)
import           Ouroboros.Consensus.Protocol.Praos
import           Ouroboros.Consensus.Protocol.TPraos hiding (PraosCrypto)
import           Ouroboros.Consensus.Protocol.Translate (TranslateProto)
import qualified Ouroboros.Consensus.Protocol.Translate as Proto
import           Ouroboros.Consensus.Shelley.Eras
import           Ouroboros.Consensus.Shelley.Ledger
import           Ouroboros.Consensus.Shelley.Ledger.Inspect as Shelley.Inspect
import           Ouroboros.Consensus.Shelley.Node ()

{-------------------------------------------------------------------------------
  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)
  ) => NoHardForks (ShelleyBlock proto era) where
  getEraParams :: TopLevelConfig (ShelleyBlock proto era) -> EraParams
getEraParams =
        ShelleyGenesis era -> EraParams
forall era. ShelleyGenesis era -> EraParams
shelleyEraParamsNeverHardForks
      (ShelleyGenesis era -> EraParams)
-> (TopLevelConfig (ShelleyBlock proto era) -> ShelleyGenesis era)
-> TopLevelConfig (ShelleyBlock proto era)
-> EraParams
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShelleyLedgerConfig era -> ShelleyGenesis era
forall era. ShelleyLedgerConfig era -> ShelleyGenesis era
shelleyLedgerGenesis
      (ShelleyLedgerConfig era -> ShelleyGenesis era)
-> (TopLevelConfig (ShelleyBlock proto era)
    -> ShelleyLedgerConfig era)
-> TopLevelConfig (ShelleyBlock proto era)
-> ShelleyGenesis era
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TopLevelConfig (ShelleyBlock proto era) -> ShelleyLedgerConfig era
forall blk. TopLevelConfig blk -> LedgerConfig blk
configLedger
  toPartialLedgerConfig :: proxy (ShelleyBlock proto era)
-> LedgerConfig (ShelleyBlock proto era)
-> PartialLedgerConfig (ShelleyBlock proto era)
toPartialLedgerConfig proxy (ShelleyBlock proto era)
_ LedgerConfig (ShelleyBlock proto era)
cfg = ShelleyPartialLedgerConfig :: forall era.
ShelleyLedgerConfig era
-> TriggerHardFork -> ShelleyPartialLedgerConfig era
ShelleyPartialLedgerConfig {
        shelleyLedgerConfig :: ShelleyLedgerConfig era
shelleyLedgerConfig    = LedgerConfig (ShelleyBlock proto era)
ShelleyLedgerConfig era
cfg
      , shelleyTriggerHardFork :: TriggerHardFork
shelleyTriggerHardFork = TriggerHardFork
TriggerHardForkNever
      }

{-------------------------------------------------------------------------------
  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))
      => SupportedNetworkProtocolVersion (ShelleyBlockHFC proto era) where
  supportedNodeToNodeVersions :: Proxy (ShelleyBlockHFC proto era)
-> Map
     NodeToNodeVersion
     (BlockNodeToNodeVersion (ShelleyBlockHFC proto era))
supportedNodeToNodeVersions Proxy (ShelleyBlockHFC proto era)
_ =
      (ShelleyNodeToNodeVersion
 -> HardForkNodeToNodeVersion '[ShelleyBlock proto era])
-> Map NodeToNodeVersion ShelleyNodeToNodeVersion
-> Map
     NodeToNodeVersion
     (HardForkNodeToNodeVersion '[ShelleyBlock proto era])
forall a b k. (a -> b) -> Map k a -> Map k b
Map.map ShelleyNodeToNodeVersion
-> HardForkNodeToNodeVersion '[ShelleyBlock proto era]
forall x (xs1 :: [*]).
BlockNodeToNodeVersion x -> HardForkNodeToNodeVersion (x : xs1)
HardForkNodeToNodeDisabled (Map NodeToNodeVersion ShelleyNodeToNodeVersion
 -> Map
      NodeToNodeVersion
      (HardForkNodeToNodeVersion '[ShelleyBlock proto era]))
-> Map NodeToNodeVersion ShelleyNodeToNodeVersion
-> Map
     NodeToNodeVersion
     (HardForkNodeToNodeVersion '[ShelleyBlock 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 (Proxy (ShelleyBlock proto era)
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)
_ =
      (ShelleyNodeToClientVersion
 -> HardForkNodeToClientVersion '[ShelleyBlock proto era])
-> Map NodeToClientVersion ShelleyNodeToClientVersion
-> Map
     NodeToClientVersion
     (HardForkNodeToClientVersion '[ShelleyBlock proto era])
forall a b k. (a -> b) -> Map k a -> Map k b
Map.map ShelleyNodeToClientVersion
-> HardForkNodeToClientVersion '[ShelleyBlock proto era]
forall x (xs1 :: [*]).
BlockNodeToClientVersion x -> HardForkNodeToClientVersion (x : xs1)
HardForkNodeToClientDisabled (Map NodeToClientVersion ShelleyNodeToClientVersion
 -> Map
      NodeToClientVersion
      (HardForkNodeToClientVersion '[ShelleyBlock proto era]))
-> Map NodeToClientVersion ShelleyNodeToClientVersion
-> Map
     NodeToClientVersion
     (HardForkNodeToClientVersion '[ShelleyBlock 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 (Proxy (ShelleyBlock proto era)
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))
 => SerialiseHFC '[ShelleyBlock proto era]
instance (ShelleyCompatible proto era, LedgerSupportsProtocol (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 major protocol version
  -> LedgerState (ShelleyBlock proto era)
  -> Maybe EpochNo
shelleyTransition :: PartialLedgerConfig (ShelleyBlock proto era)
-> Word16 -> LedgerState (ShelleyBlock proto era) -> Maybe EpochNo
shelleyTransition ShelleyPartialLedgerConfig{..}
                  Word16
transitionMajorVersion
                  LedgerState (ShelleyBlock proto era)
state =
      [EpochNo] -> Maybe EpochNo
forall a. [a] -> Maybe a
takeAny
    ([EpochNo] -> Maybe EpochNo)
-> (LedgerState (ShelleyBlock proto era) -> [EpochNo])
-> LedgerState (ShelleyBlock proto era)
-> Maybe EpochNo
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ProtocolUpdate era -> Maybe EpochNo)
-> [ProtocolUpdate era] -> [EpochNo]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe ProtocolUpdate era -> Maybe EpochNo
isTransition
    ([ProtocolUpdate era] -> [EpochNo])
-> (LedgerState (ShelleyBlock proto era) -> [ProtocolUpdate era])
-> LedgerState (ShelleyBlock proto era)
-> [EpochNo]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShelleyGenesis era
-> LedgerState (ShelleyBlock proto era) -> [ProtocolUpdate era]
forall era proto.
ShelleyBasedEra era =>
ShelleyGenesis era
-> LedgerState (ShelleyBlock proto era) -> [ProtocolUpdate era]
Shelley.Inspect.protocolUpdates ShelleyGenesis era
genesis
    (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{SizeInBytes
shelleyAfterVoting :: ShelleyTransition -> SizeInBytes
shelleyAfterVoting :: SizeInBytes
..} = 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 era
    genesis :: ShelleyGenesis era
genesis = ShelleyLedgerConfig era -> ShelleyGenesis era
forall era. ShelleyLedgerConfig era -> ShelleyGenesis era
shelleyLedgerGenesis ShelleyLedgerConfig era
shelleyLedgerConfig

    k :: Word64
    k :: Word64
k = ShelleyGenesis era -> Word64
forall era. ShelleyGenesis era -> Word64
SL.sgSecurityParam ShelleyGenesis era
genesis

    isTransition :: Shelley.Inspect.ProtocolUpdate era -> Maybe EpochNo
    isTransition :: ProtocolUpdate era -> Maybe EpochNo
isTransition Shelley.Inspect.ProtocolUpdate{UpdateState (EraCrypto era)
UpdateProposal era
protocolUpdateState :: forall era. ProtocolUpdate era -> UpdateState (EraCrypto era)
protocolUpdateProposal :: forall era. ProtocolUpdate era -> UpdateProposal era
protocolUpdateState :: UpdateState (EraCrypto era)
protocolUpdateProposal :: UpdateProposal era
..} = do
         SL.ProtVer Natural
major Natural
_minor <- Maybe ProtVer
proposalVersion
         Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Maybe ()) -> Bool -> Maybe ()
forall a b. (a -> b) -> a -> b
$ Natural -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral Natural
major Word16 -> Word16 -> Bool
forall a. Eq a => a -> a -> Bool
== Word16
transitionMajorVersion
         Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Maybe ()) -> Bool -> Maybe ()
forall a b. (a -> b) -> a -> b
$ Bool
proposalReachedQuorum
         Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Maybe ()) -> Bool -> Maybe ()
forall a b. (a -> b) -> a -> b
$ SizeInBytes
shelleyAfterVoting SizeInBytes -> SizeInBytes -> Bool
forall a. Ord a => a -> a -> Bool
>= Word64 -> SizeInBytes
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
k
         EpochNo -> Maybe EpochNo
forall (m :: * -> *) a. Monad m => a -> m a
return EpochNo
proposalEpoch
       where
         Shelley.Inspect.UpdateProposal{Maybe ProtVer
PParamsDelta era
EpochNo
proposalEpoch :: forall era. UpdateProposal era -> EpochNo
proposalVersion :: forall era. UpdateProposal era -> Maybe ProtVer
proposalParams :: forall era. UpdateProposal era -> PParamsDelta era
proposalParams :: PParamsDelta era
proposalEpoch :: EpochNo
proposalVersion :: Maybe ProtVer
..} = UpdateProposal era
protocolUpdateProposal
         Shelley.Inspect.UpdateState{Bool
[KeyHash 'Genesis (ProtoCrypto proto)]
proposalReachedQuorum :: forall c. UpdateState c -> Bool
proposalVotes :: forall c. UpdateState c -> [KeyHash 'Genesis c]
proposalVotes :: [KeyHash 'Genesis (ProtoCrypto proto)]
proposalReachedQuorum :: Bool
..}    = UpdateState (EraCrypto era)
UpdateState (ProtoCrypto proto)
protocolUpdateState

    -- In principle there could be multiple proposals that all change the
    -- major protocol version. In practice this can't happen because each
    -- delegate can only vote for one proposal, but the types don't guarantee
    -- this. We don't need to worry about this, and just pick any of them.
    takeAny :: [a] -> Maybe a
    takeAny :: [a] -> Maybe a
takeAny = [a] -> Maybe a
forall a. [a] -> Maybe a
listToMaybe

instance
  ( ShelleyCompatible proto era,
    LedgerSupportsProtocol (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 =
      case ShelleyPartialLedgerConfig era -> TriggerHardFork
forall era. ShelleyPartialLedgerConfig era -> TriggerHardFork
shelleyTriggerHardFork PartialLedgerConfig (ShelleyBlock proto era)
ShelleyPartialLedgerConfig era
pcfg of
        TriggerHardFork
TriggerHardForkNever                         -> 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 :: proxy (ShelleyBlock proto era)
-> SingleEraInfo (ShelleyBlock proto era)
singleEraInfo proxy (ShelleyBlock proto era)
_ = SingleEraInfo :: forall blk. Text -> SingleEraInfo blk
SingleEraInfo {
      singleEraName :: Text
singleEraName = Proxy era -> Text
forall era (proxy :: * -> *).
ShelleyBasedEra era =>
proxy era -> Text
shelleyBasedEraName (Proxy era
forall k (t :: k). Proxy t
Proxy @era)
    }

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

  completeConsensusConfig :: 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 :: forall c.
PraosParams
-> EpochInfo (Except PastHorizonException)
-> ConsensusConfig (Praos c)
PraosConfig {EpochInfo (Except PastHorizonException)
PartialConsensusConfig (Praos c)
PraosParams
praosParams :: PraosParams
praosEpochInfo :: EpochInfo (Except PastHorizonException)
praosParams :: PartialConsensusConfig (Praos c)
praosEpochInfo :: EpochInfo (Except PastHorizonException)
..}

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

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

  completeConsensusConfig :: 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 :: forall c.
TPraosParams
-> EpochInfo (Except PastHorizonException)
-> ConsensusConfig (TPraos c)
TPraosConfig {EpochInfo (Except PastHorizonException)
PartialConsensusConfig (TPraos c)
TPraosParams
tpraosParams :: TPraosParams
tpraosEpochInfo :: EpochInfo (Except PastHorizonException)
tpraosParams :: PartialConsensusConfig (TPraos c)
tpraosEpochInfo :: EpochInfo (Except PastHorizonException)
..}

  toPartialConsensusConfig :: proxy (TPraos c)
-> ConsensusConfig (TPraos c) -> PartialConsensusConfig (TPraos c)
toPartialConsensusConfig proxy (TPraos c)
_ = ConsensusConfig (TPraos c) -> PartialConsensusConfig (TPraos c)
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').
      ShelleyPartialLedgerConfig era -> ShelleyLedgerConfig era
shelleyLedgerConfig    :: !(ShelleyLedgerConfig 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
$cto :: forall era x.
Rep (ShelleyPartialLedgerConfig era) x
-> ShelleyPartialLedgerConfig era
$cfrom :: forall era x.
ShelleyPartialLedgerConfig era
-> Rep (ShelleyPartialLedgerConfig era) x
Generic, Context -> ShelleyPartialLedgerConfig era -> IO (Maybe ThunkInfo)
Proxy (ShelleyPartialLedgerConfig era) -> String
(Context -> ShelleyPartialLedgerConfig era -> IO (Maybe ThunkInfo))
-> (Context
    -> ShelleyPartialLedgerConfig era -> IO (Maybe ThunkInfo))
-> (Proxy (ShelleyPartialLedgerConfig era) -> String)
-> NoThunks (ShelleyPartialLedgerConfig era)
forall era.
ShelleyBasedEra era =>
Context -> ShelleyPartialLedgerConfig era -> IO (Maybe ThunkInfo)
forall era.
ShelleyBasedEra era =>
Proxy (ShelleyPartialLedgerConfig era) -> String
forall a.
(Context -> a -> IO (Maybe ThunkInfo))
-> (Context -> a -> IO (Maybe ThunkInfo))
-> (Proxy a -> String)
-> NoThunks a
showTypeOf :: Proxy (ShelleyPartialLedgerConfig era) -> String
$cshowTypeOf :: forall era.
ShelleyBasedEra era =>
Proxy (ShelleyPartialLedgerConfig era) -> String
wNoThunks :: Context -> ShelleyPartialLedgerConfig era -> IO (Maybe ThunkInfo)
$cwNoThunks :: forall era.
ShelleyBasedEra era =>
Context -> ShelleyPartialLedgerConfig era -> IO (Maybe ThunkInfo)
noThunks :: Context -> ShelleyPartialLedgerConfig era -> IO (Maybe ThunkInfo)
$cnoThunks :: forall era.
ShelleyBasedEra era =>
Context -> ShelleyPartialLedgerConfig era -> IO (Maybe ThunkInfo)
NoThunks)

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 :: 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 cfg _) =
      ShelleyLedgerConfig era
cfg {
          shelleyLedgerGlobals :: Globals
shelleyLedgerGlobals = (ShelleyLedgerConfig era -> Globals
forall era. ShelleyLedgerConfig era -> Globals
shelleyLedgerGlobals ShelleyLedgerConfig era
cfg) {
              epochInfo :: EpochInfo (Either Text)
SL.epochInfo =
                  (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
                    (Except Text a -> Either Text a
forall e a. Except e a -> Either e a
runExcept (Except Text a -> Either Text a)
-> (ExceptT PastHorizonException Identity a -> Except Text a)
-> ExceptT PastHorizonException Identity a
-> Either Text a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PastHorizonException -> Text)
-> ExceptT PastHorizonException Identity a -> Except Text a
forall (m :: * -> *) e e' a.
Functor m =>
(e -> e') -> ExceptT e m a -> ExceptT e' m a
withExceptT (String -> Text
T.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))
                    EpochInfo (Except PastHorizonException)
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 (Ticked (WrapLedgerView (ShelleyBlock protoTo eraTo)))
forecastAcrossShelley :: ShelleyLedgerConfig eraFrom
-> ShelleyLedgerConfig eraTo
-> Bound
-> SlotNo
-> LedgerState (ShelleyBlock protoFrom eraFrom)
-> Except
     OutsideForecastRange
     (Ticked (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
    = Ticked (WrapLedgerView (ShelleyBlock protoTo eraTo))
-> Except
     OutsideForecastRange
     (Ticked (WrapLedgerView (ShelleyBlock protoTo eraTo)))
forall (m :: * -> *) a. Monad m => a -> m a
return (Ticked (WrapLedgerView (ShelleyBlock protoTo eraTo))
 -> Except
      OutsideForecastRange
      (Ticked (WrapLedgerView (ShelleyBlock protoTo eraTo))))
-> Ticked (WrapLedgerView (ShelleyBlock protoTo eraTo))
-> Except
     OutsideForecastRange
     (Ticked (WrapLedgerView (ShelleyBlock protoTo eraTo)))
forall a b. (a -> b) -> a -> b
$ SlotNo -> Ticked (WrapLedgerView (ShelleyBlock protoTo eraTo))
forall era.
SlotNo -> Ticked (WrapLedgerView (ShelleyBlock protoTo era))
futureLedgerView SlotNo
forecastFor
    | Bool
otherwise
    = OutsideForecastRange
-> Except
     OutsideForecastRange
     (Ticked (WrapLedgerView (ShelleyBlock protoTo eraTo)))
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (OutsideForecastRange
 -> Except
      OutsideForecastRange
      (Ticked (WrapLedgerView (ShelleyBlock protoTo eraTo))))
-> OutsideForecastRange
-> Except
     OutsideForecastRange
     (Ticked (WrapLedgerView (ShelleyBlock protoTo eraTo)))
forall a b. (a -> b) -> a -> b
$ OutsideForecastRange :: WithOrigin SlotNo -> SlotNo -> SlotNo -> OutsideForecastRange
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 -> Ticked (WrapLedgerView (ShelleyBlock protoTo era))
    futureLedgerView :: SlotNo -> Ticked (WrapLedgerView (ShelleyBlock protoTo era))
futureLedgerView =
          Ticked (LedgerView protoTo)
-> Ticked (WrapLedgerView (ShelleyBlock protoTo era))
forall blk.
Ticked (LedgerView (BlockProtocol blk))
-> Ticked (WrapLedgerView blk)
WrapTickedLedgerView
        (Ticked (LedgerView protoTo)
 -> Ticked (WrapLedgerView (ShelleyBlock protoTo era)))
-> (SlotNo -> Ticked (LedgerView protoTo))
-> SlotNo
-> Ticked (WrapLedgerView (ShelleyBlock protoTo era))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (OutsideForecastRange -> Ticked (LedgerView protoTo))
-> (Ticked (LedgerView protoFrom) -> Ticked (LedgerView protoTo))
-> Either OutsideForecastRange (Ticked (LedgerView protoFrom))
-> Ticked (LedgerView protoTo)
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either
            (\OutsideForecastRange
e -> String -> Ticked (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))
            (TranslateProto protoFrom protoTo =>
Ticked (LedgerView protoFrom) -> Ticked (LedgerView protoTo)
forall protoFrom protoTo.
TranslateProto protoFrom protoTo =>
Ticked (LedgerView protoFrom) -> Ticked (LedgerView protoTo)
Proto.translateTickedLedgerView @protoFrom @protoTo)
        (Either OutsideForecastRange (Ticked (LedgerView protoFrom))
 -> Ticked (LedgerView protoTo))
-> (SlotNo
    -> Either OutsideForecastRange (Ticked (LedgerView protoFrom)))
-> SlotNo
-> Ticked (LedgerView protoTo)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Except OutsideForecastRange (Ticked (LedgerView protoFrom))
-> Either OutsideForecastRange (Ticked (LedgerView protoFrom))
forall e a. Except e a -> Either e a
runExcept
        (Except OutsideForecastRange (Ticked (LedgerView protoFrom))
 -> Either OutsideForecastRange (Ticked (LedgerView protoFrom)))
-> (SlotNo
    -> Except OutsideForecastRange (Ticked (LedgerView protoFrom)))
-> SlotNo
-> Either OutsideForecastRange (Ticked (LedgerView protoFrom))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Forecast (LedgerView protoFrom)
-> SlotNo
-> Except OutsideForecastRange (Ticked (LedgerView protoFrom))
forall a.
Forecast a -> SlotNo -> Except OutsideForecastRange (Ticked 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 :: 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
$ ChainDepState protoFrom -> ChainDepState protoTo
forall protoFrom protoTo.
TranslateProto protoFrom protoTo =>
ChainDepState protoFrom -> ChainDepState protoTo
Proto.translateChainDepState @protoFrom @protoTo ChainDepState protoFrom
ChainDepState (BlockProtocol (ShelleyBlock protoFrom eraFrom))
chainDepState

translateLedgerViewAcrossShelley ::
     forall eraFrom eraTo protoFrom protoTo.
     ( TranslateProto protoFrom protoTo
     , LedgerSupportsProtocol (ShelleyBlock protoFrom eraFrom)
     )
  => RequiringBoth
       WrapLedgerConfig
       (TranslateForecast LedgerState WrapLedgerView)
       (ShelleyBlock protoFrom eraFrom)
       (ShelleyBlock protoTo eraTo)
translateLedgerViewAcrossShelley :: RequiringBoth
  WrapLedgerConfig
  (TranslateForecast LedgerState WrapLedgerView)
  (ShelleyBlock protoFrom eraFrom)
  (ShelleyBlock protoTo eraTo)
translateLedgerViewAcrossShelley =
    (WrapLedgerConfig (ShelleyBlock protoFrom eraFrom)
 -> WrapLedgerConfig (ShelleyBlock protoTo eraTo)
 -> TranslateForecast
      LedgerState
      WrapLedgerView
      (ShelleyBlock protoFrom eraFrom)
      (ShelleyBlock protoTo eraTo))
-> RequiringBoth
     WrapLedgerConfig
     (TranslateForecast 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)
  -> TranslateForecast
       LedgerState
       WrapLedgerView
       (ShelleyBlock protoFrom eraFrom)
       (ShelleyBlock protoTo eraTo))
 -> RequiringBoth
      WrapLedgerConfig
      (TranslateForecast LedgerState WrapLedgerView)
      (ShelleyBlock protoFrom eraFrom)
      (ShelleyBlock protoTo eraTo))
-> (WrapLedgerConfig (ShelleyBlock protoFrom eraFrom)
    -> WrapLedgerConfig (ShelleyBlock protoTo eraTo)
    -> TranslateForecast
         LedgerState
         WrapLedgerView
         (ShelleyBlock protoFrom eraFrom)
         (ShelleyBlock protoTo eraTo))
-> RequiringBoth
     WrapLedgerConfig
     (TranslateForecast 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
      (Ticked (WrapLedgerView (ShelleyBlock protoTo eraTo))))
-> TranslateForecast
     LedgerState
     WrapLedgerView
     (ShelleyBlock protoFrom eraFrom)
     (ShelleyBlock protoTo eraTo)
forall (f :: * -> *) (g :: * -> *) x y.
(Bound
 -> SlotNo -> f x -> Except OutsideForecastRange (Ticked (g y)))
-> TranslateForecast f g x y
TranslateForecast ((Bound
  -> SlotNo
  -> LedgerState (ShelleyBlock protoFrom eraFrom)
  -> Except
       OutsideForecastRange
       (Ticked (WrapLedgerView (ShelleyBlock protoTo eraTo))))
 -> TranslateForecast
      LedgerState
      WrapLedgerView
      (ShelleyBlock protoFrom eraFrom)
      (ShelleyBlock protoTo eraTo))
-> (Bound
    -> SlotNo
    -> LedgerState (ShelleyBlock protoFrom eraFrom)
    -> Except
         OutsideForecastRange
         (Ticked (WrapLedgerView (ShelleyBlock protoTo eraTo))))
-> TranslateForecast
     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
     (Ticked (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
     (Ticked (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)
         , 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)) =
      ShelleyTip proto era
-> ExceptT Void Identity (ShelleyTip proto era)
forall (m :: * -> *) a. Monad m => a -> m a
return (ShelleyTip proto era
 -> ExceptT Void Identity (ShelleyTip proto era))
-> ShelleyTip proto era
-> ExceptT Void Identity (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 tip state _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)
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 (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 :: forall proto era.
WithOrigin (ShelleyTip proto era)
-> NewEpochState era
-> ShelleyTransition
-> LedgerState (ShelleyBlock proto era)
ShelleyLedgerState {
          shelleyLedgerTip :: WithOrigin (ShelleyTip proto era)
shelleyLedgerTip        = WithOrigin (ShelleyTip proto era)
tip'
        , shelleyLedgerState :: NewEpochState era
shelleyLedgerState      = NewEpochState era
state'
        , shelleyLedgerTransition :: ShelleyTransition
shelleyLedgerTransition = SizeInBytes -> ShelleyTransition
ShelleyTransitionInfo SizeInBytes
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 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
. WrapTx era -> Tx era
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 (Tx (PreviousEra era) -> WrapTx (PreviousEra era)
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 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
<$> TranslationContext era
-> Validated (WrapTx (PreviousEra era))
-> ExceptT
     (TranslationError era WrapTx) Identity (Validated (WrapTx era))
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)