{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -Wno-orphans #-}

module Cardano.Ledger.Alonzo.Rules.Utxos (
  AlonzoUTXOS,
  AlonzoUtxosPredFailure (..),
  lbl2Phase,
  TagMismatchDescription (..),
  validBegin,
  validEnd,
  invalidBegin,
  invalidEnd,
  AlonzoUtxosEvent (..),
  when2Phase,
  FailureDescription (..),
  scriptFailureToFailureDescription,
)
where

import Cardano.Ledger.Alonzo.Core
import Cardano.Ledger.Alonzo.Era (AlonzoEra, AlonzoUTXOS)
import Cardano.Ledger.Alonzo.Plutus.Context (ContextError, EraPlutusContext)
import Cardano.Ledger.Alonzo.Plutus.Evaluate (
  CollectError (..),
  collectPlutusScriptsWithContext,
  evalPlutusScripts,
 )
import Cardano.Ledger.Alonzo.Rules.Ppup ()
import Cardano.Ledger.Alonzo.Tx (IsValid (..))
import Cardano.Ledger.Alonzo.UTxO (AlonzoEraUTxO (..), AlonzoScriptsNeeded)
import Cardano.Ledger.BaseTypes (
  Globals,
  ShelleyBase,
  StrictMaybe,
  epochInfo,
  kindObject,
  systemStart,
 )
import Cardano.Ledger.Binary (
  DecCBOR (..),
  EncCBOR (..),
 )
import Cardano.Ledger.Binary.Coders
import qualified Cardano.Ledger.Binary.Plain as Plain
import Cardano.Ledger.CertState (certDState, dsGenDelegs)
import Cardano.Ledger.Coin (Coin)
import Cardano.Ledger.Crypto (Crypto)
import Cardano.Ledger.Plutus.Evaluate (
  PlutusWithContext,
  ScriptFailure (..),
  ScriptResult (..),
 )
import Cardano.Ledger.Rules.ValidationMode (lblStatic)
import Cardano.Ledger.SafeHash (SafeHash, hashAnnotated)
import Cardano.Ledger.Shelley.LedgerState (UTxOState (..), updateStakeDistribution)
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.Ledger.UTxO (
  EraUTxO (..),
  UTxO (..),
  coinBalance,
 )
import Cardano.Slotting.EpochInfo.Extend (unsafeLinearExtendEpochInfo)
import Cardano.Slotting.Slot (SlotNo)
import Control.DeepSeq (NFData)
import Control.Monad.Trans.Reader (ReaderT, asks)
import Control.State.Transition.Extended
import Data.Aeson (ToJSON (..), (.=))
import qualified Data.Aeson as Aeson
import Data.ByteString as BS (ByteString)
import qualified Data.ByteString.Base64 as B64
import Data.List (intercalate)
import Data.List.NonEmpty (NonEmpty (..), nonEmpty)
import qualified Data.List.NonEmpty as NE
import Data.MapExtras (extractKeys)
import Data.Text (Text)
import qualified Debug.Trace as Debug
import GHC.Generics (Generic)
import Lens.Micro
import NoThunks.Class (NoThunks)

--------------------------------------------------------------------------------
-- The AlonzoUTXOS transition system
--------------------------------------------------------------------------------

instance
  forall era.
  ( AlonzoEraTx era
  , AlonzoEraPParams era
  , ShelleyEraTxBody era
  , AlonzoEraUTxO era
  , ScriptsNeeded era ~ AlonzoScriptsNeeded era
  , AlonzoEraScript era
  , TxCert era ~ ShelleyTxCert era
  , EraGov era
  , GovState era ~ ShelleyGovState era
  , State (EraRule "PPUP" era) ~ ShelleyGovState era
  , Embed (EraRule "PPUP" era) (AlonzoUTXOS era)
  , Environment (EraRule "PPUP" era) ~ PpupEnv era
  , Signal (EraRule "PPUP" era) ~ StrictMaybe (Update era)
  , EncCBOR (PredicateFailure (EraRule "PPUP" era)) -- Serializing the PredicateFailure,
  , Eq (EraRuleFailure "PPUP" era)
  , Show (EraRuleFailure "PPUP" era)
  , EraPlutusContext era
  ) =>
  STS (AlonzoUTXOS era)
  where
  type BaseM (AlonzoUTXOS era) = ShelleyBase
  type Environment (AlonzoUTXOS era) = UtxoEnv era
  type State (AlonzoUTXOS era) = UTxOState era
  type Signal (AlonzoUTXOS era) = Tx era
  type PredicateFailure (AlonzoUTXOS era) = AlonzoUtxosPredFailure era
  type Event (AlonzoUTXOS era) = AlonzoUtxosEvent era
  transitionRules :: [TransitionRule (AlonzoUTXOS era)]
transitionRules = [forall era.
(AlonzoEraTx era, ShelleyEraTxBody era, AlonzoEraUTxO era,
 ScriptsNeeded era ~ AlonzoScriptsNeeded era,
 TxCert era ~ ShelleyTxCert era, EraGov era,
 GovState era ~ ShelleyGovState era,
 State (EraRule "PPUP" era) ~ ShelleyGovState era,
 Environment (EraRule "PPUP" era) ~ PpupEnv era,
 Signal (EraRule "PPUP" era) ~ StrictMaybe (Update era),
 Embed (EraRule "PPUP" era) (AlonzoUTXOS era),
 EncCBOR (PredicateFailure (EraRule "PPUP" era)),
 Eq (EraRuleFailure "PPUP" era), Show (EraRuleFailure "PPUP" era),
 EraPlutusContext era) =>
TransitionRule (AlonzoUTXOS era)
utxosTransition]

data AlonzoUtxosEvent era
  = AlonzoPpupToUtxosEvent (EraRuleEvent "PPUP" era)
  | TotalDeposits (SafeHash (EraCrypto era) EraIndependentTxBody) Coin
  | SuccessfulPlutusScriptsEvent (NonEmpty (PlutusWithContext (EraCrypto era)))
  | FailedPlutusScriptsEvent (NonEmpty (PlutusWithContext (EraCrypto era)))
  | -- | The UTxOs consumed and created by a signal tx
    TxUTxODiff
      -- | UTxO consumed
      (UTxO era)
      -- | UTxO created
      (UTxO era)
  deriving (forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall era x. Rep (AlonzoUtxosEvent era) x -> AlonzoUtxosEvent era
forall era x. AlonzoUtxosEvent era -> Rep (AlonzoUtxosEvent era) x
$cto :: forall era x. Rep (AlonzoUtxosEvent era) x -> AlonzoUtxosEvent era
$cfrom :: forall era x. AlonzoUtxosEvent era -> Rep (AlonzoUtxosEvent era) x
Generic)

deriving instance
  ( Era era
  , Eq (TxOut era)
  , Eq (EraRuleEvent "PPUP" era)
  ) =>
  Eq (AlonzoUtxosEvent era)

instance
  ( Era era
  , NFData (TxOut era)
  , NFData (EraRuleEvent "PPUP" era)
  ) =>
  NFData (AlonzoUtxosEvent era)

instance
  ( Era era
  , STS (ShelleyPPUP era)
  , EraRuleFailure "PPUP" era ~ ShelleyPpupPredFailure era
  , Event (EraRule "PPUP" era) ~ Event (ShelleyPPUP era)
  , EraRuleEvent "PPUP" era ~ PpupEvent era
  ) =>
  Embed (ShelleyPPUP era) (AlonzoUTXOS era)
  where
  wrapFailed :: PredicateFailure (ShelleyPPUP era)
-> PredicateFailure (AlonzoUTXOS era)
wrapFailed = forall era. EraRuleFailure "PPUP" era -> AlonzoUtxosPredFailure era
UpdateFailure
  wrapEvent :: Event (ShelleyPPUP era) -> Event (AlonzoUTXOS era)
wrapEvent = forall era. EraRuleEvent "PPUP" era -> AlonzoUtxosEvent era
AlonzoPpupToUtxosEvent

utxosTransition ::
  forall era.
  ( AlonzoEraTx era
  , ShelleyEraTxBody era
  , AlonzoEraUTxO era
  , ScriptsNeeded era ~ AlonzoScriptsNeeded era
  , TxCert era ~ ShelleyTxCert era
  , EraGov era
  , GovState era ~ ShelleyGovState era
  , State (EraRule "PPUP" era) ~ ShelleyGovState era
  , Environment (EraRule "PPUP" era) ~ PpupEnv era
  , Signal (EraRule "PPUP" era) ~ StrictMaybe (Update era)
  , Embed (EraRule "PPUP" era) (AlonzoUTXOS era)
  , EncCBOR (PredicateFailure (EraRule "PPUP" era)) -- Serializing the PredicateFailure
  , Eq (EraRuleFailure "PPUP" era)
  , Show (EraRuleFailure "PPUP" era)
  , EraPlutusContext era
  ) =>
  TransitionRule (AlonzoUTXOS era)
utxosTransition :: forall era.
(AlonzoEraTx era, ShelleyEraTxBody era, AlonzoEraUTxO era,
 ScriptsNeeded era ~ AlonzoScriptsNeeded era,
 TxCert era ~ ShelleyTxCert era, EraGov era,
 GovState era ~ ShelleyGovState era,
 State (EraRule "PPUP" era) ~ ShelleyGovState era,
 Environment (EraRule "PPUP" era) ~ PpupEnv era,
 Signal (EraRule "PPUP" era) ~ StrictMaybe (Update era),
 Embed (EraRule "PPUP" era) (AlonzoUTXOS era),
 EncCBOR (PredicateFailure (EraRule "PPUP" era)),
 Eq (EraRuleFailure "PPUP" era), Show (EraRuleFailure "PPUP" era),
 EraPlutusContext era) =>
TransitionRule (AlonzoUTXOS era)
utxosTransition =
  forall sts (rtype :: RuleType).
Rule sts rtype (RuleContext rtype sts)
judgmentContext forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \(TRC (Environment (AlonzoUTXOS era)
_, State (AlonzoUTXOS era)
_, Signal (AlonzoUTXOS era)
tx)) -> do
    case Signal (AlonzoUTXOS era)
tx forall s a. s -> Getting a s a -> a
^. forall era. AlonzoEraTx era => Lens' (Tx era) IsValid
isValidTxL of
      IsValid Bool
True -> forall era.
(AlonzoEraTx era, AlonzoEraUTxO era, ShelleyEraTxBody era,
 ScriptsNeeded era ~ AlonzoScriptsNeeded era, STS (AlonzoUTXOS era),
 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) =>
TransitionRule (AlonzoUTXOS era)
alonzoEvalScriptsTxValid
      IsValid Bool
False -> forall era.
(AlonzoEraTx era, AlonzoEraUTxO era,
 ScriptsNeeded era ~ AlonzoScriptsNeeded era, STS (AlonzoUTXOS era),
 EraPlutusContext era) =>
TransitionRule (AlonzoUTXOS era)
alonzoEvalScriptsTxInvalid

-- ===================================================================

scriptsTransition ::
  ( STS sts
  , Monad m
  , AlonzoEraTxBody era
  , AlonzoEraTxWits era
  , AlonzoEraUTxO era
  , ScriptsNeeded era ~ AlonzoScriptsNeeded era
  , BaseM sts ~ ReaderT Globals m
  , PredicateFailure sts ~ AlonzoUtxosPredFailure era
  , EraPlutusContext era
  ) =>
  SlotNo ->
  PParams era ->
  Tx era ->
  UTxO era ->
  (ScriptResult (EraCrypto era) -> Rule sts ctx ()) ->
  Rule sts ctx ()
scriptsTransition :: forall sts (m :: * -> *) era (ctx :: RuleType).
(STS sts, Monad m, AlonzoEraTxBody era, AlonzoEraTxWits era,
 AlonzoEraUTxO era, ScriptsNeeded era ~ AlonzoScriptsNeeded era,
 BaseM sts ~ ReaderT Globals m,
 PredicateFailure sts ~ AlonzoUtxosPredFailure era,
 EraPlutusContext era) =>
SlotNo
-> PParams era
-> Tx era
-> UTxO era
-> (ScriptResult (EraCrypto era) -> Rule sts ctx ())
-> Rule sts ctx ()
scriptsTransition SlotNo
slot PParams era
pp Tx era
tx UTxO era
utxo ScriptResult (EraCrypto era) -> Rule sts ctx ()
action = do
  SystemStart
sysSt <- forall sts a (ctx :: RuleType).
STS sts =>
BaseM sts a -> Rule sts ctx a
liftSTS forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) r a. Monad m => (r -> a) -> ReaderT r m a
asks Globals -> SystemStart
systemStart
  EpochInfo (Either Text)
