Add script evaluation events to LedgerEvent

cardano-api/src/Cardano/Api/LedgerEvent.hs

@@ -1,5 +1,6 @@
 {-# LANGUAGE DataKinds #-}
 {-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE GADTs #-}
 {-# LANGUAGE PartialTypeSignatures #-}
 {-# LANGUAGE PatternSynonyms #-}
@@ -21,6 +22,15 @@ import           Cardano.Api.Block (EpochNo)
 import           Cardano.Api.Certificate (Certificate)
 import           Cardano.Api.Keys.Shelley (Hash (StakePoolKeyHash), StakePoolKey)
 import           Cardano.Api.Value (Lovelace, fromShelleyDeltaLovelace, fromShelleyLovelace)
+import           Cardano.Ledger.Alonzo (AlonzoEra)
+import           Cardano.Ledger.Alonzo.Rules
+  ( AlonzoBbodyEvent (..),
+    AlonzoUtxoEvent (..),
+    AlonzoUtxosEvent (..),
+    AlonzoUtxowEvent (..),
+  )
+import           Cardano.Ledger.Alonzo.TxInfo (PlutusDebug)
+import           Cardano.Ledger.Babbage (BabbageEra)
 import qualified Cardano.Ledger.Coin as Ledger
 import qualified Cardano.Ledger.Core as Ledger.Core
 import qualified Cardano.Ledger.Credential as Ledger
@@ -29,13 +39,18 @@ import           Cardano.Ledger.Era (Crypto)
 import qualified Cardano.Ledger.Keys as Ledger
 import           Cardano.Ledger.Shelley.API (InstantaneousRewards (InstantaneousRewards))
 import           Cardano.Ledger.Shelley.Rewards
+import           Cardano.Ledger.Shelley.Rules.Bbody
 import           Cardano.Ledger.Shelley.Rules.Epoch (ShelleyEpochEvent (..))
+import qualified Cardano.Ledger.Shelley.Rules.Ledger as Shelley (ShelleyLedgerEvent (UtxowEvent))
+import qualified Cardano.Ledger.Shelley.Rules.Ledgers as Shelley (ShelleyLedgersEvent (LedgerEvent))
 import           Cardano.Ledger.Shelley.Rules.Mir (ShelleyMirEvent (..))
 import           Cardano.Ledger.Shelley.Rules.NewEpoch (ShelleyNewEpochEvent (..))
 import           Cardano.Ledger.Shelley.Rules.PoolReap (ShelleyPoolreapEvent (..))
 import           Cardano.Ledger.Shelley.Rules.Rupd (RupdEvent (..))
 import           Cardano.Ledger.Shelley.Rules.Tick (ShelleyTickEvent (NewEpochEvent))
+import           Cardano.Ledger.Shelley.Rules.Utxow (ShelleyUtxowEvent (UtxoEvent))
 import           Control.State.Transition (Event)
+import           Data.List.NonEmpty (NonEmpty)
 import           Data.Map.Strict (Map)
 import qualified Data.Map.Strict as Map
 import           Data.Set (Set)
@@ -46,7 +61,7 @@ import           Ouroboros.Consensus.HardFork.Combinator.AcrossEras (getOneEraLe
 import           Ouroboros.Consensus.Ledger.Abstract (LedgerState)
 import           Ouroboros.Consensus.Ledger.Basics (AuxLedgerEvent)
 import           Ouroboros.Consensus.Shelley.Ledger (ShelleyBlock,
-                   ShelleyLedgerEvent (ShelleyLedgerEventTICK))
+                   ShelleyLedgerEvent (..))
 import           Ouroboros.Consensus.TypeFamilyWrappers
 
 data LedgerEvent
@@ -62,6 +77,10 @@ data LedgerEvent
     MIRDistribution MIRDistributionDetails
   | -- | Pools have been reaped and deposits refunded.
     PoolReap PoolReapDetails
+    -- | A number of succeeded Plutus script evaluations.
+  | SuccessfulPlutusScript (NonEmpty PlutusDebug)
+    -- | A number of failed Plutus script evaluations.
+  | FailedPlutusScript (NonEmpty PlutusDebug)
 
 class ConvertLedgerEvent blk where
   toLedgerEvent :: WrapLedgerEvent blk -> Maybe LedgerEvent
@@ -79,16 +98,22 @@ instance
     Event (Ledger.Core.EraRule "RUPD" ledgerera) ~ RupdEvent (Crypto ledgerera)
   ) =>
   ConvertLedgerEvent (ShelleyBlock protocol ledgerera)
+  where
+  toLedgerEvent = toLedgerEventShelley
+
+instance {-# OVERLAPPING #-} ConvertLedgerEvent (ShelleyBlock protocol (AlonzoEra StandardCrypto))
+  where
+  toLedgerEvent evt = case unwrapLedgerEvent evt of
+    LEPlutusSuccess ds -> Just $ SuccessfulPlutusScript ds
+    LEPlutusFailure ds -> Just $ FailedPlutusScript ds
+    _ -> toLedgerEventShelley evt
+
+instance {-# OVERLAPPING #-} ConvertLedgerEvent (ShelleyBlock protocol (BabbageEra StandardCrypto))
   where
   toLedgerEvent evt = case unwrapLedgerEvent evt of
-    LEDeltaRewardEvent e m -> Just $ IncrementalRewardsDistribution e m
-    LERewardEvent e m -> Just $ RewardsDistribution e m
-    LEMirTransfer rp rt rtt ttr ->
-      Just $
-        MIRDistribution $
-          MIRDistributionDetails rp rt rtt ttr
-    LERetiredPools r u e -> Just $ PoolReap $ PoolReapDetails e r u
-    _ -> Nothing
+    LEPlutusSuccess ds -> Just $ SuccessfulPlutusScript ds
+    LEPlutusFailure ds -> Just $ FailedPlutusScript ds
+    _ -> toLedgerEventShelley evt
 
 instance All ConvertLedgerEvent xs => ConvertLedgerEvent (HardForkBlock xs) where
   toLedgerEvent =
@@ -97,6 +122,27 @@ instance All ConvertLedgerEvent xs => ConvertLedgerEvent (HardForkBlock xs) wher
       . getOneEraLedgerEvent
       . unwrapLedgerEvent
 
+toLedgerEventShelley ::
+  ( Crypto ledgerera ~ StandardCrypto,
+    Event (Ledger.Core.EraRule "TICK" ledgerera) ~ ShelleyTickEvent ledgerera,
+    Event (Ledger.Core.EraRule "NEWEPOCH" ledgerera) ~ ShelleyNewEpochEvent ledgerera,
+    Event (Ledger.Core.EraRule "EPOCH" ledgerera) ~ ShelleyEpochEvent ledgerera,
+    Event (Ledger.Core.EraRule "POOLREAP" ledgerera) ~ ShelleyPoolreapEvent ledgerera,
+    Event (Ledger.Core.EraRule "MIR" ledgerera) ~ ShelleyMirEvent ledgerera,
+    Event (Ledger.Core.EraRule "RUPD" ledgerera) ~ RupdEvent (Crypto ledgerera)
+  ) =>
+  WrapLedgerEvent (ShelleyBlock protocol ledgerera) ->
+  Maybe LedgerEvent
+toLedgerEventShelley evt = case unwrapLedgerEvent evt of
+  LEDeltaRewardEvent e m -> Just $ IncrementalRewardsDistribution e m
+  LERewardEvent e m -> Just $ RewardsDistribution e m
+  LEMirTransfer rp rt rtt ttr ->
+    Just $
+      MIRDistribution $
+        MIRDistributionDetails rp rt rtt ttr
+  LERetiredPools r u e -> Just $ PoolReap $ PoolReapDetails e r u
+  _ -> Nothing
+
 --------------------------------------------------------------------------------
 -- Event details
 --------------------------------------------------------------------------------
@@ -204,6 +250,66 @@ pattern LERetiredPools r u e <-
           )
       )
 
+pattern LEPlutusSuccess ::
+  ( Crypto ledgerera ~ StandardCrypto,
+    Event (Ledger.Core.EraRule "BBODY" ledgerera) ~ AlonzoBbodyEvent ledgerera,
+    Event (Ledger.Core.EraRule "LEDGERS" ledgerera) ~ Shelley.ShelleyLedgersEvent ledgerera,
+    Event (Ledger.Core.EraRule "LEDGER" ledgerera) ~ Shelley.ShelleyLedgerEvent ledgerera,
+    Event (Ledger.Core.EraRule "UTXOW" ledgerera) ~ AlonzoUtxowEvent ledgerera,
+    Event (Ledger.Core.EraRule "UTXO" ledgerera) ~ AlonzoUtxoEvent ledgerera,
+    Event (Ledger.Core.EraRule "UTXOS" ledgerera) ~ AlonzoUtxosEvent ledgerera
+  ) =>
+  NonEmpty PlutusDebug ->
+  AuxLedgerEvent (LedgerState (ShelleyBlock protocol ledgerera))
+pattern LEPlutusSuccess ds <-
+  ShelleyLedgerEventBBODY
+    ( ShelleyInAlonzoEvent
+        ( LedgersEvent
+            ( Shelley.LedgerEvent
+                ( Shelley.UtxowEvent
+                    ( WrappedShelleyEraEvent
+                        ( UtxoEvent
+                            ( UtxosEvent
+                                ( SuccessfulPlutusScriptsEvent ds
+                                  )
+                              )
+                          )
+                      )
+                  )
+              )
+          )
+      )
+
+pattern LEPlutusFailure ::
+  ( Crypto ledgerera ~ StandardCrypto,
+    Event (Ledger.Core.EraRule "BBODY" ledgerera) ~ AlonzoBbodyEvent ledgerera,
+    Event (Ledger.Core.EraRule "LEDGERS" ledgerera) ~ Shelley.ShelleyLedgersEvent ledgerera,
+    Event (Ledger.Core.EraRule "LEDGER" ledgerera) ~ Shelley.ShelleyLedgerEvent ledgerera,
+    Event (Ledger.Core.EraRule "UTXOW" ledgerera) ~ AlonzoUtxowEvent ledgerera,
+    Event (Ledger.Core.EraRule "UTXO" ledgerera) ~ AlonzoUtxoEvent ledgerera,
+    Event (Ledger.Core.EraRule "UTXOS" ledgerera) ~ AlonzoUtxosEvent ledgerera
+  ) =>
+  NonEmpty PlutusDebug ->
+  AuxLedgerEvent (LedgerState (ShelleyBlock protocol ledgerera))
+pattern LEPlutusFailure ds <-
+  ShelleyLedgerEventBBODY
+    ( ShelleyInAlonzoEvent
+        ( LedgersEvent
+            ( Shelley.LedgerEvent
+                ( Shelley.UtxowEvent
+                    ( WrappedShelleyEraEvent
+                        ( UtxoEvent
+                            ( UtxosEvent
+                                ( FailedPlutusScriptsEvent ds
+                                  )
+                              )
+                          )
+                      )
+                  )
+              )
+          )
+      )
+
 convertRetiredPoolsMap ::
      Map (Ledger.StakeCredential StandardCrypto) (Map (Ledger.KeyHash Ledger.StakePool StandardCrypto) Ledger.Coin)
   -> Map StakeCredential (Map (Hash StakePoolKey) Lovelace)