{-# LANGUAGE TypeApplications #-}

module PlutusCore.Executable.Eval where

import PlutusLedgerApi.Common
import UntypedPlutusCore qualified as UPLC
import UntypedPlutusCore.Evaluation.Machine.Cek
import UntypedPlutusCore.Transform.Certify.Trace

import PlutusCore.Builtin qualified as PLC
import PlutusCore.Default (BuiltinSemanticsVariant)
import PlutusCore.Evaluation.Machine.ExBudgetingDefaults qualified as PLC
import PlutusPrelude (unsafeFromRight)
import UntypedPlutusCore.DeBruijn (FreeVariableError)

import Data.Bifunctor (first)
import Data.Foldable qualified as F
import Data.Functor (void)

-- | Evaluate a single term in counting mode.
evalCounting
  :: EvaluationContext
  -> MajorProtocolVersion
  -> UPLC.Term UPLC.NamedDeBruijn UPLC.DefaultUni UPLC.DefaultFun ()
  -> ( Either
         (CekEvaluationException UPLC.NamedDeBruijn UPLC.DefaultUni UPLC.DefaultFun)
         (UPLC.Term UPLC.NamedDeBruijn UPLC.DefaultUni UPLC.DefaultFun ())
     , ExBudget
     )
evalCounting :: EvaluationContext
-> MajorProtocolVersion
-> Term NamedDeBruijn DefaultUni DefaultFun ()
-> (Either
      (CekEvaluationException NamedDeBruijn DefaultUni DefaultFun)
      (Term NamedDeBruijn DefaultUni DefaultFun ()),
    ExBudget)
evalCounting EvaluationContext
evalCtx MajorProtocolVersion
pv Term NamedDeBruijn DefaultUni DefaultFun ()
term =
  ( CekResult NamedDeBruijn DefaultUni DefaultFun
-> Either
     (CekEvaluationException NamedDeBruijn DefaultUni DefaultFun)
     (Term NamedDeBruijn DefaultUni DefaultFun ())
forall name (uni :: * -> *) fun.
CekResult name uni fun
-> Either
     (CekEvaluationException name uni fun) (Term name uni fun ())
cekResultToEither (CekReport CountingSt NamedDeBruijn DefaultUni DefaultFun
-> CekResult NamedDeBruijn DefaultUni DefaultFun
forall cost name (uni :: * -> *) fun.
CekReport cost name uni fun -> CekResult name uni fun
_cekReportResult CekReport CountingSt NamedDeBruijn DefaultUni DefaultFun
report)
  , let CountingSt ExBudget
cost = CekReport CountingSt NamedDeBruijn DefaultUni DefaultFun
-> CountingSt
forall cost name (uni :: * -> *) fun.
CekReport cost name uni fun -> cost
_cekReportCost CekReport CountingSt NamedDeBruijn DefaultUni DefaultFun
report in ExBudget
cost
  )
  where
    report :: CekReport CountingSt NamedDeBruijn DefaultUni DefaultFun
report = ExBudgetMode CountingSt DefaultUni DefaultFun
-> MajorProtocolVersion
-> VerboseMode
-> EvaluationContext
-> Term NamedDeBruijn DefaultUni DefaultFun ()
-> CekReport CountingSt NamedDeBruijn DefaultUni DefaultFun
forall cost.
ExBudgetMode cost DefaultUni DefaultFun
-> MajorProtocolVersion
-> VerboseMode
-> EvaluationContext
-> Term NamedDeBruijn DefaultUni DefaultFun ()
-> CekReport cost NamedDeBruijn DefaultUni DefaultFun
evaluateTerm ExBudgetMode CountingSt DefaultUni DefaultFun
forall (uni :: * -> *) fun. ExBudgetMode CountingSt uni fun
counting MajorProtocolVersion
pv VerboseMode
Quiet EvaluationContext
evalCtx Term NamedDeBruijn DefaultUni DefaultFun ()
term

-- | Build a default evaluation context for a given semantics variant.
mkDefaultEvalCtx
  :: BuiltinSemanticsVariant UPLC.DefaultFun -> EvaluationContext
mkDefaultEvalCtx :: BuiltinSemanticsVariant DefaultFun -> EvaluationContext
mkDefaultEvalCtx BuiltinSemanticsVariant DefaultFun
semvar =
  case BuiltinSemanticsVariant DefaultFun -> Maybe CostModelParams
PLC.defaultCostModelParamsForVariant BuiltinSemanticsVariant DefaultFun
semvar of
    Just CostModelParams
p ->
      (CostModelApplyError -> EvaluationContext)
-> (EvaluationContext -> EvaluationContext)
-> Either CostModelApplyError EvaluationContext
-> EvaluationContext
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either ([Char] -> EvaluationContext
forall a. HasCallStack => [Char] -> a
error ([Char] -> EvaluationContext)
-> (CostModelApplyError -> [Char])
-> CostModelApplyError
-> EvaluationContext
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CostModelApplyError -> [Char]
forall a. Show a => a -> [Char]
show) EvaluationContext -> EvaluationContext
forall a. a -> a
id (Either CostModelApplyError EvaluationContext -> EvaluationContext)
-> Either CostModelApplyError EvaluationContext
-> EvaluationContext
forall a b. (a -> b) -> a -> b
$
        PlutusLedgerLanguage
-> (MajorProtocolVersion -> CaserBuiltin DefaultUni)
-> [BuiltinSemanticsVariant DefaultFun]
-> (MajorProtocolVersion -> BuiltinSemanticsVariant DefaultFun)
-> CostModelParams
-> Either CostModelApplyError EvaluationContext
forall (m :: * -> *).
MonadError CostModelApplyError m =>
PlutusLedgerLanguage
-> (MajorProtocolVersion -> CaserBuiltin DefaultUni)
-> [BuiltinSemanticsVariant DefaultFun]
-> (MajorProtocolVersion -> BuiltinSemanticsVariant DefaultFun)
-> CostModelParams
-> m EvaluationContext
mkDynEvaluationContext
          PlutusLedgerLanguage
PlutusV3
          (\MajorProtocolVersion
_ -> (forall term.
 (UniOf term ~ DefaultUni) =>
 Some (ValueOf DefaultUni)
 -> Vector term -> HeadSpine Text term (Some (ValueOf DefaultUni)))
-> CaserBuiltin DefaultUni
forall (uni :: * -> *).
(forall term.
 (UniOf term ~ uni) =>
 Some (ValueOf uni)
 -> Vector term -> HeadSpine Text term (Some (ValueOf uni)))
-> CaserBuiltin uni
PLC.CaserBuiltin Some (ValueOf DefaultUni)
-> Vector term -> HeadSpine Text term (Some (ValueOf DefaultUni))
forall term.
(UniOf term ~ DefaultUni) =>
Some (ValueOf DefaultUni)
-> Vector term -> HeadSpine Text term (Some (ValueOf DefaultUni))
forall (uni :: * -> *) term.
(CaseBuiltin uni, UniOf term ~ uni) =>
Some (ValueOf uni)
-> Vector term -> HeadSpine Text term (Some (ValueOf uni))
PLC.caseBuiltin)
          [BuiltinSemanticsVariant DefaultFun
semvar]
          (BuiltinSemanticsVariant DefaultFun
-> MajorProtocolVersion -> BuiltinSemanticsVariant DefaultFun
forall a b. a -> b -> a
const BuiltinSemanticsVariant DefaultFun
semvar)
          CostModelParams
p
    Maybe CostModelParams
Nothing ->
      [Char] -> EvaluationContext
forall a. HasCallStack => [Char] -> a
error ([Char] -> EvaluationContext) -> [Char] -> EvaluationContext
forall a b. (a -> b) -> a -> b
$ [Char]
"Couldn't get cost model params for " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> BuiltinSemanticsVariant DefaultFun -> [Char]
forall a. Show a => a -> [Char]
show BuiltinSemanticsVariant DefaultFun
semvar

{-| Evaluate all ASTs in the trace, each applied to the given arguments arguments,
in counting mode. Returns @(Maybe error, budget)@. -}
evalSimplifierTrace
  :: EvaluationContext
  -> SimplifierTrace UPLC.Name UPLC.DefaultUni UPLC.DefaultFun a
  -> [UPLC.Term UPLC.NamedDeBruijn UPLC.DefaultUni UPLC.DefaultFun ()]
  -- ^ Arguments to apply to each AST before evaluation
  -> [ ( Maybe
           (CekEvaluationException UPLC.NamedDeBruijn UPLC.DefaultUni UPLC.DefaultFun)
       , ExBudget
       )
     ]
evalSimplifierTrace :: forall a.
EvaluationContext
-> SimplifierTrace Name DefaultUni DefaultFun a
-> [Term NamedDeBruijn DefaultUni DefaultFun ()]
-> [(Maybe
       (CekEvaluationException NamedDeBruijn DefaultUni DefaultFun),
     ExBudget)]
evalSimplifierTrace EvaluationContext
evalCtx SimplifierTrace Name DefaultUni DefaultFun a
trace [Term NamedDeBruijn DefaultUni DefaultFun ()]
args =
  (Either
   (CekEvaluationException NamedDeBruijn DefaultUni DefaultFun)
   (Term NamedDeBruijn DefaultUni DefaultFun ())
 -> Maybe
      (CekEvaluationException NamedDeBruijn DefaultUni DefaultFun))
-> (Either
      (CekEvaluationException NamedDeBruijn DefaultUni DefaultFun)
      (Term NamedDeBruijn DefaultUni DefaultFun ()),
    ExBudget)
-> (Maybe
      (CekEvaluationException NamedDeBruijn DefaultUni DefaultFun),
    ExBudget)
forall a b c. (a -> b) -> (a, c) -> (b, c)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first ((CekEvaluationException NamedDeBruijn DefaultUni DefaultFun
 -> Maybe
      (CekEvaluationException NamedDeBruijn DefaultUni DefaultFun))
-> (Term NamedDeBruijn DefaultUni DefaultFun ()
    -> Maybe
         (CekEvaluationException NamedDeBruijn DefaultUni DefaultFun))
-> Either
     (CekEvaluationException NamedDeBruijn DefaultUni DefaultFun)
     (Term NamedDeBruijn DefaultUni DefaultFun ())
-> Maybe
     (CekEvaluationException NamedDeBruijn DefaultUni DefaultFun)
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either CekEvaluationException NamedDeBruijn DefaultUni DefaultFun
-> Maybe
     (CekEvaluationException NamedDeBruijn DefaultUni DefaultFun)
forall a. a -> Maybe a
Just (Maybe (CekEvaluationException NamedDeBruijn DefaultUni DefaultFun)
-> Term NamedDeBruijn DefaultUni DefaultFun ()
-> Maybe
     (CekEvaluationException NamedDeBruijn DefaultUni DefaultFun)
forall a b. a -> b -> a
const Maybe (CekEvaluationException NamedDeBruijn DefaultUni DefaultFun)
forall a. Maybe a
Nothing)) ((Either
    (CekEvaluationException NamedDeBruijn DefaultUni DefaultFun)
    (Term NamedDeBruijn DefaultUni DefaultFun ()),
  ExBudget)
 -> (Maybe
       (CekEvaluationException NamedDeBruijn DefaultUni DefaultFun),
     ExBudget))
-> (Term NamedDeBruijn DefaultUni DefaultFun ()
    -> (Either
          (CekEvaluationException NamedDeBruijn DefaultUni DefaultFun)
          (Term NamedDeBruijn DefaultUni DefaultFun ()),
        ExBudget))
-> Term NamedDeBruijn DefaultUni DefaultFun ()
-> (Maybe
      (CekEvaluationException NamedDeBruijn DefaultUni DefaultFun),
    ExBudget)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. EvaluationContext
-> MajorProtocolVersion
-> Term NamedDeBruijn DefaultUni DefaultFun ()
-> (Either
      (CekEvaluationException NamedDeBruijn DefaultUni DefaultFun)
      (Term NamedDeBruijn DefaultUni DefaultFun ()),
    ExBudget)
evalCounting EvaluationContext
evalCtx MajorProtocolVersion
newestPV
    (Term NamedDeBruijn DefaultUni DefaultFun ()
 -> (Maybe
       (CekEvaluationException NamedDeBruijn DefaultUni DefaultFun),
     ExBudget))
-> [Term NamedDeBruijn DefaultUni DefaultFun ()]
-> [(Maybe
       (CekEvaluationException NamedDeBruijn DefaultUni DefaultFun),
     ExBudget)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Term NamedDeBruijn DefaultUni DefaultFun ()]
appliedTerms
  where
    appliedTerms :: [UPLC.Term UPLC.NamedDeBruijn UPLC.DefaultUni UPLC.DefaultFun ()]
    appliedTerms :: [Term NamedDeBruijn DefaultUni DefaultFun ()]
appliedTerms =
      ( \Term Name DefaultUni DefaultFun a
ast ->
          (Term NamedDeBruijn DefaultUni DefaultFun ()
 -> Term NamedDeBruijn DefaultUni DefaultFun ()
 -> Term NamedDeBruijn DefaultUni DefaultFun ())
-> Term NamedDeBruijn DefaultUni DefaultFun ()
-> [Term NamedDeBruijn DefaultUni DefaultFun ()]
-> Term NamedDeBruijn DefaultUni DefaultFun ()
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
F.foldl'
            Term NamedDeBruijn DefaultUni DefaultFun ()
-> Term NamedDeBruijn DefaultUni DefaultFun ()
-> Term NamedDeBruijn DefaultUni DefaultFun ()
forall a name (uni :: * -> *) fun.
Semigroup a =>
Term name uni fun a -> Term name uni fun a -> Term name uni fun a
UPLC.applyTerm
            ( forall e a. Show e => Either e a -> a
unsafeFromRight @FreeVariableError (Either
   FreeVariableError (Term NamedDeBruijn DefaultUni DefaultFun ())
 -> Term NamedDeBruijn DefaultUni DefaultFun ())
-> Either
     FreeVariableError (Term NamedDeBruijn DefaultUni DefaultFun ())
-> Term NamedDeBruijn DefaultUni DefaultFun ()
forall a b. (a -> b) -> a -> b
$
                Term Name DefaultUni DefaultFun ()
-> Either
     FreeVariableError (Term NamedDeBruijn DefaultUni DefaultFun ())
forall (m :: * -> *) (uni :: * -> *) fun ann.
MonadError FreeVariableError m =>
Term Name uni fun ann -> m (Term NamedDeBruijn uni fun ann)
UPLC.deBruijnTerm (Term Name DefaultUni DefaultFun a
-> Term Name DefaultUni DefaultFun ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void Term Name DefaultUni DefaultFun a
ast)
            )
            [Term NamedDeBruijn DefaultUni DefaultFun ()]
args
      )
        (Term Name DefaultUni DefaultFun a
 -> Term NamedDeBruijn DefaultUni DefaultFun ())
-> [Term Name DefaultUni DefaultFun a]
-> [Term NamedDeBruijn DefaultUni DefaultFun ()]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SimplifierTrace Name DefaultUni DefaultFun a
-> [Term Name DefaultUni DefaultFun a]
forall name (uni :: * -> *) fun a.
SimplifierTrace name uni fun a -> [Term name uni fun a]
allASTs SimplifierTrace Name DefaultUni DefaultFun a
trace

{-| Evaluate a single program term applied to arguments in counting mode.
Returns @(Maybe error, budget)@. -}
evalCountingWithArgs
  :: EvaluationContext
  -> UPLC.Term UPLC.Name UPLC.DefaultUni UPLC.DefaultFun ()
  -- ^ Main program
  -> [UPLC.Term UPLC.NamedDeBruijn UPLC.DefaultUni UPLC.DefaultFun ()]
  -- ^ Arguments
  -> ( Maybe
         (CekEvaluationException UPLC.NamedDeBruijn UPLC.DefaultUni UPLC.DefaultFun)
     , ExBudget
     )
evalCountingWithArgs :: EvaluationContext
-> Term Name DefaultUni DefaultFun ()
-> [Term NamedDeBruijn DefaultUni DefaultFun ()]
-> (Maybe
      (CekEvaluationException NamedDeBruijn DefaultUni DefaultFun),
    ExBudget)
evalCountingWithArgs EvaluationContext
evalCtx Term Name DefaultUni DefaultFun ()
term [Term NamedDeBruijn DefaultUni DefaultFun ()]
args =
  let dbTerm :: Term NamedDeBruijn DefaultUni DefaultFun ()
dbTerm =
        forall e a. Show e => Either e a -> a
unsafeFromRight @FreeVariableError (Either
   FreeVariableError (Term NamedDeBruijn DefaultUni DefaultFun ())
 -> Term NamedDeBruijn DefaultUni DefaultFun ())
-> Either
     FreeVariableError (Term NamedDeBruijn DefaultUni DefaultFun ())
-> Term NamedDeBruijn DefaultUni DefaultFun ()
forall a b. (a -> b) -> a -> b
$
          Term Name DefaultUni DefaultFun ()
-> Either
     FreeVariableError (Term NamedDeBruijn DefaultUni DefaultFun ())
forall (m :: * -> *) (uni :: * -> *) fun ann.
MonadError FreeVariableError m =>
Term Name uni fun ann -> m (Term NamedDeBruijn uni fun ann)
UPLC.deBruijnTerm Term Name DefaultUni DefaultFun ()
term
      applied :: Term NamedDeBruijn DefaultUni DefaultFun ()
applied = (Term NamedDeBruijn DefaultUni DefaultFun ()
 -> Term NamedDeBruijn DefaultUni DefaultFun ()
 -> Term NamedDeBruijn DefaultUni DefaultFun ())
-> Term NamedDeBruijn DefaultUni DefaultFun ()
-> [Term NamedDeBruijn DefaultUni DefaultFun ()]
-> Term NamedDeBruijn DefaultUni DefaultFun ()
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
F.foldl' Term NamedDeBruijn DefaultUni DefaultFun ()
-> Term NamedDeBruijn DefaultUni DefaultFun ()
-> Term NamedDeBruijn DefaultUni DefaultFun ()
forall a name (uni :: * -> *) fun.
Semigroup a =>
Term name uni fun a -> Term name uni fun a -> Term name uni fun a
UPLC.applyTerm Term NamedDeBruijn DefaultUni DefaultFun ()
dbTerm [Term NamedDeBruijn DefaultUni DefaultFun ()]
args
   in (Either
   (CekEvaluationException NamedDeBruijn DefaultUni DefaultFun)
   (Term NamedDeBruijn DefaultUni DefaultFun ())
 -> Maybe
      (CekEvaluationException NamedDeBruijn DefaultUni DefaultFun))
-> (Either
      (CekEvaluationException NamedDeBruijn DefaultUni DefaultFun)
      (Term NamedDeBruijn DefaultUni DefaultFun ()),
    ExBudget)
-> (Maybe
      (CekEvaluationException NamedDeBruijn DefaultUni DefaultFun),
    ExBudget)
forall a b c. (a -> b) -> (a, c) -> (b, c)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first ((CekEvaluationException NamedDeBruijn DefaultUni DefaultFun
 -> Maybe
      (CekEvaluationException NamedDeBruijn DefaultUni DefaultFun))
-> (Term NamedDeBruijn DefaultUni DefaultFun ()
    -> Maybe
         (CekEvaluationException NamedDeBruijn DefaultUni DefaultFun))
-> Either
     (CekEvaluationException NamedDeBruijn DefaultUni DefaultFun)
     (Term NamedDeBruijn DefaultUni DefaultFun ())
-> Maybe
     (CekEvaluationException NamedDeBruijn DefaultUni DefaultFun)
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either CekEvaluationException NamedDeBruijn DefaultUni DefaultFun
-> Maybe
     (CekEvaluationException NamedDeBruijn DefaultUni DefaultFun)
forall a. a -> Maybe a
Just (Maybe (CekEvaluationException NamedDeBruijn DefaultUni DefaultFun)
-> Term NamedDeBruijn DefaultUni DefaultFun ()
-> Maybe
     (CekEvaluationException NamedDeBruijn DefaultUni DefaultFun)
forall a b. a -> b -> a
const Maybe (CekEvaluationException NamedDeBruijn DefaultUni DefaultFun)
forall a. Maybe a
Nothing)) ((Either
    (CekEvaluationException NamedDeBruijn DefaultUni DefaultFun)
    (Term NamedDeBruijn DefaultUni DefaultFun ()),
  ExBudget)
 -> (Maybe
       (CekEvaluationException NamedDeBruijn DefaultUni DefaultFun),
     ExBudget))
-> (Either
      (CekEvaluationException NamedDeBruijn DefaultUni DefaultFun)
      (Term NamedDeBruijn DefaultUni DefaultFun ()),
    ExBudget)
-> (Maybe
      (CekEvaluationException NamedDeBruijn DefaultUni DefaultFun),
    ExBudget)
forall a b. (a -> b) -> a -> b
$ EvaluationContext
-> MajorProtocolVersion
-> Term NamedDeBruijn DefaultUni DefaultFun ()
-> (Either
      (CekEvaluationException NamedDeBruijn DefaultUni DefaultFun)
      (Term NamedDeBruijn DefaultUni DefaultFun ()),
    ExBudget)
evalCounting EvaluationContext
evalCtx MajorProtocolVersion
newestPV Term NamedDeBruijn DefaultUni DefaultFun ()
applied