diff --git a/eras/shelley/impl/src/Cardano/Ledger/Shelley/Rules/Epoch.hs b/eras/shelley/impl/src/Cardano/Ledger/Shelley/Rules/Epoch.hs index 23801b0bf42..e33ce94646a 100644 --- 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 index 6b3a70b812a..db323328de2 100644 --- a/eras/shelley/impl/src/Cardano/Ledger/Shelley/Rules/Snap.hs +++ b/eras/shelley/impl/src/Cardano/Ledger/Shelley/Rules/Snap.hs @@ -3,6 +3,7 @@ {-# LANGUAGE EmptyDataDeriving #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} @@ -10,6 +11,7 @@ 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,