Merge pull request #4616 from IntersectMBO/td/improve-predfailure-type

Change `ConwayWdrlNotDelegatedToDRep` to wrap `KeyHash`es
IntersectMBO · Sep 11, 2024 · 59fff80 · 59fff80
2 parents c456f5e + 3d0cb7f
commit 59fff80
Show file tree

Hide file tree

Showing 3 changed files with 10 additions and 13 deletions.
diff --git a/eras/conway/impl/CHANGELOG.md b/eras/conway/impl/CHANGELOG.md
@@ -2,7 +2,7 @@
 
 ## 1.17.0.0
 
-* Changed `ConwayWdrlNotDelegatedToDRep` to wrap `NonEmpty`
+* Changed `ConwayWdrlNotDelegatedToDRep` to wrap `NonEmpty KeyHash`
 * Add `showGovActionType`, `acceptedByEveryone`
 * Added `unRatifySignal`
 * Added lenses:

diff --git a/eras/conway/impl/src/Cardano/Ledger/Conway/Rules/Ledger.hs b/eras/conway/impl/src/Cardano/Ledger/Conway/Rules/Ledger.hs
@@ -81,7 +81,7 @@ import Cardano.Ledger.Conway.Rules.Utxow (ConwayUtxowPredFailure)
 import Cardano.Ledger.Conway.UTxO (txNonDistinctRefScriptsSize)
 import Cardano.Ledger.Credential (Credential (..), credKeyHash)
 import Cardano.Ledger.Crypto (Crypto (..))
-import Cardano.Ledger.Keys (KeyRole (..))
+import Cardano.Ledger.Keys (KeyHash, KeyRole (..))
 import qualified Cardano.Ledger.Shelley.HardForks as HF (bootstrapPhase)
 import Cardano.Ledger.Shelley.LedgerState (
   CertState (..),
@@ -136,7 +136,7 @@ data ConwayLedgerPredFailure era
   = ConwayUtxowFailure (PredicateFailure (EraRule "UTXOW" era))
   | ConwayCertsFailure (PredicateFailure (EraRule "CERTS" era))
   | ConwayGovFailure (PredicateFailure (EraRule "GOV" era))
-  | ConwayWdrlNotDelegatedToDRep (NonEmpty (Credential 'Staking (EraCrypto era)))
+  | ConwayWdrlNotDelegatedToDRep (NonEmpty (KeyHash 'Staking (EraCrypto era)))
   | ConwayTreasuryValueMismatch
       -- | Actual
       Coin
@@ -406,10 +406,9 @@ ledgerTransition = do
               delegatedAddrs = DRepUView dUnified
               wdrlsKeyHashes =
                 Set.fromList
-                  [ rc | (ra, _) <- Map.toList wdrls, let rc = raCredential ra, Just _ <- [credKeyHash rc]
-                  ]
+                  [kh | (ra, _) <- Map.toList wdrls, Just kh <- [credKeyHash $ raCredential ra]]
               nonExistentDelegations =
-                Set.filter (not . (`UMap.member` delegatedAddrs)) wdrlsKeyHashes
+                Set.filter (not . (`UMap.member` delegatedAddrs) . KeyHashObj) wdrlsKeyHashes
           failOnNonEmpty nonExistentDelegations ConwayWdrlNotDelegatedToDRep
 
         -- Votes and proposals from signal tx

diff --git a/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Imp/LedgerSpec.hs b/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Imp/LedgerSpec.hs
@@ -7,11 +7,11 @@
 
 module Test.Cardano.Ledger.Conway.Imp.LedgerSpec (spec) where
 
-import Cardano.Ledger.Address (RewardAccount (..))
 import Cardano.Ledger.BaseTypes
 import Cardano.Ledger.Coin (Coin (..))
 import Cardano.Ledger.Conway.Core
 import Cardano.Ledger.Conway.Rules (ConwayLedgerPredFailure (..), maxRefScriptSizePerTx)
+import Cardano.Ledger.Credential (Credential (..))
 import Cardano.Ledger.DRep
 import Cardano.Ledger.Plutus (SLanguage (..), hashPlutusScript)
 import Cardano.Ledger.SafeHash (originalBytesSize)
@@ -25,8 +25,6 @@ import Test.Cardano.Ledger.Plutus.Examples (
   alwaysSucceedsNoDatum,
  )
 
-import Cardano.Ledger.Credential (Credential (..))
-
 spec ::
   forall era.
   ( ConwayEraImp era
@@ -52,7 +50,8 @@ spec = do
 
   it "Withdraw from delegated and non-delegated staking key" $ do
     modifyPParams $ ppGovActionLifetimeL .~ EpochInterval 2
-    cred <- KeyHashObj <$> freshKeyHash
+    kh <- freshKeyHash
+    let cred = KeyHashObj kh
     ra <- registerStakeCredential cred
     submitAndExpireProposalToMakeReward cred
     reward <- lookupReward cred
@@ -65,15 +64,14 @@ spec = do
       else
         submitFailingTx
           tx
-          [injectFailure $ ConwayWdrlNotDelegatedToDRep [raCredential ra]]
+          [injectFailure $ ConwayWdrlNotDelegatedToDRep [kh]]
     _ <- delegateToDRep cred (Coin 1_000_000) DRepAlwaysAbstain
     submitTx_ $
       mkBasicTx $
         mkBasicTxBody
           & withdrawalsTxBodyL
             .~ Withdrawals
-              [ (ra, if HF.bootstrapPhase pv then mempty else reward)
-              ]
+              [(ra, if HF.bootstrapPhase pv then mempty else reward)]
 
   it "Withdraw from delegated and non-delegated staking script" $ do
     modifyPParams $ ppGovActionLifetimeL .~ EpochInterval 2