{-# 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
data EvaluationError =
CekError !(UPLC.CekEvaluationException NamedDeBruijn DefaultUni DefaultFun)
| DeBruijnError !FreeVariableError
| CodecError !ScriptDecodeError
| CostModelParameterMismatch
| InvalidReturnValue
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."
data VerboseMode =
Verbose
| Quiet
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)
type LogOutput = [Text]
mkTermToEvaluate
:: (MonadError EvaluationError m)
=> PlutusLedgerLanguage
-> MajorProtocolVersion
-> ScriptForEvaluation
-> [Plutus.Data]
-> 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
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
(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
data EvaluationContext = EvaluationContext
{ EvaluationContext -> PlutusLedgerLanguage
_evalCtxLedgerLang :: PlutusLedgerLanguage
, EvaluationContext
-> MajorProtocolVersion -> BuiltinSemanticsVariant DefaultFun
_evalCtxToSemVar :: MajorProtocolVersion -> BuiltinSemanticsVariant DefaultFun
, EvaluationContext
-> [(BuiltinSemanticsVariant DefaultFun, DefaultMachineParameters)]
_evalCtxMachParsCache :: [(BuiltinSemanticsVariant DefaultFun, DefaultMachineParameters)]
}
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)
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
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
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)
{-# INLINE evaluateTerm #-}
evaluateScriptRestricting
:: PlutusLedgerLanguage
-> MajorProtocolVersion
-> VerboseMode
-> EvaluationContext
-> ExBudget
-> ScriptForEvaluation
-> [Plutus.Data]
-> (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)
evaluateScriptCounting
:: PlutusLedgerLanguage
-> MajorProtocolVersion
-> VerboseMode
-> EvaluationContext
-> ScriptForEvaluation
-> [Plutus.Data]
-> (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 #-}