{-# LANGUAGE DeriveAnyClass    #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeApplications  #-}

{-# LANGUAGE StrictData        #-}

-- GHC is asked to do quite a lot of optimization in this module, so we're increasing the amount of
-- ticks for the simplifier not to run out of them.
{-# OPTIONS_GHC -fsimpl-tick-factor=200 #-}

-- | Common types and functions used across all the ledger API modules.
module Plutus.ApiCommon where

import PlutusCore as Plutus hiding (Version)
import PlutusCore as ScriptPlutus (Version)
import PlutusCore.Data as Plutus
import PlutusCore.Evaluation.Machine.CostModelInterface as Plutus
import PlutusCore.Evaluation.Machine.ExBudget as Plutus
import PlutusCore.Evaluation.Machine.MachineParameters as Plutus
import PlutusCore.MkPlc qualified as UPLC
import UntypedPlutusCore qualified as UPLC
import UntypedPlutusCore.Check.Scope qualified as UPLC
import UntypedPlutusCore.Evaluation.Machine.Cek qualified as UPLC

import Codec.CBOR.Decoding qualified as CBOR
import Codec.CBOR.Extras
import Codec.CBOR.Read qualified as CBOR
import Control.DeepSeq
import Control.Monad.Except
import Control.Monad.Writer
import Data.Bifunctor
import Data.ByteString.Lazy (fromStrict)
import Data.ByteString.Short
import Data.Coerce
import Data.Either
import Data.Foldable (fold)
import Data.Map qualified as Map
import Data.Set qualified as Set
import Data.Text
import Data.Tuple
import GHC.Exts (inline)
import GHC.Generics
import NoThunks.Class
import PlutusCore.Pretty
import PlutusPrelude (through)
import Prettyprinter

{- Note [New builtins and protocol versions]
When we add a new builtin to the language, that is a *backwards-compatible* change.
Old scripts will still work (since they don't use the new builtins), we just make some more
scripts possible.

It would be nice, therefore, to get away with just having one definition of the set of builtin
functions. Then the new builtins will just "work". However, this neglects the fact that
the new builtins will be added to the builtin universe in the *software update* that
brings a new version of Plutus, but they should only be usable after the corresponding
*hard fork*. So there is a period of time in which they must be present in the software but not
usable, so we need to decide this conditionally based on the protocol version.

To do this we need to:
- Know which protocol version a builtin was introduced in.
- Given the protocol version, check a program for builtins that should not be usable yet.

Note that this doesn't currently handle removals of builtins, although it fairly straighforwardly
could do, just by tracking when they were removed.
-}

{- Note [Size checking of constants in PLC programs]
We impose a 64-byte *on-the-wire* limit on the constants inside PLC programs. This prevents people from inserting
Mickey Mouse entire.

This is somewhat inconvenient for users, but they can always send multiple bytestrings and
concatenate them at runtime.

Unfortunately this check was broken in the ledger Plutus language version V1, and so for backwards compatibility
we only perform it in V2 and above.
-}

{- Note [Inlining meanings of builtins]
It's vitally important to inline the 'toBuiltinMeaning' method of a set of built-in functions as
that allows GHC to look under lambdas and completely optimize multiple abstractions away.

There are two ways of doing that: by relying on 'INLINE' pragmas all the way up from the
'ToBuiltinMeaning' instance for the default set of builtins or by ensuring that 'toBuiltinsRuntime'
is compiled efficient by turning it into a one-method class (see
https://github.com/input-output-hk/plutus/pull/4419 for how that looks like). We chose the former,
because it's simpler. Although it's also less reliable: machine parameters are computed in
multiple places and we need to make sure that benchmarking, cost model calculations and the actual
production path have builtins compiled in the same way, 'cause otherwise performance analysis and
cost predictions can be wrong by a big margin without us knowing. Because of this danger in addition
to putting @INLINE@ pragmas on every relevant definition, we also stick a call to 'inline' at the
call site. We also do not attempt to only compile things efficiently where we need that and instead
inline the meanins of builtins everywhere. Just to be sure.

Note that a combination of @INLINABLE@ + 'inline' does not result in proper inlining for whatever
reason. It has to be @INLINE@ (and we add 'inline' on top of that for some additional reliability
as we did have cases where sticking 'inline' on something that already had @INLINE@ would fix
inlining).
-}

-- | Scripts to the ledger are serialised bytestrings.
type SerializedScript = ShortByteString

-- | The plutus language version as seen from the ledger's side.
-- Note: the ordering of constructors matters for deriving Ord
data LedgerPlutusVersion = PlutusV1
                         | PlutusV2
   deriving stock (LedgerPlutusVersion -> LedgerPlutusVersion -> Bool
(LedgerPlutusVersion -> LedgerPlutusVersion -> Bool)
-> (LedgerPlutusVersion -> LedgerPlutusVersion -> Bool)
-> Eq LedgerPlutusVersion
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: LedgerPlutusVersion -> LedgerPlutusVersion -> Bool
$c/= :: LedgerPlutusVersion -> LedgerPlutusVersion -> Bool
== :: LedgerPlutusVersion -> LedgerPlutusVersion -> Bool
$c== :: LedgerPlutusVersion -> LedgerPlutusVersion -> Bool
Eq, Eq LedgerPlutusVersion
Eq LedgerPlutusVersion
-> (LedgerPlutusVersion -> LedgerPlutusVersion -> Ordering)
-> (LedgerPlutusVersion -> LedgerPlutusVersion -> Bool)
-> (LedgerPlutusVersion -> LedgerPlutusVersion -> Bool)
-> (LedgerPlutusVersion -> LedgerPlutusVersion -> Bool)
-> (LedgerPlutusVersion -> LedgerPlutusVersion -> Bool)
-> (LedgerPlutusVersion
    -> LedgerPlutusVersion -> LedgerPlutusVersion)
-> (LedgerPlutusVersion
    -> LedgerPlutusVersion -> LedgerPlutusVersion)
-> Ord LedgerPlutusVersion
LedgerPlutusVersion -> LedgerPlutusVersion -> Bool
LedgerPlutusVersion -> LedgerPlutusVersion -> Ordering
LedgerPlutusVersion -> LedgerPlutusVersion -> LedgerPlutusVersion
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: LedgerPlutusVersion -> LedgerPlutusVersion -> LedgerPlutusVersion
$cmin :: LedgerPlutusVersion -> LedgerPlutusVersion -> LedgerPlutusVersion
max :: LedgerPlutusVersion -> LedgerPlutusVersion -> LedgerPlutusVersion
$cmax :: LedgerPlutusVersion -> LedgerPlutusVersion -> LedgerPlutusVersion
>= :: LedgerPlutusVersion -> LedgerPlutusVersion -> Bool
$c>= :: LedgerPlutusVersion -> LedgerPlutusVersion -> Bool
> :: LedgerPlutusVersion -> LedgerPlutusVersion -> Bool
$c> :: LedgerPlutusVersion -> LedgerPlutusVersion -> Bool
<= :: LedgerPlutusVersion -> LedgerPlutusVersion -> Bool
$c<= :: LedgerPlutusVersion -> LedgerPlutusVersion -> Bool
< :: LedgerPlutusVersion -> LedgerPlutusVersion -> Bool
$c< :: LedgerPlutusVersion -> LedgerPlutusVersion -> Bool
compare :: LedgerPlutusVersion -> LedgerPlutusVersion -> Ordering
$ccompare :: LedgerPlutusVersion -> LedgerPlutusVersion -> Ordering
$cp1Ord :: Eq LedgerPlutusVersion
Ord)

-- | This represents the Cardano protocol version, with its major and minor components.
-- This relies on careful understanding between us and the ledger as to what this means.
data ProtocolVersion = ProtocolVersion { ProtocolVersion -> Int
pvMajor :: Int, ProtocolVersion -> Int
pvMinor :: Int }
  deriving stock (Int -> ProtocolVersion -> ShowS
[ProtocolVersion] -> ShowS
ProtocolVersion -> String
(Int -> ProtocolVersion -> ShowS)
-> (ProtocolVersion -> String)
-> ([ProtocolVersion] -> ShowS)
-> Show ProtocolVersion
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ProtocolVersion] -> ShowS
$cshowList :: [ProtocolVersion] -> ShowS
show :: ProtocolVersion -> String
$cshow :: ProtocolVersion -> String
showsPrec :: Int -> ProtocolVersion -> ShowS
$cshowsPrec :: Int -> ProtocolVersion -> ShowS
Show, ProtocolVersion -> ProtocolVersion -> Bool
(ProtocolVersion -> ProtocolVersion -> Bool)
-> (ProtocolVersion -> ProtocolVersion -> Bool)
-> Eq ProtocolVersion
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ProtocolVersion -> ProtocolVersion -> Bool
$c/= :: ProtocolVersion -> ProtocolVersion -> Bool
== :: ProtocolVersion -> ProtocolVersion -> Bool
$c== :: ProtocolVersion -> ProtocolVersion -> Bool
Eq)

instance Ord ProtocolVersion where
    -- same as deriving Ord, just for having it explicitly
    compare :: ProtocolVersion -> ProtocolVersion -> Ordering
compare (ProtocolVersion Int
major Int
minor) (ProtocolVersion Int
major' Int
minor') = Int -> Int -> Ordering
forall a. Ord a => a -> a -> Ordering
compare Int
major Int
major' Ordering -> Ordering -> Ordering
forall a. Semigroup a => a -> a -> a
<> Int -> Int -> Ordering
forall a. Ord a => a -> a -> Ordering
compare Int
minor Int
minor'

instance Pretty ProtocolVersion where
    pretty :: ProtocolVersion -> Doc ann
pretty (ProtocolVersion Int
major Int
minor) = Int -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Int
major Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
"." Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Int -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Int
minor

{-| A map indicating which builtin functions were introduced in which 'ProtocolVersion'. Each builtin function should appear at most once.

This *must* be updated when new builtins are added.
See Note [New builtins and protocol versions]
-}
builtinsIntroducedIn :: Map.Map (LedgerPlutusVersion, ProtocolVersion) (Set.Set DefaultFun)
builtinsIntroducedIn :: Map (LedgerPlutusVersion, ProtocolVersion) (Set DefaultFun)
builtinsIntroducedIn = [((LedgerPlutusVersion, ProtocolVersion), Set DefaultFun)]
-> Map (LedgerPlutusVersion, ProtocolVersion) (Set DefaultFun)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [
  -- 5.0 is Alonzo
  ((LedgerPlutusVersion
PlutusV1, Int -> Int -> ProtocolVersion
ProtocolVersion Int
5 Int
0), [DefaultFun] -> Set DefaultFun
forall a. Ord a => [a] -> Set a
Set.fromList [
          DefaultFun
AddInteger, DefaultFun
SubtractInteger, DefaultFun
MultiplyInteger, DefaultFun
DivideInteger, DefaultFun
QuotientInteger, DefaultFun
RemainderInteger, DefaultFun
ModInteger, DefaultFun
EqualsInteger, DefaultFun
LessThanInteger, DefaultFun
LessThanEqualsInteger,
          DefaultFun
AppendByteString, DefaultFun
ConsByteString, DefaultFun
SliceByteString, DefaultFun
LengthOfByteString, DefaultFun
IndexByteString, DefaultFun
EqualsByteString, DefaultFun
LessThanByteString, DefaultFun
LessThanEqualsByteString,
          DefaultFun
Sha2_256, DefaultFun
Sha3_256, DefaultFun
Blake2b_256, DefaultFun
VerifyEd25519Signature,
          DefaultFun
AppendString, DefaultFun
EqualsString, DefaultFun
EncodeUtf8, DefaultFun
DecodeUtf8,
          DefaultFun
IfThenElse,
          DefaultFun
ChooseUnit,
          DefaultFun
Trace,
          DefaultFun
FstPair, DefaultFun
SndPair,
          DefaultFun
ChooseList, DefaultFun
MkCons, DefaultFun
HeadList, DefaultFun
TailList, DefaultFun
NullList,
          DefaultFun
ChooseData, DefaultFun
ConstrData, DefaultFun
MapData, DefaultFun
ListData, DefaultFun
IData, DefaultFun
BData, DefaultFun
UnConstrData, DefaultFun
UnMapData, DefaultFun
UnListData, DefaultFun
UnIData, DefaultFun
UnBData, DefaultFun
EqualsData,
          DefaultFun
MkPairData, DefaultFun
MkNilData, DefaultFun
MkNilPairData
          ]),
  ((LedgerPlutusVersion
PlutusV2, Int -> Int -> ProtocolVersion
ProtocolVersion Int
7 Int
0), [DefaultFun] -> Set DefaultFun
forall a. Ord a => [a] -> Set a
Set.fromList [
          DefaultFun
SerialiseData
          ]),
  ((LedgerPlutusVersion
PlutusV2, Int -> Int -> ProtocolVersion
ProtocolVersion Int
8 Int
0), [DefaultFun] -> Set DefaultFun
forall a. Ord a => [a] -> Set a
Set.fromList [
          DefaultFun
VerifyEcdsaSecp256k1Signature, DefaultFun
VerifySchnorrSecp256k1Signature
          ])
  ]

{-| Which builtin functions are available in the given 'ProtocolVersion'?

See Note [New builtins and protocol versions]
-}
builtinsAvailableIn :: LedgerPlutusVersion -> ProtocolVersion -> Set.Set DefaultFun
builtinsAvailableIn :: LedgerPlutusVersion -> ProtocolVersion -> Set DefaultFun
builtinsAvailableIn LedgerPlutusVersion
thisLv ProtocolVersion
thisPv = [Set DefaultFun] -> Set DefaultFun
forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold ([Set DefaultFun] -> Set DefaultFun)
-> [Set DefaultFun] -> Set DefaultFun
forall a b. (a -> b) -> a -> b
$ Map (LedgerPlutusVersion, ProtocolVersion) (Set DefaultFun)
-> [Set DefaultFun]
forall k a. Map k a -> [a]
Map.elems (Map (LedgerPlutusVersion, ProtocolVersion) (Set DefaultFun)
 -> [Set DefaultFun])
-> Map (LedgerPlutusVersion, ProtocolVersion) (Set DefaultFun)
-> [Set DefaultFun]
forall a b. (a -> b) -> a -> b
$
    ((LedgerPlutusVersion, ProtocolVersion) -> Bool)
-> Map (LedgerPlutusVersion, ProtocolVersion) (Set DefaultFun)
-> Map (LedgerPlutusVersion, ProtocolVersion) (Set DefaultFun)
forall k a. (k -> Bool) -> Map k a -> Map k a
Map.takeWhileAntitone (LedgerPlutusVersion, ProtocolVersion) -> Bool
builtinAvailableIn Map (LedgerPlutusVersion, ProtocolVersion) (Set DefaultFun)
builtinsIntroducedIn
    where
      builtinAvailableIn :: (LedgerPlutusVersion, ProtocolVersion) -> Bool
      builtinAvailableIn :: (LedgerPlutusVersion, ProtocolVersion) -> Bool
builtinAvailableIn (LedgerPlutusVersion
introducedInLv,ProtocolVersion
introducedInPv) =
          -- both should be satisfied
          LedgerPlutusVersion
introducedInLv LedgerPlutusVersion -> LedgerPlutusVersion -> Bool
forall a. Ord a => a -> a -> Bool
<= LedgerPlutusVersion
thisLv Bool -> Bool -> Bool
&& ProtocolVersion
introducedInPv ProtocolVersion -> ProtocolVersion -> Bool
forall a. Ord a => a -> a -> Bool
<= ProtocolVersion
thisPv

-- | A variant of `Script` with a specialized decoder.
newtype ScriptForExecution = ScriptForExecution (UPLC.Program UPLC.NamedDeBruijn DefaultUni DefaultFun ())

{-| This decoder decodes the names directly into `NamedDeBruijn`s rather than `DeBruijn`s.
This is needed because the CEK machine expects `NameDeBruijn`s, but there are obviously no names in the serialized form of a `Script`.
Rather than traversing the term and inserting fake names after deserializing, this lets us do at the same time as deserializing.
-}
scriptCBORDecoder :: LedgerPlutusVersion -> ProtocolVersion -> CBOR.Decoder s ScriptForExecution
scriptCBORDecoder :: LedgerPlutusVersion
-> ProtocolVersion -> Decoder s ScriptForExecution
scriptCBORDecoder LedgerPlutusVersion
lv ProtocolVersion
pv =
    -- See Note [New builtins and protocol versions]
    let availableBuiltins :: Set DefaultFun
availableBuiltins = LedgerPlutusVersion -> ProtocolVersion -> Set DefaultFun
builtinsAvailableIn LedgerPlutusVersion
lv ProtocolVersion
pv
        -- TODO: optimize this by using a better datastructure e.g. 'IntSet'
        flatDecoder :: Get (Program FakeNamedDeBruijn DefaultUni DefaultFun ())
flatDecoder = (DefaultFun -> Bool)
-> Get (Program FakeNamedDeBruijn DefaultUni DefaultFun ())
forall name (uni :: * -> *) fun ann.
(Closed uni, Everywhere uni Flat,
 PrettyPlc (Term name uni fun ann), Flat fun, Flat ann, Flat name,
 Flat (Binder name)) =>
(fun -> Bool) -> Get (Program name uni fun ann)
UPLC.decodeProgram (\DefaultFun
f -> DefaultFun
f DefaultFun -> Set DefaultFun -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set DefaultFun
availableBuiltins)
    in do
        -- Deserialize using 'FakeNamedDeBruijn' to get the fake names added
        (Program FakeNamedDeBruijn DefaultUni DefaultFun ()
p :: UPLC.Program UPLC.FakeNamedDeBruijn DefaultUni DefaultFun ()) <- Get (Program FakeNamedDeBruijn DefaultUni DefaultFun ())
-> Decoder s (Program FakeNamedDeBruijn DefaultUni DefaultFun ())
forall a s. Get a -> Decoder s a
decodeViaFlat Get (Program FakeNamedDeBruijn DefaultUni DefaultFun ())
flatDecoder
        ScriptForExecution -> Decoder s ScriptForExecution
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ScriptForExecution -> Decoder s ScriptForExecution)
-> ScriptForExecution -> Decoder s ScriptForExecution
forall a b. (a -> b) -> a -> b
$ Program FakeNamedDeBruijn DefaultUni DefaultFun ()
-> ScriptForExecution
coerce Program FakeNamedDeBruijn DefaultUni DefaultFun ()
p

{-| Check if a 'Script' is "valid" according to a protocol version. At the moment this means "deserialises correctly", which in particular
implies that it is (almost certainly) an encoded script and the script does not mention any builtins unavailable in the given protocol version.

Note: Parameterized over the ledger-plutus-version since the builtins allowed (during decoding) differs.
-}
isScriptWellFormed :: LedgerPlutusVersion -> ProtocolVersion -> SerializedScript -> Bool
isScriptWellFormed :: LedgerPlutusVersion -> ProtocolVersion -> SerializedScript -> Bool
isScriptWellFormed LedgerPlutusVersion
lv ProtocolVersion
pv = Either DeserialiseFailure (ByteString, ScriptForExecution) -> Bool
forall a b. Either a b -> Bool
isRight (Either DeserialiseFailure (ByteString, ScriptForExecution)
 -> Bool)
-> (SerializedScript
    -> Either DeserialiseFailure (ByteString, ScriptForExecution))
-> SerializedScript
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall s. Decoder s ScriptForExecution)
-> ByteString
-> Either DeserialiseFailure (ByteString, ScriptForExecution)
forall a.
(forall s. Decoder s a)
-> ByteString -> Either DeserialiseFailure (ByteString, a)
CBOR.deserialiseFromBytes (LedgerPlutusVersion
-> ProtocolVersion -> Decoder s ScriptForExecution
forall s.
LedgerPlutusVersion
-> ProtocolVersion -> Decoder s ScriptForExecution
scriptCBORDecoder LedgerPlutusVersion
lv ProtocolVersion
pv) (ByteString
 -> Either DeserialiseFailure (ByteString, ScriptForExecution))
-> (SerializedScript -> ByteString)
-> SerializedScript
-> Either DeserialiseFailure (ByteString, ScriptForExecution)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
fromStrict (ByteString -> ByteString)
-> (SerializedScript -> ByteString)
-> SerializedScript
-> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SerializedScript -> ByteString
fromShort

-- | 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 CBOR.DeserialiseFailure -- ^ A serialisation 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
(Int -> EvaluationError -> ShowS)
-> (EvaluationError -> String)
-> ([EvaluationError] -> ShowS)
-> Show EvaluationError
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
(EvaluationError -> EvaluationError -> Bool)
-> (EvaluationError -> EvaluationError -> Bool)
-> Eq EvaluationError
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)

instance Pretty EvaluationError where
    pretty :: EvaluationError -> Doc ann
pretty (CekError CekEvaluationException NamedDeBruijn DefaultUni DefaultFun
e)      = CekEvaluationException NamedDeBruijn DefaultUni DefaultFun
-> Doc ann
forall a ann. PrettyClassic a => a -> Doc ann
prettyClassicDef CekEvaluationException NamedDeBruijn DefaultUni DefaultFun
e
    pretty (DeBruijnError FreeVariableError
e) = FreeVariableError -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty FreeVariableError
e
    pretty (CodecError DeserialiseFailure
e) = DeserialiseFailure -> Doc ann
forall a ann. Show a => a -> Doc ann
viaShow DeserialiseFailure
e
    pretty (IncompatibleVersionError Version ()
actual) = Doc ann
"This version of the Plutus Core interface does not support the version indicated by the AST:" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Version () -> 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]

-- | A simple toggle indicating whether or not we should produce logs.
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
/= :: VerboseMode -> VerboseMode -> Bool
$c/= :: VerboseMode -> VerboseMode -> Bool
== :: VerboseMode -> VerboseMode -> Bool
$c== :: VerboseMode -> VerboseMode -> Bool
Eq)

