Add non-trivial TranslationContext for Shelley, remove TranslateEra *…

… ShelleyGenesis instances

To support the ouroboros-network PR here:
IntersectMBO/ouroboros-network#4091

eras/alonzo/impl/src/Cardano/Ledger/Alonzo/Translation.hs

@@ -29,7 +29,6 @@ import Cardano.Ledger.Serialization (translateViaCBORAnn)
 import Cardano.Ledger.Shelley.API
  ( EpochState (..),
  NewEpochState (..),
- ShelleyGenesis,
  StrictMaybe (..),
  )
 import qualified Cardano.Ledger.Shelley.API as API
@@ -69,27 +68,6 @@ instance Crypto c => TranslateEra (AlonzoEra c) NewEpochState where
  stashedAVVMAddresses = ()
  }
 
-instance Crypto c => TranslateEra (AlonzoEra c) ShelleyGenesis where
- translateEra ctxt genesis =
- return
- API.ShelleyGenesis
- { API.sgSystemStart = API.sgSystemStart genesis,
- API.sgNetworkMagic = API.sgNetworkMagic genesis,
- API.sgNetworkId = API.sgNetworkId genesis,
- API.sgActiveSlotsCoeff = API.sgActiveSlotsCoeff genesis,
- API.sgSecurityParam = API.sgSecurityParam genesis,
- API.sgEpochLength = API.sgEpochLength genesis,
- API.sgSlotsPerKESPeriod = API.sgSlotsPerKESPeriod genesis,
- API.sgMaxKESEvolutions = API.sgMaxKESEvolutions genesis,
- API.sgSlotLength = API.sgSlotLength genesis,
- API.sgUpdateQuorum = API.sgUpdateQuorum genesis,
- API.sgMaxLovelaceSupply = API.sgMaxLovelaceSupply genesis,
- API.sgProtocolParams = translateEra' ctxt (API.sgProtocolParams genesis),
- API.sgGenDelegs = API.sgGenDelegs genesis,
- API.sgInitialFunds = API.sgInitialFunds genesis,
- API.sgStaking = API.sgStaking genesis
- }
-
 newtype Tx era = Tx {unTx :: Core.Tx era}
 
 instance

eras/babbage/impl/src/Cardano/Ledger/Babbage/Translation.hs

@@ -35,7 +35,6 @@ import Cardano.Ledger.Serialization (translateViaCBORAnn)
 import Cardano.Ledger.Shelley.API
  ( EpochState (..),
  NewEpochState (..),
- ShelleyGenesis,
  StrictMaybe (..),
  )
 import qualified Cardano.Ledger.Shelley.API as API
@@ -77,27 +76,6 @@ instance
  stashedAVVMAddresses = ()
  }
 
-instance Crypto c => TranslateEra (BabbageEra c) ShelleyGenesis where
- translateEra ctxt genesis =
- pure
- API.ShelleyGenesis
- { API.sgSystemStart = API.sgSystemStart genesis,
- API.sgNetworkMagic = API.sgNetworkMagic genesis,
- API.sgNetworkId = API.sgNetworkId genesis,
- API.sgActiveSlotsCoeff = API.sgActiveSlotsCoeff genesis,
- API.sgSecurityParam = API.sgSecurityParam genesis,
- API.sgEpochLength = API.sgEpochLength genesis,
- API.sgSlotsPerKESPeriod = API.sgSlotsPerKESPeriod genesis,
- API.sgMaxKESEvolutions = API.sgMaxKESEvolutions genesis,
- API.sgSlotLength = API.sgSlotLength genesis,
- API.sgUpdateQuorum = API.sgUpdateQuorum genesis,
- API.sgMaxLovelaceSupply = API.sgMaxLovelaceSupply genesis,
- API.sgProtocolParams = translateEra' ctxt (API.sgProtocolParams genesis),
- API.sgGenDelegs = API.sgGenDelegs genesis,
- API.sgInitialFunds = API.sgInitialFunds genesis,
- API.sgStaking = API.sgStaking genesis
- }
-
 newtype Tx era = Tx {unTx :: Core.Tx era}
 
 instance

eras/conway/impl/src/Cardano/Ledger/Conway/Translation.hs

@@ -37,7 +37,6 @@ import Cardano.Ledger.Shelley.API
  DState (..),
  EpochState (..),
  NewEpochState (..),
- ShelleyGenesis,
  StrictMaybe (..),
  )
 import qualified Cardano.Ledger.Shelley.API as API
