{-# 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. CostModel -> Rep CostModel x)
-> (forall x. Rep CostModel x -> CostModel) -> Generic CostModel
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
$cfrom :: forall x. CostModel -> Rep CostModel x
from :: forall x. CostModel -> Rep CostModel x
$cto :: forall x. Rep CostModel x -> CostModel
to :: forall x. Rep CostModel x -> CostModel
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 Language -> Language -> Bool
forall a. Eq a => a -> a -> Bool
== Language
l2 Bool -> Bool -> Bool
&& [Int64]
x [Int64] -> [Int64] -> Bool
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 " [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> Language -> [Char]
forall a. Show a => a -> [Char]
show Language
lang [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
" " [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Int64] -> [Char]
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
_) = Language -> Language -> Ordering
forall a. Ord a => a -> a -> Ordering
compare Language
l1 Language
l2 Ordering -> Ordering -> Ordering
forall a. Semigroup a => a -> a -> a
<> [Int64] -> [Int64] -> Ordering
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 Language -> () -> ()
forall a b. NFData a => a -> b -> b
`deepseq` [Int64]
cm [Int64] -> () -> ()
forall a b. NFData a => a -> b -> b
`deepseq` EvaluationContext -> ()
forall a. NFData a => a -> ()
rnf EvaluationContext
ectx

instance FromJSON CostModels where
  parseJSON :: Value -> Parser CostModels
parseJSON = [Char]
-> (Object -> Parser CostModels) -> Value -> Parser CostModels
forall a. [Char] -> (Object -> Parser a) -> Value -> Parser a
withObject [Char]
"CostModels" ((Object -> Parser CostModels) -> Value -> Parser CostModels)
-> (Object -> Parser CostModels) -> Value -> Parser CostModels
forall a b. (a -> b) -> a -> b
$ \Object
o -> do
    [Maybe CostModel]
cms <- (Language -> Parser (Maybe CostModel))
-> [Language] -> Parser [Maybe CostModel]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (Object -> Language -> Parser (Maybe CostModel)
parseCostModel Object
o) [Language]
nonNativeLanguages
    let cmsMap :: Map Language CostModel
cmsMap = [(Language, CostModel)] -> Map Language CostModel
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 Object -> Key -> Parser (Maybe (Map Word8 [Int64]))
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"Unknown" Parser (Maybe (Map Word8 [Int64]))
-> Map Word8 [Int64] -> Parser (Map Word8 [Int64])
forall a. Parser (Maybe a) -> a -> Parser a
.!= Map Word8 [Int64]
forall a. Monoid a => a
mempty
    CostModels
unknownCostModels <- Map Word8 [Int64] -> Parser CostModels
forall (m :: * -> *).
MonadFail m =>
Map Word8 [Int64] -> m CostModels
mkCostModelsLenient Map Word8 [Int64]
unknown
    CostModels -> Parser CostModels
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (CostModels -> Parser CostModels)
-> CostModels -> Parser CostModels
forall a b. (a -> b) -> a -> b
$ Map Language CostModel -> CostModels
mkCostModels Map Language CostModel
cmsMap CostModels -> CostModels -> CostModels
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 Object -> Key -> Parser (Maybe Value)
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? [Char] -> Key
fromString (Language -> [Char]
forall a. Show a => a -> [Char]
show Language
lang)
  Maybe Value
-> (Value -> Parser CostModel) -> Parser (Maybe CostModel)
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM Maybe Value
plutusCostModelValueMaybe ((Value -> Parser CostModel) -> Parser (Maybe CostModel))
-> (Value -> Parser CostModel) -> Parser (Maybe CostModel)
forall a b. (a -> b) -> a -> b
$ \Value
plutusCostModelValue ->
    case Value
plutusCostModelValue of
      Object Object
_ -> Language -> Map Text Int64 -> Parser CostModel
forall (m :: * -> *).
MonadFail m =>
Language -> Map Text Int64 -> m CostModel
costModelFromMap Language
lang (Map Text Int64 -> Parser CostModel)
-> Parser (Map Text Int64) -> Parser CostModel
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Value -> Parser (Map Text Int64)
forall a. FromJSON a => Value -> Parser a
parseJSON Value
plutusCostModelValue
      Array Array
_ -> Language -> [Int64] -> Parser CostModel
forall (m :: * -> *).
MonadFail m =>
Language -> [Int64] -> m CostModel
validateCostModel Language
lang ([Int64] -> Parser CostModel) -> Parser [Int64] -> Parser CostModel
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Value -> Parser [Int64]
forall a. FromJSON a => Value -> Parser a
parseJSON Value
plutusCostModelValue
      Value
_ -> [Char] -> Parser CostModel
forall a. [Char] -> Parser a
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail ([Char] -> Parser CostModel) -> [Char] -> Parser CostModel
forall a b. (a -> b) -> a -> b
$ [Char]
"Expected either an Array or an Object, but got: " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ Value -> [Char]
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 =
  (NonEmpty [Char] -> m CostModel)
-> ([Int64] -> m CostModel)
-> Either (NonEmpty [Char]) [Int64]
-> m CostModel
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either ([Char] -> m CostModel
forall a. [Char] -> m a
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail ([Char] -> m CostModel)
-> (NonEmpty [Char] -> [Char]) -> NonEmpty [Char] -> m CostModel
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Context -> [Char]
unlines (Context -> [Char])
-> (NonEmpty [Char] -> Context) -> NonEmpty [Char] -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Char]
header [Char] -> Context -> Context
forall a. a -> [a] -> [a]
:) (Context -> Context)
-> (NonEmpty [Char] -> Context) -> NonEmpty [Char] -> Context
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonEmpty [Char] -> Context
forall a. NonEmpty a -> [a]
NE.toList) (Language -> [Int64] -> m CostModel
forall (m :: * -> *).
MonadFail m =>
Language -> [Int64] -> m CostModel
validateCostModel Language
lang) (Either (NonEmpty [Char]) [Int64] -> m CostModel)
-> Either (NonEmpty [Char]) [Int64] -> m CostModel
forall a b. (a -> b) -> a -> b
$
    Validation (NonEmpty [Char]) [Int64]
