Use EpochNo instead of SlotNo in Pool, Cert and Certs rules

eras/conway/impl/CHANGELOG.md

@@ -2,6 +2,7 @@
 
 ## 1.18.0.0
 
+* Remove `SlotNo` from `CertEnv` and `CertsEnv`
 * Remove deprecated `translateTxOut` and `conwayWitsVKeyNeeded`
 * Add `DefaultVote` and `defaultStakePoolVote`
 * Add new event `GovRemovedVotes` for invalidated votes.

eras/conway/impl/src/Cardano/Ledger/Conway/Rules/Cert.hs

@@ -23,7 +23,7 @@ module Cardano.Ledger.Conway.Rules.Cert (
   CertEnv (..),
 ) where
 
-import Cardano.Ledger.BaseTypes (EpochNo, ShelleyBase, SlotNo, StrictMaybe)
+import Cardano.Ledger.BaseTypes (EpochNo, ShelleyBase, StrictMaybe)
 import Cardano.Ledger.Binary (DecCBOR (..), EncCBOR (..))
 import Cardano.Ledger.Binary.Coders
 import Cardano.Ledger.Conway.Core
@@ -76,20 +76,18 @@ import GHC.Generics (Generic)
 import NoThunks.Class (NoThunks)
 
 data CertEnv era = CertEnv
