{-# LANGUAGE TypeApplications #-}

module PlutusLedgerApi.V4.EvaluationContext
  ( EvaluationContext
  , mkEvaluationContext
  , CostModelParams
  , assertWellFormedCostModelParams
  , toMachineParameters
  , CostModelApplyError (..)
  ) where

import PlutusLedgerApi.Common
import PlutusLedgerApi.V4.ParamName as V4

import PlutusCore.Builtin (CaserBuiltin (..), caseBuiltin)
import PlutusCore.Default (BuiltinSemanticsVariant (DefaultFunSemanticsVariantE))

import Control.Monad
import Control.Monad.Writer.Strict
import Data.Int (Int64)

{-|  Build the 'EvaluationContext'.

The input is a list of cost model parameters (which are integer values) passed
from the ledger.

IMPORTANT: the cost model parameters __MUST__ appear in the correct order,
matching the names in `PlutusLedgerApi.V4.ParamName`.  If the parameters are
supplied in the wrong order then script cost calculations will be incorrect.

IMPORTANT: The evaluation context of every Plutus version must be recreated upon
a protocol update with the updated cost model parameters. -}
mkEvaluationContext
  :: (MonadError CostModelApplyError m, MonadWriter [CostModelApplyWarn] m)
  => [Int64]
  -- ^ the (updated) cost model parameters of the protocol
  -> m EvaluationContext
mkEvaluationContext :: forall (m :: * -> *).
(MonadError CostModelApplyError m,
 MonadWriter [CostModelApplyWarn] m) =>
[Int64] -> m EvaluationContext
mkEvaluationContext =
  forall k (m :: * -> *).
(Enum k, Bounded k, MonadError CostModelApplyError m,
 MonadWriter [CostModelApplyWarn] m) =>
[Int64] -> m [(k, Int64)]
tagWithParamNames @V4.ParamName
    ([Int64] -> m [(ParamName, Int64)])
-> ([(ParamName, Int64)] -> m EvaluationContext)
-> [Int64]
-> m EvaluationContext
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> CostModelParams -> m CostModelParams
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (CostModelParams -> m CostModelParams)
-> ([(ParamName, Int64)] -> CostModelParams)
-> [(ParamName, Int64)]
-> m CostModelParams
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(ParamName, Int64)] -> CostModelParams
forall p. IsParamName p => [(p, Int64)] -> CostModelParams
toCostModelParams
    ([(ParamName, Int64)] -> m CostModelParams)
-> (CostModelParams -> m EvaluationContext)
-> [(ParamName, Int64)]
-> m EvaluationContext
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> PlutusLedgerLanguage
-> (MajorProtocolVersion -> CaserBuiltin DefaultUni)
-> [BuiltinSemanticsVariant DefaultFun]
-> (MajorProtocolVersion -> BuiltinSemanticsVariant DefaultFun)
-> CostModelParams
-> m EvaluationContext
forall (m :: * -> *).
MonadError CostModelApplyError m =>
PlutusLedgerLanguage
-> (MajorProtocolVersion -> CaserBuiltin DefaultUni)
-> [BuiltinSemanticsVariant DefaultFun]
-> (MajorProtocolVersion -> BuiltinSemanticsVariant DefaultFun)
-> CostModelParams
-> m EvaluationContext
mkDynEvaluationContext
      PlutusLedgerLanguage
PlutusV4
      -- 'PlutusV4' is introduced at the Dijkstra HF, so casing on builtins is always available.
      (\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
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))
caseBuiltin)
      [BuiltinSemanticsVariant DefaultFun
DefaultFunSemanticsVariantE]
      -- See Note [Mapping of protocol versions and ledger languages to semantics variants].
      (\MajorProtocolVersion
_ -> BuiltinSemanticsVariant DefaultFun
DefaultFunSemanticsVariantE)