-> Either (NonEmpty [Char]) [Int64]
forall e a. Validation e a -> Either e a
validationToEither ((Text -> Validation (NonEmpty [Char]) Int64)
-> [Text] -> Validation (NonEmpty [Char]) [Int64]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse Text -> Validation (NonEmpty [Char]) Int64
lookupFail [Text]
paramNames)
  where
    header :: [Char]
header = [Char]
"Cost model language: " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ Language -> [Char]
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 Text -> Map Text Int64 -> Maybe Int64
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Text
paramName Map Text Int64
cmMap of
        Maybe Int64
Nothing -> [Char] -> Validation (NonEmpty [Char]) Int64
forall e a. e -> Validation (NonEmpty e) a
failure ([Char] -> Validation (NonEmpty [Char]) Int64)
-> [Char] -> Validation (NonEmpty [Char]) Int64
forall a b. (a -> b) -> a -> b
$ [Char]
"  Parameter name missing from cost model: " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ Text -> [Char]
forall a. Show a => a -> [Char]
show Text
paramName
        Just Int64
v -> Int64 -> Validation (NonEmpty [Char]) Int64
forall a. a -> Validation (NonEmpty [Char]) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Int64
v

costModelToMap :: CostModel -> Map Text Int64
costModelToMap :: CostModel -> Map Text Int64
costModelToMap CostModel
cm =
  [(Text, Int64)] -> Map Text Int64
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(Text, Int64)] -> Map Text Int64)
-> [(Text, Int64)] -> Map Text Int64
forall a b. (a -> b) -> a -> b
$ [Text] -> [Int64] -> [(Text, Int64)]
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 =
  (Text -> Text) -> [Text] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (\Text
newName -> Text -> Text -> Map Text Text -> Text
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 =
      [(Text, Text)] -> Map Text Text
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 = ParamName -> Text
forall a. IsParamName a => a -> Text
P.showParamName (ParamName -> Text) -> [ParamName] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [ParamName
forall a. Bounded a => a
minBound .. ParamName
forall a. Bounded a => a
maxBound :: PV1.ParamName]
plutusVXParamNames Language
PlutusV2 = ParamName -> Text
forall a. IsParamName a => a -> Text
P.showParamName (ParamName -> Text) -> [ParamName] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [ParamName
forall a. Bounded a => a
minBound .. ParamName
forall a. Bounded a => a
maxBound :: PV2.ParamName]
plutusVXParamNames Language
PlutusV3 = ParamName -> Text
forall a. IsParamName a => a -> Text
P.showParamName (ParamName -> Text) -> [ParamName] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [ParamName
forall a. Bounded a => a
minBound .. ParamName
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 -> [Char] -> m CostModel
forall a. [Char] -> m a
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail ([Char] -> m CostModel) -> [Char] -> m CostModel
forall a b. (a -> b) -> a -> b
$ CostModelApplyError -> [Char]
forall a. Show a => a -> [Char]
show CostModelApplyError
err
    Right CostModel
cm -> CostModel -> m CostModel
forall a. a -> m a
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]
_) -> CostModel -> Either CostModelApplyError CostModel
forall a b. b -> Either a b
Right (Language -> [Int64] -> EvaluationContext -> CostModel
CostModel Language
lang [Int64]
cm EvaluationContext
evalCtx)
    Left CostModelApplyError
