add sum of the deposits in a transaction event

IntersectMBO · Jul 8, 2021 · 6213021 · 6213021
1 parent 6cd0c2f
commit 6213021
Show file tree

Hide file tree

Showing 5 changed files with 23 additions and 11 deletions.
diff --git a/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/STS/Bbody.hs b/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/STS/Bbody.hs
@@ -94,8 +94,8 @@ data BbodyPredicateFailure era
   | LedgersFailure (PredicateFailure (Core.EraRule "LEDGERS" era)) -- Subtransition Failures
   deriving (Generic)
 
-data BbodyEvent era = 
-  LedgersEvent (Event (Core.EraRule "LEDGERS" era))
+data BbodyEvent era
+  = LedgersEvent (Event (Core.EraRule "LEDGERS" era))
 
 deriving stock instance
   ( Era era,
@@ -198,7 +198,8 @@ bbodyTransition =
                 b
             )
 
-instance forall era ledgers.
+instance
+  forall era ledgers.
   ( Era era,
     BaseM ledgers ~ ShelleyBase,
     ledgers ~ Core.EraRule "LEDGERS" era,

diff --git a/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/STS/Chain.hs b/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/STS/Chain.hs
@@ -73,6 +73,7 @@ import Data.Default.Class (Default, def)
 import Data.Foldable (fold)
 import Data.Map.Strict (Map)
 import qualified Data.Map.Strict as Map
+import Data.Void (Void)
 import Data.Word (Word64)
 import GHC.Generics (Generic)
 import GHC.Records
@@ -118,7 +119,6 @@ import Shelley.Spec.Ledger.STS.Prtcl
 import Shelley.Spec.Ledger.STS.Tick (TICK, TickPredicateFailure)
 import Shelley.Spec.Ledger.STS.Tickn
 import Shelley.Spec.Ledger.UTxO (UTxO (..), balance)
-import Data.Void (Void)
 
 data CHAIN era
 

diff --git a/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/STS/Pool.hs b/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/STS/Pool.hs
@@ -14,7 +14,7 @@
 
 module Shelley.Spec.Ledger.STS.Pool
   ( POOL,
-    PoolEvent(..),
+    PoolEvent (..),
     PoolEnv (..),
     PredicateFailure,
     PoolPredicateFailure (..),
@@ -127,8 +127,8 @@ instance
 
   transitionRules = [poolDelegationTransition]
 
-data PoolEvent era = 
-    RegisterPool (KeyHash 'StakePool (Crypto era))
+data PoolEvent era
+  = RegisterPool (KeyHash 'StakePool (Crypto era))
   | ReregisterPool (KeyHash 'StakePool (Crypto era))
 
 instance

diff --git a/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/STS/Upec.hs b/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/STS/Upec.hs
@@ -157,4 +157,3 @@ instance
   where
   wrapFailed = NewPpFailure
   wrapEvent = id
-
diff --git a/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/STS/Utxo.hs b/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/STS/Utxo.hs
@@ -18,6 +18,7 @@ module Shelley.Spec.Ledger.STS.Utxo
   ( UTXO,
     UtxoEnv (..),
     UtxoPredicateFailure (..),
+    UtxoEvent (..),
     PredicateFailure,
   )
 where
@@ -72,6 +73,7 @@ import Control.State.Transition
     TransitionRule,
     judgmentContext,
     liftSTS,
+    tellEvent,
     trans,
     wrapEvent,
     wrapFailed,
@@ -83,6 +85,7 @@ import qualified Data.Map.Strict as Map
 import Data.Sequence.Strict (StrictSeq)
 import Data.Set (Set)
 import qualified Data.Set as Set
+import Data.Void (Void)
 import Data.Word (Word8)
 import GHC.Generics (Generic)
 import GHC.Records (HasField (..))
@@ -128,6 +131,10 @@ data UtxoEnv era
 
 deriving instance Show (Core.PParams era) => Show (UtxoEnv era)
 
+data UtxoEvent era
+  = TotalDeposits Coin
+  | UpdateEvent (Event (Core.EraRule "PPUP" era))
+
 data UtxoPredicateFailure era
   = BadInputsUTxO
       !(Set (TxIn (Crypto era))) -- The bad transaction inputs
@@ -296,6 +303,7 @@ instance
   type Environment (UTXO era) = UtxoEnv era
   type BaseM (UTXO era) = ShelleyBase
   type PredicateFailure (UTXO era) = UtxoPredicateFailure era
+  type Event (UTXO era) = UtxoEvent era
 
   transitionRules = [utxoInductive]
 
@@ -337,6 +345,7 @@ utxoInductive ::
     State (utxo era) ~ UTxOState era,
     Signal (utxo era) ~ Tx era,
     PredicateFailure (utxo era) ~ UtxoPredicateFailure era,
+    Event (utxo era) ~ UtxoEvent era,
     Environment (Core.EraRule "PPUP" era) ~ PPUPEnv era,
     State (Core.EraRule "PPUP" era) ~ PPUPState era,
     Signal (Core.EraRule "PPUP" era) ~ Maybe (Update era),
@@ -421,7 +430,9 @@ utxoInductive = do
 
   let refunded = keyRefunds pp txb
   let txCerts = toList $ getField @"certs" txb
-  let depositChange = totalDeposits pp (`Map.notMember` stakepools) txCerts <-> refunded
+  let totalDeposits' = totalDeposits pp (`Map.notMember` stakepools) txCerts
+  tellEvent $ TotalDeposits totalDeposits'
+  let depositChange = totalDeposits' <-> refunded
 
   pure
     UTxOState
@@ -434,9 +445,10 @@ utxoInductive = do
 instance
   ( Era era,
     STS (PPUP era),
-    PredicateFailure (Core.EraRule "PPUP" era) ~ PpupPredicateFailure era
+    PredicateFailure (Core.EraRule "PPUP" era) ~ PpupPredicateFailure era,
+    Event (Core.EraRule "PPUP" era) ~ Void
   ) =>
   Embed (PPUP era) (UTXO era)
   where
   wrapFailed = UpdateFailure
-  wrapEvent = id
+  wrapEvent = UpdateEvent