{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}

module Cardano.Ledger.Plutus.CostModels (
  -- * Cost Model
  CostModel,
  mkCostModel,
  mkCostModelsLenient,
  encodeCostModel,
  getCostModelLanguage,
  getCostModelParams,
  getCostModelEvaluationContext,
  getEvaluationContext,
  costModelParamNames,
  costModelToMap,
  costModelFromMap,
  costModelParamsCount,
  decodeCostModel,

  -- * Cost Models
  CostModels,
  mkCostModels,
  emptyCostModels,
  updateCostModels,
  decodeCostModelsLenient,
  decodeCostModelsFailing,
  costModelsValid,
  costModelsUnknown,
  flattenCostModels,
)
where

import Cardano.Ledger.Binary (
  DecCBOR (decCBOR),
  Decoder,
  EncCBOR (encCBOR),
  Encoding,
  decodeMapByKey,
  encodeFoldableAsDefLenList,
  ifDecoderVersionAtLeast,
 )
import Cardano.Ledger.Binary.Version (natVersion)
import Cardano.Ledger.Plutus.Language (
  Language (..),
  languageToText,
  mkLanguageEnum,
  nonNativeLanguages,
 )
import Control.DeepSeq (NFData (..), deepseq)
import Control.Monad (forM, when)
import Control.Monad.Trans.Writer (WriterT (runWriterT))
import Data.Aeson (
  FromJSON (..),
  Object,
  ToJSON (..),
  Value (Array, Object),
  withObject,
  (.!=),
  (.:?),
 )
import Data.Aeson.Key (fromString)
import Data.Aeson.Types (Parser)
import Data.Int
import Data.List.NonEmpty as NE (toList)
import Data.Map (Map)
import qualified Data.Map.Strict as Map
import Data.Text as T (Text, pack)
import Data.Word (Word8)
import GHC.Generics (Generic)
import NoThunks.Class (NoThunks (..))
import qualified PlutusLedgerApi.Common as P (
  CostModelApplyError (..),
  CostModelApplyWarn,
  EvaluationContext,
  showParamName,
 )
import qualified PlutusLedgerApi.V1 as PV1 (
  ParamName,
  mkEvaluationContext,
 )
import qualified PlutusLedgerApi.V2 as PV2 (ParamName, mkEvaluationContext)
import qualified PlutusLedgerApi.V3 as PV3 (ParamName, mkEvaluationContext)
import Validation (failure, validationToEither)

-- | A language dependent cost model for the Plutus evaluator.
-- Note that the `P.EvaluationContext` is entirely dependent on the
-- cost model parameters (ie the `Map` `Text` `Integer`) and that
-- this type uses the smart constructor `mkCostModel`
-- to hide the evaluation context.
data CostModel = CostModel
  { CostModel -> Language
cmLanguage :: !Language
  , CostModel -> [Int64]
cmValues :: ![Int64]
  -- ^ We retain the original values for parameters for the purpose of
  -- reserialization. Starting with the Conway era there might not be the exact number
  -- of parameters in this list that Plutus' smart constructor `mkEvaluationContext`
  -- expects. This functionality is intentional for allowing the addition of new
  -- primitives on a hardfork boundary. When less than the expected number is
  -- supplied, `maxBound` will be used instead by the Plutus smart constructor.
  , CostModel -> EvaluationContext
cmEvalCtx :: !P.EvaluationContext
  }
  deriving (forall x. Rep CostModel x -> CostModel
forall x. CostModel -> Rep CostModel x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep CostModel x -> CostModel
$cfrom :: forall x. CostModel -> Rep CostModel x
Generic)

-- | Note that this Eq instance ignores the evaluation context, which is
-- entirely dependent on the cost model parameters and is guarded by the
-- smart constructor `mkCostModel`.
instance Eq CostModel where
  CostModel Language
l1 [Int64]
x EvaluationContext
_ == :: CostModel -> CostModel -> Bool
== CostModel Language
l2 [Int64]
y EvaluationContext
_ = Language
l1 forall a. Eq a => a -> a -> Bool
== Language
l2 Bool -> Bool -> Bool
&& [Int64]
x forall a. Eq a => a -> a -> Bool
== [Int64]
y

instance Show CostModel where
  show :: CostModel -> [Char]
show (CostModel Language
lang [Int64]
cm EvaluationContext
_) = [Char]
"CostModel " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> [Char]
show Language
lang forall a. Semigroup a => a -> a -> a
<> [Char]
" " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> [Char]
show [Int64]
cm