ei <- forall sts a (ctx :: RuleType).
STS sts =>
BaseM sts a -> Rule sts ctx a
liftSTS forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) r a. Monad m => (r -> a) -> ReaderT r m a
asks Globals -> EpochInfo (Either Text)
epochInfo
  case forall era.
(AlonzoEraTxBody era, AlonzoEraTxWits era, AlonzoEraUTxO era,
 ScriptsNeeded era ~ AlonzoScriptsNeeded era,
 EraPlutusContext era) =>
EpochInfo (Either Text)
-> SystemStart
-> PParams era
-> Tx era
-> UTxO era
-> Either [CollectError era] [PlutusWithContext (EraCrypto era)]
collectPlutusScriptsWithContext (forall (m :: * -> *).
Monad m =>
SlotNo -> EpochInfo m -> EpochInfo m
unsafeLinearExtendEpochInfo SlotNo
slot EpochInfo (Either Text)
ei) SystemStart
sysSt PParams era
pp Tx era
tx UTxO era
utxo of
    Right [PlutusWithContext (EraCrypto era)]
sLst ->
      forall sts (ctx :: RuleType). Rule sts ctx () -> Rule sts ctx ()
when2Phase forall a b. (a -> b) -> a -> b
$ ScriptResult (EraCrypto era) -> Rule sts ctx ()
action forall a b. (a -> b) -> a -> b
$ forall c. [PlutusWithContext c] -> ScriptResult c
evalPlutusScripts [PlutusWithContext (EraCrypto era)]
sLst
    Left [CollectError era]
