Event logger redux

alonzo/impl/src/Cardano/Ledger/Alonzo/Rules/Bbody.hs

@@ -15,6 +15,7 @@
 module Cardano.Ledger.Alonzo.Rules.Bbody
   ( AlonzoBBODY,
     AlonzoBbodyPredFail (..),
+    AlonzoBbodyEvent (..),
     bbodyTransition,
   )
 where
@@ -64,6 +65,7 @@ import Shelley.Spec.Ledger.LedgerState (LedgerState)
 import Shelley.Spec.Ledger.OverlaySchedule (isOverlaySlot)
 import Shelley.Spec.Ledger.STS.Bbody
   ( BbodyEnv (..),
+    BbodyEvent (..),
     BbodyPredicateFailure (..),
     BbodyState (..),
   )
@@ -82,6 +84,9 @@ data AlonzoBbodyPredFail era
       -- ^ Maximum allowed by protocal parameters
   deriving (Generic)
 
+data AlonzoBbodyEvent era
+  = ShelleyInAlonzoEvent (BbodyEvent era)
+
 deriving instance
   (Era era, Show (PredicateFailure (Core.EraRule "LEDGERS" era))) =>
   Show (AlonzoBbodyPredFail era)
@@ -230,6 +235,7 @@ instance
   type BaseM (AlonzoBBODY era) = ShelleyBase
 
   type PredicateFailure (AlonzoBBODY era) = AlonzoBbodyPredFail era
+  type Event (AlonzoBBODY era) = AlonzoBbodyEvent era
 
   initialRules = []
   transitionRules = [bbodyTransition @AlonzoBBODY]
@@ -245,3 +251,4 @@ instance
   Embed ledgers (AlonzoBBODY era)
   where
   wrapFailed = ShelleyInAlonzoPredFail . LedgersFailure
+  wrapEvent = ShelleyInAlonzoEvent . LedgersEvent

alonzo/impl/src/Cardano/Ledger/Alonzo/Rules/Ledger.hs

@@ -42,6 +42,7 @@ import Data.Kind (Type)
 import Data.Sequence (Seq)
 import Data.Sequence.Strict (StrictSeq)
 import qualified Data.Sequence.Strict as StrictSeq
+import Data.Void (Void)
 import GHC.Records (HasField, getField)
 import Shelley.Spec.Ledger.EpochBoundary (obligation)
 import Shelley.Spec.Ledger.LedgerState
@@ -50,8 +51,8 @@ import Shelley.Spec.Ledger.LedgerState
     PState (..),
     UTxOState (..),
   )