-- | Note that this Ord instance ignores the evaluation context, which is
-- entirely dependent on the cost model parameters and is guarded by the
-- smart constructor `mkCostModel`.
instance Ord CostModel where
  compare :: CostModel -> CostModel -> Ordering
compare (CostModel Language
l1 [Int64]
x EvaluationContext
_) (CostModel Language
l2 [Int64]
y EvaluationContext
_) = forall a. Ord a => a -> a -> Ordering
compare Language
l1 Language
l2 forall a. Semigroup a => a -> a -> a
<> forall a. Ord a => a -> a -> Ordering
compare [Int64]
x [Int64]
y

instance NoThunks CostModel

instance NFData CostModel where
  rnf :: CostModel -> ()
rnf (CostModel Language
lang [Int64]
cm EvaluationContext
ectx) = Language
lang forall a b. NFData a => a -> b -> b
`deepseq` [Int64]
cm forall a b. NFData a => a -> b -> b
`deepseq` forall a. NFData a => a -> ()
rnf EvaluationContext
ectx

instance FromJSON CostModels where
  parseJSON :: Value -> Parser CostModels
parseJSON = forall a. [Char] -> (Object -> Parser a) -> Value -> Parser a
withObject [Char]
"CostModels" forall a b. (a -> b) -> a -> b
$ \Object
o -> do
    [Maybe CostModel]
cms <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Object -> Language -> Parser (Maybe CostModel)
parseCostModel Object
o) [Language]
nonNativeLanguages
    let cmsMap :: Map Language CostModel
cmsMap = forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(CostModel -> Language
cmLanguage CostModel
cm, CostModel
cm) | Just CostModel
cm <- [Maybe CostModel]
cms]
    Map Word8 [Int64]
unknown <- Object
o forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"Unknown" forall a. Parser (Maybe a) -> a -> Parser a
.!= forall a. Monoid a => a
mempty
    CostModels
unknownCostModels <- forall (m :: * -> *).
MonadFail m =>
Map Word8 [Int64] -> m CostModels
mkCostModelsLenient Map Word8 [Int64]
unknown
    forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Map Language CostModel -> CostModels
mkCostModels Map Language CostModel
cmsMap forall a. Semigroup a => a -> a -> a
<> CostModels
unknownCostModels

-- | The costmodel parameters in Alonzo Genesis are represented as a map.  Plutus API does
-- no longer require the map as a parameter to `mkEvaluationContext`, but the list of
-- integers representing the values of the map.  The expectation on this list of integers
-- is that they are sorted in the order given by the `ParamName` enum, so even though we
-- just have to pass the list to plutus, we still need to use the names of the parameters
-- in order to sort the list.  In new versions, we want to represent the costmodel
-- parameters directly as a list, so we can avoid this reordering.
parseCostModel :: Object -> Language -> Parser (Maybe CostModel)
parseCostModel :: Object -> Language -> Parser (Maybe CostModel)
parseCostModel Object
o Language
lang = do
  Maybe Value
plutusCostModelValueMaybe <- Object
o forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? [Char] -> Key
fromString (forall a. Show a => a -> [Char]
show Language
lang)
  forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM Maybe Value
plutusCostModelValueMaybe forall a b. (a -> b) -> a -> b
$ \Value
plutusCostModelValue ->
    case Value
plutusCostModelValue of
      Object Object
_ -> forall (m :: * -> *).
MonadFail m =>
Language -> Map Text Int64 -> m CostModel
costModelFromMap Language
lang forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall a. FromJSON a => Value -> Parser a
parseJSON Value
plutusCostModelValue
      Array Array
_ -> forall (m :: * -> *).
MonadFail m =>
Language -> [Int64] -> m CostModel
validateCostModel Language
lang forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall a. FromJSON a => Value -> Parser a
parseJSON Value
plutusCostModelValue
      Value
_ -> forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail forall a b. (a -> b) -> a -> b
$ [Char]
"Expected either an Array or an Object, but got: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show Value
plutusCostModelValue

costModelFromMap :: MonadFail m => Language -> Map Text Int64 -> m CostModel
costModelFromMap :: forall (m :: * -> *).
MonadFail m =>
Language -> Map Text Int64 -> m CostModel
costModelFromMap Language
lang Map Text Int64
cmMap =
  forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail forall b c a. (b -> c) -> (a -> b) -> a -> c
