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

module PlutusLedgerApi.Common.Eval where

import Control.Lens
import PlutusCore
import PlutusCore as ScriptPlutus (Version, defaultVersion)
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.Evaluation.Machine.MachineParameters.DeferredMachineParameters
import PlutusCore.Evaluation.Machine.MachineParameters.ImmediateMachineParameters
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.Monad.Except
import Control.Monad.Writer
import Data.Text as Text
import Data.Tuple
import NoThunks.Class
import Prettyprinter

-- | 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
    | IncompatibleVersionError (ScriptPlutus.Version ()) -- ^ An error indicating a version tag that we don't support
    -- 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
    deriving stock (Int -> EvaluationError -> ShowS
[EvaluationError] -> ShowS
EvaluationError -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [EvaluationError] -> ShowS
$cshowList :: [EvaluationError] -> ShowS
show :: EvaluationError -> String
$cshow :: EvaluationError -> String
showsPrec :: Int -> EvaluationError -> ShowS
$cshowsPrec :: Int -> EvaluationError -> ShowS
Show, EvaluationError -> EvaluationError -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: EvaluationError -> EvaluationError -> Bool
$c/= :: EvaluationError -> EvaluationError -> Bool
== :: EvaluationError -> EvaluationError -> Bool
$c== :: EvaluationError -> EvaluationError -> Bool
Eq)
makeClassyPrisms ''EvaluationError

instance AsScriptDecodeError EvaluationError where
    _ScriptDecodeError :: Prism' EvaluationError ScriptDecodeError
_ScriptDecodeError = forall r. AsEvaluationError r => Prism' r ScriptDecodeError
_CodecError

instance Pretty EvaluationError where
    pretty :: forall ann. EvaluationError -> Doc ann
pretty (CekError CekEvaluationException NamedDeBruijn DefaultUni DefaultFun
e)      = forall a ann. PrettyClassic a => a -> Doc ann
prettyClassicDef CekEvaluationException NamedDeBruijn DefaultUni DefaultFun
e
    pretty (DeBruijnError FreeVariableError
e) = forall a ann. Pretty a => a -> Doc ann
pretty FreeVariableError
e
    pretty (CodecError ScriptDecodeError
e) = forall a ann. Show a => a -> Doc ann
viaShow ScriptDecodeError
e
    pretty (IncompatibleVersionError Version ()
actual) = Doc ann
"This version of the Plutus Core interface does not support the version indicated by the AST:" forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall a ann. Pretty a => a -> Doc ann
pretty Version ()
actual
    pretty EvaluationError
CostModelParameterMismatch = Doc ann
"Cost model parameters were not as we expected"

-- | The type of log output: just a list of 'Text'.
type LogOutput = [Text.Text]

-- | A simple toggle indicating whether or not we should produce logs.
data VerboseMode = Verbose | Quiet
    deriving stock (VerboseMode -> VerboseMode -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: VerboseMode -> VerboseMode -> Bool
$c/= :: VerboseMode -> VerboseMode -> Bool
== :: VerboseMode -> VerboseMode -> Bool
$c== :: VerboseMode -> VerboseMode -> Bool
Eq)

-- | Shared helper for the evaluation functions, deserialises the 'SerialisedScript' , applies it to its arguments, puts fakenamedebruijns, and scope-checks it.
mkTermToEvaluate
    :: (MonadError EvaluationError m)
    => LedgerPlutusVersion
    -> ProtocolVersion
    -> SerialisedScript
    -> [Plutus.Data]
    -> m (UPLC.Term UPLC.NamedDeBruijn DefaultUni DefaultFun ())
mkTermToEvaluate :: forall (m :: * -> *).
MonadError EvaluationError m =>
LedgerPlutusVersion
-> ProtocolVersion
-> SerialisedScript
-> [Data]
-> m (Term NamedDeBruijn DefaultUni DefaultFun ())
mkTermToEvaluate LedgerPlutusVersion
lv ProtocolVersion
pv SerialisedScript
bs [Data]
args = do
    -- It decodes the program through the optimized ScriptForExecution. See `ScriptForExecution`.
    ScriptForExecution (UPLC.Program ()
_ Version ()
v Term NamedDeBruijn DefaultUni DefaultFun ()
t) <- forall e (m :: * -> *).
(AsScriptDecodeError e, MonadError e m) =>
LedgerPlutusVersion
-> ProtocolVersion -> SerialisedScript -> m ScriptForExecution
fromSerialisedScript LedgerPlutusVersion
lv ProtocolVersion
pv SerialisedScript
bs
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Version ()
v forall a. Eq a => a -> a -> Bool
== forall ann. ann -> Version ann
ScriptPlutus.defaultVersion ()) forall a b. (a -> b) -> a -> b
$ forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall a b. (a -> b) -> a -> b
$ Version () -> EvaluationError
IncompatibleVersionError Version ()
v
    let termArgs :: [Term NamedDeBruijn DefaultUni DefaultFun ()]