-import Shelley.Spec.Ledger.STS.Delegs (DELEGS, DelegsEnv (..), DelegsPredicateFailure)
-import Shelley.Spec.Ledger.STS.Ledger (LedgerEnv (..), LedgerPredicateFailure (..))
+import Shelley.Spec.Ledger.STS.Delegs (DELEGS, DelegsEnv (..), DelegsEvent, DelegsPredicateFailure)
+import Shelley.Spec.Ledger.STS.Ledger (LedgerEnv (..), LedgerEvent (..), LedgerPredicateFailure (..))
 import qualified Shelley.Spec.Ledger.STS.Ledgers as Shelley
 import Shelley.Spec.Ledger.STS.Utxo
   ( UtxoEnv (..),
@@ -143,6 +144,7 @@ instance
   type Environment (AlonzoLEDGER era) = LedgerEnv era
   type BaseM (AlonzoLEDGER era) = ShelleyBase
   type PredicateFailure (AlonzoLEDGER era) = LedgerPredicateFailure era
+  type Event (AlonzoLEDGER era) = LedgerEvent era
 
   initialRules = []
   transitionRules = [ledgerTransition @AlonzoLEDGER]
@@ -167,26 +169,32 @@ instance
 instance
   ( Era era,
     STS (DELEGS era),
-    PredicateFailure (Core.EraRule "DELEGS" era) ~ DelegsPredicateFailure era
+    PredicateFailure (Core.EraRule "DELEGS" era) ~ DelegsPredicateFailure era,
+    Event (Core.EraRule "DELEGS" era) ~ DelegsEvent era
   ) =>
   Embed (DELEGS era) (AlonzoLEDGER era)
   where
   wrapFailed = DelegsFailure
+  wrapEvent = DelegsEvent
 
 instance
   ( Era era,
     STS (AlonzoUTXOW era),
-    PredicateFailure (Core.EraRule "UTXOW" era) ~ AlonzoPredFail era
+    PredicateFailure (Core.EraRule "UTXOW" era) ~ AlonzoPredFail era,
+    Event (Core.EraRule "UTXOW" era) ~ Void
   ) =>
   Embed (AlonzoUTXOW era) (AlonzoLEDGER era)
   where
   wrapFailed = UtxowFailure
+  wrapEvent = UtxowEvent
 
 instance
   ( Era era,
     STS (AlonzoLEDGER era),
-    PredicateFailure (Core.EraRule "LEDGER" era) ~ LedgerPredicateFailure era
+    PredicateFailure (Core.EraRule "LEDGER" era) ~ LedgerPredicateFailure era,
+    Event (Core.EraRule "LEDGER" era) ~ LedgerEvent era
   ) =>
   Embed (AlonzoLEDGER era) (Shelley.LEDGERS era)
   where
   wrapFailed = Shelley.LedgerFailure
+  wrapEvent = Shelley.LedgerEvent

alonzo/impl/src/Cardano/Ledger/Alonzo/Rules/Utxo.hs

@@ -518,6 +518,7 @@ instance
   Embed (UTXOS era) (AlonzoUTXO era)
   where
   wrapFailed = UtxosFailure
+  wrapEvent = id
 
 --------------------------------------------------------------------------------
 -- Serialisation

alonzo/impl/src/Cardano/Ledger/Alonzo/Rules/Utxos.hs

@@ -294,6 +294,7 @@ instance
   Embed (PPUP era) (UTXOS era)
   where
   wrapFailed = UpdateFailure
+  wrapEvent = id
 
 -- =================================================================
 

alonzo/impl/src/Cardano/Ledger/Alonzo/Rules/Utxow.hs

@@ -456,3 +456,4 @@ instance
   Embed (AlonzoUTXO era) (AlonzoUTXOW era)
   where
   wrapFailed = WrappedShelleyEraFailure . UtxoFailure
+  wrapEvent = id

alonzo/test/test/Test/Cardano/Ledger/Alonzo/Trials.hs

@@ -81,8 +81,8 @@ import Shelley.Spec.Ledger.LedgerState
     UTxOState,
   )
 import Shelley.Spec.Ledger.PParams (PParams' (..))
-import Shelley.Spec.Ledger.STS.Chain (CHAIN, ChainPredicateFailure (..), ChainState (..))
-import Shelley.Spec.Ledger.STS.Ledger (LEDGER, LedgerEnv (..), LedgerPredicateFailure (UtxowFailure))
+import Shelley.Spec.Ledger.STS.Chain (CHAIN, ChainEvent (..), ChainPredicateFailure (..), ChainState (..))
+import Shelley.Spec.Ledger.STS.Ledger (LEDGER, LedgerEnv (..), LedgerEvent (..), LedgerPredicateFailure (UtxowFailure))
 import System.Timeout
 import Test.Cardano.Ledger.Alonzo.AlonzoEraGen ()
 import Test.Cardano.Ledger.EraBuffet (TestCrypto)
@@ -118,9 +118,11 @@ import Test.Tasty.QuickCheck
 
 instance Embed (AlonzoBBODY (AlonzoEra TestCrypto)) (CHAIN (AlonzoEra TestCrypto)) where
   wrapFailed = BbodyFailure
+  wrapEvent = BbodyEvent
 
 instance Embed (AlonzoUTXOW (AlonzoEra TestCrypto)) (LEDGER (AlonzoEra TestCrypto)) where
   wrapFailed = UtxowFailure
+  wrapEvent = UtxowEvent
 
 -- ======================================================================================
 -- It is incredably hard to debug property test generators.  These functions mimic the

byron/chain/executable-spec/src/Byron/Spec/Chain/STS/Rule/BBody.hs

@@ -22,7 +22,7 @@ import           Byron.Spec.Ledger.Update (PParams, UPIState, maxBkSz)
 import           Byron.Spec.Ledger.UTxO (UTxO)
 import           Control.State.Transition (Embed, Environment, STS (..), Signal, State,
                      TRC (TRC), initialRules, judgmentContext, trans, transitionRules, wrapFailed,
-                     (?!))
+                     (?!), wrapEvent)
 
 import           Byron.Spec.Chain.STS.Block
 
