Update UTxOState in UTXO rather than UTXOS

eras/alonzo/impl/CHANGELOG.md

@@ -2,6 +2,9 @@
 
 ## 1.15.0.0
 
+* Move `TotalDeposits` and `TxUTxODiff` data constructors from `AlonzoUtxosEvent` to `AlonzoUtxoEvent`
+* Add `UtxosEnv`
+* Change `STS` instance of `AlonzoUTXOS`: use `UtxosEnv` as `Environment` and `ShelleyGovState` as `State`
 * Add `Generic` instance for `ApplyTxError`
 * Change `ScriptsNotPaidUTxO` to use `NonEmptyMap TxIn (TxOut era)` instead of `UTxO era`
 * Change `atadrPlutus`, `atadPlutus` and `atadPlutus'` to `atadrPlutusScripts`, `atadPlutusScripts` and `atadPlutusScripts'` respectively

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

@@ -1,3 +1,4 @@
+{-# LANGUAGE BangPatterns #-}
 {-# LANGUAGE DataKinds #-}
 {-# LANGUAGE DeriveGeneric #-}
 {-# LANGUAGE DerivingStrategies #-}
@@ -43,9 +44,13 @@ import Cardano.Ledger.Allegra.Scripts (ValidityInterval (..))
 import Cardano.Ledger.Alonzo.Era (AlonzoEra, AlonzoUTXO)
 import Cardano.Ledger.Alonzo.PParams
 import Cardano.Ledger.Alonzo.Rules.Ppup ()
-import Cardano.Ledger.Alonzo.Rules.Utxos (AlonzoUTXOS, AlonzoUtxosPredFailure)
+import Cardano.Ledger.Alonzo.Rules.Utxos (
+  AlonzoUTXOS,
+  AlonzoUtxosPredFailure,
+  UtxosEnv (..),
+ )
 import Cardano.Ledger.Alonzo.Scripts (ExUnits (..), pointWiseExUnits)
-import Cardano.Ledger.Alonzo.Tx (AlonzoEraTx (..), totExUnits)
+import Cardano.Ledger.Alonzo.Tx (AlonzoEraTx (..), IsValid (..), totExUnits)
 import Cardano.Ledger.Alonzo.TxBody (
   AllegraEraTxBody (..),
   AlonzoEraTxBody (..),
@@ -84,8 +89,13 @@ import Cardano.Ledger.Rules.ValidationMode (
   runTest,
   runTestOnSignal,
  )
-import Cardano.Ledger.Shelley.LedgerState (UTxOState (utxosUtxo))
-import Cardano.Ledger.Shelley.Rules (ShelleyPpupPredFailure, ShelleyUtxoPredFailure, UtxoEnv (..))
+import Cardano.Ledger.Shelley.LedgerState (ShelleyGovState, UTxOState (..))
+import Cardano.Ledger.Shelley.Rules (
+  ShelleyPpupPredFailure,
+  ShelleyUtxoPredFailure,
+  UtxoEnv (..),
+  updateUTxOState,
+ )
 import qualified Cardano.Ledger.Shelley.Rules as Shelley
 import Cardano.Ledger.State
 import Cardano.Ledger.TxIn (TxIn)
@@ -99,12 +109,12 @@ import Control.Monad (unless)
 import Control.Monad.Trans.Reader (asks)
 import Control.State.Transition.Extended
 import qualified Data.ByteString.Lazy as BSL (length)
-import Data.Coerce (coerce)
 import Data.Either (isRight)
 import Data.Foldable as F (foldl', sequenceA_, toList)
 import Data.List.NonEmpty (NonEmpty)
 import Data.Map.NonEmpty (NonEmptyMap)
 import qualified Data.Map.Strict as Map
+import Data.MapExtras (extractKeys)
 import qualified Data.Set as Set
 import Data.Set.NonEmpty (NonEmptySet)
 import Data.Word (Word32)
@@ -222,15 +232,37 @@ instance
   ) =>
   NFData (AlonzoUtxoPredFailure era)
 
-newtype AlonzoUtxoEvent era
+data AlonzoUtxoEvent era
   = UtxosEvent (Event (EraRule "UTXOS" era))
+  | TotalDeposits (SafeHash EraIndependentTxBody) Coin
+  | -- | The UTxOs consumed and created by a signal tx
+    TxUTxODiff
+      -- | UTxO consumed
+      (UTxO era)
+      -- | UTxO created
+      (UTxO era)
   deriving (Generic)
 
-deriving instance Show (Event (EraRule "UTXOS" era)) => Show (AlonzoUtxoEvent era)
+deriving instance
+  ( Show (TxOut era)
+  , Show
+      (Event (EraRule "UTXOS" era))
+  ) =>
+  Show (AlonzoUtxoEvent era)
 
-deriving instance Eq (Event (EraRule "UTXOS" era)) => Eq (AlonzoUtxoEvent era)
+deriving instance
+  ( Era era
+  , Eq (TxOut era)
+  , Eq (Event (EraRule "UTXOS" era))
+  ) =>
+  Eq (AlonzoUtxoEvent era)
 
-instance NFData (Event (EraRule "UTXOS" era)) => NFData (AlonzoUtxoEvent era)
+instance
+  ( Era era
+  , NFData (TxOut era)
+  , NFData (Event (EraRule "UTXOS" era))
+  ) =>
+  NFData (AlonzoUtxoEvent era)
 
 -- | Returns true for VKey locked addresses, and false for any kind of
 -- script-locked address.
@@ -478,15 +510,17 @@ utxoTransition ::
   , InjectRuleFailure "UTXO" AlonzoUtxoPredFailure era
   , InjectRuleFailure "UTXO" AllegraUtxoPredFailure era
   , Embed (EraRule "UTXOS" era) (AlonzoUTXO era)
-  , Environment (EraRule "UTXOS" era) ~ UtxoEnv era
-  , State (EraRule "UTXOS" era) ~ UTxOState era
+  , Environment (EraRule "UTXOS" era) ~ UtxosEnv era
+  , State (EraRule "UTXOS" era) ~ ShelleyGovState era
   , Signal (EraRule "UTXOS" era) ~ Tx TopTx era
   , EraCertState era
+  , EraStake era
   , SafeToHash (TxWits era)
+  , GovState era ~ ShelleyGovState era
   ) =>
   TransitionRule (EraRule "UTXO" era)
 utxoTransition = do
-  TRC (UtxoEnv slot pp dpstate, utxos, tx) <- judgmentContext
+  TRC (UtxoEnv slot pp certState, utxos, tx) <- judgmentContext
   let utxo = utxosUtxo utxos
 
   {-   txb := txbody tx   -}
@@ -517,7 +551,7 @@ utxoTransition = do
   runTest $ Shelley.validateBadInputsUTxO utxo inputsAndCollateral
 
   {- consumed pp utxo txb = produced pp poolParams txb -}
-  runTest $ Shelley.validateValueNotConservedUTxO pp utxo dpstate txBody
+  runTest $ Shelley.validateValueNotConservedUTxO pp utxo certState txBody
 
   {- adaPolicy ∉ supp mint tx
      above check not needed because mint field of type MultiAsset cannot contain ada -}
@@ -551,7 +585,30 @@ utxoTransition = do
 
   {-   ‖collateral tx‖  ≤  maxCollInputs pp   -}
 
-  trans @(EraRule "UTXOS" era) =<< coerce <$> judgmentContext
+  updatedGovState <-
+    trans @(EraRule "UTXOS" era) $
+      TRC (UtxosEnv slot pp certState utxo, utxosGovState utxos, tx)
+
+  case tx ^. isValidTxL of
+    IsValid True ->
+      updateUTxOState
+        pp
+        utxos
+        txBody
+        certState
+        updatedGovState
+        (tellEvent . TotalDeposits (hashAnnotated txBody))
+        (\a b -> tellEvent (TxUTxODiff a b))
+    IsValid False ->
+      {- utxoKeep = txBody ^. collateralInputsTxBodyL ⋪ utxo -}
+      {- utxoDel  = txBody ^. collateralInputsTxBodyL ◁ utxo -}
+      let !(utxoKeep, utxoDel) = extractKeys (unUTxO utxo) (txBody ^. collateralInputsTxBodyL)
+       in pure $!
+            utxos
+              { utxosUtxo = UTxO utxoKeep
+              , utxosFees = (utxosFees utxos) <> sumAllCoin utxoDel
+              , utxosInstantStake = deleteInstantStake (UTxO utxoDel) (utxos ^. instantStakeL)
+              }
 
 --------------------------------------------------------------------------------
 -- AlonzoUTXO STS
@@ -562,16 +619,18 @@ instance
   ( EraUTxO era
   , AlonzoEraTx era
   , Embed (EraRule "UTXOS" era) (AlonzoUTXO era)
-  , Environment (EraRule "UTXOS" era) ~ UtxoEnv era
-  , State (EraRule "UTXOS" era) ~ UTxOState era
+  , Environment (EraRule "UTXOS" era) ~ UtxosEnv era
+  , State (EraRule "UTXOS" era) ~ ShelleyGovState era
   , Signal (EraRule "UTXOS" era) ~ Tx TopTx era
   , EraRule "UTXO" era ~ AlonzoUTXO era
   , InjectRuleFailure "UTXO" ShelleyUtxoPredFailure era
   , InjectRuleFailure "UTXO" AlonzoUtxoPredFailure era
   , InjectRuleFailure "UTXO" AllegraUtxoPredFailure era
   , AtMostEra "Babbage" era
   , EraCertState era
+  , EraStake era
   , SafeToHash (TxWits era)
+  , GovState era ~ ShelleyGovState era
   ) =>
   STS (AlonzoUTXO era)
   where

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

@@ -26,6 +26,7 @@ module Cardano.Ledger.Alonzo.Rules.Utxos (
   validEnd,
   invalidBegin,
   invalidEnd,
+  UtxosEnv (..),
   AlonzoUtxosEvent (..),
   when2Phase,
   FailureDescription (..),
@@ -57,23 +58,19 @@ import Cardano.Ledger.Binary (
  )
 import Cardano.Ledger.Binary.Coders
 import qualified Cardano.Ledger.Binary.Plain as Plain
-import Cardano.Ledger.Coin (Coin)
 import Cardano.Ledger.Plutus.Evaluate (
   PlutusWithContext,
   ScriptFailure (..),
   ScriptResult (..),
  )
 import Cardano.Ledger.Rules.ValidationMode (lblStatic)
-import Cardano.Ledger.Shelley.LedgerState (UTxOState (..))
 import qualified Cardano.Ledger.Shelley.LedgerState as Shelley
 import Cardano.Ledger.Shelley.PParams (Update)
 import Cardano.Ledger.Shelley.Rules (
   PpupEnv (..),
   PpupEvent,
   ShelleyPPUP,
   ShelleyPpupPredFailure,
-  UtxoEnv (..),
-  updateUTxOState,
  )
 import Cardano.Ledger.Shelley.TxCert (ShelleyTxCert)
 import Cardano.Slotting.EpochInfo.Extend (unsafeLinearExtendEpochInfo)
@@ -89,7 +86,6 @@ import Data.List (intercalate)
 import Data.List.NonEmpty (NonEmpty (..), nonEmpty)
 import qualified Data.List.NonEmpty as NE
 import qualified Data.List.NonEmpty as NonEmpty
-import Data.MapExtras (extractKeys)
 import Data.Text (Text)
 import qualified Debug.Trace as Debug
 import GHC.Generics (Generic)
@@ -124,39 +120,30 @@ instance
   STS (AlonzoUTXOS era)
   where
   type BaseM (AlonzoUTXOS era) = ShelleyBase
-  type Environment (AlonzoUTXOS era) = UtxoEnv era
-  type State (AlonzoUTXOS era) = UTxOState era
+  type Environment (AlonzoUTXOS era) = UtxosEnv era
+  type State (AlonzoUTXOS era) = ShelleyGovState era
   type Signal (AlonzoUTXOS era) = Tx TopTx era
   type PredicateFailure (AlonzoUTXOS era) = AlonzoUtxosPredFailure era
   type Event (AlonzoUTXOS era) = AlonzoUtxosEvent era
   transitionRules = [utxosTransition]
 
+data UtxosEnv era = UtxosEnv
+  { ueSlot :: SlotNo
+  , uePParams :: PParams era
+  , ueCertState :: CertState era
+  , ueUtxo :: UTxO era
+  }
+  deriving (Generic)
+
 data AlonzoUtxosEvent era
   = AlonzoPpupToUtxosEvent (EraRuleEvent "PPUP" era)
-  | TotalDeposits (SafeHash EraIndependentTxBody) Coin
   | SuccessfulPlutusScriptsEvent (NonEmpty PlutusWithContext)
   | FailedPlutusScriptsEvent (NonEmpty PlutusWithContext)
-  | -- | The UTxOs consumed and created by a signal tx
-    TxUTxODiff
-      -- | UTxO consumed
-      (UTxO era)
-      -- | UTxO created
-      (UTxO era)
   deriving (Generic)
 
-deriving instance
-  ( Era era
-  , Eq (TxOut era)
-  , Eq (EraRuleEvent "PPUP" era)
-  ) =>
-  Eq (AlonzoUtxosEvent era)
+deriving instance Eq (EraRuleEvent "PPUP" era) => Eq (AlonzoUtxosEvent era)
 
-instance
-  ( Era era
-  , NFData (TxOut era)
-  , NFData (EraRuleEvent "PPUP" era)
-  ) =>
-  NFData (AlonzoUtxosEvent era)
+instance NFData (EraRuleEvent "PPUP" era) => NFData (AlonzoUtxosEvent era)
 
 instance
   ( Era era
@@ -240,15 +227,13 @@ alonzoEvalScriptsTxValid ::
   , Environment (EraRule "PPUP" era) ~ PpupEnv era
   , Signal (EraRule "PPUP" era) ~ StrictMaybe (Update era)
   , Embed (EraRule "PPUP" era) (AlonzoUTXOS era)
-  , GovState era ~ ShelleyGovState era
   , State (EraRule "PPUP" era) ~ ShelleyGovState era
   , EraPlutusContext era
   , EraCertState era
-  , EraStake era
   ) =>
   TransitionRule (AlonzoUTXOS era)
 alonzoEvalScriptsTxValid = do
-  TRC (UtxoEnv slot pp certState, utxos@(UTxOState utxo _ _ pup _ _), tx) <-
+  TRC (UtxosEnv slot pp certState utxo, pup, tx) <-
     judgmentContext
   let txBody = tx ^. bodyTxL
       genDelegs = certState ^. certDStateL . Shelley.dsGenDelegsL
@@ -265,18 +250,8 @@ alonzoEvalScriptsTxValid = do
 
   () <- pure $! Debug.traceEvent validEnd ()
 
-  ppup' <-
-    trans @(EraRule "PPUP" era) $
-      TRC (PPUPEnv slot pp genDelegs, pup, txBody ^. updateTxBodyL)
-
-  updateUTxOState
-    pp
-    utxos
-    txBody
-    certState
-    ppup'
-    (tellEvent . TotalDeposits (hashAnnotated txBody))
-    (\a b -> tellEvent $ TxUTxODiff a b)
+  trans @(EraRule "PPUP" era) $
+    TRC (PPUPEnv slot pp genDelegs, pup, txBody ^. updateTxBodyL)
 
 alonzoEvalScriptsTxInvalid ::
   forall era.
@@ -285,12 +260,10 @@ alonzoEvalScriptsTxInvalid ::
   , ScriptsNeeded era ~ AlonzoScriptsNeeded era
   , STS (AlonzoUTXOS era)
   , EraPlutusContext era
-  , EraStake era
   ) =>
   TransitionRule (AlonzoUTXOS era)
 alonzoEvalScriptsTxInvalid = do
-  TRC (UtxoEnv slot pp _, utxos@(UTxOState utxo _ fees _ _ _), tx) <- judgmentContext
-  let txBody = tx ^. bodyTxL
+  TRC (UtxosEnv slot pp _ utxo, pup, tx) <- judgmentContext
 
   () <- pure $! Debug.traceEvent invalidBegin ()
 
@@ -304,15 +277,7 @@ alonzoEvalScriptsTxInvalid = do
 
   () <- pure $! Debug.traceEvent invalidEnd ()
 
-  {- utxoKeep = txBody ^. collateralInputsTxBodyL ⋪ utxo -}
-  {- utxoDel  = txBody ^. collateralInputsTxBodyL ◁ utxo -}
-  let !(utxoKeep, utxoDel) = extractKeys (unUTxO utxo) (txBody ^. collateralInputsTxBodyL)
-  pure $!
-    utxos
-      { utxosUtxo = UTxO utxoKeep
-      , utxosFees = fees <> sumAllCoin utxoDel
-      , utxosInstantStake = deleteInstantStake (UTxO utxoDel) (utxos ^. instantStakeL)
-      }
+  pure pup
 
 -- =======================================
 -- Names for the events we will tell

eras/alonzo/impl/testlib/Test/Cardano/Ledger/Alonzo/TreeDiff.hs

@@ -184,11 +184,10 @@ instance
 
 instance ToExpr (Event (EraRule "UTXO" era)) => ToExpr (AlonzoUtxowEvent era)
 
-instance ToExpr (Event (EraRule "UTXOS" era)) => ToExpr (AlonzoUtxoEvent era)
+instance (ToExpr (TxOut era), ToExpr (Event (EraRule "UTXOS" era))) => ToExpr (AlonzoUtxoEvent era)
 
 instance
   ( ToExpr (EraRuleEvent "PPUP" era)
-  , ToExpr (TxOut era)
   , ToExpr PlutusWithContext
   ) =>
   ToExpr (AlonzoUtxosEvent era)

eras/babbage/impl/CHANGELOG.md

@@ -2,6 +2,9 @@
 
 ## 1.13.0.0
 
+* Add `updateUTxOStateByTxValidity`
+* Change `babbageEvalScriptsTxInvalid` to return a `Rule` instead of `TransitionRule`
+* Change `STS` instance of `BabbageUTXOS`: use `UtxosEnv` as `Environment` and `ShelleyGovState` as `State`
 * Add `Generic` instance for `ApplyTxError`
 * Add `BabbageApplyTxError` constructor for `ApplyTxError era`
 * Renamed: