Merge pull request #4981 from IntersectMBO/nm/4567-move-compactcoin-addsub

Move add/sum functions for `CompactCoin` to `Cardano.Ledger.Coin`

Author: lehins

eras/conway/impl/src/Cardano/Ledger/Conway/Governance/DRepPulser.hs

@@ -58,7 +58,7 @@ import Cardano.Ledger.Binary.Coders (
   (!>),
   (<!),
  )
-import Cardano.Ledger.Coin (Coin (..))
+import Cardano.Ledger.Coin (Coin (..), addCompactCoin)
 import Cardano.Ledger.Conway.Era (ConwayRATIFY)
 import Cardano.Ledger.Conway.Governance.Internal
 import Cardano.Ledger.Conway.Governance.Procedures (GovActionState)
@@ -214,19 +214,19 @@ computeDRepDistr instantStake regDReps proposalDeposits poolDistr dRepDistr =
       let instantStakeCredentials = instantStake ^. instantStakeCredentialsL
           stake = fromMaybe (CompactCoin 0) $ Map.lookup stakeCred instantStakeCredentials
           mProposalDeposit = Map.lookup stakeCred proposalDeposits
-          stakeAndDeposits = maybe stake (addCompact stake) mProposalDeposit
+          stakeAndDeposits = maybe stake (addCompactCoin stake) mProposalDeposit
        in case umElemDelegations umElem of
             Nothing -> (drepAccum, poolAccum)
             Just (RewardDelegationSPO spo _r) ->
               ( drepAccum
               , addToPoolDistr spo mProposalDeposit poolAccum
               )
             Just (RewardDelegationDRep drep r) ->
