Merge pull request #4821 from IntersectMBO/aniketd/conformance

Enable Imp conformance for DELEG
IntersectMBO · Jan 10, 2025 · d9e6924 · d9e6924
2 parents 5e1ed75 + caa8898
commit d9e6924
Show file tree

Hide file tree

Showing 4 changed files with 86 additions and 70 deletions.
diff --git a/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Imp/DelegSpec.hs b/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Imp/DelegSpec.hs
@@ -211,7 +211,9 @@ spec = do
         mkBasicTxBody
           & certsTxBodyL
             .~ SSeq.fromList
-              [UnRegTxCert stakeCred]
+              -- /~https://github.com/IntersectMBO/formal-ledger-specifications/issues/636
+              -- we use this inplace of UnRegTxCert to make conformance-spec happy
+              [UnRegDepositTxCert stakeCred keyDeposit]
           & withdrawalsTxBodyL
             .~ Withdrawals
               ( Map.fromList
@@ -476,6 +478,77 @@ spec = do
       expectNotRegistered cred
       expectNotDelegatedVote cred
 
+  describe "Delegate both stake and vote - separated out for conformance mismatch" $
+    -- /~https://github.com/IntersectMBO/formal-ledger-specifications/issues/640
+    -- TODO: Re-enable after issue is resolved, by removing this override
+    disableImpInitExpectLedgerRuleConformance $ do
+      it "Delegate, retire and re-register pool" $ do
+        expectedDeposit <- getsNES $ nesEsL . curPParamsEpochStateL . ppKeyDepositL
+        cred <- KeyHashObj <$> freshKeyHash
+        poolKh <- freshKeyHash
+        rewardAccount <- registerRewardAccount
+        registerPool poolKh
+        drepCred <- KeyHashObj <$> registerDRep
+
+        submitTx_ $
+          mkBasicTx mkBasicTxBody
+            & bodyTxL . certsTxBodyL
+              .~ [ RegDepositDelegTxCert
+                    cred
+                    (DelegStakeVote poolKh (DRepCredential drepCred))
+                    expectedDeposit
+                 ]
+        expectDelegatedToPool cred poolKh
+        expectDelegatedVote cred (DRepCredential drepCred)
+
+        let poolLifetime = 2
+        let poolExpiry = getsNES nesELL <&> \n -> addEpochInterval n $ EpochInterval poolLifetime
+
+        poolExpiry >>= \pe ->
+          submitTx_ $
+            mkBasicTx mkBasicTxBody
+              & bodyTxL . certsTxBodyL .~ [RetirePoolTxCert poolKh pe]
+
+        -- when pool is re-registered after its expiration, all delegations are cleared
+        passNEpochs $ fromIntegral poolLifetime
+        expectNotDelegatedToPool cred
+        registerPoolWithRewardAccount poolKh rewardAccount
+        expectNotDelegatedToPool cred
+        -- the vote delegation is kept
+        expectDelegatedVote cred (DRepCredential drepCred)
+
+        -- re-delegate
+        submitTx_ $
+          mkBasicTx mkBasicTxBody
+            & bodyTxL . certsTxBodyL
+              .~ [ DelegTxCert
+                    cred
+                    (DelegStake poolKh)
+                 ]
+        expectDelegatedToPool cred poolKh
+
+        -- when pool is re-registered before its expiration, delegations are kept
+        poolExpiry >>= \pe ->
+          submitTx_ $
+            mkBasicTx mkBasicTxBody
+              & bodyTxL . certsTxBodyL .~ [RetirePoolTxCert poolKh pe]
+        -- re-register the pool before the expiration time
+        passNEpochs $ fromIntegral poolLifetime - 1
+        registerPoolWithRewardAccount poolKh rewardAccount
+        expectDelegatedToPool cred poolKh
+        passNEpochs 2
+        expectDelegatedToPool cred poolKh
+
+        -- when pool is retired and re-registered in the same transaction, delegations are kept
+        pps <- poolParams poolKh rewardAccount
+        poolExpiry >>= \pe ->
+          submitTx_ $
+            mkBasicTx mkBasicTxBody
+              & bodyTxL . certsTxBodyL .~ [RetirePoolTxCert poolKh pe, RegPoolTxCert pps]
+
+        expectDelegatedToPool cred poolKh
+        passNEpochs $ fromIntegral poolLifetime
+        expectDelegatedToPool cred poolKh
   describe "Delegate both stake and vote" $ do
     it "Delegate and unregister credentials" $ do
       expectedDeposit <- getsNES $ nesEsL . curPParamsEpochStateL . ppKeyDepositL
@@ -531,74 +604,6 @@ spec = do
             .~ [DelegTxCert cred (DelegStake poolKh')]
       expectDelegatedToPool cred poolKh'
       expectDelegatedVote cred (DRepCredential drepCred)
-
-    it "Delegate, retire and re-register pool" $ do
-      expectedDeposit <- getsNES $ nesEsL . curPParamsEpochStateL . ppKeyDepositL
-      cred <- KeyHashObj <$> freshKeyHash
-      poolKh <- freshKeyHash
-      rewardAccount <- registerRewardAccount
-      registerPool poolKh
-      drepCred <- KeyHashObj <$> registerDRep
-
-      submitTx_ $
-        mkBasicTx mkBasicTxBody
-          & bodyTxL . certsTxBodyL
-            .~ [ RegDepositDelegTxCert
-                  cred
-                  (DelegStakeVote poolKh (DRepCredential drepCred))
-                  expectedDeposit
-               ]
-      expectDelegatedToPool cred poolKh
-      expectDelegatedVote cred (DRepCredential drepCred)
-
-      let poolLifetime = 2
-      let poolExpiry = getsNES nesELL <&> \n -> addEpochInterval n $ EpochInterval poolLifetime
-
-      poolExpiry >>= \pe ->
-        submitTx_ $
-          mkBasicTx mkBasicTxBody
-            & bodyTxL . certsTxBodyL .~ [RetirePoolTxCert poolKh pe]
-
-      -- when pool is re-registered after its expiration, all delegations are cleared
-      passNEpochs $ fromIntegral poolLifetime
-      expectNotDelegatedToPool cred
-      registerPoolWithRewardAccount poolKh rewardAccount
-      expectNotDelegatedToPool cred
-      -- the vote delegation is kept
-      expectDelegatedVote cred (DRepCredential drepCred)
-
-      -- re-delegate
-      submitTx_ $
-        mkBasicTx mkBasicTxBody
-          & bodyTxL . certsTxBodyL
-            .~ [ DelegTxCert
-                  cred
-                  (DelegStake poolKh)
-               ]
-      expectDelegatedToPool cred poolKh
-
-      -- when pool is re-registered before its expiration, delegations are kept
-      poolExpiry >>= \pe ->
-        submitTx_ $
-          mkBasicTx mkBasicTxBody
-            & bodyTxL . certsTxBodyL .~ [RetirePoolTxCert poolKh pe]
-      -- re-register the pool before the expiration time
-      passNEpochs $ fromIntegral poolLifetime - 1
-      registerPoolWithRewardAccount poolKh rewardAccount
-      expectDelegatedToPool cred poolKh
-      passNEpochs 2
-      expectDelegatedToPool cred poolKh
-
-      -- when pool is retired and re-registered in the same transaction, delegations are kept
-      pps <- poolParams poolKh rewardAccount
-      poolExpiry >>= \pe ->
-        submitTx_ $
-          mkBasicTx mkBasicTxBody
-            & bodyTxL . certsTxBodyL .~ [RetirePoolTxCert poolKh pe, RegPoolTxCert pps]
-
-      expectDelegatedToPool cred poolKh
-      passNEpochs $ fromIntegral poolLifetime
-      expectDelegatedToPool cred poolKh
   where
     expectRegistered cred = do
       umap <- getsNES $ nesEsL . esLStateL . lsCertStateL . certDStateL . dsUnifiedL

diff --git a/eras/shelley/impl/CHANGELOG.md b/eras/shelley/impl/CHANGELOG.md
@@ -18,6 +18,10 @@
   * `FromByronTranslationContext`
   * `GenesisDelegCert`, `MIRTarget`, `MIRCert`, `ShelleyDelegCert`
 
+### `testlib`
+
+* Add `disableImpInitExpectLedgerRuleConformance`. #4821
+
 ## 1.15.0.0
 
 * Change param of `PoolRank.desirability` to `Word16`

diff --git a/eras/shelley/impl/testlib/Test/Cardano/Ledger/Shelley/ImpTest.hs b/eras/shelley/impl/testlib/Test/Cardano/Ledger/Shelley/ImpTest.hs
@@ -101,6 +101,7 @@ module Test.Cardano.Ledger.Shelley.ImpTest (
   impSetSeed,
   modifyImpInitProtVer,
   modifyImpInitExpectLedgerRuleConformance,
+  disableImpInitExpectLedgerRuleConformance,
 
   -- * Logging
   Doc,
@@ -644,6 +645,12 @@ modifyImpInitExpectLedgerRuleConformance f =
             & iteExpectLedgerRuleConformanceL .~ f
       }
 
+disableImpInitExpectLedgerRuleConformance ::
+  SpecWith (ImpInit (LedgerSpec era)) ->
+  SpecWith (ImpInit (LedgerSpec era))
+disableImpInitExpectLedgerRuleConformance =
+  modifyImpInitExpectLedgerRuleConformance $ \_ _ _ _ _ -> pure ()
+
 impLedgerEnv :: EraGov era => NewEpochState era -> ImpTestM era (LedgerEnv era)
 impLedgerEnv nes = do
   slotNo <- gets impLastTick

diff --git a/libs/cardano-ledger-conformance/test/Test/Cardano/Ledger/Conformance/Imp.hs b/libs/cardano-ledger-conformance/test/Test/Cardano/Ledger/Conformance/Imp.hs
@@ -153,7 +153,7 @@ spec =
         describe "Conway Imp conformance" $ do
           describe "BBODY" Bbody.spec
           describe "CERTS" Certs.spec
-          xdescribe "DELEG" Deleg.spec
+          describe "DELEG" Deleg.spec
           xdescribe "ENACT" Enact.spec
           xdescribe "EPOCH" Epoch.spec
           xdescribe "GOV" Gov.spec