-- | Shared helper for the evaluation functions, deserializes the 'SerializedScript' , applies it to its arguments, puts fakenamedebruijns, and scope-checks it.
mkTermToEvaluate
    :: (MonadError EvaluationError m)
    => LedgerPlutusVersion
    -> ProtocolVersion
    -> SerializedScript
    -> [Plutus.Data]
    -> m (UPLC.Term UPLC.NamedDeBruijn DefaultUni DefaultFun ())
mkTermToEvaluate :: LedgerPlutusVersion
-> ProtocolVersion
-> SerializedScript
-> [Data]
-> m (Term NamedDeBruijn DefaultUni DefaultFun ())
mkTermToEvaluate LedgerPlutusVersion
lv ProtocolVersion
pv SerializedScript
bs [Data]
args = do
    -- It decodes the program through the optimized ScriptForExecution. See `ScriptForExecution`.
    (ByteString
_, ScriptForExecution (UPLC.Program ()
_ Version ()
v Term NamedDeBruijn DefaultUni DefaultFun ()
t)) <- Either EvaluationError (ByteString, ScriptForExecution)
-> m (ByteString, ScriptForExecution)
forall e (m :: * -> *) a. MonadError e m => Either e a -> m a
liftEither (Either EvaluationError (ByteString, ScriptForExecution)
 -> m (ByteString, ScriptForExecution))