-  { ceSlotNo :: !SlotNo
-  , cePParams :: !(PParams era)
+  { cePParams :: !(PParams era)
   , ceCurrentEpoch :: !EpochNo
   , ceCurrentCommittee :: StrictMaybe (Committee era)
   , ceCommitteeProposals :: Map.Map (GovPurposeId 'CommitteePurpose era) (GovActionState era)
   }
   deriving (Generic)
 
 instance EraPParams era => EncCBOR (CertEnv era) where
-  encCBOR x@(CertEnv _ _ _ _ _) =
+  encCBOR x@(CertEnv _ _ _ _) =
     let CertEnv {..} = x
      in encode $
           Rec CertEnv
-            !> To ceSlotNo
             !> To cePParams
             !> To ceCurrentEpoch
             !> To ceCurrentCommittee
@@ -215,15 +213,15 @@ certTransition ::
   ) =>
   TransitionRule (ConwayCERT era)
 certTransition = do
-  TRC (CertEnv slot pp currentEpoch committee committeeProposals, certState, c) <- judgmentContext
+  TRC (CertEnv pp currentEpoch committee committeeProposals, certState, c) <- judgmentContext
   let
     CertState {certPState} = certState
     pools = psStakePoolParams certPState
   case c of
     ConwayTxCertDeleg delegCert -> do
       trans @(EraRule "DELEG" era) $ TRC (ConwayDelegEnv pp pools, certState, delegCert)
     ConwayTxCertPool poolCert -> do
-      newPState <- trans @(EraRule "POOL" era) $ TRC (PoolEnv slot pp, certPState, poolCert)
+      newPState <- trans @(EraRule "POOL" era) $ TRC (PoolEnv currentEpoch pp, certPState, poolCert)
       pure $ certState {certPState = newPState}
     ConwayTxCertGov govCert -> do
       trans @(EraRule "GOVCERT" era) $

eras/conway/impl/src/Cardano/Ledger/Conway/Rules/Certs.hs

@@ -29,7 +29,6 @@ import Cardano.Ledger.BaseTypes (
   EpochNo (EpochNo),
   Globals (..),
   ShelleyBase,
-  SlotNo,
   StrictMaybe,
   binOpEpochNo,
  )
@@ -89,21 +88,19 @@ import NoThunks.Class (NoThunks (..))
 data CertsEnv era = CertsEnv
   { certsTx :: !(Tx era)
   , certsPParams :: !(PParams era)
-  , certsSlotNo :: !SlotNo
   , certsCurrentEpoch :: !EpochNo
   , certsCurrentCommittee :: StrictMaybe (Committee era)
   , certsCommitteeProposals :: Map.Map (GovPurposeId 'CommitteePurpose era) (GovActionState era)
   }
   deriving (Generic)
 
 instance EraTx era => EncCBOR (CertsEnv era) where
-  encCBOR x@(CertsEnv _ _ _ _ _ _) =
+  encCBOR x@(CertsEnv _ _ _ _ _) =
     let CertsEnv {..} = x
      in encode $
           Rec CertsEnv
             !> To certsTx
             !> To certsPParams
-            !> To certsSlotNo
             !> To certsCurrentEpoch
             !> To certsCurrentCommittee
             !> To certsCommitteeProposals
@@ -217,7 +214,7 @@ conwayCertsTransition ::
   TransitionRule (ConwayCERTS era)
 conwayCertsTransition = do
   TRC
-    ( env@(CertsEnv tx pp slot currentEpoch committee committeeProposals)
+    ( env@(CertsEnv tx pp currentEpoch committee committeeProposals)
       , certState
       , certificates
       ) <-
@@ -271,7 +268,7 @@ conwayCertsTransition = do
       certState' <-
         trans @(ConwayCERTS era) $ TRC (env, certState, gamma)
       trans @(EraRule "CERT" era) $
-        TRC (CertEnv slot pp currentEpoch committee committeeProposals, certState', txCert)
+        TRC (CertEnv pp currentEpoch committee committeeProposals, certState', txCert)
 
 instance
   ( Era era

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

@@ -446,7 +446,7 @@ ledgerTransition = do
         certStateAfterCERTS <-
           trans @(EraRule "CERTS" era) $
             TRC
-              ( CertsEnv tx pp slot currentEpoch committee committeeProposals
+              ( CertsEnv tx pp currentEpoch committee committeeProposals
               , certState
               , StrictSeq.fromStrict $ txBody ^. certsTxBodyL
               )

eras/shelley/impl/CHANGELOG.md

@@ -2,6 +2,7 @@
 
 ## 1.15.0.0
 
+* Change `PoolEnv` to take `EpochNo` instead of `SlotNo`
 * Added `Generic`, `Eq`, `Show`, `NFData`, `EncCBOR` instances for `ShelleyLedgersEnv`
 * Remove deprecated `witsVKeyNeededGov`, `witsVKeyNeededNoGov`, `shelleyWitsVKeyNeeded` and `propWits`
 * Remove deprecated `PPUPPredFailure`, `delPlAcnt`, `prAcnt`, `votedValue`

eras/shelley/impl/src/Cardano/Ledger/Shelley/Rules/Delpl.hs

@@ -23,7 +23,7 @@ module Cardano.Ledger.Shelley.Rules.Delpl (
 )
 where
 
-import Cardano.Ledger.BaseTypes (ShelleyBase, invalidKey)
+import Cardano.Ledger.BaseTypes (ShelleyBase, epochInfoPure, invalidKey)
 import Cardano.Ledger.Binary (
   DecCBOR (..),
   EncCBOR (..),
@@ -50,8 +50,9 @@ import Cardano.Ledger.Shelley.Rules.Deleg (
 import Cardano.Ledger.Shelley.Rules.Pool (PoolEnv (..), ShelleyPOOL, ShelleyPoolPredFailure)
 import qualified Cardano.Ledger.Shelley.Rules.Pool as Pool
 import Cardano.Ledger.Shelley.TxCert (GenesisDelegCert (..), ShelleyTxCert (..))
-import Cardano.Ledger.Slot (SlotNo)
+import Cardano.Ledger.Slot (SlotNo, epochInfoEpoch)
 import Control.DeepSeq
+import Control.Monad.Trans.Reader (asks)
 import Control.State.Transition
 import Data.Typeable (Typeable)
 import Data.Word (Word8)
@@ -196,14 +197,18 @@ delplTransition ::
   , Environment (EraRule "POOL" era) ~ PoolEnv era
   , Signal (EraRule "POOL" era) ~ PoolCert (EraCrypto era)
   , TxCert era ~ ShelleyTxCert era
+  , Era era
   ) =>
   TransitionRule (ShelleyDELPL era)
 delplTransition = do
   TRC (DelplEnv slot ptr pp acnt, d, c) <- judgmentContext
   case c of
     ShelleyTxCertPool poolCert -> do
+      cEpoch <- liftSTS $ do
+        ei <- asks epochInfoPure
+        epochInfoEpoch ei slot
       ps <-
-        trans @(EraRule "POOL" era) $ TRC (PoolEnv slot pp, certPState d, poolCert)
+        trans @(EraRule "POOL" era) $ TRC (PoolEnv cEpoch pp, certPState d, poolCert)
       pure $ d {certPState = ps}
     ShelleyTxCertGenesisDeleg GenesisDelegCert {} -> do
       ds <-

eras/shelley/impl/src/Cardano/Ledger/Shelley/Rules/Pool.hs

@@ -33,7 +33,6 @@ import Cardano.Ledger.BaseTypes (
   Relation (..),
   ShelleyBase,
   addEpochInterval,
-  epochInfoPure,
   invalidKey,
   networkId,
  )
@@ -53,7 +52,7 @@ import Cardano.Ledger.Shelley.Era (ShelleyEra, ShelleyPOOL)
 import qualified Cardano.Ledger.Shelley.HardForks as HardForks
 import Cardano.Ledger.Shelley.LedgerState (PState (..), payPoolDeposit)
 import qualified Cardano.Ledger.Shelley.SoftForks as SoftForks
-import Cardano.Ledger.Slot (EpochNo (..), SlotNo, epochInfoEpoch)
+import Cardano.Ledger.Slot (EpochNo (..))
 import Control.DeepSeq
 import Control.Monad (forM_, when)
 import Control.Monad.Trans.Reader (asks)
@@ -75,14 +74,14 @@ import Lens.Micro ((^.))
 import NoThunks.Class (NoThunks (..))
 
 data PoolEnv era
-  = PoolEnv !SlotNo !(PParams era)
+  = PoolEnv !EpochNo !(PParams era)
   deriving (Generic)
 
 instance EraPParams era => EncCBOR (PoolEnv era) where
-  encCBOR (PoolEnv s pp) =
+  encCBOR (PoolEnv e pp) =
     encode $
       Rec PoolEnv
-        !> To s
+        !> To e
         !> To pp
 
 deriving instance Show (PParams era) => Show (PoolEnv era)
@@ -199,7 +198,7 @@ poolDelegationTransition ::
   TransitionRule (ledger era)
 poolDelegationTransition = do
   TRC
-    ( PoolEnv slot pp
+    ( PoolEnv cEpoch pp
       , ps@PState {psStakePoolParams, psFutureStakePoolParams, psRetiring}
       , poolCert
       ) <-
@@ -260,16 +259,13 @@ poolDelegationTransition = do
               }
     RetirePool hk e -> do
       eval (hk ∈ dom psStakePoolParams) ?! StakePoolNotRegisteredOnKeyPOOL hk
-      cepoch <- liftSTS $ do
-        ei <- asks epochInfoPure
-        epochInfoEpoch ei slot
       let maxEpoch = pp ^. ppEMaxL
-          limitEpoch = addEpochInterval cepoch maxEpoch
-      (cepoch < e && e <= limitEpoch)
+          limitEpoch = addEpochInterval cEpoch maxEpoch
+      (cEpoch < e && e <= limitEpoch)
         ?! StakePoolRetirementWrongEpochPOOL
           Mismatch -- 'RelGT - The supplied value should be greater than the current epoch
             { mismatchSupplied = e
-            , mismatchExpected = cepoch
+            , mismatchExpected = cEpoch
             }
           Mismatch -- 'RelLTEQ - The supplied value should be less then or equal to ppEMax after the current epoch
             { mismatchSupplied = e

eras/shelley/test-suite/src/Test/Cardano/Ledger/Shelley/Rules/TestChain.hs

@@ -74,6 +74,7 @@ import Test.Cardano.Ledger.Shelley.Generator.Trace.Chain (mkGenesisChainState)
 import Test.Cardano.Ledger.Shelley.Rules.Chain (CHAIN, ChainState (..))
 import Test.Cardano.Ledger.Shelley.Utils (
   ChainProperty,
+  epochFromSlotNo,
   runShelleyBase,
   testGlobals,
  )
@@ -198,7 +199,7 @@ poolTraceFromBlock chainSt block =
     poolCerts = mapMaybe getPoolCertTxCert (certs txs)
     poolEnv =
       let (LedgerEnv s _ pp _ _) = ledgerEnv
-       in PoolEnv s pp
+       in PoolEnv (epochFromSlotNo s) pp
     poolSt0 =
       certPState (lsCertState ledgerSt0)
 

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

@@ -16,13 +16,12 @@ import Cardano.Ledger.Shelley.API (
   ShelleyPOOL,
  )
 import Cardano.Ledger.Shelley.Core
-import Cardano.Ledger.Slot (SlotNo (..))
 import Control.State.Transition.Extended hiding (Assertion)
 import Data.Default (def)
 import Lens.Micro
 import Test.Cardano.Ledger.Shelley.ConcreteCryptoTypes (C_Crypto)
 import qualified Test.Cardano.Ledger.Shelley.Examples.Cast as Cast
-import Test.Cardano.Ledger.Shelley.Utils (applySTSTest, runShelleyBase)
+import Test.Cardano.Ledger.Shelley.Utils (applySTSTest, epochFromSlotNo, runShelleyBase)
 import Test.Tasty (TestTree, testGroup)
 import Test.Tasty.HUnit (Assertion, assertBool, testCase)
 
@@ -47,7 +46,7 @@ testPoolNetworkID pv poolParams e = do
         runShelleyBase $
           applySTSTest @(ShelleyPOOL ShelleyTest)
             ( TRC
-                ( PoolEnv (SlotNo 0) $ emptyPParams & ppProtocolVersionL .~ pv
+                ( PoolEnv (epochFromSlotNo 0) $ emptyPParams & ppProtocolVersionL .~ pv
                 , def
                 , RegPool poolParams
                 )

libs/cardano-ledger-test/src/Test/Cardano/Ledger/Constrained/Conway/Cert.hs

@@ -52,7 +52,7 @@ certEnvSpec ::
   Specification fn (CertEnv era)
 certEnvSpec =
   constrained $ \ce ->
-    match ce $ \_slot pp _currEpoch _currCommittee _proposals ->
+    match ce $ \pp _currEpoch _currCommittee _proposals ->
       [ satisfies pp pparamsSpec
       ]
 
@@ -81,7 +81,7 @@ conwayTxCertSpec ::
   CertEnv (ConwayEra StandardCrypto) ->
   CertState (ConwayEra StandardCrypto) ->
   Specification fn (ConwayTxCert (ConwayEra StandardCrypto))
-conwayTxCertSpec (CertEnv slot pp ce cc cp) certState@CertState {..} =
+conwayTxCertSpec (CertEnv pp ce cc cp) certState@CertState {..} =
   constrained $ \txCert ->
     caseOn
       txCert
@@ -92,7 +92,7 @@ conwayTxCertSpec (CertEnv slot pp ce cc cp) certState@CertState {..} =
       (branchW 2 $ \govCert -> satisfies govCert $ govCertSpec govCertEnv certState)
   where
     delegEnv = ConwayDelegEnv pp (psStakePoolParams certPState)
-    poolEnv = PoolEnv slot pp
+    poolEnv = PoolEnv ce pp
     govCertEnv = ConwayGovCertEnv pp ce cc cp
 
 -- ==============================================================
@@ -143,7 +143,7 @@ shelleyTxCertSpec ::
   CertEnv era ->
   CertState era ->
   Specification fn (ShelleyTxCert era)
-shelleyTxCertSpec (CertEnv slot pp _ _ _) (CertState _vstate pstate dstate) =
+shelleyTxCertSpec (CertEnv pp e _ _) (CertState _vstate pstate dstate) =
   constrained $ \ [var|shelleyTxCert|] ->
     -- These weights try to make it equally likely that each of the many certs
     -- across the 3 categories are chosen at similar frequencies.
@@ -156,7 +156,7 @@ shelleyTxCertSpec (CertEnv slot pp _ _ _) (CertState _vstate pstate dstate) =
                 dstate
             )
       )
-      (branchW 3 $ \ [var|poolCert|] -> satisfies poolCert $ poolCertSpec (PoolEnv slot pp) pstate)
+      (branchW 3 $ \ [var|poolCert|] -> satisfies poolCert $ poolCertSpec (PoolEnv e pp) pstate)
       (branchW 1 $ \ [var|genesis|] -> satisfies genesis (genesisDelegCertSpec @fn @era dstate))
       (branchW 1 $ \ [var|_mir|] -> False) -- By design, we never generate a MIR cert
 

libs/cardano-ledger-test/src/Test/Cardano/Ledger/Constrained/Conway/Certs.hs

@@ -103,7 +103,7 @@ certsEnvSpec ::
   (EraSpecPParams era, HasSpec fn (Tx era), IsConwayUniv fn) =>
   Specification fn (CertsEnv era)
 certsEnvSpec = constrained $ \ce ->
-  match ce $ \tx pp _slot _currepoch _currcommittee commproposals ->
+  match ce $ \tx pp _currepoch _currcommittee commproposals ->
     [ satisfies pp pparamsSpec
     , assert $ tx ==. lit txZero
     , genHint 3 commproposals
@@ -114,7 +114,6 @@ projectEnv :: CertsEnv era -> CertEnv era
 projectEnv x =
   CertEnv
     { cePParams = certsPParams x
-    , ceSlotNo = certsSlotNo x
     , ceCurrentEpoch = certsCurrentEpoch x
     , ceCurrentCommittee = certsCurrentCommittee x
     , ceCommitteeProposals = certsCommitteeProposals x

libs/cardano-ledger-test/src/Test/Cardano/Ledger/Constrained/Conway/Pool.hs

@@ -60,7 +60,7 @@ poolCertSpec ::
   PoolEnv era ->
   PState era ->
   Specification fn (PoolCert (EraCrypto era))
-poolCertSpec (PoolEnv s pp) ps =
+poolCertSpec (PoolEnv e pp) ps =
   constrained $ \pc ->
     (caseOn pc)
       -- RegPool !(PoolParams c)
@@ -76,7 +76,7 @@ poolCertSpec (PoolEnv s pp) ps =
       -- RetirePool !(KeyHash 'StakePool c) !EpochNo
       ( branchW 1 $ \keyHash epochNo ->
           [ epochNo <=. lit (maxEpochNo - 1)
-          , lit (currentEpoch s) <. epochNo
+          , lit e <. epochNo
           , elem_ keyHash $ lit rpools
           ]
       )

libs/cardano-ledger-test/src/Test/Cardano/Ledger/Generic/PrettyCore.hs

@@ -3572,7 +3572,7 @@ instance Reflect era => PrettyA (ConwayGovCertEnv era) where
   prettyA = pcConwayGovCertEnv
 
 pcPoolEnv :: Reflect era => PoolEnv era -> PDoc
-pcPoolEnv (PoolEnv sn pp) = ppSexp "PoolEnv" [pcSlotNo sn, pcPParams reify pp]
+pcPoolEnv (PoolEnv en pp) = ppSexp "PoolEnv" [ppEpochNo en, pcPParams reify pp]
 
 instance forall era. Reflect era => PrettyA (PoolEnv era) where
   prettyA = pcPoolEnv
@@ -3646,8 +3646,7 @@ instance Reflect era => PrettyA (CertEnv era) where
   prettyA CertEnv {..} =
     ppRecord
       "CertEnv"
-      [ ("slot no", prettyA ceSlotNo)
-      , ("pparams", prettyA cePParams)
+      [ ("pparams", prettyA cePParams)
       , ("currentEpoch", prettyA ceCurrentEpoch)
       ]
 
@@ -3664,12 +3663,11 @@ instance PrettyA x => PrettyA (Seq x) where
   prettyA x = prettyA (toList x)
 
 instance PrettyA (ConwayRules.CertsEnv era) where
-  prettyA (ConwayRules.CertsEnv _ _ slot epoch com prop) =
+  prettyA (ConwayRules.CertsEnv _ _ epoch com prop) =
     ppRecord
       "CertsEnv"
       [ ("Tx", ppString "Tx")
       , ("pparams", ppString "PParams")
-      , ("slot", pcSlotNo slot)
       , ("epoch", ppEpochNo epoch)
       , ("committee", ppStrictMaybe pcCommittee com)
       , ("proposals", ppMap pcGovPurposeId prettyA prop)