@@ -76,27 +75,6 @@ instance Crypto c => TranslateEra (ConwayEra c) NewEpochState where
  stashedAVVMAddresses = ()
  }
 
-instance Crypto c => TranslateEra (ConwayEra c) ShelleyGenesis where
- translateEra ctxt genesis =
- pure
- API.ShelleyGenesis
- { API.sgSystemStart = API.sgSystemStart genesis,
- API.sgNetworkMagic = API.sgNetworkMagic genesis,
- API.sgNetworkId = API.sgNetworkId genesis,
- API.sgActiveSlotsCoeff = API.sgActiveSlotsCoeff genesis,
- API.sgSecurityParam = API.sgSecurityParam genesis,
- API.sgEpochLength = API.sgEpochLength genesis,
- API.sgSlotsPerKESPeriod = API.sgSlotsPerKESPeriod genesis,
- API.sgMaxKESEvolutions = API.sgMaxKESEvolutions genesis,
- API.sgSlotLength = API.sgSlotLength genesis,
- API.sgUpdateQuorum = API.sgUpdateQuorum genesis,
- API.sgMaxLovelaceSupply = API.sgMaxLovelaceSupply genesis,
- API.sgProtocolParams = translateEra' ctxt (API.sgProtocolParams genesis),
- API.sgGenDelegs = API.sgGenDelegs genesis,
- API.sgInitialFunds = API.sgInitialFunds genesis,
- API.sgStaking = API.sgStaking genesis
- }
-
 newtype Tx era = Tx {unTx :: Core.Tx era}
 
 instance

eras/shelley-ma/impl/src/Cardano/Ledger/Allegra/Translation.hs

@@ -83,27 +83,6 @@ instance forall c. Crypto c => TranslateEra (AllegraEra c) ShelleyTx where
  Right newTx -> pure newTx
  Left decoderError -> throwError decoderError
 
-instance Crypto c => TranslateEra (AllegraEra c) ShelleyGenesis where
- translateEra ctxt genesis =
- return
- ShelleyGenesis
- { sgSystemStart = sgSystemStart genesis,
- sgNetworkMagic = sgNetworkMagic genesis,
- sgNetworkId = sgNetworkId genesis,
- sgActiveSlotsCoeff = sgActiveSlotsCoeff genesis,
- sgSecurityParam = sgSecurityParam genesis,
- sgEpochLength = sgEpochLength genesis,
- sgSlotsPerKESPeriod = sgSlotsPerKESPeriod genesis,
- sgMaxKESEvolutions = sgMaxKESEvolutions genesis,
- sgSlotLength = sgSlotLength genesis,
- sgUpdateQuorum = sgUpdateQuorum genesis,
- sgMaxLovelaceSupply = sgMaxLovelaceSupply genesis,
- sgProtocolParams = translateEra' ctxt (sgProtocolParams genesis),
- sgGenDelegs = sgGenDelegs genesis,
- sgInitialFunds = sgInitialFunds genesis,
- sgStaking = sgStaking genesis
- }
-
 --------------------------------------------------------------------------------
 -- Auxiliary instances and functions
 --------------------------------------------------------------------------------

eras/shelley-ma/impl/src/Cardano/Ledger/Mary/Translation.hs

@@ -74,29 +74,6 @@ instance Crypto c => TranslateEra (MaryEra c) ShelleyTx where
  Right newTx -> pure newTx
  Left decoderError -> throwError decoderError
 
--- TODO when a genesis has been introduced for Mary, this instance can be
--- removed.
-instance Crypto c => TranslateEra (MaryEra c) ShelleyGenesis where
- translateEra ctxt genesis =
- return
- ShelleyGenesis
- { sgSystemStart = sgSystemStart genesis,
- sgNetworkMagic = sgNetworkMagic genesis,
- sgNetworkId = sgNetworkId genesis,
- sgActiveSlotsCoeff = sgActiveSlotsCoeff genesis,
- sgSecurityParam = sgSecurityParam genesis,
- sgEpochLength = sgEpochLength genesis,
- sgSlotsPerKESPeriod = sgSlotsPerKESPeriod genesis,
- sgMaxKESEvolutions = sgMaxKESEvolutions genesis,
- sgSlotLength = sgSlotLength genesis,
- sgUpdateQuorum = sgUpdateQuorum genesis,
- sgMaxLovelaceSupply = sgMaxLovelaceSupply genesis,
- sgProtocolParams = translateEra' ctxt (sgProtocolParams genesis),
- sgGenDelegs = sgGenDelegs genesis,
- sgInitialFunds = sgInitialFunds genesis,
- sgStaking = sgStaking genesis
- }
-
 --------------------------------------------------------------------------------
 -- Auxiliary instances and functions
 --------------------------------------------------------------------------------