e -> CostModelApplyError -> Either CostModelApplyError CostModel
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 -> [Int64]
-> WriterT
     [CostModelApplyWarn] (Either CostModelApplyError) EvaluationContext
forall (m :: * -> *).
(MonadError CostModelApplyError m,
 MonadWriter [CostModelApplyWarn] m) =>
[Int64] -> m EvaluationContext
PV1.mkEvaluationContext
        Language
PlutusV2 -> [Int64]
-> WriterT
     [CostModelApplyWarn] (Either CostModelApplyError) EvaluationContext
forall (m :: * -> *).
(MonadError CostModelApplyError m,
 MonadWriter [CostModelApplyWarn] m) =>
[Int64] -> m EvaluationContext
PV2.mkEvaluationContext
        Language
PlutusV3 -> [Int64]
-> WriterT
     [CostModelApplyWarn] (Either CostModelApplyError) EvaluationContext
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 = WriterT
  [CostModelApplyWarn] (Either CostModelApplyError) EvaluationContext
-> Either
     CostModelApplyError (EvaluationContext, [CostModelApplyWarn])
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 = Decoder s (Map Word8 [Int64])
forall s. Decoder s (Map Word8 [Int64])
forall a s. DecCBOR a => Decoder s a
decCBOR Decoder s (Map Word8 [Int64])
-> (Map Word8 [Int64] -> Decoder s CostModels)
-> Decoder s CostModels
forall a b. Decoder s a -> (a -> Decoder s b) -> Decoder s b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Map Word8 [Int64] -> Decoder s CostModels
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 (Map Language CostModel -> Map Word8 [Int64] -> CostModels)
-> Decoder s (Map Language CostModel)
-> Decoder s (Map Word8 [Int64] -> CostModels)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Decoder s Language
-> (Language -> Decoder s CostModel)
-> Decoder s (Map Language CostModel)
forall k s v.
Ord k =>
Decoder s k -> (k -> Decoder s v) -> Decoder s (Map k v)
decodeMapByKey Decoder s Language
forall s. Decoder s Language
forall a s. DecCBOR a => Decoder s a
decCBOR Language -> Decoder s CostModel
forall s. Language -> Decoder s CostModel
decodeCostModelLegacy Decoder s (Map Word8 [Int64] -> CostModels)
-> Decoder s (Map Word8 [Int64]) -> Decoder s CostModels
forall a b. Decoder s (a -> b) -> Decoder s a -> Decoder s b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Map Word8 [Int64] -> Decoder s (Map Word8 [Int64])
forall a. a -> Decoder s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Map Word8 [Int64]
forall a. Monoid a => a
mempty
{-# INLINE decodeCostModelsFailing #-}

decodeCostModels :: Decoder s CostModels
decodeCostModels :: forall s. Decoder s CostModels
decodeCostModels =
  Version
-> Decoder s CostModels
-> Decoder s CostModels
-> Decoder s CostModels
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 CostModels
forall s. Decoder s CostModels
decodeCostModelsLenient
    Decoder s CostModels
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
  Bool -> Decoder s () -> Decoder s ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Language
lang Language -> Language -> Bool
forall a. Ord a => a -> a -> Bool
> Language
PlutusV2) (Decoder s () -> Decoder s ()) -> Decoder s () -> Decoder s ()
forall a b. (a -> b) -> a -> b
$
    [Char] -> Decoder s ()
