WIP smarter totalCertsDeposits

eras/shelley/impl/src/Cardano/Ledger/Shelley/LedgerState/RefundsAndDeposits.hs

@@ -1,6 +1,7 @@
 {-# LANGUAGE BangPatterns #-}
 {-# LANGUAGE DataKinds #-}
 {-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE PatternSynonyms #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TypeApplications #-}
@@ -16,6 +17,7 @@ where
 import Cardano.Ledger.Coin (Coin (..))
 import Cardano.Ledger.Core
 import Cardano.Ledger.DPState (DPState (..), DState (..), PState (..))
+import Cardano.Ledger.Keys (KeyHash (..), KeyRole (..))
 import Cardano.Ledger.Shelley.Delegation.Certificates (DCert (..), isRegKey)
 import Cardano.Ledger.Shelley.TxBody (
   PoolParams (..),
@@ -32,8 +34,10 @@ import Cardano.Ledger.UMapCompact (
  )
 import qualified Cardano.Ledger.UMapCompact as UM
 import Cardano.Ledger.Val ((<+>), (<×>))
-import Data.Foldable (foldl', toList)
+import Data.Foldable (foldMap', foldl', toList)
 import qualified Data.Map.Strict as Map
+import Data.Monoid (Sum (..))
+import qualified Data.Set as Set
 import Lens.Micro ((^.))
 
 -- | Determine the total deposit amount needed from a TxBody.
@@ -48,30 +52,62 @@ import Lens.Micro ((^.))
 -- Note that this is not an issue for key registrations since subsequent
 -- registration certificates would be invalid.
 totalCertsDeposits ::
-  EraPParams era =>
+  (EraPParams era, Foldable f) =>
   PParams era ->
-  DPState c ->
-  [DCert c] ->
+  DPState (EraCrypto era) ->
+  f (DCert (EraCrypto era)) ->
   Coin
-totalCertsDeposits pp dpstate certs =
+totalCertsDeposits pp dpstate =
+  totalCertsDepositsForRegPools pp (psStakePoolParams (dpsPState dpstate))
+
+totalCertsDepositsForRegPools ::
+  (EraPParams era, Foldable f) =>
+  PParams era ->
+  -- | All of the registered pools. Could be restricted only to the pool ids that are
+  -- mentioned in the `RegPool` of supplied certificates.
+  Map.Map (KeyHash 'StakePool (EraCrypto era)) (PoolParams (EraCrypto era)) ->
+  f (DCert (EraCrypto era)) ->
+  Coin
+totalCertsDepositsForRegPools pp regPools certs =
   numKeys <×> pp ^. ppKeyDepositL
-    <+> snd (foldl' accum (regpools, Coin 0) certs)
+    <+> snd (foldl' accum (Set.empty, Coin 0) certs)
   where
-    numKeys = length $ filter isRegKey certs
-    regpools = psStakePoolParams (dpsPState dpstate)
-    accum (!pools, !ans) (DCertPool (RegPool poolparam)) =
-      if Map.member (ppId poolparam) pools -- We don't pay a deposit on a pool that is already registered
+    numKeys :: Int
+    numKeys = getSum $ foldMap' (\x -> if isRegKey x then 1 else 0) certs
+    accum (!pools, !ans) (DCertPool (RegPool (PoolParams {ppId}))) =
+      -- We don't pay a deposit on a pool that is already registered
+      if Map.member ppId regPools || Set.member ppId pools
         then (pools, ans)
-        else (Map.insert (ppId poolparam) poolparam pools, ans <+> pp ^. ppPoolDepositL)
+        else (Set.insert ppId pools, ans <+> pp ^. ppPoolDepositL)
     accum ans _ = ans
 
+-- totalRegDeposits ::
+--   (EraPParams era, Foldable f) =>
+--   PParams era ->
+--   -- | Map of registered Stake Pools
+--   Map (KeyHash 'StakePool c) (PoolParams c) ->
+--   f (DCert c) ->
+--   Coin
+-- totalRegDeposits pp regPools poolIds =
+--   numDelegKeys <×> pp ^. ppKeyDepositL
+--     <+> numRegPoolIds <×> pp ^. ppPoolDepositL
+--   where
+--     -- numDelegKeys = length $ filter isRegKey certs -- alternative
+--     numDelegKeys = getSum $ foldMap' (\x -> if isRegKey x then 1 else 0) certs
+--     poolIds = Set.fromList (map getRegPoolId certs)
+--     numRegPoolIds = Set.size poolIds - Map.size (regPools `Map.restrictKeys` poolIds)
+--     getRegPoolId = \case
+--       DCertPool (RegPool {ppId}) -> Just ppId
+--       _ -> Nothing
+
 totalTxDeposits ::
   ShelleyEraTxBody era =>
   PParams era ->
   DPState (EraCrypto era) ->
   TxBody era ->
   Coin
-totalTxDeposits pp dpstate txb = totalCertsDeposits pp dpstate (toList $ txb ^. certsTxBodyG)
+totalTxDeposits pp dpstate txb =
+  totalCertsDeposits pp dpstate (txb ^. certsTxBodyG)
 
 -- | Compute the key deregistration refunds in a transaction
 keyCertsRefunds ::

eras/shelley/impl/src/Cardano/Ledger/Shelley/UTxO.hs

@@ -128,10 +128,21 @@ produced ::
   DPState (EraCrypto era) ->
   TxBody era ->
   Value era
-produced pp dpstate txBody =
-  balance (txouts txBody)
+produced pp dpstate = getProducedCoin pp (psStakePoolParams (dpsPState dpstate))
+  -- balance (txouts txBody)
+  --   <+> Val.inject
+  --     (txBody ^. feeTxBodyL <+> totalTxDeposits pp dpstate txBody)
+
+getProducedValue ::
+  ShelleyEraTxBody era =>
+  PParams era ->
+  Map.Map (KeyHash 'StakePool (EraCrypto era)) (PoolParams (EraCrypto era)) ->
+  TxBody era ->
+  Value era
+getProducedValue pp regPools txBody =
+  sumAllValue (txBody ^. outputsTxBodyL)
     <+> Val.inject
-      (txBody ^. feeTxBodyL <+> totalTxDeposits pp dpstate txBody)
+      (txBody ^. feeTxBodyL <+> totalCertsDepositsForRegPools pp regPools (txBody ^. certsTxBodyG))
 
 -- | Compute the lovelace which are destroyed by the transaction
 getConsumedCoin ::

libs/cardano-ledger-api/src/Cardano/Ledger/Api/Tx/Body.hs

@@ -74,3 +74,30 @@ import Cardano.Ledger.Conway.Core (ConwayEraTxBody (..))
 import Cardano.Ledger.Core (EraTxBody (..))
 import Cardano.Ledger.Mary.Core (MaryEraTxBody (..))
 import Cardano.Ledger.Shelley.Core (ShelleyEraTxBody (..))
+
+
+-- | Evaluate the difference between the value currently being consumed by
+-- a transaction and the number of lovelace being produced.
+-- This value will be zero for a valid transaction.
+evalBalanceTxBody ::
+  ( EraUTxO era
+  , ShelleyEraTxBody era
+  ) =>
+  -- | Current protocol parameters
+  PParams era ->
+  -- | Registered Stake Pool
+  Map (KeyHash 'StakePool c) (PoolParams c) ->
+  -- | The UTxO relevant to the transaction.
+  UTxO era ->
+  -- | The transaction being evaluated for balance.
+  TxBody era ->
+  -- | The difference between what the transaction consumes and what it produces.
+  Value era
+evalBalanceTxBody pp dpstate u txb =
+  getConsumedValue pp dpstate u txb <-> produced pp dpstate txb
+
+
+
+-- Need queries:
+--  * [ppId] -> [PoolParams]
+--