. Context -> [Char]
unlines forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Char]
header forall a. a -> [a] -> [a]
:) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. NonEmpty a -> [a]
NE.toList) (forall (m :: * -> *).
MonadFail m =>
Language -> [Int64] -> m CostModel
validateCostModel Language
lang) forall a b. (a -> b) -> a -> b
$
    forall e a. Validation e a -> Either e a
validationToEither (forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse Text -> Validation (NonEmpty [Char]) Int64
lookupFail [Text]
paramNames)
  where
    header :: [Char]
header = [Char]
"Cost model language: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show Language
lang
    paramNames :: [Text]
paramNames = Language -> [Text]
costModelParamNames Language
lang
    lookupFail :: Text -> Validation (NonEmpty [Char]) Int64
lookupFail Text
paramName =
      case forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Text
paramName Map Text Int64
cmMap of
        Maybe Int64
Nothing -> forall e a. e -> Validation (NonEmpty e) a
failure forall a b. (a -> b) -> a -> b
$ [Char]
"  Parameter name missing from cost model: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show Text
paramName
        Just Int64
v -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Int64
v

costModelToMap :: CostModel -> Map Text Int64
costModelToMap :: CostModel -> Map Text Int64
costModelToMap CostModel
cm =
  forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList forall a b. (a -> b) -> a -> b
$ forall a b. [a] -> [b] -> [(a, b)]
zip (Language -> [Text]
costModelParamNames (CostModel -> Language
cmLanguage CostModel
cm)) (CostModel -> [Int64]
cmValues CostModel
cm)

costModelParamNames :: Language -> [Text]
costModelParamNames :: Language -> [Text]
costModelParamNames Language
PlutusV1 = [Text]
plutusV1ParamNames
costModelParamNames Language
lang = Language -> [Text]
plutusVXParamNames Language
lang

-- | There is a difference in 6 parameter names between the ones appearing alonzo genesis
-- files and the values returned by plutus via `P.showParamName` on the `ParamName` enum.
-- This listed is sorted in the order given by `ParamName` enum, so we can use it to sort
-- the costmodel param values before passing them to plutus `mkEvaluationContext`.
plutusV1ParamNames :: [Text]
plutusV1ParamNames :: [Text]
plutusV1ParamNames =
  forall a b. (a -> b) -> [a] -> [b]
map (\Text
newName -> forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault Text
newName Text
newName Map Text Text
oldNewMapping) [Text]
newNames
  where
    newNames :: [Text]
newNames = Language -> [Text]
plutusVXParamNames Language
PlutusV1
    oldNewMapping :: Map Text Text
oldNewMapping =
      forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
        [ (Text
"blake2b_256-cpu-arguments-intercept", Text
"blake2b-cpu-arguments-intercept")
        , (Text
"blake2b_256-cpu-arguments-slope", Text
"blake2b-cpu-arguments-slope")
        , (Text
"blake2b_256-memory-arguments", Text
"blake2b-memory-arguments")
        , (Text
"verifyEd25519Signature-cpu-arguments-intercept", Text
"verifySignature-cpu-arguments-intercept")
        , (Text
"verifyEd25519Signature-cpu-arguments-slope", Text
"verifySignature-cpu-arguments-slope")
        , (Text
"verifyEd25519Signature-memory-arguments", Text
"verifySignature-memory-arguments")
        ]

plutusVXParamNames :: Language -> [Text]
plutusVXParamNames :: Language -> [Text]
plutusVXParamNames Language
PlutusV1 = forall a. IsParamName a => a -> Text
P.showParamName forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [forall a. Bounded a => a
minBound .. forall a. Bounded a => a
maxBound :: PV1.ParamName]
plutusVXParamNames Language
PlutusV2 = forall a. IsParamName a => a -> Text
P.showParamName forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [forall a. Bounded a => a
minBound .. forall a. Bounded a => a
maxBound :: PV2.ParamName]
plutusVXParamNames Language
PlutusV3 = forall a. IsParamName a => a -> Text
P.showParamName forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [forall a. Bounded a => a
minBound .. forall a. Bounded a => a
maxBound :: PV3.ParamName]

validateCostModel :: MonadFail m => Language -> [Int64] -> m CostModel
validateCostModel :: forall (m :: * -> *).
MonadFail m =>
Language -> [Int64] -> m CostModel
validateCostModel Language
lang [Int64]
cmps =
  case Language -> [Int64] -> Either CostModelApplyError CostModel
mkCostModel Language
lang [Int64]
cmps of
    Left CostModelApplyError