forall a. [Char] -> Decoder s a
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail ([Char] -> Decoder s ()) -> [Char] -> Decoder s ()
forall a b. (a -> b) -> a -> b
$
      [Char]
"Legacy CostModel decoding is not supported for " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ Language -> [Char]
forall a. Show a => a -> [Char]
show Language
lang [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
" language version"
  [Int64]
values <- Decoder s [Int64]
forall s. Decoder s [Int64]
forall a s. DecCBOR a => Decoder s a
decCBOR
  let numValues :: Int
numValues = [Int64] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Int64]
values
      expectedNumValues :: Int
expectedNumValues = Language -> Int
costModelParamsCount Language
lang
  Bool -> Decoder s () -> Decoder s ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
numValues Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
expectedNumValues) (Decoder s () -> Decoder s ()) -> Decoder s () -> Decoder s ()
forall a b. (a -> b) -> a -> b
$
    [Char] -> Decoder s ()
forall a. [Char] -> Decoder s a
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail ([Char] -> Decoder s ()) -> [Char] -> Decoder s ()
forall a b. (a -> b) -> a -> b
$
      [Char]
"Expected array with "
        [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> Int -> [Char]
forall a. Show a => a -> [Char]
show Int
expectedNumValues
        [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
" entries, but encoded array has "
        [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> Int -> [Char]
forall a. Show a => a -> [Char]
show Int
numValues
        [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
" entries."
  case Language -> [Int64] -> Either CostModelApplyError CostModel
mkCostModel Language
lang [Int64]
values of
    Left CostModelApplyError
e -> [Char] -> Decoder s CostModel
forall a. [Char] -> Decoder s a
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail ([Char] -> Decoder s CostModel) -> [Char] -> Decoder s CostModel
forall a b. (a -> b) -> a -> b
$ CostModelApplyError -> [Char]
forall a. Show a => a -> [Char]
show CostModelApplyError
e
    Right CostModel
cm -> CostModel -> Decoder s CostModel
forall a. a -> Decoder s a
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
  Version
-> Decoder s CostModel
-> Decoder s CostModel
-> Decoder s CostModel
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
    (Language -> Decoder s CostModel
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 ([Int64] -> Either CostModelApplyError CostModel)
-> Decoder s [Int64]
-> Decoder s (Either CostModelApplyError CostModel)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Decoder s [Int64]
forall s. Decoder s [Int64]
forall a s. DecCBOR a => Decoder s a
decCBOR
      case Either CostModelApplyError CostModel
checked of
        Left CostModelApplyError
e -> [Char] -> Decoder s CostModel
forall a. [Char] -> Decoder s a
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail ([Char] -> Decoder s CostModel) -> [Char] -> Decoder s CostModel
forall a b. (a -> b) -> a -> b
$ CostModelApplyError -> [Char]
forall a. Show a => a -> [Char]
show CostModelApplyError
e
        Right CostModel
cm -> CostModel -> Decoder s CostModel
forall a. a -> Decoder s a
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
(CostModels -> CostModels -> Bool)
-> (CostModels -> CostModels -> Bool) -> Eq CostModels
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: CostModels -> CostModels -> Bool
== :: CostModels -> CostModels -> Bool
$c/= :: CostModels -> CostModels -> Bool
/= :: CostModels -> CostModels -> Bool
Eq, Eq CostModels
Eq CostModels =>
(CostModels -> CostModels -> Ordering)
-> (CostModels -> CostModels -> Bool)
-> (CostModels -> CostModels -> Bool)
-> (CostModels -> CostModels -> Bool)
-> (CostModels -> CostModels -> Bool)
-> (CostModels -> CostModels -> CostModels)
-> (CostModels -> CostModels -> CostModels)
-> Ord 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
$ccompare :: CostModels -> CostModels -> Ordering
compare :: CostModels -> CostModels -> Ordering
$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
>= :: CostModels -> CostModels -> Bool
$cmax :: CostModels -> CostModels -> CostModels
max :: CostModels -> CostModels -> CostModels
$cmin :: CostModels -> CostModels -> CostModels
min :: CostModels -> CostModels -> CostModels
Ord, Int -> CostModels -> ShowS
[CostModels] -> ShowS
CostModels -> [Char]
(Int -> CostModels -> ShowS)
-> (CostModels -> [Char])
-> ([CostModels] -> ShowS)
-> Show CostModels
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> CostModels -> ShowS
showsPrec :: Int -> CostModels -> ShowS
$cshow :: CostModels -> [Char]
show :: CostModels -> [Char]
$cshowList :: [CostModels] -> ShowS
showList :: [CostModels] -> ShowS
Show, (forall x. CostModels -> Rep CostModels x)
-> (forall x. Rep CostModels x -> CostModels) -> Generic CostModels
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
$cfrom :: forall x. CostModels -> Rep CostModels x
from :: forall x. CostModels -> Rep CostModels x
$cto :: forall x. Rep CostModels x -> CostModels
to :: forall x. Rep CostModels x -> CostModels
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 Map Language CostModel
forall a. Monoid a => a
mempty Map Word8 [Int64]
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
    (Map Word8 [Int64] -> Map Word8 [Int64] -> Map Word8 [Int64]
forall k a. Ord k => Map k a -> Map k a -> Map k a
Map.union Map Word8 [Int64]
modUnk Map Word8 [Int64]
oldUnk Map Word8 [Int64] -> Map Word8 CostModel -> Map Word8 [Int64]
forall k a b. Ord k => Map k a -> Map k b -> Map k a
Map.\\ (Language -> Word8)
-> Map Language CostModel -> Map Word8 CostModel
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 = Map Language CostModel
-> Map Language CostModel -> Map Language CostModel
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 Map Word8 [Int64]
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 = (Word8 -> [Int64] -> m CostModels -> m CostModels)
-> m CostModels -> Map Word8 [Int64] -> m CostModels
forall k a b. (k -> a -> b -> b) -> b -> Map k a -> b
Map.foldrWithKey Word8 -> [Int64] -> m CostModels -> m CostModels
forall (m :: * -> *).
MonadFail m =>
Word8 -> [Int64] -> m CostModels -> m CostModels
addRawCostModel (CostModels -> m CostModels
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Map Language CostModel -> Map Word8 [Int64] -> CostModels
CostModels Map Language CostModel
forall a. Monoid a => a
mempty Map Word8 [Int64]
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 (Word8 -> Int
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 -> CostModels -> m CostModels
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (CostModels -> m CostModels) -> CostModels -> m CostModels
forall a b. (a -> b) -> a -> b
$ Map Language CostModel -> Map Word8 [Int64] -> CostModels
CostModels (Language
-> CostModel -> Map Language CostModel -> Map Language CostModel
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 -> [Char] -> m CostModels
forall a. [Char] -> m a
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail ([Char] -> m CostModels) -> [Char] -> m CostModels
forall a b. (a -> b) -> a -> b
$ [Char]
"CostModel construction failure: " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ CostModelApplyError -> [Char]
forall a. Show a => a -> [Char]
show CostModelApplyError
err
        Maybe Language
Nothing -> CostModels -> m CostModels
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (CostModels -> m CostModels) -> CostModels -> m CostModels
forall a b. (a -> b) -> a -> b
$ Map Language CostModel -> Map Word8 [Int64] -> CostModels
CostModels Map Language CostModel
validCostModels (Word8 -> [Int64] -> Map Word8 [Int64] -> Map Word8 [Int64]
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) =
  (Language -> CostModel -> Map Word8 [Int64] -> Map Word8 [Int64])
-> Map Word8 [Int64] -> Map Language CostModel -> Map Word8 [Int64]
forall k a b. (k -> a -> b -> b) -> b -> Map k a -> b
Map.foldrWithKey
    (\Language
lang CostModel
cm -> Word8 -> [Int64] -> Map Word8 [Int64] -> Map Word8 [Int64]
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 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
li Bool -> Bool -> Bool
&& Int
li Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Word8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word8
forall a. Bounded a => a
maxBound :: Word8) = Int -> 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
      [Char] -> Word8
forall a. HasCallStack => [Char] -> a
error ([Char] -> Word8) -> [Char] -> Word8
forall a b. (a -> b) -> a -> b
$ [Char]
"Impossible: Overflow encountered during conversion of the language: " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ Language -> [Char]
forall a. Show a => a -> [Char]
show Language
lang
  where
    li :: Int
li = Language -> Int
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 = Decoder s CostModels
forall s. Decoder s CostModels
decodeCostModels
  {-# INLINE decCBOR #-}

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

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

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