info
      | [CollectError era]
alonzoFailures <- forall a. (a -> Bool) -> [a] -> [a]
filter forall {era}. CollectError era -> Bool
isNotBadTranslation [CollectError era]
info
      , Bool -> Bool
not (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [CollectError era]
alonzoFailures) ->
          forall sts (ctx :: RuleType).
PredicateFailure sts -> Rule sts ctx ()
failBecause (forall era. [CollectError era] -> AlonzoUtxosPredFailure era
CollectErrors [CollectError era]
alonzoFailures)
      | Bool
otherwise -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
  where
    -- BadTranslation was introduced in Babbage, thus we need to filter those failures out.
    isNotBadTranslation :: CollectError era -> Bool
isNotBadTranslation = \case
      BadTranslation {} -> Bool
False
      CollectError era
_ -> Bool
True

alonzoEvalScriptsTxValid ::
  forall era.
  ( AlonzoEraTx era
  , AlonzoEraUTxO era
  , ShelleyEraTxBody era
  , ScriptsNeeded era ~ AlonzoScriptsNeeded era
  , STS (AlonzoUTXOS era)
  , 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
  ) =>
  TransitionRule (AlonzoUTXOS era)
alonzoEvalScriptsTxValid :: forall era.
(AlonzoEraTx era, AlonzoEraUTxO era, ShelleyEraTxBody era,
 ScriptsNeeded era ~ AlonzoScriptsNeeded era, STS (AlonzoUTXOS era),
 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) =>
TransitionRule (AlonzoUTXOS era)
alonzoEvalScriptsTxValid = do
  TRC (UtxoEnv SlotNo
slot PParams era
pp CertState era
certState, utxos :: State (AlonzoUTXOS era)
utxos@(UTxOState UTxO era
utxo Coin
_ Coin
_ GovState era
pup IncrementalStake (EraCrypto era)
_ Coin
_), Signal (AlonzoUTXOS era)
tx) <-
    forall sts (rtype :: RuleType).
Rule sts rtype (RuleContext rtype sts)
judgmentContext
  let txBody :: TxBody era
txBody = Signal (AlonzoUTXOS era)
tx forall s a. s -> Getting a s a -> a
^. forall era. EraTx era => Lens' (Tx era) (TxBody era)
bodyTxL
      genDelegs :: GenDelegs (EraCrypto era)
genDelegs = forall era. DState era -> GenDelegs (EraCrypto era)
dsGenDelegs (forall era. CertState era -> DState era
certDState CertState era
certState)

  () <- forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$! forall a. [Char] -> a -> a
Debug.traceEvent [Char]
validBegin ()

  forall sts (m :: * -> *) era (ctx :: RuleType).
(STS sts, Monad m, AlonzoEraTxBody era, AlonzoEraTxWits era,
 AlonzoEraUTxO era, ScriptsNeeded era ~ AlonzoScriptsNeeded era,
 BaseM sts ~ ReaderT Globals m,
 PredicateFailure sts ~ AlonzoUtxosPredFailure era,
 EraPlutusContext era) =>
SlotNo
-> PParams era
-> Tx era
-> UTxO era
-> (ScriptResult (EraCrypto era) -> Rule sts ctx ())
-> Rule sts ctx ()
scriptsTransition SlotNo
slot PParams era
pp Signal (AlonzoUTXOS era)
tx UTxO era
utxo forall a b. (a -> b) -> a -> b
$ \case
    Fails [PlutusWithContext (EraCrypto era)]
_ps NonEmpty (ScriptFailure (EraCrypto era))
fs ->
      forall sts (ctx :: RuleType).
