Replace ShelleyTxCertDeleg in Shelley TxCert with specialized patterns

`RegTxCert`,`UnRegTxCert`, `DelegStakeTxCert`
IntersectMBO · Jun 2, 2023 · 6d96686 · 6d96686
1 parent fde9a0d
commit 6d96686
Show file tree

Hide file tree

Showing 35 changed files with 333 additions and 216 deletions.
diff --git a/eras/allegra/impl/src/Cardano/Ledger/Allegra/TxCert.hs b/eras/allegra/impl/src/Cardano/Ledger/Allegra/TxCert.hs
@@ -29,10 +29,20 @@ instance Crypto c => EraTxCert (AllegraEra c) where
 instance Crypto c => ShelleyEraTxCert (AllegraEra c) where
   {-# SPECIALIZE instance ShelleyEraTxCert (AllegraEra StandardCrypto) #-}
 
-  mkShelleyTxCertDeleg = ShelleyTxCertDelegCert
+  mkRegTxCert = ShelleyTxCertDelegCert . ShelleyRegCert
 
-  getShelleyTxCertDeleg (ShelleyTxCertDelegCert c) = Just c
-  getShelleyTxCertDeleg _ = Nothing
+  getRegTxCert (ShelleyTxCertDelegCert (ShelleyRegCert c)) = Just c
+  getRegTxCert _ = Nothing
+
+  mkUnRegTxCert = ShelleyTxCertDelegCert . ShelleyUnRegCert
+
+  getUnRegTxCert (ShelleyTxCertDelegCert (ShelleyUnRegCert c)) = Just c
+  getUnRegTxCert _ = Nothing
+
+  mkDelegStakeTxCert c kh = ShelleyTxCertDelegCert $ ShelleyDelegCert c kh
+
+  getDelegStakeTxCert (ShelleyTxCertDelegCert (ShelleyDelegCert c kh)) = Just (c, kh)
+  getDelegStakeTxCert _ = Nothing
 
   mkTxCertGenesisDeleg = ShelleyTxCertGenesisDeleg
 

diff --git a/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/TxCert.hs b/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/TxCert.hs
@@ -29,10 +29,20 @@ instance Crypto c => EraTxCert (AlonzoEra c) where
 instance Crypto c => ShelleyEraTxCert (AlonzoEra c) where
   {-# SPECIALIZE instance ShelleyEraTxCert (AlonzoEra StandardCrypto) #-}
 
-  mkShelleyTxCertDeleg = ShelleyTxCertDelegCert
+  mkRegTxCert = ShelleyTxCertDelegCert . ShelleyRegCert
 
-  getShelleyTxCertDeleg (ShelleyTxCertDelegCert c) = Just c
-  getShelleyTxCertDeleg _ = Nothing
+  getRegTxCert (ShelleyTxCertDelegCert (ShelleyRegCert c)) = Just c
+  getRegTxCert _ = Nothing
+
+  mkUnRegTxCert = ShelleyTxCertDelegCert . ShelleyUnRegCert
+
+  getUnRegTxCert (ShelleyTxCertDelegCert (ShelleyUnRegCert c)) = Just c
+  getUnRegTxCert _ = Nothing
+
+  mkDelegStakeTxCert c kh = ShelleyTxCertDelegCert $ ShelleyDelegCert c kh
+
+  getDelegStakeTxCert (ShelleyTxCertDelegCert (ShelleyDelegCert c kh)) = Just (c, kh)
+  getDelegStakeTxCert _ = Nothing
 
   mkTxCertGenesisDeleg = ShelleyTxCertGenesisDeleg
 

diff --git a/eras/babbage/impl/src/Cardano/Ledger/Babbage/TxCert.hs b/eras/babbage/impl/src/Cardano/Ledger/Babbage/TxCert.hs
@@ -29,10 +29,20 @@ instance Crypto c => EraTxCert (BabbageEra c) where
 instance Crypto c => ShelleyEraTxCert (BabbageEra c) where
   {-# SPECIALIZE instance ShelleyEraTxCert (BabbageEra StandardCrypto) #-}
 
-  mkShelleyTxCertDeleg = ShelleyTxCertDelegCert
+  mkRegTxCert = ShelleyTxCertDelegCert . ShelleyRegCert
 
-  getShelleyTxCertDeleg (ShelleyTxCertDelegCert c) = Just c
-  getShelleyTxCertDeleg _ = Nothing
+  getRegTxCert (ShelleyTxCertDelegCert (ShelleyRegCert c)) = Just c
+  getRegTxCert _ = Nothing
+
+  mkUnRegTxCert = ShelleyTxCertDelegCert . ShelleyUnRegCert
+
+  getUnRegTxCert (ShelleyTxCertDelegCert (ShelleyUnRegCert c)) = Just c
+  getUnRegTxCert _ = Nothing
+
+  mkDelegStakeTxCert c kh = ShelleyTxCertDelegCert $ ShelleyDelegCert c kh
+
+  getDelegStakeTxCert (ShelleyTxCertDelegCert (ShelleyDelegCert c kh)) = Just (c, kh)
+  getDelegStakeTxCert _ = Nothing
 
   mkTxCertGenesisDeleg = ShelleyTxCertGenesisDeleg
 

diff --git a/eras/conway/impl/src/Cardano/Ledger/Conway/TxCert.hs b/eras/conway/impl/src/Cardano/Ledger/Conway/TxCert.hs
@@ -82,10 +82,20 @@ instance Crypto c => EraTxCert (ConwayEra c) where
   getRetirePoolTxCert _ = Nothing
 
 instance Crypto c => ShelleyEraTxCert (ConwayEra c) where
-  mkShelleyTxCertDeleg = ConwayTxCertDeleg . fromShelleyDelegCert
+  mkRegTxCert c = ConwayTxCertDeleg $ ConwayRegCert c SNothing
 
-  getShelleyTxCertDeleg (ConwayTxCertDeleg conwayDelegCert) = toShelleyDelegCert conwayDelegCert
-  getShelleyTxCertDeleg _ = Nothing
+  getRegTxCert (ConwayTxCertDeleg (ConwayRegCert c _)) = Just c
+  getRegTxCert _ = Nothing
+
+  mkUnRegTxCert c = ConwayTxCertDeleg $ ConwayUnRegCert c SNothing
+
+  getUnRegTxCert (ConwayTxCertDeleg (ConwayUnRegCert c _)) = Just c
+  getUnRegTxCert _ = Nothing
+
+  mkDelegStakeTxCert c kh = ConwayTxCertDeleg $ ConwayDelegCert c (DelegStake kh)
+
+  getDelegStakeTxCert (ConwayTxCertDeleg (ConwayDelegCert c (DelegStake kh))) = Just (c, kh)
+  getDelegStakeTxCert _ = Nothing
 
   mkTxCertGenesisDeleg = notSupportedInThisEra
   getTxCertGenesisDeleg _ = Nothing

diff --git a/eras/mary/impl/src/Cardano/Ledger/Mary/TxCert.hs b/eras/mary/impl/src/Cardano/Ledger/Mary/TxCert.hs
@@ -8,6 +8,7 @@ import Cardano.Ledger.Mary.Era (MaryEra)
 import Cardano.Ledger.Shelley.TxCert (
   EraTxCert (..),
   PoolCert (..),
+  ShelleyDelegCert (..),
   ShelleyEraTxCert (..),
   ShelleyTxCert (..),
   getScriptWitnessShelleyTxCert,
@@ -36,10 +37,20 @@ instance Crypto c => EraTxCert (MaryEra c) where
 instance Crypto c => ShelleyEraTxCert (MaryEra c) where
   {-# SPECIALIZE instance ShelleyEraTxCert (MaryEra StandardCrypto) #-}
 
-  mkShelleyTxCertDeleg = ShelleyTxCertDelegCert
+  mkRegTxCert = ShelleyTxCertDelegCert . ShelleyRegCert
 
-  getShelleyTxCertDeleg (ShelleyTxCertDelegCert c) = Just c
-  getShelleyTxCertDeleg _ = Nothing
+  getRegTxCert (ShelleyTxCertDelegCert (ShelleyRegCert c)) = Just c
+  getRegTxCert _ = Nothing
+
+  mkUnRegTxCert = ShelleyTxCertDelegCert . ShelleyUnRegCert
+
+  getUnRegTxCert (ShelleyTxCertDelegCert (ShelleyUnRegCert c)) = Just c
+  getUnRegTxCert _ = Nothing
+
+  mkDelegStakeTxCert c kh = ShelleyTxCertDelegCert $ ShelleyDelegCert c kh
+
+  getDelegStakeTxCert (ShelleyTxCertDelegCert (ShelleyDelegCert c kh)) = Just (c, kh)
+  getDelegStakeTxCert _ = Nothing
 
   mkTxCertGenesisDeleg = ShelleyTxCertGenesisDeleg
 

diff --git a/...shelley-ma/test-suite/test/Test/Cardano/Ledger/ShelleyMA/Serialisation/Golden/Encoding.hs b/...shelley-ma/test-suite/test/Test/Cardano/Ledger/ShelleyMA/Serialisation/Golden/Encoding.hs
@@ -39,8 +39,7 @@ import Cardano.Ledger.Shelley.TxBody (
   Withdrawals (..),
  )
 import Cardano.Ledger.Shelley.TxCert (
-  ShelleyDelegCert (..),
-  pattern ShelleyTxCertDeleg,
+  pattern RegTxCert,
  )
 import Cardano.Ledger.Slot (EpochNo (..), SlotNo (..))
 import Cardano.Ledger.TxIn (mkTxInPartial)
@@ -242,7 +241,7 @@ goldenEncodingTestsAllegra =
     , -- "full_txn_body"
       let tin = mkTxInPartial genesisId 1
           tout = ShelleyTxOut @Allegra testAddrE (Coin 2)
-          reg = ShelleyTxCertDeleg (ShelleyRegCert testStakeCred)
+          reg = RegTxCert testStakeCred
           ras = Map.singleton (RewardAcnt Testnet (KeyHashObj testKeyHash)) (Coin 123)
           up = testUpdate
           mdh = hashTxAuxData @Allegra $ AllegraTxAuxData Map.empty StrictSeq.empty
@@ -396,7 +395,7 @@ goldenEncodingTestsMary =
     , -- "full_txn_body"
       let tin = mkTxInPartial genesisId 1
           tout = ShelleyTxOut @Mary testAddrE (Val.inject $ Coin 2)
-          reg = ShelleyTxCertDeleg (ShelleyRegCert testStakeCred)
+          reg = RegTxCert testStakeCred
           ras = Map.singleton (RewardAcnt Testnet (KeyHashObj testKeyHash)) (Coin 123)
           up = testUpdate
           mdh = hashTxAuxData @Allegra $ AllegraTxAuxData Map.empty StrictSeq.empty

diff --git a/eras/shelley/impl/src/Cardano/Ledger/Shelley/LedgerState/RefundsAndDeposits.hs b/eras/shelley/impl/src/Cardano/Ledger/Shelley/LedgerState/RefundsAndDeposits.hs
@@ -25,9 +25,9 @@ import Cardano.Ledger.Keys (KeyHash (..), KeyRole (..))
 import Cardano.Ledger.PoolParams (PoolParams (..))
 import Cardano.Ledger.Shelley.Core (ShelleyEraTxBody (..), ShelleyEraTxCert)
 import Cardano.Ledger.Shelley.TxCert (
-  ShelleyDelegCert (..),
   isRegKey,
-  pattern ShelleyTxCertDeleg,
+  pattern RegTxCert,
+  pattern UnRegTxCert,
  )
 import Cardano.Ledger.Val ((<+>), (<×>))
 import Data.Foldable (Foldable (..), foldMap', foldl')
@@ -107,11 +107,11 @@ keyCertsRefunds pp lookupDeposit certs = snd (foldl' accum (mempty, Coin 0) cert
   where
     keyDeposit = pp ^. ppKeyDepositL
     accum (!regKeys, !totalRefunds) = \case
-      ShelleyTxCertDeleg (ShelleyRegCert k) ->
+      RegTxCert k ->
         -- Need to track new delegations in case that the same key is later deregistered in
         -- the same transaction.
         (Set.insert k regKeys, totalRefunds)
-      ShelleyTxCertDeleg (ShelleyUnRegCert k)
+      UnRegTxCert k
         -- We first check if there was already a registration certificate in this
         -- transaction.
         | Set.member k regKeys -> (Set.delete k regKeys, totalRefunds <+> keyDeposit)

diff --git a/eras/shelley/impl/src/Cardano/Ledger/Shelley/Rules/Deleg.hs b/eras/shelley/impl/src/Cardano/Ledger/Shelley/Rules/Deleg.hs
@@ -58,9 +58,10 @@ import Cardano.Ledger.Shelley.TxBody (
  )
 import Cardano.Ledger.Shelley.TxCert (
   GenesisDelegCert (..),
-  ShelleyDelegCert (..),
-  pattern ShelleyTxCertDeleg,
+  pattern DelegStakeTxCert,
+  pattern RegTxCert,
   pattern TxCertGenesisDeleg,
+  pattern UnRegTxCert,
  )
 import Cardano.Ledger.Slot (
   Duration (..),
@@ -267,15 +268,15 @@ delegationTransition = do
   TRC (DelegEnv slot ptr acnt pp, ds, c) <- judgmentContext
   let pv = pp ^. ppProtocolVersionL
   case c of
-    ShelleyTxCertDeleg (ShelleyRegCert hk) -> do
+    RegTxCert hk -> do
       -- (hk ∉ dom (rewards ds))
       UM.notMember hk (rewards ds) ?! StakeKeyAlreadyRegisteredDELEG hk
       let u1 = dsUnified ds
           deposit = compactCoinOrError (pp ^. ppKeyDepositL)
           u2 = RewDepUView u1 UM.∪ (hk, RDPair (UM.CompactCoin 0) deposit)
           u3 = PtrUView u2 UM.∪ (ptr, hk)
       pure (ds {dsUnified = u3})
-    ShelleyTxCertDeleg (ShelleyUnRegCert hk) -> do
+    UnRegTxCert hk -> do
       -- note that pattern match is used instead of cwitness, as in the spec
       -- (hk ∈ dom (rewards ds))
       UM.member hk (rewards ds) ?! StakeKeyNotRegisteredDELEG hk
@@ -288,7 +289,7 @@ delegationTransition = do
           u3 = PtrUView u2 UM.⋫ Set.singleton hk
           u4 = ds {dsUnified = u3}
       pure u4
-    ShelleyTxCertDeleg (ShelleyDelegCert hk dpool) -> do
+    DelegStakeTxCert hk dpool -> do
       -- note that pattern match is used instead of cwitness and dpool, as in the spec
       -- (hk ∈ dom (rewards ds))
       UM.member hk (rewards ds) ?! StakeDelegationImpossibleDELEG hk

diff --git a/eras/shelley/impl/src/Cardano/Ledger/Shelley/Rules/Delegs.hs b/eras/shelley/impl/src/Cardano/Ledger/Shelley/Rules/Delegs.hs
@@ -68,7 +68,7 @@ import Cardano.Ledger.Shelley.TxBody (
   ShelleyEraTxBody (..),
   Withdrawals (..),
  )
-import Cardano.Ledger.Shelley.TxCert (ShelleyDelegCert (..), ShelleyEraTxCert, pattern ShelleyTxCertDeleg)
+import Cardano.Ledger.Shelley.TxCert (ShelleyEraTxCert, pattern DelegStakeTxCert)
 import Cardano.Ledger.Slot (SlotNo)
 import Cardano.Ledger.UMap (UMElem (..), UMap (..), UView (..), fromCompact)
 import qualified Cardano.Ledger.UMap as UM
@@ -243,7 +243,7 @@ validateDelegationRegistered ::
   TxCert era ->
   Test (KeyHash 'StakePool (EraCrypto era))
 validateDelegationRegistered certState = \case
-  ShelleyTxCertDeleg (ShelleyDelegCert _ targetPool) ->
+  DelegStakeTxCert _ targetPool ->
     let stPools = psStakePoolParams $ certPState certState
      in failureUnless (eval (targetPool ∈ dom stPools)) targetPool
   _ -> pure ()

diff --git a/eras/shelley/impl/src/Cardano/Ledger/Shelley/Rules/Pool.hs b/eras/shelley/impl/src/Cardano/Ledger/Shelley/Rules/Pool.hs
@@ -52,8 +52,10 @@ import Cardano.Ledger.Shelley.TxBody (
  )
 import Cardano.Ledger.Shelley.TxCert (
   isInstantaneousRewards,
-  pattern ShelleyTxCertDeleg,
+  pattern DelegStakeTxCert,
+  pattern RegTxCert,
   pattern TxCertGenesisDeleg,
+  pattern UnRegTxCert,
  )
 import Cardano.Ledger.Slot (EpochNo (..), SlotNo, epochInfoEpoch)
 import Control.DeepSeq
@@ -234,7 +236,13 @@ poolDelegationTransition = do
         ?! StakePoolRetirementWrongEpochPOOL cepoch e (cepoch + maxEpoch)
       -- We just schedule it for retirement. When it is retired we refund the deposit (see POOLREAP)
       pure $ ps {psRetiring = eval (psRetiring ps ⨃ singleton hk e)}
-    ShelleyTxCertDeleg _ -> do
+    RegTxCert _ -> do
+      failBecause $ WrongCertificateTypePOOL 0
+      pure ps
+    UnRegTxCert _ -> do
+      failBecause $ WrongCertificateTypePOOL 0
+      pure ps
+    DelegStakeTxCert _ _ -> do
       failBecause $ WrongCertificateTypePOOL 0
       pure ps
     TxCertGenesisDeleg _ -> do

diff --git a/eras/shelley/impl/src/Cardano/Ledger/Shelley/Rules/Reports.hs b/eras/shelley/impl/src/Cardano/Ledger/Shelley/Rules/Reports.hs
@@ -32,10 +32,11 @@ import Cardano.Ledger.Shelley.AdaPots (consumedTxBody, producedTxBody)
 import Cardano.Ledger.Shelley.Core
 import Cardano.Ledger.Shelley.TxBody
 import Cardano.Ledger.Shelley.TxCert (
-  ShelleyDelegCert (..),
   isInstantaneousRewards,
-  pattern ShelleyTxCertDeleg,
+  pattern DelegStakeTxCert,
+  pattern RegTxCert,
   pattern TxCertGenesisDeleg,
+  pattern UnRegTxCert,
  )
 import Cardano.Ledger.UTxO (UTxO (..))
 import Data.Foldable (fold, toList)
@@ -51,9 +52,9 @@ showCred (KeyHashObj (KeyHash x)) = show x
 
 synopsisCert :: ShelleyEraTxCert era => TxCert era -> String
 synopsisCert x = case x of
-  ShelleyTxCertDeleg (ShelleyRegCert cred) -> "ShelleyRegCert " ++ take 10 (showCred cred)
-  ShelleyTxCertDeleg (ShelleyUnRegCert cred) -> "ShelleyUnRegCert " ++ take 10 (showCred cred)
-  ShelleyTxCertDeleg (ShelleyDelegCert cred _) -> "ShelleyDelegCert" ++ take 10 (showCred cred)
+  RegTxCert cred -> "ShelleyRegCert " ++ take 10 (showCred cred)
+  UnRegTxCert cred -> "ShelleyUnRegCert " ++ take 10 (showCred cred)
+  DelegStakeTxCert cred _ -> "ShelleyDelegCert" ++ take 10 (showCred cred)
   RegPoolTxCert pool -> let KeyHash hash = ppId pool in "RegPool " ++ take 10 (show hash)
   RetirePoolTxCert khash e -> "RetirePool " ++ showKeyHash khash ++ " " ++ show e
   TxCertGenesisDeleg _ -> "GenesisCert"