-- editorconfig-checker-disable-file
{-# LANGUAGE DeriveAnyClass    #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE StrictData        #-}
{-# LANGUAGE TemplateHaskell   #-}
{-# LANGUAGE TypeApplications  #-}

module PlutusLedgerApi.Common.Eval
    ( EvaluationError (..)
    , EvaluationContext (..)
    , AsScriptDecodeError (..)
    , LogOutput
    , VerboseMode (..)
    , evaluateScriptRestricting
    , evaluateScriptCounting
    , evaluateTerm
    , mkDynEvaluationContext
    , toMachineParameters
    , mkTermToEvaluate
    , assertWellFormedCostModelParams
    ) where

import PlutusCore
import PlutusCore.Builtin (readKnown)
import PlutusCore.Data as Plutus
import PlutusCore.Default
import PlutusCore.Evaluation.Machine.CostModelInterface as Plutus
import PlutusCore.Evaluation.Machine.ExBudget as Plutus
import PlutusCore.Evaluation.Machine.ExBudgetingDefaults qualified as Plutus
import PlutusCore.Evaluation.Machine.MachineParameters.Default
import PlutusCore.MkPlc qualified as UPLC
import PlutusCore.Pretty
import PlutusLedgerApi.Common.SerialisedScript
import PlutusLedgerApi.Common.Versions
import PlutusPrelude
import UntypedPlutusCore qualified as UPLC
import UntypedPlutusCore.Evaluation.Machine.Cek qualified as UPLC

import Control.Lens
import Control.Monad (unless)
import Control.Monad.Error.Lens
import Control.Monad.Except (MonadError (..), liftEither, runExceptT)
import Control.Monad.Writer (MonadWriter (..), runWriter)
import Data.Set as Set
import Data.Text (Text)
import Data.Tuple
import NoThunks.Class

-- | Errors that can be thrown when evaluating a Plutus script.
data EvaluationError =
    CekError !(UPLC.CekEvaluationException NamedDeBruijn DefaultUni DefaultFun) -- ^ An error from the evaluator itself
    | DeBruijnError !FreeVariableError -- ^ An error in the pre-evaluation step of converting from de-Bruijn indices
    | CodecError !ScriptDecodeError -- ^ A deserialisation error
    -- TODO: make this error more informative when we have more information about what went wrong
    | CostModelParameterMismatch -- ^ An error indicating that the cost model parameters didn't match what we expected
    | InvalidReturnValue -- ^ The script evaluated to a value that is not a valid return value.
    deriving stock (Int -> EvaluationError -> ShowS
[EvaluationError] -> ShowS
EvaluationError -> [Char]
(Int -> EvaluationError -> ShowS)
-> (EvaluationError -> [Char])
-> ([EvaluationError] -> ShowS)
-> Show EvaluationError
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> EvaluationError -> ShowS
showsPrec :: Int -> EvaluationError -> ShowS
$cshow :: EvaluationError -> [Char]
show :: EvaluationError -> [Char]
$cshowList :: [EvaluationError] -> ShowS
showList :: [EvaluationError] -> ShowS
Show, EvaluationError -> EvaluationError -> Bool
(EvaluationError -> EvaluationError -> Bool)
-> (EvaluationError -> EvaluationError -> Bool)
-> Eq EvaluationError
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: EvaluationError -> EvaluationError -> Bool
== :: EvaluationError -> EvaluationError -> Bool
$c/= :: EvaluationError -> EvaluationError -> Bool
/= :: EvaluationError -> EvaluationError -> Bool
Eq)
makeClassyPrisms ''EvaluationError

instance AsScriptDecodeError EvaluationError where
    _ScriptDecodeError :: Prism' EvaluationError ScriptDecodeError
_ScriptDecodeError = p ScriptDecodeError (f ScriptDecodeError)
-> p EvaluationError (f EvaluationError)
forall r. AsEvaluationError r => Prism' r ScriptDecodeError
Prism' EvaluationError ScriptDecodeError
_CodecError

instance Pretty EvaluationError where
    pretty :: forall ann. EvaluationError -> Doc ann
pretty (CekError CekEvaluationException NamedDeBruijn DefaultUni DefaultFun
e)               = CekEvaluationException NamedDeBruijn DefaultUni DefaultFun
-> Doc ann
forall a ann. PrettyClassic a => a -> Doc ann
prettyClassic CekEvaluationException NamedDeBruijn DefaultUni DefaultFun
e
    pretty (DeBruijnError FreeVariableError
e)          = FreeVariableError -> Doc ann
forall a ann. Pretty a => a -> Doc ann
forall ann. FreeVariableError -> Doc ann
pretty FreeVariableError
e
    pretty (CodecError ScriptDecodeError
e)             = ScriptDecodeError -> Doc ann
forall a ann. Pretty a => a -> Doc ann
forall ann. ScriptDecodeError -> Doc ann
pretty ScriptDecodeError
e
    pretty EvaluationError
CostModelParameterMismatch = Doc ann
"Cost model parameters were not as we expected"
    pretty EvaluationError
InvalidReturnValue         =
        Doc ann
"The evaluation finished but the result value is not valid. "
        Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
"Plutus V3 scripts must return BuiltinUnit. "
        Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
"Returning any other value is considered a failure."

-- | A simple toggle indicating whether or not we should accumulate logs during script execution.
data VerboseMode =
    Verbose -- ^ accumulate all traces
    | Quiet -- ^ don't accumulate anything
    deriving stock (VerboseMode -> VerboseMode -> Bool
(VerboseMode -> VerboseMode -> Bool)
-> (VerboseMode -> VerboseMode -> Bool) -> Eq VerboseMode
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: VerboseMode -> VerboseMode -> Bool
== :: VerboseMode -> VerboseMode -> Bool
$c/= :: VerboseMode -> VerboseMode -> Bool
/= :: VerboseMode -> VerboseMode -> Bool
Eq)

{-| The type of the executed script's accumulated log output: a list of 'Text'.

It will be an empty list if the `VerboseMode` is set to `Quiet`.
-}
type LogOutput = [Text]

{-| Shared helper for the evaluation functions: 'evaluateScriptCounting' and 'evaluateScriptRestricting',

Given a 'ScriptForEvaluation':

1) applies the term to a list of 'Data' arguments (e.g. Datum, Redeemer, `ScriptContext`)
2) checks that the applied-term is well-scoped
3) returns the applied-term
-}
mkTermToEvaluate
    :: (MonadError EvaluationError m)
    => PlutusLedgerLanguage -- ^ the Plutus ledger language of the script under execution.
    -> MajorProtocolVersion -- ^ which major protocol version to run the operation in
    -> ScriptForEvaluation -- ^ the script to evaluate
    -> [Plutus.Data] -- ^ the arguments that the script's underlying term will be applied to
    -> m (UPLC.Term UPLC.NamedDeBruijn DefaultUni DefaultFun ())