eras/shelley-ma/test-suite/test/Test/Cardano/Ledger/Allegra/Translation.hs

@@ -49,7 +49,6 @@ allegraTranslationTests =
  testGroup
  "Allegra translation binary compatibiliby tests"
  [ testProperty "Tx compatibility" (test @S.ShelleyTx),
- testProperty "ShelleyGenesis compatibility" (test @S.ShelleyGenesis),
  testProperty "ProposedPPUpdates compatibility" (test @S.ProposedPPUpdates),
  testProperty "PPUPState compatibility" (test @S.PPUPState),
  testProperty "TxOut compatibility" (test @S.ShelleyTxOut),

eras/shelley/impl/cardano-ledger-shelley.cabal

@@ -80,6 +80,7 @@ library
  Cardano.Ledger.Shelley.Rules.Upec
  Cardano.Ledger.Shelley.Rules.Utxo
  Cardano.Ledger.Shelley.Rules.Utxow
+ Cardano.Ledger.Shelley.Translation
  Cardano.Ledger.Shelley.Tx
  Cardano.Ledger.Shelley.TxBody
  Cardano.Ledger.Shelley.UTxO

eras/shelley/impl/src/Cardano/Ledger/Shelley/API/ByronTranslation.hs

@@ -29,6 +29,7 @@ import Cardano.Ledger.Shelley (ShelleyEra)
 import Cardano.Ledger.Shelley.API.Types
 import Cardano.Ledger.Shelley.EpochBoundary
 import Cardano.Ledger.Shelley.Rules.EraMapping ()
+import Cardano.Ledger.Shelley.Translation (FromByronTranslationContext (..))
 import Cardano.Ledger.Slot
 import Cardano.Ledger.Val ((<->))
 import qualified Data.ByteString.Short as SBS
@@ -91,11 +92,11 @@ translateUTxOByronToShelley (Byron.UTxO utxoByron) =
 translateToShelleyLedgerState ::
  forall c.
  (CC.Crypto c, CC.ADDRHASH c ~ Crypto.Blake2b_224) =>
- ShelleyGenesis (ShelleyEra c) ->
+ FromByronTranslationContext (ShelleyEra c) ->
  EpochNo ->
  Byron.ChainValidationState ->
  NewEpochState (ShelleyEra c)
-translateToShelleyLedgerState genesisShelley epochNo cvs =
+translateToShelleyLedgerState transCtxt epochNo cvs =
  NewEpochState
  { nesEL = epochNo,
  nesBprev = BlocksMade Map.empty,
@@ -114,7 +115,7 @@ translateToShelleyLedgerState genesisShelley epochNo cvs =
  }
  where
  pparams :: ShelleyPParams (ShelleyEra c)
- pparams = sgProtocolParams genesisShelley
+ pparams = fbtcProtocolParams transCtxt
 
  -- NOTE: we ignore the Byron delegation map because the genesis and
  -- delegation verification keys are hashed using a different hashing
@@ -127,11 +128,11 @@ translateToShelleyLedgerState genesisShelley epochNo cvs =
  -- Shelley genesis contains the same genesis and delegation verification
  -- keys, but hashed with the right algorithm.
  genDelegs :: GenDelegs c
- genDelegs = GenDelegs $ sgGenDelegs genesisShelley
+ genDelegs = GenDelegs $ fbtcGenDelegs transCtxt
 
  reserves :: Coin
  reserves =
- word64ToCoin (sgMaxLovelaceSupply genesisShelley) <-> balance utxoShelley
+ word64ToCoin (fbtcMaxLovelaceSupply transCtxt) <-> balance utxoShelley
 
  epochState :: EpochState (ShelleyEra c)
  epochState =

eras/shelley/impl/src/Cardano/Ledger/Shelley/Era.hs

@@ -4,7 +4,7 @@
 module Cardano.Ledger.Shelley.Era (ShelleyEra) where
 
 import Cardano.Ledger.Coin (Coin)
-import Cardano.Ledger.Core (Era (..), TranslationContext, Value)
+import Cardano.Ledger.Core (Era (..), Value)
 import Cardano.Ledger.Crypto as CC (Crypto)
 
 data ShelleyEra crypto
@@ -14,5 +14,3 @@ instance CC.Crypto c => Era (ShelleyEra c) where
  type ProtVerLow (ShelleyEra c) = 2
 
 type instance Value (ShelleyEra _c) = Coin
-
-type instance TranslationContext (ShelleyEra c) = ()

eras/shelley/impl/src/Cardano/Ledger/Shelley/Genesis.hs

@@ -24,6 +24,7 @@ module Cardano.Ledger.Shelley.Genesis
  validateGenesis,
  describeValidationErr,
  mkShelleyGlobals,
+ translateShelleyGenesis
  )
 where
 
