StakeDistEvent

IntersectMBO · Oct 12, 2021 · 8c268e7 · 8c268e7
1 parent 02db700
commit 8c268e7
Show file tree

Hide file tree

Showing 2 changed files with 14 additions and 2 deletions.
diff --git a/eras/shelley/impl/src/Cardano/Ledger/Shelley/Rules/Epoch.hs b/eras/shelley/impl/src/Cardano/Ledger/Shelley/Rules/Epoch.hs
@@ -47,7 +47,7 @@ import Cardano.Ledger.Shelley.LedgerState
   )
 import Cardano.Ledger.Shelley.Rewards ()
 import Cardano.Ledger.Shelley.Rules.PoolReap (POOLREAP, PoolreapEvent, PoolreapPredicateFailure, PoolreapState (..))
-import Cardano.Ledger.Shelley.Rules.Snap (SNAP, SnapPredicateFailure)
+import Cardano.Ledger.Shelley.Rules.Snap (SNAP, SnapPredicateFailure, SnapEvent)
 import Cardano.Ledger.Shelley.Rules.Upec (UPEC, UpecPredicateFailure)
 import Cardano.Ledger.Slot (EpochNo)
 import Control.SetAlgebra (eval, (⨃))
@@ -209,7 +209,7 @@ instance
   ( UsesTxOut era,
     UsesValue era,
     PredicateFailure (Core.EraRule "SNAP" era) ~ SnapPredicateFailure era,
-    Event (Core.EraRule "SNAP" era) ~ Void
+    Event (Core.EraRule "SNAP" era) ~ SnapEvent era
   ) =>
   Embed (SNAP era) (EPOCH era)
   where

diff --git a/eras/shelley/impl/src/Cardano/Ledger/Shelley/Rules/Snap.hs b/eras/shelley/impl/src/Cardano/Ledger/Shelley/Rules/Snap.hs
@@ -3,13 +3,15 @@
 {-# LANGUAGE EmptyDataDeriving #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE UndecidableInstances #-}
 
 module Cardano.Ledger.Shelley.Rules.Snap
   ( SNAP,
     PredicateFailure,
     SnapPredicateFailure,
+    SnapEvent,
   )
 where
 
@@ -30,6 +32,7 @@ import Control.State.Transition
     TRC (..),
     TransitionRule,
     judgmentContext,
+    tellEvent,
   )
 import GHC.Generics (Generic)
 import GHC.Records (HasField)
@@ -42,16 +45,21 @@ data SnapPredicateFailure era -- No predicate failures
 
 instance NoThunks (SnapPredicateFailure era)
 
+data SnapEvent era
+  = StakeDistEvent !(SnapShot (Crypto era))
+
 instance (UsesTxOut era, UsesValue era) => STS (SNAP era) where
   type State (SNAP era) = SnapShots (Crypto era)
   type Signal (SNAP era) = ()
   type Environment (SNAP era) = LedgerState era
   type BaseM (SNAP era) = ShelleyBase
   type PredicateFailure (SNAP era) = SnapPredicateFailure era
+  type Event (SNAP era) = SnapEvent era
   initialRules = [pure emptySnapShots]
   transitionRules = [snapTransition]
 
 snapTransition ::
+  forall era.
   ( UsesValue era,
     HasField "address" (Core.TxOut era) (Addr (Crypto era))
   ) =>
@@ -60,7 +68,11 @@ snapTransition = do
   TRC (lstate, s, _) <- judgmentContext
 
   let LedgerState (UTxOState utxo _ fees _) (DPState dstate pstate) = lstate
+      stake :: SnapShot (Crypto era)
       stake = stakeDistr utxo dstate pstate
+
+  tellEvent $ StakeDistEvent stake
+
   pure $
     s
       { _pstakeMark = stake,