@@ -93,9 +93,12 @@ instance STS BBODY where
 
 instance Embed BUPI BBODY where
   wrapFailed = BUPIFailure
+  wrapEvent = id
 
 instance Embed DELEG BBODY where
   wrapFailed = DelegationFailure
+  wrapEvent = id
 
 instance Embed UTXOWS BBODY where
   wrapFailed = UTXOWSFailure
+  wrapEvent = id

byron/chain/executable-spec/src/Byron/Spec/Chain/STS/Rule/Bupi.hs

@@ -10,7 +10,7 @@ import           Data.Data (Data, Typeable)
 
 import           Control.State.Transition (Embed, Environment, PredicateFailure, STS, Signal, State,
                      TRC (TRC), TransitionRule, initialRules, judgmentContext, trans,
-                     transitionRules, wrapFailed)
+                     transitionRules, wrapFailed, wrapEvent)
 import           Byron.Spec.Ledger.Core (VKey)
 import           Byron.Spec.Ledger.Update (ProtVer, UPIEND, UPIEnv, UPIREG, UPIState, UPIVOTES, UProp, Vote)
 
@@ -67,9 +67,12 @@ instance STS BUPI where
 
 instance Embed UPIREG BUPI where
   wrapFailed = UPIREGFailure
+  wrapEvent = id
 
 instance Embed UPIVOTES BUPI where
   wrapFailed = UPIVOTESFailure
+  wrapEvent = id
 
 instance Embed UPIEND BUPI where
   wrapFailed = UPIENDFailure
+  wrapEvent = id

byron/chain/executable-spec/src/Byron/Spec/Chain/STS/Rule/Chain.hs

@@ -162,18 +162,23 @@ instance STS CHAIN where
 
 instance Embed EPOCH CHAIN where
   wrapFailed = EpochFailure
+  wrapEvent = id
 
 instance Embed BBODY CHAIN where
   wrapFailed = BBodyFailure
+  wrapEvent = id
 
 instance Embed PBFT CHAIN where
   wrapFailed = PBFTFailure
+  wrapEvent = id
 
 instance Embed DELEG CHAIN where
   wrapFailed = LedgerDelegationFailure
+  wrapEvent = id
 
 instance Embed UTXOWS CHAIN where
   wrapFailed = LedgerUTxOFailure
+  wrapEvent = id
 
 isHeaderSizeTooBigFailure :: PredicateFailure CHAIN -> Bool
 isHeaderSizeTooBigFailure (HeaderSizeTooBig _ _ _) = True

byron/chain/executable-spec/src/Byron/Spec/Chain/STS/Rule/Epoch.hs

@@ -42,6 +42,7 @@ instance STS EPOCH where
   type Signal EPOCH = Slot
   type PredicateFailure EPOCH = EpochPredicateFailure
 
+
   initialRules = []
 
   transitionRules =
@@ -57,3 +58,4 @@ instance STS EPOCH where
 
 instance Embed UPIEC EPOCH where
   wrapFailed = UPIECFailure
+  wrapEvent = id

byron/chain/executable-spec/src/Byron/Spec/Chain/STS/Rule/Pbft.hs

@@ -43,6 +43,7 @@ instance STS PBFT where
 
   type PredicateFailure PBFT = PbftPredicateFailure
 
+
   initialRules = []
 
   transitionRules =
@@ -61,3 +62,4 @@ instance STS PBFT where
 
 instance Embed SIGCNT PBFT where
   wrapFailed = SigCountFailure
+  wrapEvent = id

byron/chain/executable-spec/src/Byron/Spec/Chain/STS/Rule/SigCnt.hs

@@ -44,6 +44,7 @@ instance STS SIGCNT where
   type Signal SIGCNT = VKey
   type PredicateFailure SIGCNT = SigcntPredicateFailure
 
+
   initialRules = []
 
   transitionRules =

byron/crypto/test/Test/Cardano/Crypto/Limits.hs

@@ -45,7 +45,7 @@ tests = checkParallel $$discover
 --   is almost certainly amiss.
 
 newtype Limit t = Limit