PredicateFailure sts -> Rule sts ctx ()
failBecause forall a b. (a -> b) -> a -> b
$
        forall era.
IsValid -> TagMismatchDescription -> AlonzoUtxosPredFailure era
ValidationTagMismatch
          (Signal (AlonzoUTXOS era)
tx forall s a. s -> Getting a s a -> a
^. forall era. AlonzoEraTx era => Lens' (Tx era) IsValid
isValidTxL)
          (NonEmpty FailureDescription -> TagMismatchDescription
FailedUnexpectedly (forall c. Crypto c => ScriptFailure c -> FailureDescription
scriptFailureToFailureDescription forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NonEmpty (ScriptFailure (EraCrypto era))
fs))
    Passes [PlutusWithContext (EraCrypto era)]
ps -> forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (forall sts (ctx :: RuleType). Event sts -> Rule sts ctx ()
tellEvent forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
NonEmpty (PlutusWithContext (EraCrypto era))
-> AlonzoUtxosEvent era
SuccessfulPlutusScriptsEvent) (forall a. [a] -> Maybe (NonEmpty a)
nonEmpty [PlutusWithContext (EraCrypto era)]
ps)

  () <- forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$! forall a. [Char] -> a -> a
Debug.traceEvent [Char]
validEnd ()

  ShelleyGovState era
ppup' <-
    forall sub super (rtype :: RuleType).
Embed sub super =>
RuleContext rtype sub -> Rule super rtype (State sub)
trans @(EraRule "PPUP" era) forall a b. (a -> b) -> a -> b
$
      forall sts. (Environment sts, State sts, Signal sts) -> TRC sts
TRC (forall era.
SlotNo -> PParams era -> GenDelegs (EraCrypto era) -> PpupEnv era
PPUPEnv SlotNo
slot PParams era
pp GenDelegs (EraCrypto era)
genDelegs, GovState era
pup, TxBody era
txBody forall s a. s -> Getting a s a -> a
^. forall era.
ShelleyEraTxBody era =>
Lens' (TxBody era) (StrictMaybe (Update era))
updateTxBodyL)

  forall era (m :: * -> *).
(EraTxBody era, Monad m) =>
PParams era
-> UTxOState era
-> TxBody era
-> CertState era
-> GovState era
-> (Coin -> m ())
-> (UTxO era -> UTxO era -> m ())
-> m (UTxOState era)
updateUTxOState
    PParams era
pp
    State (AlonzoUTXOS era)
utxos
    TxBody era
txBody
    CertState era
certState
    ShelleyGovState era
ppup'
    (forall sts (ctx :: RuleType). Event sts -> Rule sts ctx ()
tellEvent forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
SafeHash (EraCrypto era) EraIndependentTxBody
-> Coin -> AlonzoUtxosEvent era
TotalDeposits (forall x index c.
(HashAnnotated x index c, HashAlgorithm (HASH c)) =>
x -> SafeHash c index
hashAnnotated TxBody era
txBody))
    (\UTxO era
a UTxO era
b -> forall sts (ctx :: RuleType). Event sts -> Rule sts ctx ()
tellEvent forall a b. (a -> b) -> a -> b
$ forall era. UTxO era -> UTxO era -> AlonzoUtxosEvent era
TxUTxODiff UTxO era
a UTxO era
b)

alonzoEvalScriptsTxInvalid ::
  forall era.
  ( AlonzoEraTx era
  , AlonzoEraUTxO era
  , ScriptsNeeded era ~ AlonzoScriptsNeeded era
  , STS (AlonzoUTXOS era)
  , EraPlutusContext era
  ) =>
  TransitionRule (AlonzoUTXOS era)
alonzoEvalScriptsTxInvalid :: forall era.
(AlonzoEraTx era, AlonzoEraUTxO era,
 ScriptsNeeded era ~ AlonzoScriptsNeeded era, STS (AlonzoUTXOS era),
 EraPlutusContext era) =>
TransitionRule (AlonzoUTXOS era)
alonzoEvalScriptsTxInvalid = do
  TRC (UtxoEnv SlotNo
slot PParams era
pp CertState era
_, us :: State (AlonzoUTXOS era)
us@(UTxOState UTxO era
utxo Coin
_ Coin
fees GovState era
_ IncrementalStake (EraCrypto era)
_ Coin
_), Signal (AlonzoUTXOS era)
tx) <- forall sts (rtype :: RuleType).
Rule sts rtype (RuleContext rtype sts)
judgmentContext
  let txBody :: TxBody era
txBody = Signal (AlonzoUTXOS era)
tx forall s a. s -> Getting a s a -> a
^. forall era. EraTx era => Lens' (Tx era) (TxBody era)
bodyTxL

  () <- forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$! forall a. [Char] -> a -> a
Debug.traceEvent [Char]
invalidBegin ()

  forall sts (m :: * -> *) era (ctx :: RuleType).
(STS sts, Monad m, AlonzoEraTxBody era, AlonzoEraTxWits era,
 AlonzoEraUTxO era, ScriptsNeeded era ~ AlonzoScriptsNeeded era,
 BaseM sts ~ ReaderT Globals m,
 PredicateFailure sts ~ AlonzoUtxosPredFailure era,
 EraPlutusContext era) =>
SlotNo
-> PParams era
-> Tx era
-> UTxO era
-> (ScriptResult (EraCrypto era) -> Rule sts ctx ())
-> Rule sts ctx ()
scriptsTransition SlotNo
slot PParams era
pp Signal (AlonzoUTXOS era)
tx UTxO era
utxo forall a b. (a -> b) -> a -> b
$ \case
    Passes [PlutusWithContext (EraCrypto era)]
_ps ->
      forall sts (ctx :: RuleType).
PredicateFailure sts -> Rule sts ctx ()
failBecause forall a b. (a -> b) -> a -> b
$
        forall era.