mkTermToEvaluate :: forall (m :: * -> *).
MonadError EvaluationError m =>
PlutusLedgerLanguage
-> MajorProtocolVersion
-> ScriptForEvaluation
-> [Data]
-> m (Term NamedDeBruijn DefaultUni DefaultFun ())
mkTermToEvaluate PlutusLedgerLanguage
ll MajorProtocolVersion
pv ScriptForEvaluation
script [Data]
args = do
    let ScriptNamedDeBruijn (UPLC.Program ()
_ Version
v Term NamedDeBruijn DefaultUni DefaultFun ()
t) = ScriptForEvaluation -> ScriptNamedDeBruijn
deserialisedScript ScriptForEvaluation
script
        termArgs :: [Term NamedDeBruijn DefaultUni DefaultFun ()]
termArgs = (Data -> Term NamedDeBruijn DefaultUni DefaultFun ())
-> [Data] -> [Term NamedDeBruijn DefaultUni DefaultFun ()]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (() -> Data -> Term NamedDeBruijn DefaultUni DefaultFun ()
forall a (uni :: * -> *) fun (term :: * -> *) tyname name ann.
(TermLike term tyname name uni fun, HasTermLevel uni a) =>
ann -> a -> term ann
UPLC.mkConstant ()) [Data]
args
        appliedT :: Term NamedDeBruijn DefaultUni DefaultFun ()
appliedT = Term NamedDeBruijn DefaultUni DefaultFun ()
-> [Term NamedDeBruijn DefaultUni DefaultFun ()]
-> Term NamedDeBruijn DefaultUni DefaultFun ()
forall (term :: * -> *) tyname name (uni :: * -> *) fun.
TermLike term tyname name uni fun =>
term () -> [term ()] -> term ()
UPLC.mkIterAppNoAnn Term NamedDeBruijn DefaultUni DefaultFun ()
t [Term NamedDeBruijn DefaultUni DefaultFun ()]
termArgs

    -- check that the Plutus Core language version is available
    -- See Note [Checking the Plutus Core language version]
    Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Version
