{-# 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.State
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.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)
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
  ( 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
  , EraCertState era
  , EraStake 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 = [TransitionRule (AlonzoUTXOS era)
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, EraCertState era, EraStake era) =>
TransitionRule (AlonzoUTXOS era)
utxosTransition]

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 ((forall x. AlonzoUtxosEvent era -> Rep (AlonzoUtxosEvent era) x)
-> (forall x. Rep (AlonzoUtxosEvent era) x -> AlonzoUtxosEvent era)
-> Generic (AlonzoUtxosEvent era)
forall x. Rep (AlonzoUtxosEvent era) x -> AlonzoUtxosEvent era
forall x. AlonzoUtxosEvent era -> Rep (AlonzoUtxosEvent era) x
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
$cfrom :: forall era x. AlonzoUtxosEvent era -> Rep (AlonzoUtxosEvent era) x
from :: forall x. AlonzoUtxosEvent era -> Rep (AlonzoUtxosEvent era) x
$cto :: forall era x. Rep (AlonzoUtxosEvent era) x -> AlonzoUtxosEvent era
to :: forall x. Rep (AlonzoUtxosEvent era) x -> AlonzoUtxosEvent era
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 = EraRuleFailure "PPUP" era -> AlonzoUtxosPredFailure era
PredicateFailure (ShelleyPPUP era)
-> PredicateFailure (AlonzoUTXOS era)
forall era. EraRuleFailure "PPUP" era -> AlonzoUtxosPredFailure era
UpdateFailure
  wrapEvent :: Event (ShelleyPPUP era) -> Event (AlonzoUTXOS era)
wrapEvent = EraRuleEvent "PPUP" era -> AlonzoUtxosEvent era
Event (ShelleyPPUP era) -> Event (AlonzoUTXOS era)
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
  , EraCertState era
  , EraStake 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, EraCertState era, EraStake era) =>