IsValid -> TagMismatchDescription -> AlonzoUtxosPredFailure era
ValidationTagMismatch (Signal (AlonzoUTXOS era)
tx forall s a. s -> Getting a s a -> a
^. forall era. AlonzoEraTx era => Lens' (Tx era) IsValid
isValidTxL) TagMismatchDescription
PassedUnexpectedly
    Fails [PlutusWithContext (EraCrypto era)]
ps NonEmpty (ScriptFailure (EraCrypto era))
fs -> do
      forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (forall sts (ctx :: RuleType). Event sts -> Rule sts ctx ()
tellEvent forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
NonEmpty (PlutusWithContext (EraCrypto era))
-> AlonzoUtxosEvent era
SuccessfulPlutusScriptsEvent) (forall a. [a] -> Maybe (NonEmpty a)
nonEmpty [PlutusWithContext (EraCrypto era)]
ps)
      forall sts (ctx :: RuleType). Event sts -> Rule sts ctx ()
tellEvent (forall era.
NonEmpty (PlutusWithContext (EraCrypto era))
-> AlonzoUtxosEvent era
FailedPlutusScriptsEvent (forall c. ScriptFailure c -> PlutusWithContext c
scriptFailurePlutus forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NonEmpty (ScriptFailure (EraCrypto era))
fs))

  () <- forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$! forall a. [Char] -> a -> a
Debug.traceEvent [Char]
invalidEnd ()

  {- utxoKeep = txBody ^. collateralInputsTxBodyL ⋪ utxo -}
  {- utxoDel  = txBody ^. collateralInputsTxBodyL ◁ utxo -}
  let !(Map (TxIn (EraCrypto era)) (TxOut era)
utxoKeep, Map (TxIn (EraCrypto era)) (TxOut era)
utxoDel) = forall k a. Ord k => Map k a -> Set k -> (Map k a, Map k a)
extractKeys (forall era. UTxO era -> Map (TxIn (EraCrypto era)) (TxOut era)
unUTxO UTxO era
utxo) (TxBody era
txBody forall s a. s -> Getting a s a -> a
^. forall era.
AlonzoEraTxBody era =>
Lens' (TxBody era) (Set (TxIn (EraCrypto era)))
collateralInputsTxBodyL)
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$!
    State (AlonzoUTXOS era)
us
      { utxosUtxo :: UTxO era
utxosUtxo = forall era. Map (TxIn (EraCrypto era)) (TxOut era) -> UTxO era
UTxO Map (TxIn (EraCrypto era)) (TxOut era)
utxoKeep
      , utxosFees :: Coin
utxosFees = Coin
fees forall a. Semigroup a => a -> a -> a
<> forall era. EraTxOut era => UTxO era -> Coin
coinBalance (forall era. Map (TxIn (EraCrypto era)) (TxOut era) -> UTxO era
UTxO Map (TxIn (EraCrypto era)) (TxOut era)
utxoDel)
      , utxosStakeDistr :: IncrementalStake (EraCrypto era)
utxosStakeDistr = forall era.
EraTxOut era =>
PParams era
-> IncrementalStake (EraCrypto era)
-> UTxO era
-> UTxO era
-> IncrementalStake (EraCrypto era)
updateStakeDistribution PParams era
pp (forall era. UTxOState era -> IncrementalStake (EraCrypto era)
utxosStakeDistr State (AlonzoUTXOS era)
us) (forall era. Map (TxIn (EraCrypto era)) (TxOut era) -> UTxO era
UTxO Map (TxIn (EraCrypto era)) (TxOut era)
utxoDel) forall a. Monoid a => a
mempty
      }

-- =======================================
-- Names for the events we will tell

validBegin, validEnd, invalidBegin, invalidEnd :: String
validBegin :: [Char]
validBegin = forall a. [a] -> [[a]] -> [a]
intercalate [Char]
"," [[Char]
"[LEDGER][SCRIPTS_VALIDATION]", [Char]
"BEGIN"]
validEnd :: [Char]
validEnd = forall a. [a] -> [[a]] -> [a]
intercalate [Char]
"," [[Char]
"[LEDGER][SCRIPTS_VALIDATION]", [Char]
"END"]
invalidBegin :: [Char]
invalidBegin = forall a. [a] -> [[a]] -> [a]
intercalate [Char]
"," [[Char]
"[LEDGER][SCRIPTS_NOT_VALIDATE_TRANSITION]", [Char]
"BEGIN"]
invalidEnd :: [Char]
invalidEnd = forall a. [a] -> [[a]] -> [a]
intercalate [Char]
"," [[Char]
"[LEDGER][SCRIPTS_NOT_VALIDATE_TRANSITION]", [Char]
"END"]

-- =============================================
-- PredicateFailure data type for AlonzoUTXOS

data FailureDescription
  = PlutusFailure Text BS.ByteString
  deriving (Int -> FailureDescription -> ShowS
[FailureDescription] -> ShowS
FailureDescription -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [FailureDescription] -> ShowS
$cshowList :: [FailureDescription] -> ShowS
show :: FailureDescription -> [Char]
$cshow :: FailureDescription -> [Char]
showsPrec :: Int -> FailureDescription -> ShowS
$cshowsPrec :: Int -> FailureDescription -> ShowS
Show, FailureDescription -> FailureDescription -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: FailureDescription -> FailureDescription -> Bool
$c/= :: FailureDescription -> FailureDescription -> Bool
== :: FailureDescription -> FailureDescription -> Bool
$c== :: FailureDescription -> FailureDescription -> Bool
Eq, forall x. Rep FailureDescription x -> FailureDescription
forall x. FailureDescription -> Rep FailureDescription x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep FailureDescription x -> FailureDescription
$cfrom :: forall x. FailureDescription -> Rep FailureDescription x
Generic, [[Char]] -> FailureDescription -> IO (Maybe ThunkInfo)
Proxy FailureDescription -> [Char]
forall a.
([[Char]] -> a -> IO (Maybe ThunkInfo))
-> ([[Char]] -> a -> IO (Maybe ThunkInfo))
-> (Proxy a -> [Char])
-> NoThunks a
showTypeOf :: Proxy FailureDescription -> [Char]
$cshowTypeOf :: Proxy FailureDescription -> [Char]
wNoThunks :: [[Char]] -> FailureDescription -> IO (Maybe ThunkInfo)
$cwNoThunks :: [[Char]] -> FailureDescription -> IO (Maybe ThunkInfo)
noThunks :: [[Char]] -> FailureDescription -> IO (Maybe ThunkInfo)
$cnoThunks :: [[Char]] -> FailureDescription -> IO (Maybe ThunkInfo)
NoThunks)