-  { getLimit :: Word32 
+  { getLimit :: Word32
   } deriving (Eq, Ord, Show, Num, Enum, Real, Integral)
 
 instance Functor Limit where

byron/ledger/executable-spec/src/Byron/Spec/Ledger/Delegation.hs

@@ -114,7 +114,7 @@ import           Lens.Micro (Lens', lens, to, (%~), (&), (.~), (<>~), (^.), _1)
 import           Lens.Micro.TH (makeFields)
 import           NoThunks.Class (NoThunks (..), allNoThunks, noThunksInKeysAndValues)
 
-import           Control.State.Transition (Embed, Environment, IRC (IRC), PredicateFailure, STS,
+import           Control.State.Transition (Embed(..), Environment, IRC (IRC), PredicateFailure, STS(..),
                      Signal, State, TRC (TRC), initialRules, judgmentContext, trans,
                      transitionRules, wrapFailed, (?!))
 import           Control.State.Transition.Generator (HasTrace, SignalGenerator, envGen, genTrace,
@@ -451,6 +451,7 @@ instance STS SDELEGS where
 
 instance Embed SDELEG SDELEGS where
   wrapFailed = SDelegFailure
+  wrapEvent = id
 
 -- | Delegation rules sequencing
 data ADELEGS deriving (Data, Typeable)
@@ -484,6 +485,7 @@ instance STS ADELEGS where
 
 instance Embed ADELEG ADELEGS where
   wrapFailed = ADelegFailure
+  wrapEvent = id
 
 -- | Delegation interface
 data DELEG deriving (Data, Typeable)
@@ -528,9 +530,11 @@ instance STS DELEG where
 
 instance Embed SDELEGS DELEG where
   wrapFailed = SDelegSFailure
+  wrapEvent = id
 
 instance Embed ADELEGS DELEG where
   wrapFailed = ADelegSFailure
+  wrapEvent = id
 
 --------------------------------------------------------------------------------
 -- Generators
@@ -623,6 +627,7 @@ instance STS MSDELEG where
 
 instance Embed SDELEG MSDELEG where
   wrapFailed = SDELEGFailure
+  wrapEvent = id
 
 instance HasTrace MSDELEG where
 

byron/ledger/executable-spec/src/Byron/Spec/Ledger/STS/UTXOW.hs

@@ -25,7 +25,7 @@ import qualified Hedgehog.Gen as Gen
 import           Hedgehog.Internal.Property (CoverPercentage)
 import qualified Hedgehog.Range as Range
 
-import           Control.State.Transition (Embed, Environment, IRC (IRC), STS (..),
+import           Control.State.Transition (Embed(..), Environment, IRC (IRC), STS (..),
                      Signal, State, TRC (TRC), initialRules, judgmentContext, trans,
                      transitionRules, wrapFailed, (?!))
 import           Control.State.Transition.Generator (HasTrace, SignalGenerator, coverFailures,
@@ -93,6 +93,7 @@ witnessed (Tx tx wits) utxo =
 
 instance Embed UTXO UTXOW where
   wrapFailed = UtxoFailure
+  wrapEvent = id
 
 -- | Constant list of addresses intended to be used in the generators.
 traceAddrs :: [Addr]

byron/ledger/executable-spec/src/Byron/Spec/Ledger/STS/UTXOWS.hs

@@ -20,9 +20,9 @@ import           GHC.Generics (Generic)
 import           Byron.Spec.Ledger.STS.UTXO (UTxOEnv, UTxOState)
 import           Byron.Spec.Ledger.STS.UTXOW (UTXOW)
 import           Byron.Spec.Ledger.UTxO (Tx)
-import           Control.State.Transition (Embed, Environment, IRC (IRC), PredicateFailure, STS,
+import           Control.State.Transition (Embed, Environment, IRC (IRC), PredicateFailure, STS(..),
                      Signal, State, TRC (TRC), initialRules, judgmentContext, trans,
-                     transitionRules, wrapFailed)
+                     transitionRules, wrapFailed, wrapEvent)
 import           Control.State.Transition.Generator (HasTrace, envGen, genTrace, sigGen)
 import           Control.State.Transition.Trace (TraceOrder (OldestFirst), traceSignals)
 
@@ -57,6 +57,7 @@ instance STS UTXOWS where
 
 instance Embed UTXOW UTXOWS where
   wrapFailed = UtxowFailure
+  wrapEvent = id
 
 instance HasTrace UTXOWS where
   envGen = envGen @UTXOW