-> Either EvaluationError (ByteString, ScriptForExecution)
-> m (ByteString, ScriptForExecution)
forall a b. (a -> b) -> a -> b
$ (DeserialiseFailure -> EvaluationError)
-> Either DeserialiseFailure (ByteString, ScriptForExecution)
-> Either EvaluationError (ByteString, ScriptForExecution)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first DeserialiseFailure -> EvaluationError
CodecError (Either DeserialiseFailure (ByteString, ScriptForExecution)
 -> Either EvaluationError (ByteString, ScriptForExecution))
-> Either DeserialiseFailure (ByteString, ScriptForExecution)
-> Either EvaluationError (ByteString, ScriptForExecution)
forall a b. (a -> b) -> a -> b
$ (forall s. Decoder s ScriptForExecution)
-> ByteString
-> Either DeserialiseFailure (ByteString, ScriptForExecution)
forall a.
(forall s. Decoder s a)
-> ByteString -> Either DeserialiseFailure (ByteString, a)
CBOR.deserialiseFromBytes (LedgerPlutusVersion
-> ProtocolVersion -> Decoder s ScriptForExecution
forall s.
LedgerPlutusVersion
-> ProtocolVersion -> Decoder s ScriptForExecution
scriptCBORDecoder LedgerPlutusVersion
lv ProtocolVersion
pv) (ByteString
 -> Either DeserialiseFailure (ByteString, ScriptForExecution))