@@ -143,6 +144,54 @@ data ShelleyGenesis era = ShelleyGenesis
 
 deriving instance Era era => NoThunks (ShelleyGenesis era)
 
+-- | Although there could be (and was) a `TranslateEra` instance for ShelleyGenesis, it is morally
+-- more correct to have a separate function fulfill that task. The reason is that conceptually there
+-- is no need to translate ShelleyGenesis values when moving to the next era. A `TranslateEra`
+-- instance would be a convenience that is ultimately more confusing.
+translateShelleyGenesis :: Crypto era1 ~ Crypto era2 => ShelleyGenesis era1 -> ShelleyGenesis era2
+translateShelleyGenesis genesis =
+ ShelleyGenesis
+ { sgSystemStart = sgSystemStart genesis,
+ sgNetworkMagic = sgNetworkMagic genesis,
+ sgNetworkId = sgNetworkId genesis,
+ sgActiveSlotsCoeff = sgActiveSlotsCoeff genesis,
+ sgSecurityParam = sgSecurityParam genesis,
+ sgEpochLength = sgEpochLength genesis,
+ sgSlotsPerKESPeriod = sgSlotsPerKESPeriod genesis,
+ sgMaxKESEvolutions = sgMaxKESEvolutions genesis,
+ sgSlotLength = sgSlotLength genesis,
+ sgUpdateQuorum = sgUpdateQuorum genesis,
+ sgMaxLovelaceSupply = sgMaxLovelaceSupply genesis,
+ sgProtocolParams = translatePParams $ sgProtocolParams genesis,
+ sgGenDelegs = sgGenDelegs genesis,
+ sgInitialFunds = sgInitialFunds genesis,
+ sgStaking = sgStaking genesis
+ }
+ where
+ translatePParams :: ShelleyPParams era1 -> ShelleyPParams era2
+ translatePParams pp = ShelleyPParams
+ { _minfeeA = _minfeeA pp,
+ _minfeeB = _minfeeB pp,
+ _maxBBSize = _maxBBSize pp,
+ _maxTxSize = _maxTxSize pp,
+ _maxBHSize = _maxBHSize pp,
+ _keyDeposit = _keyDeposit pp,
+ _poolDeposit = _poolDeposit pp,
+ _eMax = _eMax pp,
+ _nOpt = _nOpt pp,
+ _a0 = _a0 pp,
+ _rho = _rho pp,
+ _tau = _tau pp,
+ _d = _d pp,
+ _extraEntropy = _extraEntropy pp,
+ _protocolVersion = _protocolVersion pp,
+ _minUTxOValue = _minUTxOValue pp,
+ _minPoolCost = _minPoolCost pp
+ }
+
+
+
+
 sgActiveSlotCoeff :: ShelleyGenesis era -> ActiveSlotCoeff
 sgActiveSlotCoeff = mkActiveSlotCoeff . sgActiveSlotsCoeff
 

eras/shelley/impl/src/Cardano/Ledger/Shelley/Translation.hs