v Version -> Set Version -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` PlutusLedgerLanguage -> MajorProtocolVersion -> Set Version
plcVersionsAvailableIn PlutusLedgerLanguage
ll MajorProtocolVersion
pv) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
      AReview EvaluationError ScriptDecodeError
-> ScriptDecodeError -> m ()
forall e (m :: * -> *) t x.
MonadError e m =>
AReview e t -> t -> m x
throwing AReview EvaluationError ScriptDecodeError
forall r. AsScriptDecodeError r => Prism' r ScriptDecodeError
Prism' EvaluationError ScriptDecodeError
_ScriptDecodeError (ScriptDecodeError -> m ()) -> ScriptDecodeError -> m ()
forall a b. (a -> b) -> a -> b
$ Version
-> PlutusLedgerLanguage
-> MajorProtocolVersion
-> ScriptDecodeError
PlutusCoreLanguageNotAvailableError Version
v PlutusLedgerLanguage
ll MajorProtocolVersion
pv

    -- make sure that term is closed, i.e. well-scoped
    (Term NamedDeBruijn DefaultUni DefaultFun () -> m ())
-> Term NamedDeBruijn DefaultUni DefaultFun ()
-> m (Term NamedDeBruijn DefaultUni DefaultFun ())
forall (f :: * -> *) a b. Functor f => (a -> f b) -> a -> f a
through (Either EvaluationError () -> m ()
forall e (m :: * -> *) a. MonadError e m => Either e a -> m a
liftEither (Either EvaluationError () -> m ())
-> (Term NamedDeBruijn DefaultUni DefaultFun ()
    -> Either EvaluationError ())
-> Term NamedDeBruijn DefaultUni DefaultFun ()
-> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FreeVariableError -> EvaluationError)
-> Either FreeVariableError () -> Either EvaluationError ()
forall a b c. (a -> b) -> Either a c -> Either b c
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first FreeVariableError -> EvaluationError
DeBruijnError (Either FreeVariableError () -> Either EvaluationError ())
-> (Term NamedDeBruijn DefaultUni DefaultFun ()
    -> Either FreeVariableError ())
-> Term NamedDeBruijn DefaultUni DefaultFun ()
-> Either EvaluationError ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Term NamedDeBruijn DefaultUni DefaultFun ()
-> Either FreeVariableError ()
forall e (m :: * -> *) name (uni :: * -> *) fun a.
(HasIndex name, MonadError e m, AsFreeVariableError e) =>
Term name uni fun a -> m ()
UPLC.checkScope) Term NamedDeBruijn DefaultUni DefaultFun ()
appliedT

toMachineParameters :: MajorProtocolVersion -> EvaluationContext -> DefaultMachineParameters
toMachineParameters :: MajorProtocolVersion
-> EvaluationContext -> DefaultMachineParameters
toMachineParameters MajorProtocolVersion
pv (EvaluationContext PlutusLedgerLanguage
ll MajorProtocolVersion -> BuiltinSemanticsVariant DefaultFun
toSemVar [(BuiltinSemanticsVariant DefaultFun, DefaultMachineParameters)]
machParsList) =
    case BuiltinSemanticsVariant DefaultFun
-> [(BuiltinSemanticsVariant DefaultFun, DefaultMachineParameters)]
-> Maybe DefaultMachineParameters
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup (MajorProtocolVersion -> BuiltinSemanticsVariant DefaultFun
toSemVar MajorProtocolVersion
pv) [(BuiltinSemanticsVariant DefaultFun, DefaultMachineParameters)]
machParsList of
        Maybe DefaultMachineParameters
Nothing -> [Char] -> DefaultMachineParameters
forall a. HasCallStack => [Char] -> a
error ([Char] -> DefaultMachineParameters)
-> [Char] -> DefaultMachineParameters
forall a b. (a -> b) -> a -> b
$ [[Char]] -> [Char]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
Prelude.concat
            [[Char]
"Internal error: ", PlutusLedgerLanguage -> [Char]
forall a. Show a => a -> [Char]
show PlutusLedgerLanguage
ll, [Char]
" does not support protocol version ", MajorProtocolVersion -> [Char]
forall a. Show a => a -> [Char]
show MajorProtocolVersion
pv]
        Just DefaultMachineParameters
machPars -> DefaultMachineParameters
machPars

{-| An opaque type that contains all the static parameters that the evaluator needs to evaluate a
script. This is so that they can be computed once and cached, rather than being recomputed on every
evaluation.

Different protocol versions may require different bundles of machine parameters, which allows us for
example to tweak the shape of the costing function of a builtin, so that the builtin costs less.
Currently this means that we have to create multiple 'DefaultMachineParameters' per language
version, which we put into a cache (represented by an association list) in order to avoid costly
recomputation of machine parameters.

In order to get the appropriate 'DefaultMachineParameters' at validation time we look it up in the
cache using a semantics variant as a key. We compute the semantics variant from the protocol
version using the stored function. Note that the semantics variant depends on the language version
too, but the latter is known statically (because each language version has its own evaluation
context), hence there's no reason to require it to be provided at runtime.

To say it differently, there's a matrix of semantics variants indexed by (LL, PV) pairs and we
cache its particular row corresponding to the statically given LL in an 'EvaluationContext'.

The reason why we associate a 'DefaultMachineParameters' with a semantics variant rather than a
protocol version are

1. generally there are far more protocol versions than semantics variants supported by a specific
   language version, so we save on pointless duplication of bundles of machine parameters
2. builtins don't know anything about protocol versions, only semantics variants. It is therefore
   more semantically precise to associate bundles of machine parameters with semantics variants than
   with protocol versions
-}
data EvaluationContext = EvaluationContext
    { EvaluationContext -> PlutusLedgerLanguage
_evalCtxLedgerLang    :: PlutusLedgerLanguage
      -- ^ Specifies what language versions the 'EvaluationContext' is for.
    , EvaluationContext
-> MajorProtocolVersion -> BuiltinSemanticsVariant DefaultFun
_evalCtxToSemVar      :: MajorProtocolVersion -> BuiltinSemanticsVariant DefaultFun
      -- ^ Specifies how to get a semantics variant for this ledger language given a
      -- 'MajorProtocolVersion'.
    , EvaluationContext
-> [(BuiltinSemanticsVariant DefaultFun, DefaultMachineParameters)]
_evalCtxMachParsCache :: [(BuiltinSemanticsVariant DefaultFun, DefaultMachineParameters)]
      -- ^ The cache of 'DefaultMachineParameters' for each semantics variant supported by the
      -- current language version.
    }
    deriving stock (forall x. EvaluationContext -> Rep EvaluationContext x)
-> (forall x. Rep EvaluationContext x -> EvaluationContext)
-> Generic EvaluationContext
forall x. Rep EvaluationContext x -> EvaluationContext
forall x. EvaluationContext -> Rep EvaluationContext x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. EvaluationContext -> Rep EvaluationContext x
from :: forall x. EvaluationContext -> Rep EvaluationContext x
$cto :: forall x. Rep EvaluationContext x -> EvaluationContext
to :: forall x. Rep EvaluationContext x -> EvaluationContext
Generic
    deriving anyclass (EvaluationContext -> ()
(EvaluationContext -> ()) -> NFData EvaluationContext
forall a. (a -> ()) -> NFData a
$crnf :: EvaluationContext -> ()
rnf :: EvaluationContext -> ()
NFData, [[Char]] -> EvaluationContext -> IO (Maybe ThunkInfo)
Proxy EvaluationContext -> [Char]
([[Char]] -> EvaluationContext -> IO (Maybe ThunkInfo))
-> ([[Char]] -> EvaluationContext -> IO (Maybe ThunkInfo))
-> (Proxy EvaluationContext -> [Char])
-> NoThunks EvaluationContext
forall a.
([[Char]] -> a -> IO (Maybe ThunkInfo))
-> ([[Char]] -> a -> IO (Maybe ThunkInfo))
-> (Proxy a -> [Char])
-> NoThunks a
$cnoThunks :: [[Char]] -> EvaluationContext -> IO (Maybe ThunkInfo)
noThunks :: [[Char]] -> EvaluationContext -> IO (Maybe ThunkInfo)
$cwNoThunks :: [[Char]] -> EvaluationContext -> IO (Maybe ThunkInfo)
wNoThunks :: [[Char]] -> EvaluationContext -> IO (Maybe ThunkInfo)
$cshowTypeOf :: Proxy EvaluationContext -> [Char]
showTypeOf :: Proxy EvaluationContext -> [Char]
NoThunks)

{-|  Create an 'EvaluationContext' given all builtin semantics variants supported by the provided
language version.

The input is a `Map` of `Text`s to cost integer values (aka `Plutus.CostModelParams`, `Alonzo.CostModel`)
See Note [Inlining meanings of builtins].

IMPORTANT: the 'toSemVar' argument computes the semantics variant for each 'MajorProtocolVersion'
and it must only return semantics variants from the 'semVars' list, as well as cover ANY
'MajorProtocolVersion', including those that do not exist yet (i.e. 'toSemVar' must never fail).

IMPORTANT: The evaluation context of every Plutus version must be recreated upon a protocol update
with the updated cost model parameters.
-}
mkDynEvaluationContext
    :: MonadError CostModelApplyError m
    => PlutusLedgerLanguage
    -> [BuiltinSemanticsVariant DefaultFun]
    -> (MajorProtocolVersion -> BuiltinSemanticsVariant DefaultFun)
    -> Plutus.CostModelParams
    -> m EvaluationContext
mkDynEvaluationContext :: forall (m :: * -> *).
MonadError CostModelApplyError m =>
PlutusLedgerLanguage
-> [BuiltinSemanticsVariant DefaultFun]
-> (MajorProtocolVersion -> BuiltinSemanticsVariant DefaultFun)
-> CostModelParams
-> m EvaluationContext
mkDynEvaluationContext PlutusLedgerLanguage
ll [BuiltinSemanticsVariant DefaultFun]
semVars MajorProtocolVersion -> BuiltinSemanticsVariant DefaultFun
toSemVar CostModelParams
newCMP =
    PlutusLedgerLanguage
-> (MajorProtocolVersion -> BuiltinSemanticsVariant DefaultFun)
-> [(BuiltinSemanticsVariant DefaultFun, DefaultMachineParameters)]
-> EvaluationContext
EvaluationContext PlutusLedgerLanguage
ll MajorProtocolVersion -> BuiltinSemanticsVariant DefaultFun
toSemVar ([(BuiltinSemanticsVariant DefaultFun, DefaultMachineParameters)]
 -> EvaluationContext)
-> m [(BuiltinSemanticsVariant DefaultFun,
       DefaultMachineParameters)]
-> m EvaluationContext
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [BuiltinSemanticsVariant DefaultFun]
-> CostModelParams
-> m [(BuiltinSemanticsVariant DefaultFun,
       DefaultMachineParameters)]
forall (m :: * -> *).
MonadError CostModelApplyError m =>
[BuiltinSemanticsVariant DefaultFun]
-> CostModelParams
-> m [(BuiltinSemanticsVariant DefaultFun,
       DefaultMachineParameters)]
mkMachineParametersFor [BuiltinSemanticsVariant DefaultFun]
semVars CostModelParams
newCMP

-- FIXME: remove this function
assertWellFormedCostModelParams :: MonadError CostModelApplyError m => Plutus.CostModelParams -> m ()
assertWellFormedCostModelParams :: forall (m :: * -> *).
MonadError CostModelApplyError m =>
CostModelParams -> m ()
assertWellFormedCostModelParams = m (CostModel (CekMachineCostsBase Identity) BuiltinCostModel)
-> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (m (CostModel (CekMachineCostsBase Identity) BuiltinCostModel)
 -> m ())
-> (CostModelParams
    -> m (CostModel (CekMachineCostsBase Identity) BuiltinCostModel))
-> CostModelParams
-> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CostModel (CekMachineCostsBase Identity) BuiltinCostModel
-> CostModelParams
-> m (CostModel (CekMachineCostsBase Identity) BuiltinCostModel)
forall evaluatorcosts builtincosts (m :: * -> *).
(FromJSON evaluatorcosts, FromJSON builtincosts,
 ToJSON evaluatorcosts, ToJSON builtincosts,
 MonadError CostModelApplyError m) =>
CostModel evaluatorcosts builtincosts
-> CostModelParams -> m (CostModel evaluatorcosts builtincosts)
Plutus.applyCostModelParams CostModel (CekMachineCostsBase Identity) BuiltinCostModel
Plutus.defaultCekCostModelForTesting

-- | Evaluate a fully-applied term using the CEK machine. Useful for mimicking the behaviour of the
-- on-chain evaluator.
evaluateTerm
    :: UPLC.ExBudgetMode cost DefaultUni DefaultFun
    -> MajorProtocolVersion
    -> VerboseMode
    -> EvaluationContext
    -> UPLC.Term UPLC.NamedDeBruijn DefaultUni DefaultFun ()
    -> ( Either
            (UPLC.CekEvaluationException NamedDeBruijn DefaultUni DefaultFun)
            (UPLC.Term UPLC.NamedDeBruijn DefaultUni DefaultFun ())
       , cost
       , [Text]
       )
evaluateTerm :: forall cost.
ExBudgetMode cost DefaultUni DefaultFun
-> MajorProtocolVersion
-> VerboseMode
-> EvaluationContext
-> Term NamedDeBruijn DefaultUni DefaultFun ()
-> (Either
      (CekEvaluationException NamedDeBruijn DefaultUni DefaultFun)
      (Term NamedDeBruijn DefaultUni DefaultFun ()),
    cost, LogOutput)
evaluateTerm ExBudgetMode cost DefaultUni DefaultFun
budgetMode MajorProtocolVersion
pv VerboseMode
verbose EvaluationContext
ectx =
    DefaultMachineParameters
-> ExBudgetMode cost DefaultUni DefaultFun
-> EmitterMode DefaultUni DefaultFun
-> Term NamedDeBruijn DefaultUni DefaultFun ()
-> (Either
      (CekEvaluationException NamedDeBruijn DefaultUni DefaultFun)
      (Term NamedDeBruijn DefaultUni DefaultFun ()),
    cost, LogOutput)
forall (uni :: * -> *) fun ann cost.
ThrowableBuiltins uni fun =>
MachineParameters
  (CekMachineCostsBase Identity) fun (CekValue uni fun ann)
-> ExBudgetMode cost uni fun
-> EmitterMode uni fun
-> NTerm uni fun ann
-> (Either
      (CekEvaluationException NamedDeBruijn uni fun) (NTerm uni fun ()),
    cost, LogOutput)
UPLC.runCekDeBruijn
        (MajorProtocolVersion
-> EvaluationContext -> DefaultMachineParameters
toMachineParameters MajorProtocolVersion
pv EvaluationContext
ectx)
        ExBudgetMode cost DefaultUni DefaultFun
budgetMode
        (if VerboseMode
verbose VerboseMode -> VerboseMode -> Bool
forall a. Eq a => a -> a -> Bool
== VerboseMode
Verbose then EmitterMode DefaultUni DefaultFun
forall (uni :: * -> *) fun. EmitterMode uni fun
UPLC.logEmitter else EmitterMode DefaultUni DefaultFun
forall (uni :: * -> *) fun. EmitterMode uni fun
UPLC.noEmitter)
-- Just replicating the old behavior, probably doesn't matter.
{-# INLINE evaluateTerm #-}

{-| Evaluates a script, with a cost model and a budget that restricts how many
resources it can use according to the cost model. Also returns the budget that
was actually used.

Can be used to calculate budgets for scripts, but even in this case you must give
a limit to guard against scripts that run for a long time or loop.

Note: Parameterized over the 'LedgerPlutusVersion' since
1. The builtins allowed (during decoding) differ, and
2. The Plutus language versions allowed differ.
-}
evaluateScriptRestricting
    :: PlutusLedgerLanguage -- ^ The Plutus ledger language of the script under execution.
    -> MajorProtocolVersion -- ^ Which major protocol version to run the operation in
    -> VerboseMode          -- ^ Whether to produce log output
    -> EvaluationContext    -- ^ Includes the cost model to use for tallying up the execution costs
    -> ExBudget             -- ^ The resource budget which must not be exceeded during evaluation
    -> ScriptForEvaluation  -- ^ The script to evaluate
    -> [Plutus.Data]        -- ^ The arguments to the script
    -> (LogOutput, Either EvaluationError ExBudget)
evaluateScriptRestricting :: PlutusLedgerLanguage
-> MajorProtocolVersion
-> VerboseMode
-> EvaluationContext
-> ExBudget
-> ScriptForEvaluation
-> [Data]
-> (LogOutput, Either EvaluationError ExBudget)
evaluateScriptRestricting PlutusLedgerLanguage
ll MajorProtocolVersion
pv VerboseMode
verbose EvaluationContext
ectx ExBudget
budget ScriptForEvaluation
p [Data]
args = (Either EvaluationError ExBudget, LogOutput)
-> (LogOutput, Either EvaluationError ExBudget)
forall a b. (a, b) -> (b, a)
swap ((Either EvaluationError ExBudget, LogOutput)
 -> (LogOutput, Either EvaluationError ExBudget))
-> (Either EvaluationError ExBudget, LogOutput)
-> (LogOutput, Either EvaluationError ExBudget)
forall a b. (a -> b) -> a -> b
$ forall w a. Writer w a -> (a, w)
runWriter @LogOutput (Writer LogOutput (Either EvaluationError ExBudget)
 -> (Either EvaluationError ExBudget, LogOutput))
-> Writer LogOutput (Either EvaluationError ExBudget)
-> (Either EvaluationError ExBudget, LogOutput)
forall a b. (a -> b) -> a -> b
$ ExceptT EvaluationError (WriterT LogOutput Identity) ExBudget
-> Writer LogOutput (Either EvaluationError ExBudget)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT EvaluationError (WriterT LogOutput Identity) ExBudget
 -> Writer LogOutput (Either EvaluationError ExBudget))
-> ExceptT EvaluationError (WriterT LogOutput Identity) ExBudget
-> Writer LogOutput (Either EvaluationError ExBudget)
forall a b. (a -> b) -> a -> b
$ do
    Term NamedDeBruijn DefaultUni DefaultFun ()
appliedTerm <- PlutusLedgerLanguage
-> MajorProtocolVersion
-> ScriptForEvaluation
-> [Data]
-> ExceptT
     EvaluationError
     (WriterT LogOutput Identity)
     (Term NamedDeBruijn DefaultUni DefaultFun ())
forall (m :: * -> *).
MonadError EvaluationError m =>
PlutusLedgerLanguage
-> MajorProtocolVersion
-> ScriptForEvaluation
-> [Data]
-> m (Term NamedDeBruijn DefaultUni DefaultFun ())
mkTermToEvaluate PlutusLedgerLanguage
ll MajorProtocolVersion
pv ScriptForEvaluation
p [Data]
args
    let (Either
  (CekEvaluationException NamedDeBruijn DefaultUni DefaultFun)
  (Term NamedDeBruijn DefaultUni DefaultFun ())
res, UPLC.RestrictingSt (ExRestrictingBudget ExBudget
final), LogOutput
logs) =
            ExBudgetMode RestrictingSt DefaultUni DefaultFun
-> MajorProtocolVersion
-> VerboseMode
-> EvaluationContext
-> Term NamedDeBruijn DefaultUni DefaultFun ()
-> (Either
      (CekEvaluationException NamedDeBruijn DefaultUni DefaultFun)
      (Term NamedDeBruijn DefaultUni DefaultFun ()),
    RestrictingSt, LogOutput)
forall cost.
ExBudgetMode cost DefaultUni DefaultFun
-> MajorProtocolVersion
-> VerboseMode
-> EvaluationContext
-> Term NamedDeBruijn DefaultUni DefaultFun ()
-> (Either
      (CekEvaluationException NamedDeBruijn DefaultUni DefaultFun)
      (Term NamedDeBruijn DefaultUni DefaultFun ()),
    cost, LogOutput)
evaluateTerm (ExRestrictingBudget
-> ExBudgetMode RestrictingSt DefaultUni DefaultFun
forall (uni :: * -> *) fun.
ThrowableBuiltins uni fun =>
ExRestrictingBudget -> ExBudgetMode RestrictingSt uni fun
UPLC.restricting (ExRestrictingBudget
 -> ExBudgetMode RestrictingSt DefaultUni DefaultFun)
-> ExRestrictingBudget
-> ExBudgetMode RestrictingSt DefaultUni DefaultFun
forall a b. (a -> b) -> a -> b
$ ExBudget -> ExRestrictingBudget
ExRestrictingBudget ExBudget
budget) MajorProtocolVersion
pv VerboseMode
verbose EvaluationContext
ectx Term NamedDeBruijn DefaultUni DefaultFun ()
appliedTerm
    PlutusLedgerLanguage
-> LogOutput
-> Either
     (CekEvaluationException NamedDeBruijn DefaultUni DefaultFun)
     (Term NamedDeBruijn DefaultUni DefaultFun ())
-> ExceptT EvaluationError (WriterT LogOutput Identity) ()
forall (m :: * -> *).
(MonadError EvaluationError m, MonadWriter LogOutput m) =>
PlutusLedgerLanguage
-> LogOutput
-> Either
     (CekEvaluationException NamedDeBruijn DefaultUni DefaultFun)
     (Term NamedDeBruijn DefaultUni DefaultFun ())
-> m ()
processLogsAndErrors PlutusLedgerLanguage
ll LogOutput
logs Either
  (CekEvaluationException NamedDeBruijn DefaultUni DefaultFun)
  (Term NamedDeBruijn DefaultUni DefaultFun ())
res
    ExBudget
-> ExceptT EvaluationError (WriterT LogOutput Identity) ExBudget
forall a.
a -> ExceptT EvaluationError (WriterT LogOutput Identity) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ExBudget
budget ExBudget -> ExBudget -> ExBudget
`minusExBudget` ExBudget
final)

{-| Evaluates a script, returning the minimum budget that the script would need
to evaluate successfully. This will take as long as the script takes, if you need to
limit the execution time of the script also, you can use 'evaluateScriptRestricting', which
also returns the used budget.

Note: Parameterized over the ledger-plutus-version since the builtins allowed (during decoding) differs.
-}
evaluateScriptCounting
    :: PlutusLedgerLanguage -- ^ The Plutus ledger language of the script under execution.
    -> MajorProtocolVersion -- ^ Which major protocol version to run the operation in
    -> VerboseMode          -- ^ Whether to produce log output
    -> EvaluationContext    -- ^ Includes the cost model to use for tallying up the execution costs
    -> ScriptForEvaluation  -- ^ The script to evaluate
    -> [Plutus.Data]        -- ^ The arguments to the script
    -> (LogOutput, Either EvaluationError ExBudget)
evaluateScriptCounting :: PlutusLedgerLanguage
-> MajorProtocolVersion
-> VerboseMode
-> EvaluationContext
-> ScriptForEvaluation
-> [Data]
-> (LogOutput, Either EvaluationError ExBudget)
evaluateScriptCounting PlutusLedgerLanguage
ll MajorProtocolVersion
pv VerboseMode
verbose EvaluationContext
ectx ScriptForEvaluation
p [Data]
args = (Either EvaluationError ExBudget, LogOutput)
-> (LogOutput, Either EvaluationError ExBudget)
forall a b. (a, b) -> (b, a)
swap ((Either EvaluationError ExBudget, LogOutput)
 -> (LogOutput, Either EvaluationError ExBudget))
-> (Either EvaluationError ExBudget, LogOutput)
-> (LogOutput, Either EvaluationError ExBudget)
forall a b. (a -> b) -> a -> b
$ forall w a. Writer w a -> (a, w)
runWriter @LogOutput (Writer LogOutput (Either EvaluationError ExBudget)
 -> (Either EvaluationError ExBudget, LogOutput))
-> Writer LogOutput (Either EvaluationError ExBudget)
-> (Either EvaluationError ExBudget, LogOutput)
forall a b. (a -> b) -> a -> b
$ ExceptT EvaluationError (WriterT LogOutput Identity) ExBudget
-> Writer LogOutput (Either EvaluationError ExBudget)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT EvaluationError (WriterT LogOutput Identity) ExBudget
 -> Writer LogOutput (Either EvaluationError ExBudget))
-> ExceptT EvaluationError (WriterT LogOutput Identity) ExBudget
-> Writer LogOutput (Either EvaluationError ExBudget)
forall a b. (a -> b) -> a -> b
$ do
    Term NamedDeBruijn DefaultUni DefaultFun ()
appliedTerm <- PlutusLedgerLanguage
-> MajorProtocolVersion
-> ScriptForEvaluation
-> [Data]
-> ExceptT
     EvaluationError
     (WriterT LogOutput Identity)
     (Term NamedDeBruijn DefaultUni DefaultFun ())
forall (m :: * -> *).
MonadError EvaluationError m =>
PlutusLedgerLanguage
-> MajorProtocolVersion
-> ScriptForEvaluation
-> [Data]
-> m (Term NamedDeBruijn DefaultUni DefaultFun ())
mkTermToEvaluate PlutusLedgerLanguage
ll MajorProtocolVersion
pv ScriptForEvaluation
p [Data]
args
    let (Either
  (CekEvaluationException NamedDeBruijn DefaultUni DefaultFun)
  (Term NamedDeBruijn DefaultUni DefaultFun ())
res, UPLC.CountingSt ExBudget
final, LogOutput
logs) =
            ExBudgetMode CountingSt DefaultUni DefaultFun
-> MajorProtocolVersion
-> VerboseMode
-> EvaluationContext
-> Term NamedDeBruijn DefaultUni DefaultFun ()
-> (Either
      (CekEvaluationException NamedDeBruijn DefaultUni DefaultFun)
      (Term NamedDeBruijn DefaultUni DefaultFun ()),
    CountingSt, LogOutput)
forall cost.
ExBudgetMode cost DefaultUni DefaultFun
-> MajorProtocolVersion
-> VerboseMode
-> EvaluationContext
-> Term NamedDeBruijn DefaultUni DefaultFun ()
-> (Either
      (CekEvaluationException NamedDeBruijn DefaultUni DefaultFun)
      (Term NamedDeBruijn DefaultUni DefaultFun ()),
    cost, LogOutput)
evaluateTerm ExBudgetMode CountingSt DefaultUni DefaultFun
forall (uni :: * -> *) fun. ExBudgetMode CountingSt uni fun
UPLC.counting MajorProtocolVersion
pv VerboseMode
verbose EvaluationContext
ectx Term NamedDeBruijn DefaultUni DefaultFun ()
appliedTerm
    PlutusLedgerLanguage
-> LogOutput
-> Either
     (CekEvaluationException NamedDeBruijn DefaultUni DefaultFun)
     (Term NamedDeBruijn DefaultUni DefaultFun ())
-> ExceptT EvaluationError (WriterT LogOutput Identity) ()
forall (m :: * -> *).
(MonadError EvaluationError m, MonadWriter LogOutput m) =>
PlutusLedgerLanguage
-> LogOutput
-> Either
     (CekEvaluationException NamedDeBruijn DefaultUni DefaultFun)
     (Term NamedDeBruijn DefaultUni DefaultFun ())
-> m ()
processLogsAndErrors PlutusLedgerLanguage
ll LogOutput
logs Either
  (CekEvaluationException NamedDeBruijn DefaultUni DefaultFun)
  (Term NamedDeBruijn DefaultUni DefaultFun ())
res
    ExBudget
-> ExceptT EvaluationError (WriterT LogOutput Identity) ExBudget
forall a.
a -> ExceptT EvaluationError (WriterT LogOutput Identity) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ExBudget
final

processLogsAndErrors ::
    forall m.
    (MonadError EvaluationError m, MonadWriter LogOutput m) =>
    PlutusLedgerLanguage ->
    LogOutput ->
    Either
        (UPLC.CekEvaluationException NamedDeBruijn DefaultUni DefaultFun)
        (UPLC.Term UPLC.NamedDeBruijn DefaultUni DefaultFun ()) ->
    m ()
processLogsAndErrors :: forall (m :: * -> *).
(MonadError EvaluationError m, MonadWriter LogOutput m) =>
PlutusLedgerLanguage
-> LogOutput
-> Either
     (CekEvaluationException NamedDeBruijn DefaultUni DefaultFun)
     (Term NamedDeBruijn DefaultUni DefaultFun ())
-> m ()
processLogsAndErrors PlutusLedgerLanguage
ll LogOutput
logs Either
  (CekEvaluationException NamedDeBruijn DefaultUni DefaultFun)
  (Term NamedDeBruijn DefaultUni DefaultFun ())
res = do
    LogOutput -> m ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell LogOutput
logs
    case Either
  (CekEvaluationException NamedDeBruijn DefaultUni DefaultFun)
  (Term NamedDeBruijn DefaultUni DefaultFun ())
res of
        Left CekEvaluationException NamedDeBruijn DefaultUni DefaultFun
e  -> EvaluationError -> m ()
forall a. EvaluationError -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (CekEvaluationException NamedDeBruijn DefaultUni DefaultFun
-> EvaluationError
CekError CekEvaluationException NamedDeBruijn DefaultUni DefaultFun
e)
        Right Term NamedDeBruijn DefaultUni DefaultFun ()
v -> Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (PlutusLedgerLanguage
-> Term NamedDeBruijn DefaultUni DefaultFun () -> Bool
isResultValid PlutusLedgerLanguage
ll Term NamedDeBruijn DefaultUni DefaultFun ()
v) (EvaluationError -> m ()
forall a. EvaluationError -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError EvaluationError
InvalidReturnValue)
{-# INLINE processLogsAndErrors #-}

isResultValid ::
    PlutusLedgerLanguage ->
    UPLC.Term UPLC.NamedDeBruijn DefaultUni DefaultFun () ->
    Bool
isResultValid :: PlutusLedgerLanguage
-> Term NamedDeBruijn DefaultUni DefaultFun () -> Bool
isResultValid PlutusLedgerLanguage
ll Term NamedDeBruijn DefaultUni DefaultFun ()
res = PlutusLedgerLanguage
ll PlutusLedgerLanguage -> PlutusLedgerLanguage -> Bool
forall a. Eq a => a -> a -> Bool
== PlutusLedgerLanguage
PlutusV1 Bool -> Bool -> Bool
|| PlutusLedgerLanguage
ll PlutusLedgerLanguage -> PlutusLedgerLanguage -> Bool
forall a. Eq a => a -> a -> Bool
== PlutusLedgerLanguage
PlutusV2 Bool -> Bool -> Bool
|| Term NamedDeBruijn DefaultUni DefaultFun () -> Bool
forall {val}. ReadKnownIn (UniOf val) val () => val -> Bool
isBuiltinUnit Term NamedDeBruijn DefaultUni DefaultFun ()
res
    where
        isBuiltinUnit :: val -> Bool
isBuiltinUnit val
t = case val -> ReadKnownM ()
forall (uni :: * -> *) val a.
ReadKnownIn uni val a =>
val -> ReadKnownM a
readKnown val
t of
            Right () -> Bool
True
            ReadKnownM ()
_        -> Bool
False
{-# INLINE isResultValid #-}

{- Note [Checking the Plutus Core language version]
Since long ago this check has been in `mkTermToEvaluate`, which makes it a phase 2 failure.
But this is really far too strict: we can check when deserializing, so it can be a phase 1
failure, like the other such checks that we have. For now we keep it as it is, but we may
try to move it later.
-}