Parametrise PParams by era (#1846)

This will be needed since `PParams` will vary in future eras.

shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/API/Mempool.hs

@@ -35,7 +35,7 @@ import Shelley.Spec.Ledger.Slot (SlotNo)
 import Shelley.Spec.Ledger.Tx (Tx)
 import qualified Shelley.Spec.Ledger.Tx as Tx
 
-type MempoolEnv = Ledgers.LedgersEnv
+type MempoolEnv era = Ledgers.LedgersEnv era
 
 type MempoolState = LedgerState.LedgerState
 
@@ -55,7 +55,7 @@ type MempoolState = LedgerState.LedgerState
 mkMempoolEnv ::
   ShelleyState era ->
   SlotNo ->
-  MempoolEnv
+  MempoolEnv era
 mkMempoolEnv
   LedgerState.NewEpochState
     { LedgerState.nesEs
@@ -98,7 +98,7 @@ applyTxs ::
     DSignable era (Hash era (Tx.TxBody era))
   ) =>
   Globals ->
-  MempoolEnv ->
+  MempoolEnv era ->
   Seq (Tx era) ->
   MempoolState era ->
   m (MempoolState era)

shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/API/Protocol.hs

@@ -77,7 +77,7 @@ import Shelley.Spec.Ledger.Slot (SlotNo)
 
 -- | Data required by the Transitional Praos protocol from the Shelley ledger.
 data LedgerView era = LedgerView
-  { lvProtParams :: PParams,
+  { lvProtParams :: PParams era,
     lvOverlaySched :: OverlaySchedule era,
     lvPoolDistr :: PoolDistr era,
     lvGenDelegs :: GenDelegs era
@@ -268,12 +268,14 @@ deriving instance (Era era) => Show (ChainTransitionError era)
 
 -- | Tick the chain state to a new epoch.
 tickChainDepState ::
+  forall era.
+  (Era era) =>
   Globals ->
-  LedgerView c ->
+  LedgerView era ->
   -- | Are we in a new epoch?
   Bool ->
-  ChainDepState c ->
-  ChainDepState c
+  ChainDepState era ->
+  ChainDepState era
 tickChainDepState
   globals
   LedgerView {lvProtParams}
@@ -284,7 +286,7 @@ tickChainDepState
       err = error "Panic! tickChainDepState failed."
       newTickState =
         fromRight err . flip runReader globals
-          . applySTS @STS.Tickn.TICKN
+          . applySTS @(STS.Tickn.TICKN era)
           $ TRC
             ( STS.Tickn.TicknEnv
                 lvProtParams

shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/API/Validation.hs

@@ -45,7 +45,7 @@ chainChecks ::
   forall era m.
   (Era era, MonadError (STS.PredicateFailure (STS.CHAIN era)) m) =>
   Globals ->
-  PParams ->
+  PParams era ->
   BHeader era ->
   m ()
 chainChecks globals pp bh = STS.chainChecks (maxMajorPV globals) pp bh

shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/ByronTranslation.hs

@@ -106,7 +106,7 @@ translateToShelleyLedgerState genesisShelley globals epochNo cvs =
       nesOsched = oSchedule
     }
   where
-    pparams :: PParams
+    pparams :: PParams era
     pparams = sgProtocolParams genesisShelley
 
     -- NOTE: we ignore the Byron delegation map because the genesis and

shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/EpochBoundary.hs

@@ -104,7 +104,7 @@ poolStake hk delegs (Stake stake) =
 
 -- | Calculate total possible refunds.
 obligation ::
-  PParams ->
+  PParams era ->
   Map (Credential 'Staking era) Coin ->
   Map (KeyHash 'StakePool era) (PoolParams era) ->
   Coin
@@ -113,7 +113,7 @@ obligation pp rewards stakePools =
     <> Val.scale (length stakePools) (_poolDeposit pp)
 
 -- | Calculate maximal pool reward
-maxPool :: PParams -> Coin -> Rational -> Rational -> Coin
+maxPool :: PParams era -> Coin -> Rational -> Rational -> Coin
 maxPool pc r sigma pR = rationalToCoinViaFloor $ factor1 * factor2
   where
     a0 = _a0 pc

shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/Genesis.hs

@@ -63,27 +63,27 @@ import Shelley.Spec.Ledger.UTxO
 --
 -- For simplicity, pools defined in the genesis staking do not pay deposits for
 -- their registration.
-data ShelleyGenesisStaking c = ShelleyGenesisStaking
+data ShelleyGenesisStaking era = ShelleyGenesisStaking
   { -- | Pools to register
     --
     --   The key in this map is the hash of the public key of the _pool_. This
     --   need not correspond to any payment or staking key, but must correspond
     --   to the cold key held by 'TPraosIsCoreNode'.
-    sgsPools :: !(Map (KeyHash 'StakePool c) (PoolParams c)),
+    sgsPools :: !(Map (KeyHash 'StakePool era) (PoolParams era)),
     -- | Stake-holding key hash credentials and the pools to delegate that stake
     -- to. We require the raw staking key hash in order to:
     --
     -- - Avoid pointer addresses, which would be tricky when there's no slot or
     --   transaction to point to.
     -- - Avoid script credentials.
-    sgsStake :: !(Map (KeyHash 'Staking c) (KeyHash 'StakePool c))
+    sgsStake :: !(Map (KeyHash 'Staking era) (KeyHash 'StakePool era))
   }
   deriving stock (Eq, Show, Generic)
 
 instance NoUnexpectedThunks (ShelleyGenesisStaking era)
 
 -- | Empty genesis staking
-emptyGenesisStaking :: ShelleyGenesisStaking c
+emptyGenesisStaking :: ShelleyGenesisStaking era
 emptyGenesisStaking =
   ShelleyGenesisStaking
     { sgsPools = Map.empty,
@@ -96,7 +96,7 @@ emptyGenesisStaking =
 -- defined here rather than in its own module. In mainnet, Shelley will
 -- transition naturally from Byron, and thus will never have its own genesis
 -- information.
-data ShelleyGenesis c = ShelleyGenesis
+data ShelleyGenesis era = ShelleyGenesis
   { sgSystemStart :: !UTCTime,
     sgNetworkMagic :: !Word32,
     sgNetworkId :: !Network,
@@ -108,16 +108,16 @@ data ShelleyGenesis c = ShelleyGenesis
     sgSlotLength :: !NominalDiffTime,
     sgUpdateQuorum :: !Word64,
     sgMaxLovelaceSupply :: !Word64,
-    sgProtocolParams :: !PParams,
-    sgGenDelegs :: !(Map (KeyHash 'Genesis c) (GenDelegPair c)),
-    sgInitialFunds :: !(Map (Addr c) Coin),
-    sgStaking :: !(ShelleyGenesisStaking c)
+    sgProtocolParams :: !(PParams era),
+    sgGenDelegs :: !(Map (KeyHash 'Genesis era) (GenDelegPair era)),
+    sgInitialFunds :: !(Map (Addr era) Coin),
+    sgStaking :: !(ShelleyGenesisStaking era)
   }
   deriving stock (Eq, Show, Generic)
 
 deriving instance (Era era) => NoUnexpectedThunks (ShelleyGenesis era)
 
-sgActiveSlotCoeff :: ShelleyGenesis c -> ActiveSlotCoeff
+sgActiveSlotCoeff :: ShelleyGenesis era -> ActiveSlotCoeff
 sgActiveSlotCoeff =
   mkActiveSlotCoeff
     . unitIntervalFromRational
@@ -322,7 +322,7 @@ validateGenesis
 -------------------------------------------------------------------------------}
 
 mkShelleyGlobals ::
-  ShelleyGenesis c ->
+  ShelleyGenesis era ->
   EpochInfo Identity ->
   Natural ->
   Globals

shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/LedgerState.hs

@@ -409,8 +409,8 @@ data EpochState era = EpochState
   { esAccountState :: !AccountState,
     esSnapshots :: !(SnapShots era),
     esLState :: !(LedgerState era),
-    esPrevPp :: !PParams,
-    esPp :: !PParams,
+    esPrevPp :: !(PParams era),
+    esPp :: !(PParams era),
     esNonMyopic :: !(NonMyopic era) -- TODO document this in the formal spec, see github #1319
   }
   deriving (Show, Eq, Generic)
@@ -502,7 +502,7 @@ pvCanFollow (ProtVer m n) (SJust (ProtVer m' n')) =
 -- | Update the protocol parameter updates by clearing out the proposals
 -- and making the future proposals become the new proposals,
 -- provided the new proposals can follow (otherwise reset them).
-updatePpup :: UTxOState era -> PParams -> UTxOState era
+updatePpup :: UTxOState era -> PParams era -> UTxOState era
 updatePpup utxoSt pp = utxoSt {_ppups = PPUPState ps emptyPPPUpdates}
   where
     (ProposedPPUpdates newProposals) = futureProposals . _ppups $ utxoSt
@@ -657,17 +657,17 @@ txsizeBound tx = numInputs * inputSize + numOutputs * outputSize + rest
     rest = fromIntegral $ BSL.length (txFullBytes tx) - extraSize txbody
 
 -- | Minimum fee calculation
-minfee :: PParams -> Tx era -> Coin
+minfee :: PParams era -> Tx era -> Coin
 minfee pp tx = Coin $ fromIntegral (_minfeeA pp) * txsize tx + fromIntegral (_minfeeB pp)
 
 -- | Minimum fee bound using txsizeBound
-minfeeBound :: forall era. (Era era) => PParams -> Tx era -> Coin
+minfeeBound :: forall era. (Era era) => PParams era -> Tx era -> Coin
 minfeeBound pp tx = Coin $ fromIntegral (_minfeeA pp) * txsizeBound tx + fromIntegral (_minfeeB pp)
 
 -- | Compute the lovelace which are created by the transaction
 produced ::
   (Era era) =>
-  PParams ->
+  PParams era ->
   Map (KeyHash 'StakePool era) (PoolParams era) ->
   TxBody era ->
   Coin
@@ -677,7 +677,7 @@ produced pp stakePools tx =
 -- | Compute the key deregistration refunds in a transaction
 keyRefunds ::
   Era era =>
-  PParams ->
+  PParams era ->
   TxBody era ->
   Coin
 keyRefunds pp tx = Val.scale (length deregistrations) (_keyDeposit pp)
@@ -687,7 +687,7 @@ keyRefunds pp tx = Val.scale (length deregistrations) (_keyDeposit pp)
 -- | Compute the lovelace which are destroyed by the transaction
 consumed ::
   Era era =>
-  PParams ->
+  PParams era ->
   UTxO era ->
   TxBody era ->
   Coin
@@ -816,7 +816,7 @@ propWits (Just (Update (ProposedPPUpdates pup) _)) (GenDelegs genDelegs) =
 depositPoolChange ::
   Era era =>
   LedgerState era ->
-  PParams ->
+  PParams era ->
   TxBody era ->
   Coin
 depositPoolChange ls pp tx = (currentPool <> txDeposits) Val.~~ txRefunds

shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/OverlaySchedule.hs

@@ -97,7 +97,7 @@ overlayScheduleIsEmpty (OverlaySchedule oSched) = Map.null oSched
 overlaySchedule ::
   EpochNo ->
   Set (KeyHash 'Genesis era) ->
-  PParams ->
+  PParams era ->
   ShelleyBase (OverlaySchedule era)
 overlaySchedule e gkeys pp = do
   ei <- asks epochInfo

shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/PParams.hs

@@ -102,7 +102,7 @@ type family HKD f a where
 --         ...
 --       }
 -- @
-data PParams' f = PParams
+data PParams' f era = PParams
   { -- | The linear factor for the minimum fee calculation
     _minfeeA :: !(HKD f Natural),
     -- | The constant factor for the minimum fee calculation
@@ -140,13 +140,13 @@ data PParams' f = PParams
   }
   deriving (Generic)
 
-type PParams = PParams' Identity
+type PParams era = PParams' Identity era
 
-deriving instance Eq (PParams' Identity)
+deriving instance Eq (PParams' Identity era)
 
-deriving instance Show (PParams' Identity)
+deriving instance Show (PParams' Identity era)
 
-deriving instance NFData (PParams' Identity)
+deriving instance NFData (PParams' Identity era)
 
 data ProtVer = ProtVer !Natural !Natural
   deriving (Show, Eq, Generic, Ord, NFData)
@@ -187,9 +187,9 @@ instance FromCBORGroup ProtVer where
     y <- fromCBOR
     pure $ ProtVer x y
 
-instance NoUnexpectedThunks PParams
+instance NoUnexpectedThunks (PParams era)
 
-instance ToCBOR PParams where
+instance (Era era) => ToCBOR (PParams era) where
   toCBOR
     ( PParams
         { _minfeeA = minfeeA',
@@ -230,7 +230,7 @@ instance ToCBOR PParams where
         <> toCBOR minUTxOValue'
         <> toCBOR minPoolCost'
 
-instance FromCBOR PParams where
+instance (Era era) => FromCBOR (PParams era) where
   fromCBOR = do
     decodeRecordNamed "PParams" (const 18) $
       PParams
@@ -252,7 +252,7 @@ instance FromCBOR PParams where
         <*> fromCBOR -- _minUTxOValue    :: Natural
         <*> fromCBOR -- _minPoolCost     :: Natural
 
-instance ToJSON PParams where
+instance ToJSON (PParams era) where
   toJSON pp =
     Aeson.object
       [ "minFeeA" .= _minfeeA pp,
@@ -274,7 +274,7 @@ instance ToJSON PParams where
         "minPoolCost" .= _minPoolCost pp
       ]
 
-instance FromJSON PParams where
+instance FromJSON (PParams era) where
   parseJSON =
     Aeson.withObject "PParams" $ \obj ->
       PParams
@@ -299,7 +299,7 @@ instance FromJSON PParams where
         <*> obj .:? "minPoolCost" .!= mempty
 
 -- | Returns a basic "empty" `PParams` structure with all zero values.
-emptyPParams :: PParams
+emptyPParams :: PParams era
 emptyPParams =
   PParams
     { _minfeeA = 0,
@@ -343,19 +343,19 @@ data PPUpdateEnv era = PPUpdateEnv SlotNo (GenDelegs era)
 
 instance NoUnexpectedThunks (PPUpdateEnv era)
 
-type PParamsUpdate = PParams' StrictMaybe
+type PParamsUpdate era = PParams' StrictMaybe era
 
-deriving instance Eq (PParams' StrictMaybe)
+deriving instance Eq (PParams' StrictMaybe era)
 
-deriving instance Show (PParams' StrictMaybe)
+deriving instance Show (PParams' StrictMaybe era)
 
-deriving instance Ord (PParams' StrictMaybe)
+deriving instance Ord (PParams' StrictMaybe era)
 
-deriving instance NFData (PParams' StrictMaybe)
+deriving instance NFData (PParams' StrictMaybe era)
 
-instance NoUnexpectedThunks PParamsUpdate
+instance NoUnexpectedThunks (PParamsUpdate era)
 
-instance ToCBOR PParamsUpdate where
+instance (Era era) => ToCBOR (PParamsUpdate era) where
   toCBOR ppup =
     let l =
           mapMaybe
@@ -383,7 +383,7 @@ instance ToCBOR PParamsUpdate where
     where
       encodeMapElement ix encoder x = SJust (encodeWord ix <> encoder x)
 
-emptyPParamsUpdate :: PParamsUpdate
+emptyPParamsUpdate :: PParamsUpdate era
 emptyPParamsUpdate =
   PParams
     { _minfeeA = SNothing,
@@ -405,7 +405,7 @@ emptyPParamsUpdate =
       _minPoolCost = SNothing
     }
 
-instance FromCBOR PParamsUpdate where
+instance (Era era) => FromCBOR (PParamsUpdate era) where
   fromCBOR = do
     mapParts <-
       decodeMapContents $
@@ -436,7 +436,7 @@ instance FromCBOR PParamsUpdate where
 
 -- | Update operation for protocol parameters structure @PParams
 newtype ProposedPPUpdates era
-  = ProposedPPUpdates (Map (KeyHash 'Genesis era) PParamsUpdate)
+  = ProposedPPUpdates (Map (KeyHash 'Genesis era) (PParamsUpdate era))
   deriving (Show, Eq, Generic, NFData)
 
 instance NoUnexpectedThunks (ProposedPPUpdates era)
@@ -450,7 +450,7 @@ instance Era era => FromCBOR (ProposedPPUpdates era) where
 emptyPPPUpdates :: ProposedPPUpdates era
 emptyPPPUpdates = ProposedPPUpdates Map.empty
 
-updatePParams :: PParams -> PParamsUpdate -> PParams
+updatePParams :: PParams era -> PParamsUpdate era -> PParams era
 updatePParams pp ppup =
   PParams
     { _minfeeA = fromMaybe' (_minfeeA pp) (_minfeeA ppup),