@@ -0,0 +1,46 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE DeriveAnyClass #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE NamedFieldPuns #-}
+module Cardano.Ledger.Shelley.Translation where
+
+import Cardano.Ledger.Shelley.Era (ShelleyEra)
+import Cardano.Ledger.Core (TranslationContext, Era, Crypto)
+import Cardano.Ledger.Shelley.PParams (ShelleyPParams, emptyPParams)
+import Cardano.Ledger.Shelley.Genesis (ShelleyGenesis (..))
+import Cardano.Ledger.Keys
+import Data.Map (Map)
+import qualified Data.Map as Map
+import GHC.Generics (Generic)
+import GHC.Word (Word64)
+import NoThunks.Class (NoThunks (..))
+
+-- | Required data to translate a Byron ledger into a Shelley ledger.
+data FromByronTranslationContext era = FromByronTranslationContext {
+ fbtcGenDelegs :: !(Map (KeyHash 'Genesis (Crypto era)) (GenDelegPair (Crypto era)))
+ , fbtcProtocolParams :: !(ShelleyPParams era)
+ , fbtcMaxLovelaceSupply :: !Word64
+ } deriving (Eq, Show, Generic)
+
+-- | Trivial FromByronTranslationContext value, for use in cases where we do not need
+-- to translate from Byron to Shelley.
+emptyFromByronTranslationContext :: FromByronTranslationContext era
+emptyFromByronTranslationContext = FromByronTranslationContext {
+ fbtcGenDelegs = Map.empty
+ , fbtcMaxLovelaceSupply = 0
+ , fbtcProtocolParams = emptyPParams
+ }
+
+toFromByronTranslationContext :: ShelleyGenesis era -> FromByronTranslationContext era
+toFromByronTranslationContext ShelleyGenesis {sgGenDelegs, sgMaxLovelaceSupply, sgProtocolParams} =
+ FromByronTranslationContext {
+ fbtcGenDelegs = sgGenDelegs
+ , fbtcProtocolParams = sgProtocolParams
+ , fbtcMaxLovelaceSupply = sgMaxLovelaceSupply
+ }
+
+deriving instance Era era => NoThunks (FromByronTranslationContext era)
+
+type instance TranslationContext (ShelleyEra c) = FromByronTranslationContext (ShelleyEra c)

eras/shelley/test-suite/src/Test/Cardano/Ledger/Shelley/Examples/Consensus.hs

@@ -32,6 +32,7 @@ import Cardano.Ledger.Shelley.PParams
 import Cardano.Ledger.Shelley.Rules.Delegs
 import Cardano.Ledger.Shelley.Rules.Ledger
 import Cardano.Ledger.Shelley.Tx
+import Cardano.Ledger.Shelley.Translation (emptyFromByronTranslationContext)
 import Cardano.Ledger.Shelley.UTxO
 import Cardano.Protocol.TPraos.API
 import Cardano.Protocol.TPraos.BHeader
@@ -406,7 +407,7 @@ ledgerExamplesShelley =
  exampleCoin
  exampleTxBodyShelley
  exampleAuxiliaryDataShelley
- ()
+ emptyFromByronTranslationContext
 
 mkWitnessesPreAlonzo ::
  ( Core.EraTx era,

libs/cardano-protocol-tpraos/src/Cardano/Protocol/TPraos/API.hs

@@ -76,7 +76,7 @@ import Cardano.Ledger.Mary (MaryEra)
 import Cardano.Ledger.PoolDistr (PoolDistr (..), individualPoolStake)
 import Cardano.Ledger.Serialization (decodeRecordNamed)
 import Cardano.Ledger.Shelley (ShelleyEra)
-import Cardano.Ledger.Shelley.Genesis (ShelleyGenesis (..))
+import Cardano.Ledger.Shelley.Translation (FromByronTranslationContext (..))
 import Cardano.Ledger.Shelley.LedgerState
  ( EpochState (..),
  NewEpochState (..),
@@ -596,14 +596,14 @@ getLeaderSchedule globals ss cds poolHash key pp = Set.filter isLeader epochSlot
 -- way as 'translateToShelleyLedgerState'.
 mkInitialShelleyLedgerView ::
  forall c.
- ShelleyGenesis (ShelleyEra c) ->
+ FromByronTranslationContext (ShelleyEra c) ->
  LedgerView c
-mkInitialShelleyLedgerView genesisShelley =
- let !ee = _extraEntropy . sgProtocolParams $ genesisShelley
+mkInitialShelleyLedgerView transCtxt =
+ let !ee = _extraEntropy . fbtcProtocolParams $ transCtxt
  in LedgerView
- { lvD = _d . sgProtocolParams $ genesisShelley,
+ { lvD = _d . fbtcProtocolParams $ transCtxt,
  lvExtraEntropy = ee,
  lvPoolDistr = PoolDistr Map.empty,
- lvGenDelegs = GenDelegs $ sgGenDelegs genesisShelley,
- lvChainChecks = pparamsToChainChecksPParams . sgProtocolParams $ genesisShelley
+ lvGenDelegs = GenDelegs $ fbtcGenDelegs transCtxt,
+ lvChainChecks = pparamsToChainChecksPParams . fbtcProtocolParams $ transCtxt
  }