termArgs = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a (uni :: * -> *) fun (term :: * -> *) tyname name ann.
(TermLike term tyname name uni fun, Includes uni a) =>
ann -> a -> term ann
UPLC.mkConstant ()) [Data]
args
        appliedT :: Term NamedDeBruijn DefaultUni DefaultFun ()
appliedT = forall (term :: * -> *) tyname name (uni :: * -> *) fun ann.
TermLike term tyname name uni fun =>
ann -> term ann -> [term ann] -> term ann
UPLC.mkIterApp () Term NamedDeBruijn DefaultUni DefaultFun ()
t [Term NamedDeBruijn DefaultUni DefaultFun ()]
termArgs

    -- make sure that term is closed, i.e. well-scoped
    forall (f :: * -> *) a b. Functor f => (a -> f b) -> a -> f a
through (forall e (m :: * -> *) a. MonadError e m => Either e a -> m a
liftEither forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first FreeVariableError -> EvaluationError
DeBruijnError forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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

-- | Which unlifting mode should we use in the given 'ProtocolVersion'
-- so as to correctly construct the machine's parameters
unliftingModeIn :: ProtocolVersion -> UnliftingMode
unliftingModeIn :: ProtocolVersion -> UnliftingMode
unliftingModeIn ProtocolVersion
pv =
    -- This just changes once in vasil hf version 7.0
    if ProtocolVersion
pv forall a. Ord a => a -> a -> Bool
>= ProtocolVersion
vasilPV then UnliftingMode
UnliftingDeferred else UnliftingMode
UnliftingImmediate

toMachineParameters :: ProtocolVersion -> EvaluationContext -> DefaultMachineParameters
toMachineParameters :: ProtocolVersion -> EvaluationContext -> DefaultMachineParameters
toMachineParameters ProtocolVersion
pv = case ProtocolVersion -> UnliftingMode
unliftingModeIn ProtocolVersion
pv of
    UnliftingMode
UnliftingImmediate -> EvaluationContext -> DefaultMachineParameters
machineParametersImmediate
    UnliftingMode
UnliftingDeferred  -> EvaluationContext -> DefaultMachineParameters
machineParametersDeferred

{-| 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 recomputed on every
evaluation.

There are two sets of parameters: one is with immediate unlifting and the other one is with
deferred unlifting. We have to keep both of them, because depending on the language version
 either one has to be used or the other. We also compile them separately due to all the inlining
 and optimization that need to happen for things to be efficient.
-}
data EvaluationContext = EvaluationContext
    { EvaluationContext -> DefaultMachineParameters
machineParametersImmediate :: DefaultMachineParameters
    , EvaluationContext -> DefaultMachineParameters
machineParametersDeferred  :: DefaultMachineParameters
    }
    deriving stock 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
$cto :: forall x. Rep EvaluationContext x -> EvaluationContext
$cfrom :: forall x. EvaluationContext -> Rep EvaluationContext x
Generic
    deriving anyclass (EvaluationContext -> ()
forall a. (a -> ()) -> NFData a
rnf :: EvaluationContext -> ()
$crnf :: EvaluationContext -> ()
NFData, Context -> EvaluationContext -> IO (Maybe ThunkInfo)
Proxy EvaluationContext -> String
forall a.
(Context -> a -> IO (Maybe ThunkInfo))
-> (Context -> a -> IO (Maybe ThunkInfo))
-> (Proxy a -> String)
-> NoThunks a
showTypeOf :: Proxy EvaluationContext -> String
$cshowTypeOf :: Proxy EvaluationContext -> String
wNoThunks :: Context -> EvaluationContext -> IO (Maybe ThunkInfo)
$cwNoThunks :: Context -> EvaluationContext -> IO (Maybe ThunkInfo)
noThunks :: Context -> EvaluationContext -> IO (Maybe ThunkInfo)
$cnoThunks :: Context -> EvaluationContext -> IO (Maybe ThunkInfo)
NoThunks)

{-|  Build the 'EvaluationContext'.

The input is a `Map` of `Text`s to cost integer values (aka `Plutus.CostModelParams`, `Alonzo.CostModel`)
See Note [Inlining meanings of builtins].
-}
mkDynEvaluationContext :: MonadError CostModelApplyError m => BuiltinVersion DefaultFun -> Plutus.CostModelParams -> m EvaluationContext
mkDynEvaluationContext :: forall (m :: * -> *).
MonadError CostModelApplyError m =>
BuiltinVersion DefaultFun -> CostModelParams -> m EvaluationContext
mkDynEvaluationContext BuiltinVersion DefaultFun
ver CostModelParams
newCMP =
    DefaultMachineParameters
-> DefaultMachineParameters -> EvaluationContext
EvaluationContext
        forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *).