TransitionRule (AlonzoUTXOS era)
utxosTransition =
  Rule
  (AlonzoUTXOS era)
  'Transition
  (RuleContext 'Transition (AlonzoUTXOS era))
F (Clause (AlonzoUTXOS era) 'Transition) (TRC (AlonzoUTXOS era))
forall sts (rtype :: RuleType).
Rule sts rtype (RuleContext rtype sts)
judgmentContext F (Clause (AlonzoUTXOS era) 'Transition) (TRC (AlonzoUTXOS era))
-> (TRC (AlonzoUTXOS era)
    -> F (Clause (AlonzoUTXOS era) 'Transition) (UTxOState era))
-> F (Clause (AlonzoUTXOS era) 'Transition) (UTxOState era)
forall a b.
F (Clause (AlonzoUTXOS era) 'Transition) a
-> (a -> F (Clause (AlonzoUTXOS era) 'Transition) b)
-> F (Clause (AlonzoUTXOS era) 'Transition) b
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 Tx era
Signal (AlonzoUTXOS era)
tx Tx era -> Getting IsValid (Tx era) IsValid -> IsValid
forall s a. s -> Getting a s a -> a
^. Getting IsValid (Tx era) IsValid
forall era. AlonzoEraTx era => Lens' (Tx era) IsValid
Lens' (Tx era) IsValid
isValidTxL of
      IsValid Bool
True -> F (Clause (AlonzoUTXOS era) 'Transition) (State (AlonzoUTXOS era))
F (Clause (AlonzoUTXOS era) 'Transition) (UTxOState era)
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, EraCertState era, EraStake era) =>
TransitionRule (AlonzoUTXOS era)
alonzoEvalScriptsTxValid
      IsValid Bool
False -> F (Clause (AlonzoUTXOS era) 'Transition) (State (AlonzoUTXOS era))
F (Clause (AlonzoUTXOS era) 'Transition) (UTxOState era)
forall era.
(AlonzoEraTx era, AlonzoEraUTxO era,
 ScriptsNeeded era ~ AlonzoScriptsNeeded era, STS (AlonzoUTXOS era),
 EraPlutusContext era, EraStake 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 -> 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 -> Rule sts ctx ())
-> Rule sts ctx ()
scriptsTransition SlotNo
slot PParams era
pp Tx era
tx UTxO era
utxo ScriptResult -> Rule sts ctx ()
action = do
  SystemStart
sysSt <- BaseM sts SystemStart -> Rule sts ctx SystemStart
forall sts a (ctx :: RuleType).
STS sts =>
BaseM sts a -> Rule sts ctx a
liftSTS (BaseM sts SystemStart -> Rule sts ctx SystemStart)
-> BaseM sts SystemStart -> Rule sts ctx SystemStart
forall a b. (a -> b) -> a -> b
$ (Globals -> SystemStart) -> ReaderT Globals m SystemStart
forall (m :: * -> *) r a. Monad m => (r -> a) -> ReaderT r m a
asks Globals -> SystemStart
systemStart
  EpochInfo (Either Text)
ei <- BaseM sts (EpochInfo (Either Text))
-> Rule sts ctx (EpochInfo (Either Text))
forall sts a (ctx :: RuleType).
STS sts =>
BaseM sts a -> Rule sts ctx a
liftSTS (BaseM sts (EpochInfo (Either Text))
 -> Rule sts ctx (EpochInfo (Either Text)))
-> BaseM sts (EpochInfo (Either Text))
-> Rule sts ctx (EpochInfo (Either Text))
forall a b. (a -> b) -> a -> b
$ (Globals -> EpochInfo (Either Text))
-> ReaderT Globals m (EpochInfo (Either Text))
forall (m :: * -> *) r a. Monad m => (r -> a) -> ReaderT r m a
asks Globals -> EpochInfo (Either Text)
epochInfo
  case EpochInfo (Either Text)
-> SystemStart
-> PParams era
-> Tx era
-> UTxO era
-> Either [CollectError era] [PlutusWithContext]
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]
collectPlutusScriptsWithContext (SlotNo -> EpochInfo (Either Text) -> EpochInfo (Either Text)
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]
sLst ->
      Rule sts ctx () -> Rule sts ctx ()
forall sts (ctx :: RuleType). Rule sts ctx () -> Rule sts ctx ()
when2Phase (Rule sts ctx () -> Rule sts ctx ())
-> Rule sts ctx () -> Rule sts ctx ()
forall a b. (a -> b) -> a -> b
$ ScriptResult -> Rule sts ctx ()
action (ScriptResult -> Rule sts ctx ())
-> ScriptResult -> Rule sts ctx ()
forall a b. (a -> b) -> a -> b
$ [PlutusWithContext] -> ScriptResult
evalPlutusScripts [PlutusWithContext]
sLst
    Left [CollectError era]
info
      | [CollectError era]
alonzoFailures <- (CollectError era -> Bool)
-> [CollectError era] -> [CollectError era]
forall a. (a -> Bool) -> [a] -> [a]
filter CollectError era -> Bool
forall {era}. CollectError era -> Bool
isNotBadTranslation [CollectError era]
info
      , Bool -> Bool
not ([CollectError era] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [CollectError era]
alonzoFailures) ->
          PredicateFailure sts -> Rule sts ctx ()
forall sts (ctx :: RuleType).
PredicateFailure sts -> Rule sts ctx ()
failBecause ([CollectError era] -> AlonzoUtxosPredFailure era
forall era. [CollectError era] -> AlonzoUtxosPredFailure era
CollectErrors [CollectError era]
alonzoFailures)
      | Bool
otherwise -> () -> Rule sts ctx ()
forall a. a -> F (Clause sts ctx) a
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
  , EraCertState era
  , EraStake 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, EraCertState era, EraStake 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 InstantStake era
_ Coin
_), Signal (AlonzoUTXOS era)
tx) <-
    Rule
  (AlonzoUTXOS era)
  'Transition
  (RuleContext 'Transition (AlonzoUTXOS era))
F (Clause (AlonzoUTXOS era) 'Transition) (TRC (AlonzoUTXOS era))
forall sts (rtype :: RuleType).
Rule sts rtype (RuleContext rtype sts)
judgmentContext
  let txBody :: TxBody era
txBody = Tx era
Signal (AlonzoUTXOS era)
tx Tx era -> Getting (TxBody era) (Tx era) (TxBody era) -> TxBody era
forall s a. s -> Getting a s a -> a
^. Getting (TxBody era) (Tx era) (TxBody era)
forall era. EraTx era => Lens' (Tx era) (TxBody era)
Lens' (Tx era) (TxBody era)
bodyTxL
      genDelegs :: GenDelegs
genDelegs = CertState era
certState CertState era
-> Getting GenDelegs (CertState era) GenDelegs -> GenDelegs
forall s a. s -> Getting a s a -> a
^. (DState era -> Const GenDelegs (DState era))
-> CertState era -> Const GenDelegs (CertState era)
forall era. EraCertState era => Lens' (CertState era) (DState era)
Lens' (CertState era) (DState era)
certDStateL ((DState era -> Const GenDelegs (DState era))
 -> CertState era -> Const GenDelegs (CertState era))
-> ((GenDelegs -> Const GenDelegs GenDelegs)
    -> DState era -> Const GenDelegs (DState era))
-> Getting GenDelegs (CertState era) GenDelegs
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (GenDelegs -> Const GenDelegs GenDelegs)
-> DState era -> Const GenDelegs (DState era)
forall era (f :: * -> *).
Functor f =>
(GenDelegs -> f GenDelegs) -> DState era -> f (DState era)
Shelley.dsGenDelegsL

  () <- () -> F (Clause (AlonzoUTXOS era) 'Transition) ()
forall a. a -> F (Clause (AlonzoUTXOS era) 'Transition) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (() -> F (Clause (AlonzoUTXOS era) 'Transition) ())
-> () -> F (Clause (AlonzoUTXOS era) 'Transition) ()
forall a b. (a -> b) -> a -> b
$! [Char] -> () -> ()
forall a. [Char] -> a -> a
Debug.traceEvent [Char]
validBegin ()

  SlotNo
-> PParams era
-> Tx era
-> UTxO era
-> (ScriptResult -> F (Clause (AlonzoUTXOS era) 'Transition) ())
-> F (Clause (AlonzoUTXOS era) 'Transition) ()
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 -> Rule sts ctx ())
-> Rule sts ctx ()
scriptsTransition SlotNo
slot PParams era
pp Tx era
Signal (AlonzoUTXOS era)
tx UTxO era
utxo ((ScriptResult -> F (Clause (AlonzoUTXOS era) 'Transition) ())
 -> F (Clause (AlonzoUTXOS era) 'Transition) ())
-> (ScriptResult -> F (Clause (AlonzoUTXOS era) 'Transition) ())
-> F (Clause (AlonzoUTXOS era) 'Transition) ()
forall a b. (a -> b) -> a -> b
$ \case
    Fails [PlutusWithContext]
_ps NonEmpty ScriptFailure
fs ->
      PredicateFailure (AlonzoUTXOS era)
-> F (Clause (AlonzoUTXOS era) 'Transition) ()
forall sts (ctx :: RuleType).
PredicateFailure sts -> Rule sts ctx ()
failBecause (PredicateFailure (AlonzoUTXOS era)
 -> F (Clause (AlonzoUTXOS era) 'Transition) ())
-> PredicateFailure (AlonzoUTXOS era)
-> F (Clause (AlonzoUTXOS era) 'Transition) ()
forall a b. (a -> b) -> a -> b
$
        IsValid -> TagMismatchDescription -> AlonzoUtxosPredFailure era
forall era.
IsValid -> TagMismatchDescription -> AlonzoUtxosPredFailure era
ValidationTagMismatch
          (Tx era
Signal (AlonzoUTXOS era)
tx Tx era -> Getting IsValid (Tx era) IsValid -> IsValid
forall s a. s -> Getting a s a -> a
^. Getting IsValid (Tx era) IsValid
forall era. AlonzoEraTx era => Lens' (Tx era) IsValid
Lens' (Tx era) IsValid
isValidTxL)
          (NonEmpty FailureDescription -> TagMismatchDescription
FailedUnexpectedly (ScriptFailure -> FailureDescription
scriptFailureToFailureDescription (ScriptFailure -> FailureDescription)
-> NonEmpty ScriptFailure -> NonEmpty FailureDescription
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NonEmpty ScriptFailure
fs))
    Passes [PlutusWithContext]
ps -> (NonEmpty PlutusWithContext
 -> F (Clause (AlonzoUTXOS era) 'Transition) ())
-> Maybe (NonEmpty PlutusWithContext)
-> F (Clause (AlonzoUTXOS era) 'Transition) ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Event (AlonzoUTXOS era)
-> F (Clause (AlonzoUTXOS era) 'Transition) ()
AlonzoUtxosEvent era -> F (Clause (AlonzoUTXOS era) 'Transition) ()
forall sts (ctx :: RuleType). Event sts -> Rule sts ctx ()
tellEvent (AlonzoUtxosEvent era
 -> F (Clause (AlonzoUTXOS era) 'Transition) ())
-> (NonEmpty PlutusWithContext -> AlonzoUtxosEvent era)
-> NonEmpty PlutusWithContext
-> F (Clause (AlonzoUTXOS era) 'Transition) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonEmpty PlutusWithContext -> AlonzoUtxosEvent era
forall era. NonEmpty PlutusWithContext -> AlonzoUtxosEvent era
SuccessfulPlutusScriptsEvent) ([PlutusWithContext] -> Maybe (NonEmpty PlutusWithContext)
forall a. [a] -> Maybe (NonEmpty a)
nonEmpty [PlutusWithContext]
ps)

  () <- () -> F (Clause (AlonzoUTXOS era) 'Transition) ()
forall a. a -> F (Clause (AlonzoUTXOS era) 'Transition) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (() -> F (Clause (AlonzoUTXOS era) 'Transition) ())
-> () -> F (Clause (AlonzoUTXOS era) 'Transition) ()
forall a b. (a -> b) -> a -> b
$! [Char] -> () -> ()
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) (RuleContext 'Transition (EraRule "PPUP" era)
 -> Rule (AlonzoUTXOS era) 'Transition (State (EraRule "PPUP" era)))
-> RuleContext 'Transition (EraRule "PPUP" era)
-> Rule (AlonzoUTXOS era) 'Transition (State (EraRule "PPUP" era))
forall a b. (a -> b) -> a -> b
$
      (Environment (EraRule "PPUP" era), State (EraRule "PPUP" era),
 Signal (EraRule "PPUP" era))
-> TRC (EraRule "PPUP" era)
forall sts. (Environment sts, State sts, Signal sts) -> TRC sts
TRC (SlotNo -> PParams era -> GenDelegs -> PpupEnv era
forall era. SlotNo -> PParams era -> GenDelegs -> PpupEnv era
PPUPEnv SlotNo
slot PParams era
pp GenDelegs
genDelegs, GovState era
State (EraRule "PPUP" era)
pup, TxBody era
txBody TxBody era
-> Getting
     (StrictMaybe (Update era)) (TxBody era) (StrictMaybe (Update era))
-> StrictMaybe (Update era)
forall s a. s -> Getting a s a -> a
^. Getting
  (StrictMaybe (Update era)) (TxBody era) (StrictMaybe (Update era))
forall era.
ShelleyEraTxBody era =>
Lens' (TxBody era) (StrictMaybe (Update era))
Lens' (TxBody era) (StrictMaybe (Update era))
updateTxBodyL)

  PParams era
-> UTxOState era
-> TxBody era
-> CertState era
-> GovState era
-> (Coin -> F (Clause (AlonzoUTXOS era) 'Transition) ())
-> (UTxO era
    -> UTxO era -> F (Clause (AlonzoUTXOS era) 'Transition) ())
-> F (Clause (AlonzoUTXOS era) 'Transition) (UTxOState era)
forall era (m :: * -> *).
(EraTxBody era, EraStake era, EraCertState 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)
UTxOState era
utxos
    TxBody era
txBody
    CertState era
certState
    GovState era
ShelleyGovState era
ppup'
    (Event (AlonzoUTXOS era)
-> F (Clause (AlonzoUTXOS era) 'Transition) ()
AlonzoUtxosEvent era -> F (Clause (AlonzoUTXOS era) 'Transition) ()
forall sts (ctx :: RuleType). Event sts -> Rule sts ctx ()
tellEvent (AlonzoUtxosEvent era
 -> F (Clause (AlonzoUTXOS era) 'Transition) ())
-> (Coin -> AlonzoUtxosEvent era)
-> Coin
-> F (Clause (AlonzoUTXOS era) 'Transition) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SafeHash EraIndependentTxBody -> Coin -> AlonzoUtxosEvent era
forall era.
SafeHash EraIndependentTxBody -> Coin -> AlonzoUtxosEvent era
TotalDeposits (TxBody era -> SafeHash EraIndependentTxBody
forall x i. HashAnnotated x i => x -> SafeHash i
hashAnnotated TxBody era
txBody))
    (\UTxO era
a UTxO era
b -> Event (AlonzoUTXOS era)
-> F (Clause (AlonzoUTXOS era) 'Transition) ()
forall sts (ctx :: RuleType). Event sts -> Rule sts ctx ()
tellEvent (Event (AlonzoUTXOS era)
 -> F (Clause (AlonzoUTXOS era) 'Transition) ())
-> Event (AlonzoUTXOS era)
-> F (Clause (AlonzoUTXOS era) 'Transition) ()
forall a b. (a -> b) -> a -> b
$ UTxO era -> UTxO era -> AlonzoUtxosEvent era
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
  , EraStake era
  ) =>
  TransitionRule (AlonzoUTXOS era)
alonzoEvalScriptsTxInvalid :: forall era.
(AlonzoEraTx era, AlonzoEraUTxO era,
 ScriptsNeeded era ~ AlonzoScriptsNeeded era, STS (AlonzoUTXOS era),
 EraPlutusContext era, EraStake era) =>
TransitionRule (AlonzoUTXOS era)
alonzoEvalScriptsTxInvalid = do
  TRC (UtxoEnv SlotNo
slot PParams era
pp CertState era
_, utxos :: State (AlonzoUTXOS era)
utxos@(UTxOState UTxO era
utxo Coin
_ Coin
fees GovState era
_ InstantStake era
_ Coin
_), Signal (AlonzoUTXOS era)
tx) <- Rule
  (AlonzoUTXOS era)
  'Transition
  (RuleContext 'Transition (AlonzoUTXOS era))
F (Clause (AlonzoUTXOS era) 'Transition) (TRC (AlonzoUTXOS era))
forall sts (rtype :: RuleType).
Rule sts rtype (RuleContext rtype sts)
judgmentContext
  let txBody :: TxBody era
txBody = Tx era
Signal (AlonzoUTXOS era)
tx Tx era -> Getting (TxBody era) (Tx era) (TxBody era) -> TxBody era
forall s a. s -> Getting a s a -> a
^. Getting (TxBody era) (Tx era) (TxBody era)
forall era. EraTx era => Lens' (Tx era) (TxBody era)
Lens' (Tx era) (TxBody era)
bodyTxL

  () <- () -> F (Clause (AlonzoUTXOS era) 'Transition) ()
forall a. a -> F (Clause (AlonzoUTXOS era) 'Transition) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (() -> F (Clause (AlonzoUTXOS era) 'Transition) ())
-> () -> F (Clause (AlonzoUTXOS era) 'Transition) ()
forall a b. (a -> b) -> a -> b
$! [Char] -> () -> ()
forall a. [Char] -> a -> a
Debug.traceEvent [Char]
invalidBegin ()

  SlotNo
-> PParams era
-> Tx era
-> UTxO era
-> (ScriptResult -> F (Clause (AlonzoUTXOS era) 'Transition) ())
-> F (Clause (AlonzoUTXOS era) 'Transition) ()
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 -> Rule sts ctx ())
-> Rule sts ctx ()
scriptsTransition SlotNo
slot PParams era
pp Tx era
Signal (AlonzoUTXOS era)
tx UTxO era
utxo ((ScriptResult -> F (Clause (AlonzoUTXOS era) 'Transition) ())
 -> F (Clause (AlonzoUTXOS era) 'Transition) ())
-> (ScriptResult -> F (Clause (AlonzoUTXOS era) 'Transition) ())
-> F (Clause (AlonzoUTXOS era) 'Transition) ()
forall a b. (a -> b) -> a -> b
$ \case
    Passes [PlutusWithContext]
_ps ->
      PredicateFailure (AlonzoUTXOS era)
-> F (Clause (AlonzoUTXOS era) 'Transition) ()
forall sts (ctx :: RuleType).
PredicateFailure sts -> Rule sts ctx ()
failBecause (PredicateFailure (AlonzoUTXOS era)
 -> F (Clause (AlonzoUTXOS era) 'Transition) ())
-> PredicateFailure (AlonzoUTXOS era)
-> F (Clause (AlonzoUTXOS era) 'Transition) ()
forall a b. (a -> b) -> a -> b
$
        IsValid -> TagMismatchDescription -> AlonzoUtxosPredFailure era
forall era.
IsValid -> TagMismatchDescription -> AlonzoUtxosPredFailure era
ValidationTagMismatch (Tx era
Signal (AlonzoUTXOS era)
tx Tx era -> Getting IsValid (Tx era) IsValid -> IsValid
forall s a. s -> Getting a s a -> a
^. Getting IsValid (Tx era) IsValid
forall era. AlonzoEraTx era => Lens' (Tx era) IsValid
Lens' (Tx era) IsValid
isValidTxL) TagMismatchDescription
PassedUnexpectedly
    Fails [PlutusWithContext]
ps NonEmpty ScriptFailure
fs -> do
      (NonEmpty PlutusWithContext
 -> F (Clause (AlonzoUTXOS era) 'Transition) ())
-> Maybe (NonEmpty PlutusWithContext)
-> F (Clause (AlonzoUTXOS era) 'Transition) ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Event (AlonzoUTXOS era)
-> F (Clause (AlonzoUTXOS era) 'Transition) ()
AlonzoUtxosEvent era -> F (Clause (AlonzoUTXOS era) 'Transition) ()
forall sts (ctx :: RuleType). Event sts -> Rule sts ctx ()
tellEvent (AlonzoUtxosEvent era
 -> F (Clause (AlonzoUTXOS era) 'Transition) ())
-> (NonEmpty PlutusWithContext -> AlonzoUtxosEvent era)
-> NonEmpty PlutusWithContext
-> F (Clause (AlonzoUTXOS era) 'Transition) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonEmpty PlutusWithContext -> AlonzoUtxosEvent era
forall era. NonEmpty PlutusWithContext -> AlonzoUtxosEvent era
SuccessfulPlutusScriptsEvent) ([PlutusWithContext] -> Maybe (NonEmpty PlutusWithContext)
forall a. [a] -> Maybe (NonEmpty a)
nonEmpty [PlutusWithContext]
ps)
      Event (AlonzoUTXOS era)
-> F (Clause (AlonzoUTXOS era) 'Transition) ()
forall sts (ctx :: RuleType). Event sts -> Rule sts ctx ()
tellEvent (NonEmpty PlutusWithContext -> AlonzoUtxosEvent era
forall era. NonEmpty PlutusWithContext -> AlonzoUtxosEvent era
FailedPlutusScriptsEvent (ScriptFailure -> PlutusWithContext
scriptFailurePlutus (ScriptFailure -> PlutusWithContext)
-> NonEmpty ScriptFailure -> NonEmpty PlutusWithContext
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NonEmpty ScriptFailure
fs))

  () <- () -> F (Clause (AlonzoUTXOS era) 'Transition) ()
forall a. a -> F (Clause (AlonzoUTXOS era) 'Transition) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (() -> F (Clause (AlonzoUTXOS era) 'Transition) ())
-> () -> F (Clause (AlonzoUTXOS era) 'Transition) ()
forall a b. (a -> b) -> a -> b
$! [Char] -> () -> ()
forall a. [Char] -> a -> a
Debug.traceEvent [Char]
invalidEnd ()

  {- utxoKeep = txBody ^. collateralInputsTxBodyL ⋪ utxo -}
  {- utxoDel  = txBody ^. collateralInputsTxBodyL ◁ utxo -}
  let !(Map TxIn (TxOut era)
utxoKeep, Map TxIn (TxOut era)
utxoDel) = Map TxIn (TxOut era)
-> Set TxIn -> (Map TxIn (TxOut era), Map TxIn (TxOut era))
forall k a. Ord k => Map k a -> Set k -> (Map k a, Map k a)
extractKeys (UTxO era -> Map TxIn (TxOut era)
forall era. UTxO era -> Map TxIn (TxOut era)
unUTxO UTxO era
utxo) (TxBody era
txBody TxBody era
-> Getting (Set TxIn) (TxBody era) (Set TxIn) -> Set TxIn
forall s a. s -> Getting a s a -> a
^. Getting (Set TxIn) (TxBody era) (Set TxIn)
forall era. AlonzoEraTxBody era => Lens' (TxBody era) (Set TxIn)
Lens' (TxBody era) (Set TxIn)
collateralInputsTxBodyL)
  UTxOState era
-> F (Clause (AlonzoUTXOS era) 'Transition) (UTxOState era)
forall a. a -> F (Clause (AlonzoUTXOS era) 'Transition) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (UTxOState era
 -> F (Clause (AlonzoUTXOS era) 'Transition) (UTxOState era))
-> UTxOState era
-> F (Clause (AlonzoUTXOS era) 'Transition) (UTxOState era)
forall a b. (a -> b) -> a -> b
$!
    State (AlonzoUTXOS era)
utxos
      { utxosUtxo = UTxO utxoKeep
      , utxosFees = fees <> sumAllCoin utxoDel
      , utxosInstantStake = deleteInstantStake (UTxO utxoDel) (utxos ^. instantStakeL)
      }

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

validBegin, validEnd, invalidBegin, invalidEnd :: String
validBegin :: [Char]
validBegin = [Char] -> [[Char]] -> [Char]
forall a. [a] -> [[a]] -> [a]
intercalate [Char]
"," [[Char]
"[LEDGER][SCRIPTS_VALIDATION]", [Char]
"BEGIN"]
validEnd :: [Char]
validEnd = [Char] -> [[Char]] -> [Char]
forall a. [a] -> [[a]] -> [a]
intercalate [Char]
"," [[Char]
"[LEDGER][SCRIPTS_VALIDATION]", [Char]
"END"]
invalidBegin :: [Char]
invalidBegin = [Char] -> [[Char]] -> [Char]
forall a. [a] -> [[a]] -> [a]
intercalate [Char]
"," [[Char]
"[LEDGER][SCRIPTS_NOT_VALIDATE_TRANSITION]", [Char]
"BEGIN"]
invalidEnd :: [Char]
invalidEnd = [Char] -> [[Char]] -> [Char]
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]
(Int -> FailureDescription -> ShowS)
-> (FailureDescription -> [Char])
-> ([FailureDescription] -> ShowS)
-> Show FailureDescription
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> FailureDescription -> ShowS
showsPrec :: Int -> FailureDescription -> ShowS
$cshow :: FailureDescription -> [Char]
show :: FailureDescription -> [Char]
$cshowList :: [FailureDescription] -> ShowS
showList :: [FailureDescription] -> ShowS
Show, FailureDescription -> FailureDescription -> Bool
(FailureDescription -> FailureDescription -> Bool)
-> (FailureDescription -> FailureDescription -> Bool)
-> Eq FailureDescription
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: FailureDescription -> FailureDescription -> Bool
== :: FailureDescription -> FailureDescription -> Bool
$c/= :: FailureDescription -> FailureDescription -> Bool
/= :: FailureDescription -> FailureDescription -> Bool
Eq, (forall x. FailureDescription -> Rep FailureDescription x)
-> (forall x. Rep FailureDescription x -> FailureDescription)
-> Generic FailureDescription
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
$cfrom :: forall x. FailureDescription -> Rep FailureDescription x
from :: forall x. FailureDescription -> Rep FailureDescription x
$cto :: forall x. Rep FailureDescription x -> FailureDescription
to :: forall x. Rep FailureDescription x -> FailureDescription
Generic, [[Char]] -> FailureDescription -> IO (Maybe ThunkInfo)
Proxy FailureDescription -> [Char]
([[Char]] -> FailureDescription -> IO (Maybe ThunkInfo))
-> ([[Char]] -> FailureDescription -> IO (Maybe ThunkInfo))
-> (Proxy FailureDescription -> [Char])
-> NoThunks FailureDescription
forall a.
([[Char]] -> a -> IO (Maybe ThunkInfo))
-> ([[Char]] -> a -> IO (Maybe ThunkInfo))
-> (Proxy a -> [Char])
-> NoThunks a
$cnoThunks :: [[Char]] -> FailureDescription -> IO (Maybe ThunkInfo)
noThunks :: [[Char]] -> FailureDescription -> IO (Maybe ThunkInfo)
$cwNoThunks :: [[Char]] -> FailureDescription -> IO (Maybe ThunkInfo)
wNoThunks :: [[Char]] -> FailureDescription -> IO (Maybe ThunkInfo)
$cshowTypeOf :: Proxy FailureDescription -> [Char]
showTypeOf :: Proxy FailureDescription -> [Char]
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) = Encode 'Open FailureDescription -> Encoding
forall (w :: Wrapped) t. Encode w t -> Encoding
encode (Encode 'Open FailureDescription -> Encoding)
-> Encode 'Open FailureDescription -> Encoding
forall a b. (a -> b) -> a -> b
$ (Text -> ByteString -> FailureDescription)
-> Word -> Encode 'Open (Text -> ByteString -> FailureDescription)
forall t. t -> Word -> Encode 'Open t
Sum Text -> ByteString -> FailureDescription
PlutusFailure Word
1 Encode 'Open (Text -> ByteString -> FailureDescription)
-> Encode ('Closed 'Dense) Text
-> Encode 'Open (ByteString -> FailureDescription)
forall (w :: Wrapped) a t (r :: Density).
Encode w (a -> t) -> Encode ('Closed r) a -> Encode w t
!> Text -> Encode ('Closed 'Dense) Text
forall t. EncCBOR t => t -> Encode ('Closed 'Dense) t
To Text
s Encode 'Open (ByteString -> FailureDescription)
-> Encode ('Closed 'Dense) ByteString
-> Encode 'Open FailureDescription
forall (w :: Wrapped) a t (r :: Density).
Encode w (a -> t) -> Encode ('Closed r) a -> Encode w t
!> ByteString -> Encode ('Closed 'Dense) ByteString
forall t. EncCBOR t => t -> Encode ('Closed 'Dense) t
To ByteString
b

instance DecCBOR FailureDescription where
  decCBOR :: forall s. Decoder s FailureDescription
decCBOR = Decode ('Closed 'Dense) FailureDescription
-> Decoder s FailureDescription
forall t (w :: Wrapped) s. Typeable t => Decode w t -> Decoder s t
decode (Decode ('Closed 'Dense) FailureDescription
 -> Decoder s FailureDescription)
-> Decode ('Closed 'Dense) FailureDescription
-> Decoder s FailureDescription
forall a b. (a -> b) -> a -> b
$ Text
-> (Word -> Decode 'Open FailureDescription)
-> Decode ('Closed 'Dense) FailureDescription
forall t.
Text -> (Word -> Decode 'Open t) -> Decode ('Closed 'Dense) t
Summands Text
"FailureDescription" ((Word -> Decode 'Open FailureDescription)
 -> Decode ('Closed 'Dense) FailureDescription)
-> (Word -> Decode 'Open FailureDescription)
-> Decode ('Closed 'Dense) 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 -> (Text -> ByteString -> FailureDescription)
-> Decode 'Open (Text -> ByteString -> FailureDescription)
forall t. t -> Decode 'Open t
SumD Text -> ByteString -> FailureDescription
PlutusFailure Decode 'Open (Text -> ByteString -> FailureDescription)
-> Decode ('Closed Any) Text
-> Decode 'Open (ByteString -> FailureDescription)
forall a (w1 :: Wrapped) t (w :: Density).
Typeable a =>
Decode w1 (a -> t) -> Decode ('Closed w) a -> Decode w1 t
<! Decode ('Closed Any) Text
forall t (w :: Wrapped). DecCBOR t => Decode w t
From Decode 'Open (ByteString -> FailureDescription)
-> Decode ('Closed Any) ByteString
-> Decode 'Open FailureDescription
forall a (w1 :: Wrapped) t (w :: Density).
Typeable a =>
Decode w1 (a -> t) -> Decode ('Closed w) a -> Decode w1 t
<! Decode ('Closed Any) ByteString
forall t (w :: Wrapped). DecCBOR t => Decode w t
From
    Word
n -> Word -> Decode 'Open FailureDescription
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" Key -> Value -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Text -> Value
Aeson.String Text
"PlutusFailure"
      , Key
"description" Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
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 :: ScriptFailure -> FailureDescription
scriptFailureToFailureDescription :: ScriptFailure -> FailureDescription
scriptFailureToFailureDescription (ScriptFailure Text
msg PlutusWithContext
pwc) =
  Text -> ByteString -> FailureDescription
PlutusFailure Text
msg (ByteString -> ByteString
B64.encode (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ PlutusWithContext -> ByteString
forall a. ToCBOR a => a -> ByteString
Plain.serialize' PlutusWithContext
pwc)

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

instance NFData TagMismatchDescription

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

instance DecCBOR TagMismatchDescription where
  decCBOR :: forall s. Decoder s TagMismatchDescription
decCBOR = Decode ('Closed 'Dense) TagMismatchDescription
-> Decoder s TagMismatchDescription
forall t (w :: Wrapped) s. Typeable t => Decode w t -> Decoder s t
decode (Text
-> (Word -> Decode 'Open TagMismatchDescription)
-> Decode ('Closed 'Dense) TagMismatchDescription
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 = TagMismatchDescription -> Decode 'Open TagMismatchDescription
forall t. t -> Decode 'Open t
SumD TagMismatchDescription
PassedUnexpectedly
      dec Word
1 = (NonEmpty FailureDescription -> TagMismatchDescription)
-> Decode
     'Open (NonEmpty FailureDescription -> TagMismatchDescription)
forall t. t -> Decode 'Open t
SumD NonEmpty FailureDescription -> TagMismatchDescription
FailedUnexpectedly Decode
  'Open (NonEmpty FailureDescription -> TagMismatchDescription)
-> Decode ('Closed Any) (NonEmpty FailureDescription)
-> Decode 'Open TagMismatchDescription
forall a (w1 :: Wrapped) t (w :: Density).
Typeable a =>
Decode w1 (a -> t) -> Decode ('Closed w) a -> Decode w1 t
<! Decode ('Closed Any) (NonEmpty FailureDescription)
forall t (w :: Wrapped). DecCBOR t => Decode w t
From
      dec Word
n = Word -> Decode 'Open TagMismatchDescription
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" Key -> Value -> Pair
forall v. ToJSON v => Key -> v -> Pair
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" Key -> Value -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Text -> Value
Aeson.String Text
"FailedUnexpectedly"
        , Key
"reconstruction" Key -> NonEmpty FailureDescription -> Pair
forall v. ToJSON v => Key -> v -> Pair
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 x.
 AlonzoUtxosPredFailure era -> Rep (AlonzoUtxosPredFailure era) x)
-> (forall x.
    Rep (AlonzoUtxosPredFailure era) x -> AlonzoUtxosPredFailure era)
-> Generic (AlonzoUtxosPredFailure era)
forall x.
Rep (AlonzoUtxosPredFailure era) x -> AlonzoUtxosPredFailure era
forall x.
AlonzoUtxosPredFailure era -> Rep (AlonzoUtxosPredFailure era) x
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
$cfrom :: forall era x.
AlonzoUtxosPredFailure era -> Rep (AlonzoUtxosPredFailure era) x
from :: forall x.
AlonzoUtxosPredFailure era -> Rep (AlonzoUtxosPredFailure era) x
$cto :: forall era x.
Rep (AlonzoUtxosPredFailure era) x -> AlonzoUtxosPredFailure era
to :: forall x.
Rep (AlonzoUtxosPredFailure era) x -> AlonzoUtxosPredFailure era
Generic)

type instance EraRuleFailure "UTXOS" AlonzoEra = AlonzoUtxosPredFailure AlonzoEra

instance InjectRuleFailure "UTXOS" AlonzoUtxosPredFailure AlonzoEra

instance InjectRuleFailure "UTXOS" ShelleyPpupPredFailure AlonzoEra where
  injectFailure :: ShelleyPpupPredFailure AlonzoEra
-> EraRuleFailure "UTXOS" AlonzoEra
injectFailure = EraRuleFailure "PPUP" AlonzoEra -> AlonzoUtxosPredFailure AlonzoEra
ShelleyPpupPredFailure AlonzoEra
-> EraRuleFailure "UTXOS" AlonzoEra
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) = Encode 'Open (AlonzoUtxosPredFailure Any) -> Encoding
forall (w :: Wrapped) t. Encode w t -> Encoding
encode ((IsValid -> TagMismatchDescription -> AlonzoUtxosPredFailure Any)
-> Word
-> Encode
     'Open
     (IsValid -> TagMismatchDescription -> AlonzoUtxosPredFailure Any)
forall t. t -> Word -> Encode 'Open t
Sum IsValid -> TagMismatchDescription -> AlonzoUtxosPredFailure Any
forall era.
IsValid -> TagMismatchDescription -> AlonzoUtxosPredFailure era
ValidationTagMismatch Word
0 Encode
  'Open
  (IsValid -> TagMismatchDescription -> AlonzoUtxosPredFailure Any)
-> Encode ('Closed 'Dense) IsValid
-> Encode
     'Open (TagMismatchDescription -> AlonzoUtxosPredFailure Any)
forall (w :: Wrapped) a t (r :: Density).
Encode w (a -> t) -> Encode ('Closed r) a -> Encode w t
!> IsValid -> Encode ('Closed 'Dense) IsValid
forall t. EncCBOR t => t -> Encode ('Closed 'Dense) t
To IsValid
v Encode 'Open (TagMismatchDescription -> AlonzoUtxosPredFailure Any)
-> Encode ('Closed 'Dense) TagMismatchDescription
-> Encode 'Open (AlonzoUtxosPredFailure Any)
forall (w :: Wrapped) a t (r :: Density).
Encode w (a -> t) -> Encode ('Closed r) a -> Encode w t
!> TagMismatchDescription
-> Encode ('Closed 'Dense) TagMismatchDescription
forall t. EncCBOR t => t -> Encode ('Closed 'Dense) t
To TagMismatchDescription
descr)
  encCBOR (CollectErrors [CollectError era]
cs) =
    Encode 'Open (AlonzoUtxosPredFailure era) -> Encoding
forall (w :: Wrapped) t. Encode w t -> Encoding
encode (([CollectError era] -> AlonzoUtxosPredFailure era)
-> Word
-> Encode 'Open ([CollectError era] -> AlonzoUtxosPredFailure era)
forall t. t -> Word -> Encode 'Open t
Sum (forall era. [CollectError era] -> AlonzoUtxosPredFailure era
CollectErrors @era) Word
1 Encode 'Open ([CollectError era] -> AlonzoUtxosPredFailure era)
-> Encode ('Closed 'Dense) [CollectError era]
-> Encode 'Open (AlonzoUtxosPredFailure era)
forall (w :: Wrapped) a t (r :: Density).
Encode w (a -> t) -> Encode ('Closed r) a -> Encode w t
!> [CollectError era] -> Encode ('Closed 'Dense) [CollectError era]
forall t. EncCBOR t => t -> Encode ('Closed 'Dense) t
To [CollectError era]
cs)
  encCBOR (UpdateFailure EraRuleFailure "PPUP" era
pf) = Encode 'Open (AlonzoUtxosPredFailure era) -> Encoding
forall (w :: Wrapped) t. Encode w t -> Encoding
encode ((EraRuleFailure "PPUP" era -> AlonzoUtxosPredFailure era)
-> Word
-> Encode
     'Open (EraRuleFailure "PPUP" era -> AlonzoUtxosPredFailure era)
forall t. t -> Word -> Encode 'Open t
Sum (forall era. EraRuleFailure "PPUP" era -> AlonzoUtxosPredFailure era
UpdateFailure @era) Word
2 Encode
  'Open (EraRuleFailure "PPUP" era -> AlonzoUtxosPredFailure era)
-> Encode ('Closed 'Dense) (EraRuleFailure "PPUP" era)
-> Encode 'Open (AlonzoUtxosPredFailure era)
forall (w :: Wrapped) a t (r :: Density).
Encode w (a -> t) -> Encode ('Closed r) a -> Encode w t
!> EraRuleFailure "PPUP" era
-> Encode ('Closed 'Dense) (EraRuleFailure "PPUP" era)
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 = Decode ('Closed 'Dense) (AlonzoUtxosPredFailure era)
-> Decoder s (AlonzoUtxosPredFailure era)
forall t (w :: Wrapped) s. Typeable t => Decode w t -> Decoder s t
decode (Text
-> (Word -> Decode 'Open (AlonzoUtxosPredFailure era))
-> Decode ('Closed 'Dense) (AlonzoUtxosPredFailure era)
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 = (IsValid -> TagMismatchDescription -> AlonzoUtxosPredFailure era)
-> Decode
     'Open
     (IsValid -> TagMismatchDescription -> AlonzoUtxosPredFailure era)
forall t. t -> Decode 'Open t
SumD IsValid -> TagMismatchDescription -> AlonzoUtxosPredFailure era
forall era.
IsValid -> TagMismatchDescription -> AlonzoUtxosPredFailure era
ValidationTagMismatch Decode
  'Open
  (IsValid -> TagMismatchDescription -> AlonzoUtxosPredFailure era)
-> Decode ('Closed Any) IsValid
-> Decode
     'Open (TagMismatchDescription -> AlonzoUtxosPredFailure era)
forall a (w1 :: Wrapped) t (w :: Density).
Typeable a =>
Decode w1 (a -> t) -> Decode ('Closed w) a -> Decode w1 t
<! Decode ('Closed Any) IsValid
forall t (w :: Wrapped). DecCBOR t => Decode w t
From Decode 'Open (TagMismatchDescription -> AlonzoUtxosPredFailure era)
-> Decode ('Closed Any) TagMismatchDescription
-> Decode 'Open (AlonzoUtxosPredFailure era)
forall a (w1 :: Wrapped) t (w :: Density).
Typeable a =>
Decode w1 (a -> t) -> Decode ('Closed w) a -> Decode w1 t
<! Decode ('Closed Any) TagMismatchDescription
forall t (w :: Wrapped). DecCBOR t => Decode w t
From
      dec Word
1 = ([CollectError era] -> AlonzoUtxosPredFailure era)
-> Decode 'Open ([CollectError era] -> AlonzoUtxosPredFailure era)
forall t. t -> Decode 'Open t
SumD (forall era. [CollectError era] -> AlonzoUtxosPredFailure era
CollectErrors @era) Decode 'Open ([CollectError era] -> AlonzoUtxosPredFailure era)
-> Decode ('Closed Any) [CollectError era]
-> Decode 'Open (AlonzoUtxosPredFailure era)
forall a (w1 :: Wrapped) t (w :: Density).
Typeable a =>
Decode w1 (a -> t) -> Decode ('Closed w) a -> Decode w1 t
<! Decode ('Closed Any) [CollectError era]
forall t (w :: Wrapped). DecCBOR t => Decode w t
From
      dec Word
2 = (EraRuleFailure "PPUP" era -> AlonzoUtxosPredFailure era)
-> Decode
     'Open (EraRuleFailure "PPUP" era -> AlonzoUtxosPredFailure era)
forall t. t -> Decode 'Open t
SumD EraRuleFailure "PPUP" era -> AlonzoUtxosPredFailure era
forall era. EraRuleFailure "PPUP" era -> AlonzoUtxosPredFailure era
UpdateFailure Decode
  'Open (EraRuleFailure "PPUP" era -> AlonzoUtxosPredFailure era)
-> Decode ('Closed Any) (EraRuleFailure "PPUP" era)
-> Decode 'Open (AlonzoUtxosPredFailure era)
forall a (w1 :: Wrapped) t (w :: Density).
Typeable a =>
Decode w1 (a -> t) -> Decode ('Closed w) a -> Decode w1 t
<! Decode ('Closed Any) (EraRuleFailure "PPUP" era)
forall t (w :: Wrapped). DecCBOR t => Decode w t
From
      dec Word
n = Word -> Decode 'Open (AlonzoUtxosPredFailure era)
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 = NonEmpty [Char] -> Rule sts ctx () -> Rule sts ctx ()
forall sts (ctx :: RuleType).
NonEmpty [Char] -> Rule sts ctx () -> Rule sts ctx ()
labeled (NonEmpty [Char] -> Rule sts ctx () -> Rule sts ctx ())
-> NonEmpty [Char] -> Rule sts ctx () -> Rule sts ctx ()
forall a b. (a -> b) -> a -> b
$ [Char]
lblStatic [Char] -> [[Char]] -> NonEmpty [Char]
forall a. a -> [a] -> NonEmpty a
NE.:| [[Char]
lbl2Phase]