instance NFData FailureDescription

instance EncCBOR FailureDescription where
  -- This strange encoding results from the fact that 'FailureDescription'
  -- used to have another constructor, which used key 0.
  -- We must maintain the original serialization in order to not disrupt
  -- the node-to-client protocol of the cardano node.
  encCBOR :: FailureDescription -> Encoding
encCBOR (PlutusFailure Text
s ByteString
b) = forall (w :: Wrapped) t. Encode w t -> Encoding
encode forall a b. (a -> b) -> a -> b
$ forall t. t -> Word -> Encode 'Open t
Sum Text -> ByteString -> FailureDescription
PlutusFailure Word
1 forall (w :: Wrapped) a t (r :: Density).
Encode w (a -> t) -> Encode ('Closed r) a -> Encode w t
!> forall t. EncCBOR t => t -> Encode ('Closed 'Dense) t
To Text
s forall (w :: Wrapped) a t (r :: Density).
Encode w (a -> t) -> Encode ('Closed r) a -> Encode w t
!> forall t. EncCBOR t => t -> Encode ('Closed 'Dense) t
To ByteString
b

instance DecCBOR FailureDescription where
  decCBOR :: forall s. Decoder s FailureDescription
decCBOR = forall (w :: Wrapped) t s. Decode w t -> Decoder s t
decode forall a b. (a -> b) -> a -> b
$ forall t.
Text -> (Word -> Decode 'Open t) -> Decode ('Closed 'Dense) t
Summands Text
"FailureDescription" forall a b. (a -> b) -> a -> b
$ \case
    -- Note the lack of key 0. See the EncCBOR instance above for an explanation.
    Word
1 -> forall t. t -> Decode 'Open t
SumD Text -> ByteString -> FailureDescription
PlutusFailure forall (w1 :: Wrapped) a t (w :: Density).
Decode w1 (a -> t) -> Decode ('Closed w) a -> Decode w1 t
<! forall t (w :: Wrapped). DecCBOR t => Decode w t
From forall (w1 :: Wrapped) a t (w :: Density).
Decode w1 (a -> t) -> Decode ('Closed w) a -> Decode w1 t
<! forall t (w :: Wrapped). DecCBOR t => Decode w t
From
    Word
n -> forall (w :: Wrapped) t. Word -> Decode w t
Invalid Word
n

instance ToJSON FailureDescription where
  toJSON :: FailureDescription -> Value
toJSON (PlutusFailure Text
t ByteString
_bs) =
    Text -> [Pair] -> Value
kindObject
      Text
"FailureDescription"
      [ Key
"error" forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Text -> Value
Aeson.String Text
"PlutusFailure"
      , Key
"description" forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Text
t
      -- Plutus context can be pretty big, therefore it's omitted in JSON
      -- "reconstructionDetail" .= bs
      ]

scriptFailureToFailureDescription :: Crypto c => ScriptFailure c -> FailureDescription
scriptFailureToFailureDescription :: forall c. Crypto c => ScriptFailure c -> FailureDescription
scriptFailureToFailureDescription (ScriptFailure Text
msg PlutusWithContext c
pwc) =
  Text -> ByteString -> FailureDescription
PlutusFailure Text
msg (ByteString -> ByteString
B64.encode forall a b. (a -> b) -> a -> b
$ forall a. ToCBOR a => a -> ByteString
Plain.serialize' PlutusWithContext c
pwc)

data TagMismatchDescription
  = PassedUnexpectedly
  | FailedUnexpectedly (NonEmpty FailureDescription)
  deriving (Int -> TagMismatchDescription -> ShowS
[TagMismatchDescription] -> ShowS
TagMismatchDescription -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [TagMismatchDescription] -> ShowS
$cshowList :: [TagMismatchDescription] -> ShowS
show :: TagMismatchDescription -> [Char]
$cshow :: TagMismatchDescription -> [Char]
showsPrec :: Int -> TagMismatchDescription -> ShowS
$cshowsPrec :: Int -> TagMismatchDescription -> ShowS
Show, TagMismatchDescription -> TagMismatchDescription -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: TagMismatchDescription -> TagMismatchDescription -> Bool
$c/= :: TagMismatchDescription -> TagMismatchDescription -> Bool
== :: TagMismatchDescription -> TagMismatchDescription -> Bool
$c== :: TagMismatchDescription -> TagMismatchDescription -> Bool
Eq, forall x. Rep TagMismatchDescription x -> TagMismatchDescription
forall x. TagMismatchDescription -> Rep TagMismatchDescription x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep TagMismatchDescription x -> TagMismatchDescription
$cfrom :: forall x. TagMismatchDescription -> Rep TagMismatchDescription x
Generic, [[Char]] -> TagMismatchDescription -> IO (Maybe ThunkInfo)
Proxy TagMismatchDescription -> [Char]
forall a.
([[Char]] -> a -> IO (Maybe ThunkInfo))
-> ([[Char]] -> a -> IO (Maybe ThunkInfo))
-> (Proxy a -> [Char])
-> NoThunks a
showTypeOf :: Proxy TagMismatchDescription -> [Char]
$cshowTypeOf :: Proxy TagMismatchDescription -> [Char]
wNoThunks :: [[Char]] -> TagMismatchDescription -> IO (Maybe ThunkInfo)
$cwNoThunks :: [[Char]] -> TagMismatchDescription -> IO (Maybe ThunkInfo)
noThunks :: [[Char]] -> TagMismatchDescription -> IO (Maybe ThunkInfo)
$cnoThunks :: [[Char]] -> TagMismatchDescription -> IO (Maybe ThunkInfo)
NoThunks)

instance NFData TagMismatchDescription

instance EncCBOR TagMismatchDescription where
  encCBOR :: TagMismatchDescription -> Encoding
encCBOR TagMismatchDescription
PassedUnexpectedly = forall (w :: Wrapped) t. Encode w t -> Encoding
encode (forall t. t -> Word -> Encode 'Open t
Sum TagMismatchDescription
PassedUnexpectedly Word
0)
  encCBOR (FailedUnexpectedly NonEmpty FailureDescription
fs) = forall (w :: Wrapped) t. Encode w t -> Encoding
encode (forall t. t -> Word -> Encode 'Open t
Sum NonEmpty FailureDescription -> TagMismatchDescription
FailedUnexpectedly Word
1 forall (w :: Wrapped) a t (r :: Density).
Encode w (a -> t) -> Encode ('Closed r) a -> Encode w t
!> forall t. EncCBOR t => t -> Encode ('Closed 'Dense) t
To NonEmpty FailureDescription
fs)

instance DecCBOR TagMismatchDescription where
  decCBOR :: forall s. Decoder s TagMismatchDescription
decCBOR = forall (w :: Wrapped) t s. Decode w t -> Decoder s t
decode (forall t.
Text -> (Word -> Decode 'Open t) -> Decode ('Closed 'Dense) t
Summands Text
"TagMismatchDescription" Word -> Decode 'Open TagMismatchDescription
dec)
    where
      dec :: Word -> Decode 'Open TagMismatchDescription
dec Word
0 = forall t. t -> Decode 'Open t
SumD TagMismatchDescription
PassedUnexpectedly
      dec Word
1 = forall t. t -> Decode 'Open t
SumD NonEmpty FailureDescription -> TagMismatchDescription
FailedUnexpectedly forall (w1 :: Wrapped) a t (w :: Density).
Decode w1 (a -> t) -> Decode ('Closed w) a -> Decode w1 t
<! forall t (w :: Wrapped). DecCBOR t => Decode w t
From
      dec Word
n = forall (w :: Wrapped) t. Word -> Decode w t
Invalid Word
n

instance ToJSON TagMismatchDescription where
  toJSON :: TagMismatchDescription -> Value
toJSON = \case
    TagMismatchDescription
PassedUnexpectedly ->
      Text -> [Pair] -> Value
kindObject
        Text
"TagMismatchDescription"
        [Key
"error" forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Text -> Value
Aeson.String Text
"PassedUnexpectedly"]
    FailedUnexpectedly NonEmpty FailureDescription
forReasons ->
      Text -> [Pair] -> Value
kindObject
        Text
"TagMismatchDescription"
        [ Key
"error" forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Text -> Value
Aeson.String Text
"FailedUnexpectedly"
        , Key
"reconstruction" forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= NonEmpty FailureDescription
forReasons
        ]

data AlonzoUtxosPredFailure era
  = -- | The 'isValid' tag on the transaction is incorrect. The tag given
    --   here is that provided on the transaction (whereas evaluation of the
    --   scripts gives the opposite.). The Text tries to explain why it failed.
    ValidationTagMismatch IsValid TagMismatchDescription
  | -- | We could not find all the necessary inputs for a Plutus Script.
    --         Previous PredicateFailure tests should make this impossible, but the
    --         consequences of not detecting this means scripts get dropped, so things
    --         might validate that shouldn't. So we double check in the function
    --         collectTwoPhaseScriptInputs, it should find data for every Script.
    CollectErrors [CollectError era]
  | UpdateFailure (EraRuleFailure "PPUP" era)
  deriving
    (forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall era x.
Rep (AlonzoUtxosPredFailure era) x -> AlonzoUtxosPredFailure era
forall era x.
AlonzoUtxosPredFailure era -> Rep (AlonzoUtxosPredFailure era) x
$cto :: forall era x.
Rep (AlonzoUtxosPredFailure era) x -> AlonzoUtxosPredFailure era
$cfrom :: forall era x.
AlonzoUtxosPredFailure era -> Rep (AlonzoUtxosPredFailure era) x
Generic)

type instance EraRuleFailure "UTXOS" (AlonzoEra c) = AlonzoUtxosPredFailure (AlonzoEra c)

instance InjectRuleFailure "UTXOS" AlonzoUtxosPredFailure (AlonzoEra c)

instance InjectRuleFailure "UTXOS" ShelleyPpupPredFailure (AlonzoEra c) where
  injectFailure :: ShelleyPpupPredFailure (AlonzoEra c)
-> EraRuleFailure "UTXOS" (AlonzoEra c)
injectFailure = forall era. EraRuleFailure "PPUP" era -> AlonzoUtxosPredFailure era
UpdateFailure

instance
  ( EraTxCert era
  , AlonzoEraScript era
  , EncCBOR (ContextError era)
  , EncCBOR (EraRuleFailure "PPUP" era)
  ) =>
  EncCBOR (AlonzoUtxosPredFailure era)
  where
  encCBOR :: AlonzoUtxosPredFailure era -> Encoding
encCBOR (ValidationTagMismatch IsValid
v TagMismatchDescription
descr) = forall (w :: Wrapped) t. Encode w t -> Encoding
encode (forall t. t -> Word -> Encode 'Open t
Sum forall era.
IsValid -> TagMismatchDescription -> AlonzoUtxosPredFailure era
ValidationTagMismatch Word
0 forall (w :: Wrapped) a t (r :: Density).
Encode w (a -> t) -> Encode ('Closed r) a -> Encode w t
!> forall t. EncCBOR t => t -> Encode ('Closed 'Dense) t
To IsValid
v forall (w :: Wrapped) a t (r :: Density).
Encode w (a -> t) -> Encode ('Closed r) a -> Encode w t
!> forall t. EncCBOR t => t -> Encode ('Closed 'Dense) t
To TagMismatchDescription
descr)
  encCBOR (CollectErrors [CollectError era]
cs) =
    forall (w :: Wrapped) t. Encode w t -> Encoding
encode (forall t. t -> Word -> Encode 'Open t
Sum (forall era. [CollectError era] -> AlonzoUtxosPredFailure era
CollectErrors @era) Word
1 forall (w :: Wrapped) a t (r :: Density).
Encode w (a -> t) -> Encode ('Closed r) a -> Encode w t
!> forall t. EncCBOR t => t -> Encode ('Closed 'Dense) t
To [CollectError era]
cs)
  encCBOR (UpdateFailure EraRuleFailure "PPUP" era
pf) = forall (w :: Wrapped) t. Encode w t -> Encoding
encode (forall t. t -> Word -> Encode 'Open t
Sum (forall era. EraRuleFailure "PPUP" era -> AlonzoUtxosPredFailure era
UpdateFailure @era) Word
2 forall (w :: Wrapped) a t (r :: Density).
Encode w (a -> t) -> Encode ('Closed r) a -> Encode w t
!> forall t. EncCBOR t => t -> Encode ('Closed 'Dense) t
To EraRuleFailure "PPUP" era
pf)

instance
  ( EraTxCert era
  , AlonzoEraScript era
  , DecCBOR (ContextError era)
  , DecCBOR (EraRuleFailure "PPUP" era)
  ) =>
  DecCBOR (AlonzoUtxosPredFailure era)
  where
  decCBOR :: forall s. Decoder s (AlonzoUtxosPredFailure era)
decCBOR = forall (w :: Wrapped) t s. Decode w t -> Decoder s t
decode (forall t.
Text -> (Word -> Decode 'Open t) -> Decode ('Closed 'Dense) t
Summands Text
"AlonzoUtxosPredicateFailure" Word -> Decode 'Open (AlonzoUtxosPredFailure era)
dec)
    where
      dec :: Word -> Decode 'Open (AlonzoUtxosPredFailure era)
dec Word
0 = forall t. t -> Decode 'Open t
SumD forall era.
IsValid -> TagMismatchDescription -> AlonzoUtxosPredFailure era
ValidationTagMismatch forall (w1 :: Wrapped) a t (w :: Density).
Decode w1 (a -> t) -> Decode ('Closed w) a -> Decode w1 t
<! forall t (w :: Wrapped). DecCBOR t => Decode w t
From forall (w1 :: Wrapped) a t (w :: Density).
Decode w1 (a -> t) -> Decode ('Closed w) a -> Decode w1 t
<! forall t (w :: Wrapped). DecCBOR t => Decode w t
From
      dec Word
1 = forall t. t -> Decode 'Open t
SumD (forall era. [CollectError era] -> AlonzoUtxosPredFailure era
CollectErrors @era) forall (w1 :: Wrapped) a t (w :: Density).
Decode w1 (a -> t) -> Decode ('Closed w) a -> Decode w1 t
<! forall t (w :: Wrapped). DecCBOR t => Decode w t
From
      dec Word
2 = forall t. t -> Decode 'Open t
SumD forall era. EraRuleFailure "PPUP" era -> AlonzoUtxosPredFailure era
UpdateFailure forall (w1 :: Wrapped) a t (w :: Density).
Decode w1 (a -> t) -> Decode ('Closed w) a -> Decode w1 t
<! forall t (w :: Wrapped). DecCBOR t => Decode w t
From
      dec Word
n = forall (w :: Wrapped) t. Word -> Decode w t
Invalid Word
n

deriving stock instance
  ( AlonzoEraScript era
  , Show (TxCert era)
  , Show (ContextError era)
  , Show (Shelley.UTxOState era)
  , Show (EraRuleFailure "PPUP" era)
  ) =>
  Show (AlonzoUtxosPredFailure era)

deriving stock instance
  ( AlonzoEraScript era
  , Eq (TxCert era)
  , Eq (ContextError era)
  , Eq (Shelley.UTxOState era)
  , Eq (EraRuleFailure "PPUP" era)
  ) =>
  Eq (AlonzoUtxosPredFailure era)

instance
  ( AlonzoEraScript era
  , NoThunks (TxCert era)
  , NoThunks (ContextError era)
  , NoThunks (Shelley.UTxOState era)
  , NoThunks (EraRuleFailure "PPUP" era)
  ) =>
  NoThunks (AlonzoUtxosPredFailure era)

instance
  ( AlonzoEraScript era
  , NFData (TxCert era)
  , NFData (ContextError era)
  , NFData (Shelley.UTxOState era)
  , NFData (EraRuleFailure "PPUP" era)
  ) =>
  NFData (AlonzoUtxosPredFailure era)

--------------------------------------------------------------------------------
-- 2-phase checks
--------------------------------------------------------------------------------

-- $2-phase
--
-- Above and beyond 'static' checks (see 'Cardano.Ledger.Rules.ValidateMode') we
-- additionally label 2-phase checks. This is to support a workflow where we
-- validate a 'AlonzoTx'. We would like to trust the flag we have ourselves just
-- computed rather than re-calculating it. However, all other checks should be
-- computed as normal.

-- | Indicates that this check depends only upon the signal to the transition,
-- not the state or environment.
lbl2Phase :: Label
lbl2Phase :: [Char]
lbl2Phase = [Char]
"2phase"

-- | Construct a 2-phase predicate check.
--
--   Note that 2-phase predicate checks are by definition static.
when2Phase :: Rule sts ctx () -> Rule sts ctx ()
when2Phase :: forall sts (ctx :: RuleType). Rule sts ctx () -> Rule sts ctx ()
when2Phase = forall sts (ctx :: RuleType).
NonEmpty [Char] -> Rule sts ctx () -> Rule sts ctx ()
labeled forall a b. (a -> b) -> a -> b
$ [Char]
lblStatic forall a. a -> [a] -> NonEmpty a
NE.:| [[Char]
lbl2Phase]