err -> forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> [Char]
show CostModelApplyError
err
    Right CostModel
cm -> forall (f :: * -> *) a. Applicative f => a -> f a
pure CostModel
cm

-- | Convert cost model parameters to a cost model, making use of the
--  conversion function mkEvaluationContext from the Plutus API.
--
-- Note that we always retain the original values that were supplied.
mkCostModel :: Language -> [Int64] -> Either P.CostModelApplyError CostModel
mkCostModel :: Language -> [Int64] -> Either CostModelApplyError CostModel
mkCostModel Language
lang [Int64]
cm =
  case Either
  CostModelApplyError (EvaluationContext, [CostModelApplyWarn])
eCostModel of
    Right (EvaluationContext
evalCtx, [CostModelApplyWarn]
_) -> forall a b. b -> Either a b
Right (Language -> [Int64] -> EvaluationContext -> CostModel
CostModel Language
lang [Int64]
cm EvaluationContext
evalCtx)
    Left CostModelApplyError
e -> forall a b. a -> Either a b
Left CostModelApplyError
e
  where
    mkEvaluationContext :: [Int64]
-> WriterT
     [CostModelApplyWarn] (Either CostModelApplyError) EvaluationContext
mkEvaluationContext =
      case Language
lang of
        Language
PlutusV1 -> forall (m :: * -> *).
(MonadError CostModelApplyError m,
 MonadWriter [CostModelApplyWarn] m) =>
[Int64] -> m EvaluationContext
PV1.mkEvaluationContext
        Language
PlutusV2 -> forall (m :: * -> *).
(MonadError CostModelApplyError m,
 MonadWriter [CostModelApplyWarn] m) =>
[Int64] -> m EvaluationContext
PV2.mkEvaluationContext
        Language
PlutusV3 -> forall (m :: * -> *).
(MonadError CostModelApplyError m,
 MonadWriter [CostModelApplyWarn] m) =>
[Int64] -> m EvaluationContext
PV3.mkEvaluationContext
    eCostModel :: Either P.CostModelApplyError (P.EvaluationContext, [P.CostModelApplyWarn])
    eCostModel :: Either
  CostModelApplyError (EvaluationContext, [CostModelApplyWarn])
eCostModel = forall w (m :: * -> *) a. WriterT w m a -> m (a, w)
runWriterT ([Int64]
-> WriterT
     [CostModelApplyWarn] (Either CostModelApplyError) EvaluationContext
mkEvaluationContext [Int64]
cm)

getCostModelLanguage :: CostModel -> Language
getCostModelLanguage :: CostModel -> Language
getCostModelLanguage (CostModel Language
lang [Int64]
_ EvaluationContext
_) = Language
lang

getCostModelParams :: CostModel -> [Int64]
getCostModelParams :: CostModel -> [Int64]
getCostModelParams (CostModel Language
_ [Int64]
cm EvaluationContext
_) = [Int64]
cm

getCostModelEvaluationContext :: CostModel -> P.EvaluationContext
getCostModelEvaluationContext :: CostModel -> EvaluationContext
getCostModelEvaluationContext = CostModel -> EvaluationContext
cmEvalCtx