-> ByteString
-> Either DeserialiseFailure (ByteString, ScriptForExecution)
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
fromStrict (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ SerializedScript -> ByteString
fromShort SerializedScript
bs
    Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Version ()
v Version () -> Version () -> Bool
forall a. Eq a => a -> a -> Bool
== () -> Version ()
forall ann. ann -> Version ann
Plutus.defaultVersion ()) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ EvaluationError -> m ()
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (EvaluationError -> m ()) -> EvaluationError -> m ()
forall a b. (a -> b) -> a -> b
$ Version () -> EvaluationError
IncompatibleVersionError Version ()
v
    let termArgs :: [Term NamedDeBruijn DefaultUni DefaultFun ()]
termArgs = (Data -> Term NamedDeBruijn DefaultUni DefaultFun ())
-> [Data] -> [Term NamedDeBruijn DefaultUni DefaultFun ()]
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, Includes 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 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
    (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 (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

-- | 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 version 7.0
    if ProtocolVersion
pv ProtocolVersion -> ProtocolVersion -> Bool
forall a. Ord a => a -> a -> Bool
>= Int -> Int -> ProtocolVersion
ProtocolVersion Int
7 Int
0 then UnliftingMode
UnliftingDeferred else UnliftingMode
UnliftingImmediate

type DefaultMachineParameters = MachineParameters CekMachineCosts UPLC.CekValue DefaultUni DefaultFun

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

mkMachineParametersFor :: (MonadError CostModelApplyError m)
                       => UnliftingMode
                       -> Plutus.CostModelParams
                       -> m DefaultMachineParameters
mkMachineParametersFor :: UnliftingMode -> CostModelParams -> m DefaultMachineParameters
mkMachineParametersFor UnliftingMode
unlMode CostModelParams
newCMP =
    (UnliftingMode
 -> CostModel CekMachineCosts BuiltinCostModel
 -> DefaultMachineParameters)
-> UnliftingMode
-> CostModel CekMachineCosts BuiltinCostModel
-> DefaultMachineParameters
forall a. a -> a
inline UnliftingMode
-> CostModel CekMachineCosts BuiltinCostModel
-> DefaultMachineParameters
forall (uni :: * -> *) fun builtincosts (val :: (* -> *) -> * -> *)
       machinecosts.
(CostingPart uni fun ~ builtincosts,
 HasConstantIn uni (val uni fun), ToBuiltinMeaning uni fun) =>
UnliftingMode
-> CostModel machinecosts builtincosts
-> MachineParameters machinecosts val uni fun
Plutus.mkMachineParameters UnliftingMode
unlMode (CostModel CekMachineCosts BuiltinCostModel
 -> DefaultMachineParameters)
-> m (CostModel CekMachineCosts BuiltinCostModel)
-> m DefaultMachineParameters
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
        CostModel CekMachineCosts BuiltinCostModel
-> CostModelParams
-> m (CostModel CekMachineCosts 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 CekMachineCosts BuiltinCostModel
Plutus.defaultCekCostModel CostModelParams
newCMP
{-# INLINE mkMachineParametersFor #-}


{-| 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. 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
$cto :: forall x. Rep EvaluationContext x -> EvaluationContext
$cfrom :: forall x. EvaluationContext -> Rep EvaluationContext x
Generic
    deriving anyclass (EvaluationContext -> ()
(EvaluationContext -> ()) -> NFData EvaluationContext
forall a. (a -> ()) -> NFData a
rnf :: EvaluationContext -> ()
$crnf :: EvaluationContext -> ()
NFData, Context -> EvaluationContext -> IO (Maybe ThunkInfo)
Proxy EvaluationContext -> String
(Context -> EvaluationContext -> IO (Maybe ThunkInfo))
-> (Context -> EvaluationContext -> IO (Maybe ThunkInfo))
-> (Proxy EvaluationContext -> String)
-> NoThunks EvaluationContext
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 strings to cost integer values (aka `Plutus.CostModelParams`, `Alonzo.CostModel`)
See Note [Inlining meanings of builtins].
-}
mkEvaluationContext :: MonadError CostModelApplyError m => Plutus.CostModelParams -> m EvaluationContext
mkEvaluationContext :: CostModelParams -> m EvaluationContext
mkEvaluationContext CostModelParams
newCMP =
    DefaultMachineParameters
-> DefaultMachineParameters -> EvaluationContext
EvaluationContext
        (DefaultMachineParameters
 -> DefaultMachineParameters -> EvaluationContext)
-> m DefaultMachineParameters
-> m (DefaultMachineParameters -> EvaluationContext)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (UnliftingMode -> CostModelParams -> m DefaultMachineParameters)
-> UnliftingMode -> CostModelParams -> m DefaultMachineParameters
forall a. a -> a
inline UnliftingMode -> CostModelParams -> m DefaultMachineParameters
forall (m :: * -> *).
MonadError CostModelApplyError m =>
UnliftingMode -> CostModelParams -> m DefaultMachineParameters
mkMachineParametersFor UnliftingMode
UnliftingImmediate CostModelParams
newCMP
        m (DefaultMachineParameters -> EvaluationContext)
-> m DefaultMachineParameters -> m EvaluationContext
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (UnliftingMode -> CostModelParams -> m DefaultMachineParameters)
-> UnliftingMode -> CostModelParams -> m DefaultMachineParameters
forall a. a -> a
inline UnliftingMode -> CostModelParams -> m DefaultMachineParameters
forall (m :: * -> *).
MonadError CostModelApplyError m =>
UnliftingMode -> CostModelParams -> m DefaultMachineParameters
mkMachineParametersFor UnliftingMode
UnliftingDeferred CostModelParams
newCMP

-- | Comparably expensive to `mkEvaluationContext`, so it should only be used sparingly.
assertWellFormedCostModelParams :: MonadError CostModelApplyError m => Plutus.CostModelParams -> m ()
assertWellFormedCostModelParams :: CostModelParams -> m ()
assertWellFormedCostModelParams = m (CostModel CekMachineCosts BuiltinCostModel) -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (m (CostModel CekMachineCosts BuiltinCostModel) -> m ())
-> (CostModelParams
    -> m (CostModel CekMachineCosts BuiltinCostModel))
-> CostModelParams
-> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CostModel CekMachineCosts BuiltinCostModel
-> CostModelParams
-> m (CostModel CekMachineCosts 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 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
    -> SerializedScript          -- ^ The script to evaluate
    -> [Plutus.Data]          -- ^ The arguments to the script
    -> (LogOutput, Either EvaluationError ExBudget)
evaluateScriptRestricting :: LedgerPlutusVersion
-> ProtocolVersion
-> VerboseMode
-> EvaluationContext
-> ExBudget
-> SerializedScript
-> [Data]
-> (LogOutput, Either EvaluationError ExBudget)
evaluateScriptRestricting LedgerPlutusVersion
lv ProtocolVersion
pv VerboseMode
verbose EvaluationContext
ectx ExBudget
budget SerializedScript
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 a. Writer LogOutput a -> (a, LogOutput)
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 <- LedgerPlutusVersion
-> ProtocolVersion
-> SerializedScript
-> [Data]
-> ExceptT
     EvaluationError
     (WriterT LogOutput Identity)
     (Term NamedDeBruijn DefaultUni DefaultFun ())
forall (m :: * -> *).
MonadError EvaluationError m =>
LedgerPlutusVersion
-> ProtocolVersion
-> SerializedScript
-> [Data]
-> m (Term NamedDeBruijn DefaultUni DefaultFun ())
mkTermToEvaluate LedgerPlutusVersion
lv ProtocolVersion
pv SerializedScript
p [Data]
args

    let (Either
  (CekEvaluationException NamedDeBruijn DefaultUni DefaultFun)
  (Term NamedDeBruijn DefaultUni DefaultFun ())
res, UPLC.RestrictingSt (ExRestrictingBudget ExBudget
final), LogOutput
logs) =
            DefaultMachineParameters
-> ExBudgetMode RestrictingSt DefaultUni DefaultFun
-> EmitterMode DefaultUni DefaultFun
-> Term NamedDeBruijn DefaultUni DefaultFun ()
-> (Either
      (CekEvaluationException NamedDeBruijn DefaultUni DefaultFun)
      (Term NamedDeBruijn DefaultUni DefaultFun ()),
    RestrictingSt, LogOutput)
forall (uni :: * -> *) fun cost.
(Everywhere uni ExMemoryUsage, 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)
                (ExRestrictingBudget
-> ExBudgetMode RestrictingSt DefaultUni DefaultFun
forall (uni :: * -> *) fun.
PrettyUni 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)
                (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)
                Term NamedDeBruijn DefaultUni DefaultFun ()
appliedTerm

    LogOutput
-> ExceptT EvaluationError (WriterT LogOutput Identity) ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell LogOutput
logs
    Either EvaluationError ()
-> ExceptT EvaluationError (WriterT LogOutput Identity) ()
forall e (m :: * -> *) a. MonadError e m => Either e a -> m a
liftEither (Either EvaluationError ()
 -> ExceptT EvaluationError (WriterT LogOutput Identity) ())
-> Either EvaluationError ()
-> ExceptT EvaluationError (WriterT LogOutput Identity) ()
forall a b. (a -> b) -> a -> b
$ (CekEvaluationException NamedDeBruijn DefaultUni DefaultFun
 -> EvaluationError)
-> Either
     (CekEvaluationException NamedDeBruijn DefaultUni DefaultFun) ()
-> Either EvaluationError ()
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first CekEvaluationException NamedDeBruijn DefaultUni DefaultFun
-> EvaluationError
CekError (Either
   (CekEvaluationException NamedDeBruijn DefaultUni DefaultFun) ()
 -> Either EvaluationError ())
-> Either
     (CekEvaluationException NamedDeBruijn DefaultUni DefaultFun) ()
-> Either EvaluationError ()
forall a b. (a -> b) -> a -> b
$ Either
  (CekEvaluationException NamedDeBruijn DefaultUni DefaultFun)
  (Term NamedDeBruijn DefaultUni DefaultFun ())
-> Either
     (CekEvaluationException NamedDeBruijn DefaultUni DefaultFun) ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void Either
  (CekEvaluationException NamedDeBruijn DefaultUni DefaultFun)
  (Term NamedDeBruijn DefaultUni DefaultFun ())
res
    ExBudget
-> ExceptT EvaluationError (WriterT LogOutput Identity) ExBudget
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
    -> SerializedScript          -- ^ The script to evaluate
    -> [Plutus.Data]          -- ^ The arguments to the script
    -> (LogOutput, Either EvaluationError ExBudget)
evaluateScriptCounting :: LedgerPlutusVersion
-> ProtocolVersion
-> VerboseMode
-> EvaluationContext
-> SerializedScript
-> [Data]
-> (LogOutput, Either EvaluationError ExBudget)
evaluateScriptCounting LedgerPlutusVersion
lv ProtocolVersion
pv VerboseMode
verbose EvaluationContext
ectx SerializedScript
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 a. Writer LogOutput a -> (a, LogOutput)
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 <- LedgerPlutusVersion
-> ProtocolVersion
-> SerializedScript
-> [Data]
-> ExceptT
     EvaluationError
     (WriterT LogOutput Identity)
     (Term NamedDeBruijn DefaultUni DefaultFun ())
forall (m :: * -> *).
MonadError EvaluationError m =>
LedgerPlutusVersion
-> ProtocolVersion
-> SerializedScript
-> [Data]
-> m (Term NamedDeBruijn DefaultUni DefaultFun ())
mkTermToEvaluate LedgerPlutusVersion
lv ProtocolVersion
pv SerializedScript
p [Data]
args

    let (Either
  (CekEvaluationException NamedDeBruijn DefaultUni DefaultFun)
  (Term NamedDeBruijn DefaultUni DefaultFun ())
res, UPLC.CountingSt ExBudget
final, LogOutput
logs) =
            DefaultMachineParameters
-> ExBudgetMode CountingSt DefaultUni DefaultFun
-> EmitterMode DefaultUni DefaultFun
-> Term NamedDeBruijn DefaultUni DefaultFun ()
-> (Either
      (CekEvaluationException NamedDeBruijn DefaultUni DefaultFun)
      (Term NamedDeBruijn DefaultUni DefaultFun ()),
    CountingSt, LogOutput)
forall (uni :: * -> *) fun cost.
(Everywhere uni ExMemoryUsage, 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)
                ExBudgetMode CountingSt DefaultUni DefaultFun
forall (uni :: * -> *) fun. ExBudgetMode CountingSt uni fun
UPLC.counting
                (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)
                Term NamedDeBruijn DefaultUni DefaultFun ()
appliedTerm

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