MonadError CostModelApplyError m =>
BuiltinVersion DefaultFun
-> CostModelParams -> m DefaultMachineParameters
immediateMachineParameters BuiltinVersion DefaultFun
ver CostModelParams
newCMP
        forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (m :: * -> *).
MonadError CostModelApplyError m =>
BuiltinVersion DefaultFun
-> CostModelParams -> m DefaultMachineParameters
deferredMachineParameters BuiltinVersion DefaultFun
ver CostModelParams
newCMP

-- | Comparably expensive to `mkEvaluationContext`, so it should only be used sparingly.
assertWellFormedCostModelParams :: MonadError CostModelApplyError m => Plutus.CostModelParams -> m ()
assertWellFormedCostModelParams :: forall (m :: * -> *).
MonadError CostModelApplyError m =>
CostModelParams -> m ()
assertWellFormedCostModelParams = forall (f :: * -> *) a. Functor f => f a -> f ()
void forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 CekMachineCosts BuiltinCostModel
Plutus.defaultCekCostModel

{-|
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 ledger-plutus-version since the builtins allowed (during decoding) differs.
-}
evaluateScriptRestricting
    :: LedgerPlutusVersion
    -> ProtocolVersion
    -> VerboseMode     -- ^ Whether to produce log output
    -> EvaluationContext -- ^ The cost model that should already be synced to the most recent cost-model-params coming from the current protocol
    -> ExBudget        -- ^ The resource budget which must not be exceeded during evaluation
    -> SerialisedScript          -- ^ The script to evaluate
    -> [Plutus.Data]          -- ^ The arguments to the script
    -> (LogOutput, Either EvaluationError ExBudget)
evaluateScriptRestricting :: LedgerPlutusVersion
-> ProtocolVersion
-> VerboseMode
-> EvaluationContext
-> ExBudget
-> SerialisedScript
-> [Data]
-> (LogOutput, Either EvaluationError ExBudget)
evaluateScriptRestricting LedgerPlutusVersion
lv ProtocolVersion
pv VerboseMode
verbose EvaluationContext
ectx ExBudget
budget SerialisedScript
p [Data]
args = forall a b. (a, b) -> (b, a)
swap forall a b. (a -> b) -> a -> b
$ forall w a. Writer w a -> (a, w)
runWriter @LogOutput forall a b. (a -> b) -> a -> b
$ forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT forall a b. (a -> b) -> a -> b
$ do
    Term NamedDeBruijn DefaultUni DefaultFun ()
appliedTerm <- forall (m :: * -> *).
MonadError EvaluationError m =>
LedgerPlutusVersion
-> ProtocolVersion
-> SerialisedScript
-> [Data]
-> m (Term NamedDeBruijn DefaultUni DefaultFun ())
mkTermToEvaluate LedgerPlutusVersion
lv ProtocolVersion
pv SerialisedScript
p [Data]
args

    let (Either
  (CekEvaluationException NamedDeBruijn DefaultUni DefaultFun)
  (Term NamedDeBruijn DefaultUni DefaultFun ())
res, UPLC.RestrictingSt (ExRestrictingBudget ExBudget
final), LogOutput
logs) =
            forall fun (uni :: * -> *) cost.
(Ix fun, PrettyUni uni fun) =>
MachineParameters CekMachineCosts CekValue uni fun
-> ExBudgetMode cost uni fun
-> EmitterMode uni fun
-> Term NamedDeBruijn uni fun ()
-> (Either
      (CekEvaluationException NamedDeBruijn uni fun)
      (Term NamedDeBruijn uni fun ()),
    cost, LogOutput)