decodeCostModelsLenient :: Decoder s CostModels
decodeCostModelsLenient :: forall s. Decoder s CostModels
decodeCostModelsLenient = forall a s. DecCBOR a => Decoder s a
decCBOR forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *).
MonadFail m =>
Map Word8 [Int64] -> m CostModels
mkCostModelsLenient
{-# INLINE decodeCostModelsLenient #-}

decodeCostModelsFailing :: Decoder s CostModels
decodeCostModelsFailing :: forall s. Decoder s CostModels
decodeCostModelsFailing =
  Map Language CostModel -> Map Word8 [Int64] -> CostModels
CostModels forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall k s v.
Ord k =>
Decoder s k -> (k -> Decoder s v) -> Decoder s (Map k v)
decodeMapByKey forall a s. DecCBOR a => Decoder s a
decCBOR forall s. Language -> Decoder s CostModel
decodeCostModelLegacy forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Monoid a => a
mempty
{-# INLINE decodeCostModelsFailing #-}

decodeCostModels :: Decoder s CostModels
decodeCostModels :: forall s. Decoder s CostModels
decodeCostModels =
  forall s a. Version -> Decoder s a -> Decoder s a -> Decoder s a
ifDecoderVersionAtLeast
    (forall (v :: Natural).
(KnownNat v, MinVersion <= v, v <= MaxVersion) =>
Version
natVersion @9)
    forall s. Decoder s CostModels
decodeCostModelsLenient
    forall s. Decoder s CostModels
decodeCostModelsFailing
{-# INLINEABLE decodeCostModels #-}

-- | Initial number of parameters in a CostModel for a specific language when the language was
-- introduced. Starting with Conway we support variable number of parameters, therefore
-- do not expect this number to reflect the reality on the number of supported parameters.
costModelParamsCount :: Language -> Int
costModelParamsCount :: Language -> Int
costModelParamsCount Language
PlutusV1 = Int
166
costModelParamsCount Language
PlutusV2 = Int
175
costModelParamsCount Language
PlutusV3 = Int
231

decodeCostModelLegacy :: Language -> Decoder s CostModel
decodeCostModelLegacy :: forall s. Language -> Decoder s CostModel
decodeCostModelLegacy Language
lang = do
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Language
lang forall a. Ord a => a -> a -> Bool
> Language
PlutusV2) forall a b. (a -> b) -> a -> b
$
    forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail forall a b. (a -> b) -> a -> b
$
      [Char]
"Legacy CostModel decoding is not supported for " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show Language
lang forall a. [a] -> [a] -> [a]
++ [Char]
" language version"
  [Int64]
values <- forall a s. DecCBOR a => Decoder s a
decCBOR
  let numValues :: Int
numValues = forall (t :: * -> *) a. Foldable t => t a -> Int
length [Int64]
values
      expectedNumValues :: Int
expectedNumValues = Language -> Int
costModelParamsCount Language
lang
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
numValues forall a. Eq a => a -> a -> Bool
/= Int
expectedNumValues) forall a b. (a -> b) -> a -> b
$
    forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail forall a b. (a -> b) -> a -> b
$
      [Char]
"Expected array with "
        forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> [Char]
show Int
expectedNumValues
        forall a. Semigroup a => a -> a -> a
<> [Char]
" entries, but encoded array has "
        forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> [Char]
show Int
numValues
        forall a. Semigroup a => a -> a -> a
<> [Char]
" entries."
  case Language -> [Int64] -> Either CostModelApplyError CostModel
mkCostModel Language
lang [Int64]
values of
    Left CostModelApplyError
e -> forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> [Char]
show CostModelApplyError
e
    Right CostModel
cm -> forall (f :: * -> *) a. Applicative f => a -> f a
pure CostModel
cm
{-# INLINEABLE decodeCostModelLegacy #-}

-- | Prior to version 9, each 'CostModel' was expected to be serialized as an array of
-- integers of a specific length (depending on the version of Plutus).  Starting in
-- version 9, we allow the decoders to accept lists longer or shorter than what they
-- require, so that new fields can be added in the future. For this reason, we must hard
-- code the length expectation into the deserializers prior to version 9.
--
-- Note that the number of elements in the V1 and V2 cost models are allowed to change in
-- the future, they are only fixed prior to version 9.
--
-- See https://github.com/intersectmbo/cardano-ledger/issues/2902
-- and https://github.com/intersectmbo/cardano-ledger/blob/master/docs/adr/2022-12-05_006-cost-model-serialization.md
decodeCostModel :: Language -> Decoder s CostModel
decodeCostModel :: forall s. Language -> Decoder s CostModel
decodeCostModel Language
lang = do
  forall s a. Version -> Decoder s a -> Decoder s a -> Decoder s a
ifDecoderVersionAtLeast
    (forall (v :: Natural).
(KnownNat v, MinVersion <= v, v <= MaxVersion) =>
Version
natVersion @9)
    Decoder s CostModel
decodeCostModelLenient
    (forall s. Language -> Decoder s CostModel
decodeCostModelLegacy Language
lang)
  where
    decodeCostModelLenient :: Decoder s CostModel
decodeCostModelLenient = do
      Either CostModelApplyError CostModel
checked <- Language -> [Int64] -> Either CostModelApplyError CostModel
mkCostModel Language
lang forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a s. DecCBOR a => Decoder s a
decCBOR
      case Either CostModelApplyError CostModel
checked of
        Left CostModelApplyError
e -> forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> [Char]
show CostModelApplyError
e
        Right CostModel
cm -> forall (f :: * -> *) a. Applicative f => a -> f a
pure CostModel
cm
{-# INLINEABLE decodeCostModel #-}

getEvaluationContext :: CostModel -> P.EvaluationContext
getEvaluationContext :: CostModel -> EvaluationContext
getEvaluationContext (CostModel Language
_ [Int64]
_ EvaluationContext
ec) = EvaluationContext
ec

-- | For a known version of Plutus, attempting to construct a cost model with
-- too few parameters (depending on the version) will result in an error.
-- 'CostModelApplyError' exists to collect these errors in the 'CostModels' type.
-- The 'CostModels' type itself needs to be flexible enough to accept any map
-- of 'Word8' to '[Int64]', so that cost models can be placed in the protocol parameters
-- ahead of changes to the Plutus evaluation context. In this way, serializing a cost model,
-- updating software, and deserializing can result in errors going away.
--
-- Additionally, 'CostModels' needs to be able to store cost models for future version
-- of Plutus, which we cannot yet even validate. These are stored in
-- 'costModelsUnknown`.
data CostModels = CostModels
  { CostModels -> Map Language CostModel
_costModelsValid :: !(Map Language CostModel)
  , CostModels -> Map Word8 [Int64]
_costModelsUnknown :: !(Map Word8 [Int64])
  }
  deriving stock (CostModels -> CostModels -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: CostModels -> CostModels -> Bool
$c/= :: CostModels -> CostModels -> Bool
== :: CostModels -> CostModels -> Bool
$c== :: CostModels -> CostModels -> Bool
Eq, Eq CostModels
CostModels -> CostModels -> Bool
CostModels -> CostModels -> Ordering
CostModels -> CostModels -> CostModels
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 :: CostModels -> CostModels -> CostModels
$cmin :: CostModels -> CostModels -> CostModels
max :: CostModels -> CostModels -> CostModels
$cmax :: CostModels -> CostModels -> CostModels
>= :: CostModels -> CostModels -> Bool
$c>= :: CostModels -> CostModels -> Bool
> :: CostModels -> CostModels -> Bool
$c> :: CostModels -> CostModels -> Bool
<= :: CostModels -> CostModels -> Bool
$c<= :: CostModels -> CostModels -> Bool
< :: CostModels -> CostModels -> Bool
$c< :: CostModels -> CostModels -> Bool
compare :: CostModels -> CostModels -> Ordering
$ccompare :: CostModels -> CostModels -> Ordering
Ord, Int -> CostModels -> ShowS
[CostModels] -> ShowS
CostModels -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [CostModels] -> ShowS
$cshowList :: [CostModels] -> ShowS
show :: CostModels -> [Char]
$cshow :: CostModels -> [Char]
showsPrec :: Int -> CostModels -> ShowS
$cshowsPrec :: Int -> CostModels -> ShowS
Show, forall x. Rep CostModels x -> CostModels
forall x. CostModels -> Rep CostModels x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep CostModels x -> CostModels
$cfrom :: forall x. CostModels -> Rep CostModels x
Generic)

instance Semigroup CostModels where
  <> :: CostModels -> CostModels -> CostModels
(<>) = CostModels -> CostModels -> CostModels
updateCostModels

instance Monoid CostModels where
  mempty :: CostModels
mempty = CostModels
emptyCostModels

costModelsValid :: CostModels -> Map Language CostModel
costModelsValid :: CostModels -> Map Language CostModel
costModelsValid = CostModels -> Map Language CostModel
_costModelsValid

costModelsUnknown :: CostModels -> Map Word8 [Int64]
costModelsUnknown :: CostModels -> Map Word8 [Int64]
costModelsUnknown = CostModels -> Map Word8 [Int64]
_costModelsUnknown

emptyCostModels :: CostModels
emptyCostModels :: CostModels
emptyCostModels = Map Language CostModel -> Map Word8 [Int64] -> CostModels
CostModels forall a. Monoid a => a
mempty forall a. Monoid a => a
mempty

-- | Updates the first @`CostModels`@ with the second one, so that only the cost models
-- that are present in the second one get updated while all the others stay
-- unchanged. Language specific errors and unknown cost models are removed, whenever a
-- valid `CostModel` for the language is supplied in the update.
updateCostModels ::
  -- | Old CostModels that will be overwritten
  CostModels ->
  -- | New CostModels that will overwrite
  CostModels ->
  CostModels
updateCostModels :: CostModels -> CostModels -> CostModels
updateCostModels (CostModels Map Language CostModel
oldValid Map Word8 [Int64]
oldUnk) (CostModels Map Language CostModel
modValid Map Word8 [Int64]
modUnk) =
  Map Language CostModel -> Map Word8 [Int64] -> CostModels
CostModels
    Map Language CostModel
newValid
    (forall k a. Ord k => Map k a -> Map k a -> Map k a
Map.union Map Word8 [Int64]
modUnk Map Word8 [Int64]
oldUnk forall k a b. Ord k => Map k a -> Map k b -> Map k a
Map.\\ forall k2 k1 a. Ord k2 => (k1 -> k2) -> Map k1 a -> Map k2 a
Map.mapKeys Language -> Word8
languageToWord8 Map Language CostModel
newValid)
  where
    newValid :: Map Language CostModel
newValid = forall k a. Ord k => Map k a -> Map k a -> Map k a
Map.union Map Language CostModel
modValid Map Language CostModel
oldValid

-- | Construct an all valid `CostModels`
mkCostModels :: Map Language CostModel -> CostModels
mkCostModels :: Map Language CostModel -> CostModels
mkCostModels Map Language CostModel
cms = Map Language CostModel -> Map Word8 [Int64] -> CostModels
CostModels Map Language CostModel
cms forall a. Monoid a => a
mempty

-- | This function attempts to convert a Map with potential cost models into validated
-- 'CostModels'.  If it is a valid cost model for a known version of Plutus, it is added
-- to 'costModelsValid'. If it is an invalid cost model for a known version of Plutus, the
-- function will fail with a string version of 'P.CostModelApplyError'. Lastly, if the
-- Plutus version is unknown, the cost model is also stored in 'costModelsUnknown'.
mkCostModelsLenient :: MonadFail m => Map Word8 [Int64] -> m CostModels
mkCostModelsLenient :: forall (m :: * -> *).
MonadFail m =>
Map Word8 [Int64] -> m CostModels
mkCostModelsLenient = forall k a b. (k -> a -> b -> b) -> b -> Map k a -> b
Map.foldrWithKey forall (m :: * -> *).
MonadFail m =>
Word8 -> [Int64] -> m CostModels -> m CostModels
addRawCostModel (forall (f :: * -> *) a. Applicative f => a -> f a
pure (Map Language CostModel -> Map Word8 [Int64] -> CostModels
CostModels forall a. Monoid a => a
mempty forall a. Monoid a => a
mempty))
  where
    addRawCostModel :: MonadFail m => Word8 -> [Int64] -> m CostModels -> m CostModels
    addRawCostModel :: forall (m :: * -> *).
MonadFail m =>
Word8 -> [Int64] -> m CostModels -> m CostModels
addRawCostModel Word8
langW8 [Int64]
cmIds m CostModels
costModelsM = do
      CostModels Map Language CostModel
validCostModels Map Word8 [Int64]
unknownCostModels <- m CostModels
costModelsM
      case Int -> Maybe Language
mkLanguageEnum (forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
langW8) of
        Just Language
lang ->
          -- Note that we also retain the original values for the known languages as well,
          -- which are stored in the `CostModel.cmValues` instead of the unknown
          -- `CostModel._costModelsUnknown` Map.
          case Language -> [Int64] -> Either CostModelApplyError CostModel
mkCostModel Language
lang [Int64]
cmIds of
            Right CostModel
cm -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Map Language CostModel -> Map Word8 [Int64] -> CostModels
CostModels (forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Language
lang CostModel
cm Map Language CostModel
validCostModels) Map Word8 [Int64]
unknownCostModels
            Left CostModelApplyError
err -> forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail forall a b. (a -> b) -> a -> b
$ [Char]
"CostModel construction failure: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show CostModelApplyError
err
        Maybe Language
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Map Language CostModel -> Map Word8 [Int64] -> CostModels
CostModels Map Language CostModel
validCostModels (forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Word8
langW8 [Int64]
cmIds Map Word8 [Int64]
unknownCostModels)

-- | Turn a 'CostModels' into a mapping of potential language versions and cost model
-- values, with no distinction between valid and unknown cost models. This is used for
-- serialization, so that judgements about known languages can be made upon
-- deserialization.
flattenCostModels :: CostModels -> Map Word8 [Int64]
flattenCostModels :: CostModels -> Map Word8 [Int64]
flattenCostModels (CostModels Map Language CostModel
validCostModels Map Word8 [Int64]
unknownCostModels) =
  forall k a b. (k -> a -> b -> b) -> b -> Map k a -> b
Map.foldrWithKey
    (\Language
lang CostModel
cm -> forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert (Language -> Word8
languageToWord8 Language
lang) (CostModel -> [Int64]
cmValues CostModel
cm))
    Map Word8 [Int64]
unknownCostModels
    Map Language CostModel
validCostModels

languageToWord8 :: Language -> Word8
languageToWord8 :: Language -> Word8
languageToWord8 Language
lang
  | Int
0 forall a. Ord a => a -> a -> Bool
<= Int
li Bool -> Bool -> Bool
&& Int
li forall a. Ord a => a -> a -> Bool
<= forall a b. (Integral a, Num b) => a -> b
fromIntegral (forall a. Bounded a => a
maxBound :: Word8) = forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
li
  | Bool
otherwise =
      -- This should be impossible while we have under 256 versions of Plutus
      forall a. HasCallStack => [Char] -> a
error forall a b. (a -> b) -> a -> b
$ [Char]
"Impossible: Overflow encountered during conversion of the language: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show Language
lang
  where
    li :: Int
li = forall a. Enum a => a -> Int
fromEnum Language
lang

instance NoThunks CostModels

instance NFData CostModels

instance DecCBOR CostModels where
  decCBOR :: forall s. Decoder s CostModels
decCBOR = forall s. Decoder s CostModels
decodeCostModels
  {-# INLINE decCBOR #-}

instance EncCBOR CostModels where
  encCBOR :: CostModels -> Encoding
encCBOR = forall a. EncCBOR a => a -> Encoding
encCBOR forall b c a. (b -> c) -> (a -> b) -> a -> c
. CostModels -> Map Word8 [Int64]
flattenCostModels

instance ToJSON CostModel where
  toJSON :: CostModel -> Value
toJSON = forall a. ToJSON a => a -> Value
toJSON forall b c a. (b -> c) -> (a -> b) -> a -> c
. CostModel -> [Int64]
getCostModelParams

instance ToJSON CostModels where
  toJSON :: CostModels -> Value
toJSON CostModels
cms = forall a. ToJSON a => a -> Value
toJSON forall a b. (a -> b) -> a -> b
$ Map Text Value
jsonValid forall a. Semigroup a => a -> a -> a
<> Map Text Value
jsonUnknown
    where
      jsonMap :: (k1 -> k2) -> Map k1 a -> Map k2 Value
jsonMap k1 -> k2
toKey = forall k2 k1 a. Ord k2 => (k1 -> k2) -> Map k1 a -> Map k2 a
Map.mapKeys k1 -> k2
toKey forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b k. (a -> b) -> Map k a -> Map k b
Map.map forall a. ToJSON a => a -> Value
toJSON
      jsonValid :: Map Text Value
jsonValid = forall {k2} {a} {k1}.
(Ord k2, ToJSON a) =>
(k1 -> k2) -> Map k1 a -> Map k2 Value
jsonMap Language -> Text
languageToText forall a b. (a -> b) -> a -> b
$ CostModels -> Map Language CostModel
costModelsValid CostModels
cms
      jsonUnknown :: Map Text Value
jsonUnknown
        | forall (t :: * -> *) a. Foldable t => t a -> Bool
null (CostModels -> Map Word8 [Int64]
costModelsUnknown CostModels
cms) = forall a. Monoid a => a
mempty
        | Bool
otherwise =
            forall k a. k -> a -> Map k a
Map.singleton Text
"Unknown" forall a b. (a -> b) -> a -> b
$ forall a. ToJSON a => a -> Value
toJSON forall a b. (a -> b) -> a -> b
$ forall {k2} {a} {k1}.
(Ord k2, ToJSON a) =>
(k1 -> k2) -> Map k1 a -> Map k2 Value
jsonMap ([Char] -> Text
T.pack forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> [Char]
show) forall a b. (a -> b) -> a -> b
$ CostModels -> Map Word8 [Int64]
costModelsUnknown CostModels
cms

-- | Encoding for the `CostModel`. Important to note that it differs from `Encoding` used
-- by `Cardano.Ledger.Alonzo.PParams.getLanguageView`
encodeCostModel :: CostModel -> Encoding
encodeCostModel :: CostModel -> Encoding
encodeCostModel = forall (f :: * -> *) a.
Foldable f =>
(a -> Encoding) -> f a -> Encoding
encodeFoldableAsDefLenList forall a. EncCBOR a => a -> Encoding
encCBOR forall b c a. (b -> c) -> (a -> b) -> a -> c
. CostModel -> [Int64]
getCostModelParams