-              ( addToDRepDistr drep (addCompact stakeAndDeposits r) drepAccum
+              ( addToDRepDistr drep (addCompactCoin stakeAndDeposits r) drepAccum
               , poolAccum
               )
             Just (RewardDelegationBoth spo drep r) ->
-              ( addToDRepDistr drep (addCompact stakeAndDeposits r) drepAccum
+              ( addToDRepDistr drep (addCompactCoin stakeAndDeposits r) drepAccum
               , addToPoolDistr spo mProposalDeposit poolAccum
               )
     addToPoolDistr spo mProposalDeposit distr = fromMaybe distr $ do
@@ -237,7 +237,7 @@ computeDRepDistr instantStake regDReps proposalDeposits poolDistr dRepDistr =
           & poolDistrDistrL %~ Map.insert spo (ips & individualTotalPoolStakeL <>~ proposalDeposit)
           & poolDistrTotalL <>~ proposalDeposit
     addToDRepDistr drep ccoin distr =
-      let updatedDistr = Map.insertWith addCompact drep ccoin distr
+      let updatedDistr = Map.insertWith addCompactCoin drep ccoin distr
        in case drep of
             DRepAlwaysAbstain -> updatedDistr
             DRepAlwaysNoConfidence -> updatedDistr

eras/conway/impl/src/Cardano/Ledger/Conway/Governance/Proposals.hs

@@ -131,11 +131,11 @@ import Cardano.Ledger.Binary (
   decodeListLikeWithCountT,
   decodeRecordNamedT,
  )
-import Cardano.Ledger.Coin (Coin, CompactForm (CompactCoin))
+import Cardano.Ledger.Coin (Coin, CompactForm (CompactCoin), addCompactCoin)
+import Cardano.Ledger.Compactible (toCompact)
 import Cardano.Ledger.Conway.Governance.Procedures
 import Cardano.Ledger.Core
 import Cardano.Ledger.Credential (Credential)
-import Cardano.Ledger.UMap (addCompact, toCompact)
 import Control.DeepSeq (NFData)
 import Control.Exception (assert)
 import Control.Monad (unless)
@@ -545,7 +545,7 @@ proposalsDeposits =
   F.foldl'
     ( \gasMap gas ->
         Map.insertWith
-          addCompact
+          addCompactCoin
           (gas ^. gasReturnAddrL . rewardAccountCredentialL)
           (fromMaybe (CompactCoin 0) $ toCompact $ gas ^. gasDepositL)
           gasMap

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

@@ -57,7 +57,12 @@ import Cardano.Ledger.BaseTypes (
   (⭒),
  )
 import Cardano.Ledger.Block (Block (..), bheader)
-import Cardano.Ledger.Coin (Coin (..))
+import Cardano.Ledger.Coin (
+  Coin (..),
+  CompactForm (CompactCoin),
+  addCompactCoin,
+  compactCoinOrError,
+ )
 import Cardano.Ledger.Credential (Credential (..), Ptr)
 import Cardano.Ledger.Hashes (GenDelegPair, GenDelegs (..))
 import Cardano.Ledger.PoolParams (PoolParams (..))
@@ -186,7 +191,7 @@ feesAndDeposits ppEx newFees stakes pools cs = cs {chainNes = nes'}
     newcount = F.foldl' accum 0 pools
     accum n x = if Map.member (ppId x) (psDeposits pstate) then (n :: Integer) else n + 1
     newDeposits =
-      Map.fromList (map (\cred -> (cred, UM.compactCoinOrError (ppEx ^. ppKeyDepositL))) stakes)
+      Map.fromList (map (\cred -> (cred, compactCoinOrError (ppEx ^. ppKeyDepositL))) stakes)
     newPools = Map.fromList (map (\p -> (ppId p, ppEx ^. ppPoolDepositL)) pools)
     dpstate' =
       mkShelleyCertState
@@ -222,7 +227,7 @@ feesAndKeyRefund newFees key cs = cs {chainNes = nes'}
     es' = es {esLState = ls'}
     nes' = nes {nesEs = es'}
     dpstate' = certState & certDStateL . dsUnifiedL %~ (UM.adjust zeroD key . RewDepUView)
-    zeroD (RDPair x _) = RDPair x (UM.CompactCoin 0)
+    zeroD (RDPair x _) = RDPair x (CompactCoin 0)
 
 -- | = Update the UTxO
 --
@@ -273,7 +278,7 @@ newStakeCred cred ptr cs = cs {chainNes = nes'}
       ds
         { dsUnified =
             let um0 = dsUnified ds
-                um1 = UM.insert cred (UM.RDPair (UM.CompactCoin 0) (UM.CompactCoin 0)) (RewDepUView um0)
+                um1 = UM.insert cred (UM.RDPair (CompactCoin 0) (CompactCoin 0)) (RewDepUView um0)
                 um2 = (PtrUView um1 UM.∪ (ptr, cred))
              in um2
         }
@@ -469,7 +474,7 @@ reapPool pool cs = cs {chainNes = nes'}
         Just (UM.RDPair ccoin dep) ->
           ( UM.insert'
               rewardAddr
-              (UM.RDPair (UM.addCompact ccoin (UM.compactCoinOrError (pp ^. ppPoolDepositL))) dep)
+              (UM.RDPair (addCompactCoin ccoin (compactCoinOrError (pp ^. ppPoolDepositL))) dep)
               (rewards ds)
           , Coin 0
           )
@@ -542,7 +547,7 @@ applyMIR pot newrewards cs = cs {chainNes = nes'}
     ds = dps ^. certDStateL
     ds' =
       ds
-        { dsUnified = rewards ds UM.∪+ Map.map UM.compactCoinOrError newrewards
+        { dsUnified = rewards ds UM.∪+ Map.map compactCoinOrError newrewards
         , dsIRewards = emptyInstantaneousRewards
         }
     dps' = dps & certDStateL .~ ds'

libs/cardano-ledger-core/CHANGELOG.md

@@ -2,6 +2,9 @@
 
 ## 1.18.0.0
 
+* Add `addCompactCoin` to `Cardano.Ledger.Coin` and deprecate `Cardano.Ledger.UMap.addCompact`
+  in its favor
+* Move `sumCompactCoin` to `Cardano.Ledger.Coin`
 * Add `eraDecoderWithBytes`
 * Move `Annotator` instances to `testlib`
 * Expose `MkData` constructor.

libs/cardano-ledger-core/src/Cardano/Ledger/Coin.hs

@@ -24,6 +24,8 @@ module Cardano.Ledger.Coin (
   integerToWord64,
   decodePositiveCoin,
   compactCoinOrError,
+  addCompactCoin,
+  sumCompactCoin,
   -- NonZero helpers
   toCompactCoinNonZero,
   unCoinNonZero,
@@ -54,6 +56,7 @@ import Cardano.Ledger.Compactible
 import Control.DeepSeq (NFData)
 import Data.Aeson (FromJSON, ToJSON)
 import Data.Coerce (coerce)
+import qualified Data.Foldable as F (foldl') -- Drop this when ghc >= 9.10
 import Data.Group (Abelian, Group (..))
 import Data.MemPack
 import Data.Monoid (Sum (..))
@@ -173,6 +176,12 @@ instance EncCBOR (CompactForm DeltaCoin) where
 instance DecCBOR (CompactForm DeltaCoin) where
   decCBOR = CompactDeltaCoin <$> decCBOR
 
+addCompactCoin :: CompactForm Coin -> CompactForm Coin -> CompactForm Coin
+addCompactCoin (CompactCoin x) (CompactCoin y) = CompactCoin (x + y)
+
+sumCompactCoin :: Foldable t => t (CompactForm Coin) -> CompactForm Coin
+sumCompactCoin = F.foldl' addCompactCoin (CompactCoin 0)
+
 -- ================================
 
 decodePositiveCoin :: String -> Decoder s Coin

libs/cardano-ledger-core/src/Cardano/Ledger/UMap.hs

@@ -119,7 +119,13 @@ where
 
 import Cardano.Ledger.BaseTypes (strictMaybe)
 import Cardano.Ledger.Binary
-import Cardano.Ledger.Coin (Coin (..), CompactForm (CompactCoin), compactCoinOrError)
+import Cardano.Ledger.Coin (
+  Coin (..),
+  CompactForm (CompactCoin),
+  addCompactCoin,
+  compactCoinOrError,
+  sumCompactCoin,
+ )
 import Cardano.Ledger.Compactible (Compactible (..))
 import Cardano.Ledger.Credential (Credential (..), Ptr, mkPtrNormalized)
 import Cardano.Ledger.DRep (DRep)
@@ -926,7 +932,7 @@ unionRewAgg view m = Map.foldlWithKey' accum (unUView view) m
   where
     accum umap key ccoin = adjust combine key (RewDepUView umap)
       where
-        combine (RDPair r d) = RDPair (addCompact r ccoin) d
+        combine (RDPair r d) = RDPair (addCompactCoin r ccoin) d
 (∪+) = unionRewAgg
 
 -- | Add the deposit from the `Map` on the right side to the deposit in the `UView` on the left.
@@ -937,7 +943,7 @@ unionKeyDeposits view m = unUView $ Map.foldlWithKey' accum view m
     accum vw key ccoin = insertWith' combine key (RDPair (CompactCoin 0) ccoin) vw
     -- If the key isn't present in the `UMap` the combining function is ignored
     -- and the new `RDPair` is inserted in the `UMap`. Ref: haddock for `insertWith'`.
-    combine (RDPair r d) (RDPair _ newD) = RDPair r (addCompact d newD)
+    combine (RDPair r d) (RDPair _ newD) = RDPair r (addCompactCoin d newD)
 
 -- | Delete all keys in the given `Set` from the domain of the given map-like `UView`.
 --
@@ -1083,17 +1089,15 @@ unify rd ptr sPool dRep = um4
     um4 = unUView $ Map.foldlWithKey' (\um k v -> insert' k v um) (PtrUView um3) ptr
 
 addCompact :: CompactForm Coin -> CompactForm Coin -> CompactForm Coin
-addCompact (CompactCoin x) (CompactCoin y) = CompactCoin (x + y)
-
-sumCompactCoin :: Foldable t => t (CompactForm Coin) -> CompactForm Coin
-sumCompactCoin = foldl' addCompact (CompactCoin 0)
+addCompact = addCompactCoin
+{-# DEPRECATED addCompact "In favor of `Cardano.Ledger.Coin.addCompactCoin`" #-}
 
 sumRewardsUView :: UView k RDPair -> CompactForm Coin
 sumRewardsUView = foldl' accum (CompactCoin 0)
   where
-    accum ans (RDPair r _) = addCompact ans r
+    accum ans (RDPair r _) = addCompactCoin ans r
 
 sumDepositUView :: UView k RDPair -> CompactForm Coin
 sumDepositUView = foldl' accum (CompactCoin 0)
   where
-    accum ans (RDPair _ d) = addCompact ans d
+    accum ans (RDPair _ d) = addCompactCoin ans d

libs/cardano-ledger-core/test/Test/Cardano/Ledger/UMapSpec.hs

@@ -7,7 +7,7 @@
 module Test.Cardano.Ledger.UMapSpec where
 
 import Cardano.Ledger.BaseTypes (StrictMaybe (SJust, SNothing))
-import Cardano.Ledger.Coin (Coin, CompactForm)
+import Cardano.Ledger.Coin (Coin, CompactForm, addCompactCoin)
 import Cardano.Ledger.Compactible (fromCompact)
 import Cardano.Ledger.Credential (Credential, Ptr)
 import Cardano.Ledger.DRep (DRep)
@@ -18,7 +18,6 @@ import Cardano.Ledger.UMap (
   UMElem (UMElem),
   UMap (UMap, umElems, umPtrs),
   UView (DRepUView, PtrUView, RewDepUView, SPoolUView),
-  addCompact,
   compactRewardMap,
   dRepMap,
   delete,
@@ -216,7 +215,7 @@ oldUnionRewAgg ::
     addC :: CompactForm Coin -> StrictMaybe RDPair -> StrictMaybe RDPair
     addC newR = \case
       SNothing -> SNothing
-      SJust (RDPair r d) -> SJust $ RDPair (addCompact r newR) d
+      SJust (RDPair r d) -> SJust $ RDPair (addCompactCoin r newR) d
 
 spec :: Spec
 spec = do