UPLC.runCekDeBruijn
                (ProtocolVersion -> EvaluationContext -> DefaultMachineParameters
toMachineParameters ProtocolVersion
pv EvaluationContext
ectx)
                (forall (uni :: * -> *) fun.
PrettyUni uni fun =>
ExRestrictingBudget -> ExBudgetMode RestrictingSt uni fun
UPLC.restricting forall a b. (a -> b) -> a -> b
$ ExBudget -> ExRestrictingBudget
ExRestrictingBudget ExBudget
budget)
                (if VerboseMode
verbose forall a. Eq a => a -> a -> Bool
== VerboseMode
Verbose then forall (uni :: * -> *) fun. EmitterMode uni fun
UPLC.logEmitter else forall (uni :: * -> *) fun. EmitterMode uni fun
UPLC.noEmitter)
                Term NamedDeBruijn DefaultUni DefaultFun ()
appliedTerm

    forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell LogOutput
logs
    forall e (m :: * -> *) a. MonadError e m => Either e a -> m a
liftEither forall a b. (a -> b) -> a -> b
$ forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first CekEvaluationException NamedDeBruijn DefaultUni DefaultFun
-> EvaluationError
CekError forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Functor f => f a -> f ()
void Either
  (CekEvaluationException NamedDeBruijn DefaultUni DefaultFun)
  (Term NamedDeBruijn DefaultUni DefaultFun ())
res
    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
    :: LedgerPlutusVersion
    -> ProtocolVersion
    -> VerboseMode     -- ^ Whether to produce log output
    -> EvaluationContext -- ^ The cost model that should already be synced to the most recent cost-model-params coming from the current protocol
    -> SerialisedScript          -- ^ The script to evaluate
    -> [Plutus.Data]          -- ^ The arguments to the script
    -> (LogOutput, Either EvaluationError ExBudget)
evaluateScriptCounting :: LedgerPlutusVersion
-> ProtocolVersion
-> VerboseMode
-> EvaluationContext
-> SerialisedScript
-> [Data]
-> (LogOutput, Either EvaluationError ExBudget)
evaluateScriptCounting LedgerPlutusVersion
lv ProtocolVersion
pv VerboseMode
verbose EvaluationContext
ectx SerialisedScript
p [Data]
args = forall a b. (a, b) -> (b, a)
swap forall a b. (a -> b) -> a -> b
$ forall w a. Writer w a -> (a, w)
runWriter @LogOutput forall a b. (a -> b) -> a -> b
$ forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT forall a b. (a -> b) -> a -> b
$ do
    Term NamedDeBruijn DefaultUni DefaultFun ()
appliedTerm <- forall (m :: * -> *).
MonadError EvaluationError m =>
LedgerPlutusVersion
-> ProtocolVersion
-> SerialisedScript
-> [Data]
-> m (Term NamedDeBruijn DefaultUni DefaultFun ())
mkTermToEvaluate LedgerPlutusVersion
lv ProtocolVersion
pv SerialisedScript
p [Data]
args

    let (Either
  (CekEvaluationException NamedDeBruijn DefaultUni DefaultFun)
  (Term NamedDeBruijn DefaultUni DefaultFun ())
res, UPLC.CountingSt ExBudget
final, LogOutput
logs) =
            forall fun (uni :: * -> *) cost.
(Ix fun, PrettyUni uni fun) =>
MachineParameters CekMachineCosts CekValue uni fun
-> ExBudgetMode cost uni fun
-> EmitterMode uni fun
-> Term NamedDeBruijn uni fun ()
-> (Either
      (CekEvaluationException NamedDeBruijn uni fun)
      (Term NamedDeBruijn uni fun ()),
    cost, LogOutput)
UPLC.runCekDeBruijn
                (ProtocolVersion -> EvaluationContext -> DefaultMachineParameters
toMachineParameters ProtocolVersion
pv EvaluationContext
ectx)
                forall (uni :: * -> *) fun. ExBudgetMode CountingSt uni fun
UPLC.counting
                (if VerboseMode
verbose forall a. Eq a => a -> a -> Bool
== VerboseMode
Verbose then forall (uni :: * -> *) fun. EmitterMode uni fun
UPLC.logEmitter else forall (uni :: * -> *) fun. EmitterMode uni fun
UPLC.noEmitter)
                Term NamedDeBruijn DefaultUni DefaultFun ()
appliedTerm

    forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell LogOutput
logs
    forall e (m :: * -> *) a. MonadError e m => Either e a -> m a
liftEither forall a b. (a -> b) -> a -> b
$ forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first CekEvaluationException NamedDeBruijn DefaultUni DefaultFun
-> EvaluationError
CekError forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Functor f => f a -> f ()
void Either
  (CekEvaluationException NamedDeBruijn DefaultUni DefaultFun)
  (Term NamedDeBruijn DefaultUni DefaultFun ())
res
    forall (f :: * -> *) a. Applicative f => a -> f a
pure ExBudget
final