{-# LANGUAGE DataKinds #-}
{-# 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 UndecidableInstances #-}
-- Needed for (NoThunks PV1.EvaluationContext)
{-# OPTIONS_GHC -fno-warn-orphans #-}

module Cardano.Ledger.Alonzo.Scripts
  ( Tag (..),
    Script (TimelockScript, PlutusScript),
    txscriptfee,
    isPlutusScript,
    pointWiseExUnits,

    -- * Cost Model
    CostModel,
    mkCostModel,
    getCostModelLanguage,
    getCostModelParams,
    getEvaluationContext,
    ExUnits (ExUnits, exUnitsMem, exUnitsSteps, ..),
    ExUnits',
    Prices (..),
    hashCostModel,
    assertWellFormedCostModelParams,
    decodeCostModelMap,
    decodeCostModel,
    CostModels (..),
    CostModelApplyError (..),
  )
where

import Cardano.Binary (DecoderError (..), FromCBOR (fromCBOR), ToCBOR (toCBOR), serialize')
import Cardano.Ledger.Alonzo.Language (Language (..))
import Cardano.Ledger.BaseTypes (BoundedRational (unboundRational), NonNegativeInterval)
import Cardano.Ledger.Coin (Coin (..))
import qualified Cardano.Ledger.Core as Core
import qualified Cardano.Ledger.Crypto as CC (Crypto)
import Cardano.Ledger.Era (Era (Crypto), ValidateScript (hashScript))
import Cardano.Ledger.SafeHash
  ( HashWithCrypto (..),
    SafeHash,
    SafeToHash (..),
  )
import Cardano.Ledger.Serialization (mapToCBOR)
import Cardano.Ledger.ShelleyMA.Timelocks (Timelock)
import Control.DeepSeq (NFData (..), deepseq, rwhnf)
import Control.Monad (when)
import Data.ByteString.Short (ShortByteString, fromShort)
import Data.Coders
  ( Annotator,
    Decode (Ann, D, From, Invalid, RecD, SumD, Summands),
    Decoder,
    Encode (Rec, Sum, To),
    Wrapped (Open),
    cborError,
    decode,
    decodeList,
    decodeMapByKey,
    encode,
    encodeFoldableAsDefinite,
    (!>),
    (<!),
    (<*!),
  )
import Data.DerivingVia (InstantiatedAt (..))
import Data.Int (Int64)
import Data.Map (Map)
import qualified Data.Map.Strict as Map
import Data.Measure (BoundedMeasure, Measure)
import Data.Set (Set)
import qualified Data.Set as Set
import Data.Text (Text)
import Data.Typeable (Proxy (..), Typeable)
import Data.Word (Word64, Word8)
import GHC.Generics (Generic)
import NoThunks.Class (InspectHeapNamed (..), NoThunks (..))
import Numeric.Natural (Natural)
import Plutus.V1.Ledger.Api as PV1 hiding (Map, Script)
import Plutus.V2.Ledger.Api as PV2 (costModelParamNames, mkEvaluationContext)

-- | Marker indicating the part of a transaction for which this script is acting
-- as a validator.
data Tag
  = -- | Validates spending a script-locked UTxO
    Spend
  | -- | Validates minting new tokens
    Mint
  | -- | Validates certificate transactions
    Cert
  | -- | Validates withdrawl from a reward account
    Rewrd
  deriving (Tag -> Tag -> Bool
(Tag -> Tag -> Bool) -> (Tag -> Tag -> Bool) -> Eq Tag
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Tag -> Tag -> Bool
$c/= :: Tag -> Tag -> Bool
== :: Tag -> Tag -> Bool
$c== :: Tag -> Tag -> Bool
Eq, (forall x. Tag -> Rep Tag x)
-> (forall x. Rep Tag x -> Tag) -> Generic Tag
forall x. Rep Tag x -> Tag
forall x. Tag -> Rep Tag x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep Tag x -> Tag
$cfrom :: forall x. Tag -> Rep Tag x
Generic, Eq Tag
Eq Tag
-> (Tag -> Tag -> Ordering)
-> (Tag -> Tag -> Bool)
-> (Tag -> Tag -> Bool)
-> (Tag -> Tag -> Bool)
-> (Tag -> Tag -> Bool)
-> (Tag -> Tag -> Tag)
-> (Tag -> Tag -> Tag)
-> Ord Tag
Tag -> Tag -> Bool
Tag -> Tag -> Ordering
Tag -> Tag -> Tag
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 :: Tag -> Tag -> Tag
$cmin :: Tag -> Tag -> Tag
max :: Tag -> Tag -> Tag
$cmax :: Tag -> Tag -> Tag
>= :: Tag -> Tag -> Bool
$c>= :: Tag -> Tag -> Bool
> :: Tag -> Tag -> Bool
$c> :: Tag -> Tag -> Bool
<= :: Tag -> Tag -> Bool
$c<= :: Tag -> Tag -> Bool
< :: Tag -> Tag -> Bool
$c< :: Tag -> Tag -> Bool
compare :: Tag -> Tag -> Ordering
$ccompare :: Tag -> Tag -> Ordering
$cp1Ord :: Eq Tag
Ord, Int -> Tag -> ShowS
[Tag] -> ShowS
Tag -> String
(Int -> Tag -> ShowS)
-> (Tag -> String) -> ([Tag] -> ShowS) -> Show Tag
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Tag] -> ShowS
$cshowList :: [Tag] -> ShowS
show :: Tag -> String
$cshow :: Tag -> String
showsPrec :: Int -> Tag -> ShowS
$cshowsPrec :: Int -> Tag -> ShowS
Show, Int -> Tag
Tag -> Int
Tag -> [Tag]
Tag -> Tag
Tag -> Tag -> [Tag]
Tag -> Tag -> Tag -> [Tag]
(Tag -> Tag)
-> (Tag -> Tag)
-> (Int -> Tag)
-> (Tag -> Int)
-> (Tag -> [Tag])
-> (Tag -> Tag -> [Tag])
-> (Tag -> Tag -> [Tag])
-> (Tag -> Tag -> Tag -> [Tag])
-> Enum Tag
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
enumFromThenTo :: Tag -> Tag -> Tag -> [Tag]
$cenumFromThenTo :: Tag -> Tag -> Tag -> [Tag]
enumFromTo :: Tag -> Tag -> [Tag]
$cenumFromTo :: Tag -> Tag -> [Tag]
enumFromThen :: Tag -> Tag -> [Tag]
$cenumFromThen :: Tag -> Tag -> [Tag]
enumFrom :: Tag -> [Tag]
$cenumFrom :: Tag -> [Tag]
fromEnum :: Tag -> Int
$cfromEnum :: Tag -> Int
toEnum :: Int -> Tag
$ctoEnum :: Int -> Tag
pred :: Tag -> Tag
$cpred :: Tag -> Tag
succ :: Tag -> Tag
$csucc :: Tag -> Tag
Enum, Tag
Tag -> Tag -> Bounded Tag
forall a. a -> a -> Bounded a
maxBound :: Tag
$cmaxBound :: Tag
minBound :: Tag
$cminBound :: Tag
Bounded)

instance NoThunks Tag

instance NFData Tag where
  rnf :: Tag -> ()
rnf = Tag -> ()
forall a. a -> ()
rwhnf

-- =======================================================

-- | Scripts in the Alonzo Era, Either a Timelock script or a Plutus script.
data Script era
  = TimelockScript (Timelock (Crypto era))
  | PlutusScript Language ShortByteString
  deriving (Script era -> Script era -> Bool
(Script era -> Script era -> Bool)
-> (Script era -> Script era -> Bool) -> Eq (Script era)
forall era. Script era -> Script era -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Script era -> Script era -> Bool
$c/= :: forall era. Script era -> Script era -> Bool
== :: Script era -> Script era -> Bool
$c== :: forall era. Script era -> Script era -> Bool
Eq, (forall x. Script era -> Rep (Script era) x)
-> (forall x. Rep (Script era) x -> Script era)
-> Generic (Script era)
forall x. Rep (Script era) x -> Script era
forall x. Script era -> Rep (Script era) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall era x. Rep (Script era) x -> Script era
forall era x. Script era -> Rep (Script era) x
$cto :: forall era x. Rep (Script era) x -> Script era
$cfrom :: forall era x. Script era -> Rep (Script era) x
Generic, Eq (Script era)
Eq (Script era)
-> (Script era -> Script era -> Ordering)
-> (Script era -> Script era -> Bool)
-> (Script era -> Script era -> Bool)
-> (Script era -> Script era -> Bool)
-> (Script era -> Script era -> Bool)
-> (Script era -> Script era -> Script era)
-> (Script era -> Script era -> Script era)
-> Ord (Script era)
Script era -> Script era -> Bool
Script era -> Script era -> Ordering
Script era -> Script era -> Script era
forall era. Eq (Script era)
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
forall era. Script era -> Script era -> Bool
forall era. Script era -> Script era -> Ordering
forall era. Script era -> Script era -> Script era
min :: Script era -> Script era -> Script era
$cmin :: forall era. Script era -> Script era -> Script era
max :: Script era -> Script era -> Script era
$cmax :: forall era. Script era -> Script era -> Script era
>= :: Script era -> Script era -> Bool
$c>= :: forall era. Script era -> Script era -> Bool
> :: Script era -> Script era -> Bool
$c> :: forall era. Script era -> Script era -> Bool
<= :: Script era -> Script era -> Bool
$c<= :: forall era. Script era -> Script era -> Bool
< :: Script era -> Script era -> Bool
$c< :: forall era. Script era -> Script era -> Bool
compare :: Script era -> Script era -> Ordering
$ccompare :: forall era. Script era -> Script era -> Ordering
$cp1Ord :: forall era. Eq (Script era)
Ord)

instance (ValidateScript era, Core.Script era ~ Script era) => Show (Script era) where
  show :: Script era -> String
show (TimelockScript Timelock (Crypto era)
x) = String
"TimelockScript " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Timelock (Crypto era) -> String
forall a. Show a => a -> String
show Timelock (Crypto era)
x
  show s :: Script era
s@(PlutusScript Language
v ShortByteString
_) = String
"PlutusScript " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Language -> String
forall a. Show a => a -> String
show Language
v String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" " String -> ShowS
forall a. [a] -> [a] -> [a]
++ ScriptHash (Crypto era) -> String
forall a. Show a => a -> String
show (Script era -> ScriptHash (Crypto era)
forall era.
ValidateScript era =>
Script era -> ScriptHash (Crypto era)
hashScript @era Script era
Script era
s)

deriving via
  InspectHeapNamed "Script" (Script era)
  instance
    NoThunks (Script era)

instance NFData (Script era)

-- | Both constructors know their original bytes
instance SafeToHash (Script era) where
  originalBytes :: Script era -> ByteString
originalBytes (TimelockScript Timelock (Crypto era)
t) = Timelock (Crypto era) -> ByteString
forall t. SafeToHash t => t -> ByteString
originalBytes Timelock (Crypto era)
t
  originalBytes (PlutusScript Language
_ ShortByteString
bs) = ShortByteString -> ByteString
fromShort ShortByteString
bs

isPlutusScript :: Script era -> Bool
isPlutusScript :: Script era -> Bool
isPlutusScript (PlutusScript Language
_ ShortByteString
_) = Bool
True
isPlutusScript (TimelockScript Timelock (Crypto era)
_) = Bool
False

-- ===========================================

-- | Arbitrary execution unit in which we measure the cost of scripts in terms
-- of space in memory and execution time.
--
-- The ledger itself uses 'ExUnits' Natural' exclusively, but the flexibility here
-- alows the consensus layer to translate the execution units into something
-- equivalent to 'ExUnits (Inf Natural)'. This is needed in order to provide
-- a 'BoundedMeasure' instance, which itself is needed for the alonzo instance of
-- 'TxLimits' (in consensus).
data ExUnits' a = ExUnits'
  { ExUnits' a -> a
exUnitsMem' :: !a,
    ExUnits' a -> a
exUnitsSteps' :: !a
  }
  deriving (ExUnits' a -> ExUnits' a -> Bool
(ExUnits' a -> ExUnits' a -> Bool)
-> (ExUnits' a -> ExUnits' a -> Bool) -> Eq (ExUnits' a)
forall a. Eq a => ExUnits' a -> ExUnits' a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ExUnits' a -> ExUnits' a -> Bool
$c/= :: forall a. Eq a => ExUnits' a -> ExUnits' a -> Bool
== :: ExUnits' a -> ExUnits' a -> Bool
$c== :: forall a. Eq a => ExUnits' a -> ExUnits' a -> Bool
Eq, (forall x. ExUnits' a -> Rep (ExUnits' a) x)
-> (forall x. Rep (ExUnits' a) x -> ExUnits' a)
-> Generic (ExUnits' a)
forall x. Rep (ExUnits' a) x -> ExUnits' a
forall x. ExUnits' a -> Rep (ExUnits' a) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall a x. Rep (ExUnits' a) x -> ExUnits' a
forall a x. ExUnits' a -> Rep (ExUnits' a) x
$cto :: forall a x. Rep (ExUnits' a) x -> ExUnits' a
$cfrom :: forall a x. ExUnits' a -> Rep (ExUnits' a) x
Generic, Int -> ExUnits' a -> ShowS
[ExUnits' a] -> ShowS
ExUnits' a -> String
(Int -> ExUnits' a -> ShowS)
-> (ExUnits' a -> String)
-> ([ExUnits' a] -> ShowS)
-> Show (ExUnits' a)
forall a. Show a => Int -> ExUnits' a -> ShowS
forall a. Show a => [ExUnits' a] -> ShowS
forall a. Show a => ExUnits' a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ExUnits' a] -> ShowS
$cshowList :: forall a. Show a => [ExUnits' a] -> ShowS
show :: ExUnits' a -> String
$cshow :: forall a. Show a => ExUnits' a -> String
showsPrec :: Int -> ExUnits' a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> ExUnits' a -> ShowS
Show, a -> ExUnits' b -> ExUnits' a
(a -> b) -> ExUnits' a -> ExUnits' b
(forall a b. (a -> b) -> ExUnits' a -> ExUnits' b)
-> (forall a b. a -> ExUnits' b -> ExUnits' a) -> Functor ExUnits'
forall a b. a -> ExUnits' b -> ExUnits' a
forall a b. (a -> b) -> ExUnits' a -> ExUnits' b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> ExUnits' b -> ExUnits' a
$c<$ :: forall a b. a -> ExUnits' b -> ExUnits' a
fmap :: (a -> b) -> ExUnits' a -> ExUnits' b
$cfmap :: forall a b. (a -> b) -> ExUnits' a -> ExUnits' b
Functor)
  -- It is deliberate that there is no Ord instance, use `pointWiseExUnits` instead.
  deriving
    (Eq (ExUnits' a)
ExUnits' a
Eq (ExUnits' a)
-> ExUnits' a
-> (ExUnits' a -> ExUnits' a -> ExUnits' a)
-> (ExUnits' a -> ExUnits' a -> ExUnits' a)
-> (ExUnits' a -> ExUnits' a -> ExUnits' a)
-> Measure (ExUnits' a)
ExUnits' a -> ExUnits' a -> ExUnits' a
forall a.
Eq a
-> a
-> (a -> a -> a)
-> (a -> a -> a)
-> (a -> a -> a)
-> Measure a
forall a. Measure a => Eq (ExUnits' a)
forall a. Measure a => ExUnits' a
forall a. Measure a => ExUnits' a -> ExUnits' a -> ExUnits' a
max :: ExUnits' a -> ExUnits' a -> ExUnits' a
$cmax :: forall a. Measure a => ExUnits' a -> ExUnits' a -> ExUnits' a
min :: ExUnits' a -> ExUnits' a -> ExUnits' a
$cmin :: forall a. Measure a => ExUnits' a -> ExUnits' a -> ExUnits' a
plus :: ExUnits' a -> ExUnits' a -> ExUnits' a
$cplus :: forall a. Measure a => ExUnits' a -> ExUnits' a -> ExUnits' a
zero :: ExUnits' a
$czero :: forall a. Measure a => ExUnits' a
$cp1Measure :: forall a. Measure a => Eq (ExUnits' a)
Measure, Measure (ExUnits' a)
ExUnits' a
Measure (ExUnits' a) -> ExUnits' a -> BoundedMeasure (ExUnits' a)
forall a. Measure a -> a -> BoundedMeasure a
forall a. BoundedMeasure a => Measure (ExUnits' a)
forall a. BoundedMeasure a => ExUnits' a
maxBound :: ExUnits' a
$cmaxBound :: forall a. BoundedMeasure a => ExUnits' a
$cp1BoundedMeasure :: forall a. BoundedMeasure a => Measure (ExUnits' a)
BoundedMeasure)
    via (InstantiatedAt Generic (ExUnits' a))
  deriving
    (Semigroup (ExUnits' a)
ExUnits' a
Semigroup (ExUnits' a)
-> ExUnits' a
-> (ExUnits' a -> ExUnits' a -> ExUnits' a)
-> ([ExUnits' a] -> ExUnits' a)
-> Monoid (ExUnits' a)
[ExUnits' a] -> ExUnits' a
ExUnits' a -> ExUnits' a -> ExUnits' a
forall a.
Semigroup a -> a -> (a -> a -> a) -> ([a] -> a) -> Monoid a
forall a. Measure a => Semigroup (ExUnits' a)
forall a. Measure a => ExUnits' a
forall a. Measure a => [ExUnits' a] -> ExUnits' a
forall a. Measure a => ExUnits' a -> ExUnits' a -> ExUnits' a
mconcat :: [ExUnits' a] -> ExUnits' a
$cmconcat :: forall a. Measure a => [ExUnits' a] -> ExUnits' a
mappend :: ExUnits' a -> ExUnits' a -> ExUnits' a
$cmappend :: forall a. Measure a => ExUnits' a -> ExUnits' a -> ExUnits' a
mempty :: ExUnits' a
$cmempty :: forall a. Measure a => ExUnits' a
$cp1Monoid :: forall a. Measure a => Semigroup (ExUnits' a)
Monoid, b -> ExUnits' a -> ExUnits' a
NonEmpty (ExUnits' a) -> ExUnits' a
ExUnits' a -> ExUnits' a -> ExUnits' a
(ExUnits' a -> ExUnits' a -> ExUnits' a)
-> (NonEmpty (ExUnits' a) -> ExUnits' a)
-> (forall b. Integral b => b -> ExUnits' a -> ExUnits' a)
-> Semigroup (ExUnits' a)
forall b. Integral b => b -> ExUnits' a -> ExUnits' a
forall a. Measure a => NonEmpty (ExUnits' a) -> ExUnits' a
forall a. Measure a => ExUnits' a -> ExUnits' a -> ExUnits' a
forall a b.
(Measure a, Integral b) =>
b -> ExUnits' a -> ExUnits' a
forall a.
(a -> a -> a)
-> (NonEmpty a -> a)
-> (forall b. Integral b => b -> a -> a)
-> Semigroup a
stimes :: b -> ExUnits' a -> ExUnits' a
$cstimes :: forall a b.
(Measure a, Integral b) =>
b -> ExUnits' a -> ExUnits' a
sconcat :: NonEmpty (ExUnits' a) -> ExUnits' a
$csconcat :: forall a. Measure a => NonEmpty (ExUnits' a) -> ExUnits' a
<> :: ExUnits' a -> ExUnits' a -> ExUnits' a
$c<> :: forall a. Measure a => ExUnits' a -> ExUnits' a -> ExUnits' a
Semigroup)
    via (InstantiatedAt Measure (ExUnits' a))

instance NoThunks a => NoThunks (ExUnits' a)

instance NFData a => NFData (ExUnits' a)

-- | This newtype wrapper of ExUnits' is used to hide
--  an implementation detail inside the ExUnits pattern.
newtype ExUnits = WrapExUnits {ExUnits -> ExUnits' Natural
unWrapExUnits :: ExUnits' Natural}
  deriving (ExUnits -> ExUnits -> Bool
(ExUnits -> ExUnits -> Bool)
-> (ExUnits -> ExUnits -> Bool) -> Eq ExUnits
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ExUnits -> ExUnits -> Bool
$c/= :: ExUnits -> ExUnits -> Bool
== :: ExUnits -> ExUnits -> Bool
$c== :: ExUnits -> ExUnits -> Bool
Eq, (forall x. ExUnits -> Rep ExUnits x)
-> (forall x. Rep ExUnits x -> ExUnits) -> Generic ExUnits
forall x. Rep ExUnits x -> ExUnits
forall x. ExUnits -> Rep ExUnits x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep ExUnits x -> ExUnits
$cfrom :: forall x. ExUnits -> Rep ExUnits x
Generic, Int -> ExUnits -> ShowS
[ExUnits] -> ShowS
ExUnits -> String
(Int -> ExUnits -> ShowS)
-> (ExUnits -> String) -> ([ExUnits] -> ShowS) -> Show ExUnits
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ExUnits] -> ShowS
$cshowList :: [ExUnits] -> ShowS
show :: ExUnits -> String
$cshow :: ExUnits -> String
showsPrec :: Int -> ExUnits -> ShowS
$cshowsPrec :: Int -> ExUnits -> ShowS
Show)
  deriving newtype (Semigroup ExUnits
ExUnits
Semigroup ExUnits
-> ExUnits
-> (ExUnits -> ExUnits -> ExUnits)
-> ([ExUnits] -> ExUnits)
-> Monoid ExUnits
[ExUnits] -> ExUnits
ExUnits -> ExUnits -> ExUnits
forall a.
Semigroup a -> a -> (a -> a -> a) -> ([a] -> a) -> Monoid a
mconcat :: [ExUnits] -> ExUnits
$cmconcat :: [ExUnits] -> ExUnits
mappend :: ExUnits -> ExUnits -> ExUnits
$cmappend :: ExUnits -> ExUnits -> ExUnits
mempty :: ExUnits
$cmempty :: ExUnits
$cp1Monoid :: Semigroup ExUnits
Monoid, b -> ExUnits -> ExUnits
NonEmpty ExUnits -> ExUnits
ExUnits -> ExUnits -> ExUnits
(ExUnits -> ExUnits -> ExUnits)
-> (NonEmpty ExUnits -> ExUnits)
-> (forall b. Integral b => b -> ExUnits -> ExUnits)
-> Semigroup ExUnits
forall b. Integral b => b -> ExUnits -> ExUnits
forall a.
(a -> a -> a)
-> (NonEmpty a -> a)
-> (forall b. Integral b => b -> a -> a)
-> Semigroup a
stimes :: b -> ExUnits -> ExUnits
$cstimes :: forall b. Integral b => b -> ExUnits -> ExUnits
sconcat :: NonEmpty ExUnits -> ExUnits
$csconcat :: NonEmpty ExUnits -> ExUnits
<> :: ExUnits -> ExUnits -> ExUnits
$c<> :: ExUnits -> ExUnits -> ExUnits
Semigroup)

instance NoThunks ExUnits

instance NFData ExUnits

-- | Arbitrary execution unit in which we measure the cost of scripts in terms
-- of space in memory and execution time.
--
-- This pattern hides the fact that ExUnits' is parametric in the underlying type.
-- The ledger itself uses 'ExUnits' Natural' exclusively.
--
-- We would have preferred to use a type alias for 'ExUnits' Natural',
-- but this is not possible: https://gitlab.haskell.org/ghc/ghc/-/issues/19507.
pattern ExUnits :: Natural -> Natural -> ExUnits
pattern $bExUnits :: Natural -> Natural -> ExUnits
$mExUnits :: forall r. ExUnits -> (Natural -> Natural -> r) -> (Void# -> r) -> r
ExUnits {ExUnits -> Natural
exUnitsMem, ExUnits -> Natural
exUnitsSteps} <-
  WrapExUnits (ExUnits' exUnitsMem exUnitsSteps)
  where
    ExUnits Natural
m Natural
s = ExUnits' Natural -> ExUnits
WrapExUnits (Natural -> Natural -> ExUnits' Natural
forall a. a -> a -> ExUnits' a
ExUnits' Natural
m Natural
s)

{-# COMPLETE ExUnits #-}

-- | It is deliberate that there is no `Ord` instance for `ExUnits`. Use this function
--   to compare if one `ExUnit` is pointwise compareable to another.
pointWiseExUnits :: (Natural -> Natural -> Bool) -> ExUnits -> ExUnits -> Bool
pointWiseExUnits :: (Natural -> Natural -> Bool) -> ExUnits -> ExUnits -> Bool
pointWiseExUnits Natural -> Natural -> Bool
oper (ExUnits Natural
m1 Natural
s1) (ExUnits Natural
m2 Natural
s2) = (Natural
m1 Natural -> Natural -> Bool
`oper` Natural
m2) Bool -> Bool -> Bool
&& (Natural
s1 Natural -> Natural -> Bool
`oper` Natural
s2)

-- =====================================

-- | A language dependent cost model for the Plutus evaluator.
-- Note that the `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 !Language !(Map Text Integer) !PV1.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
$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 Map Text Integer
x EvaluationContext
_ == :: CostModel -> CostModel -> Bool
== CostModel Language
l2 Map Text Integer
y EvaluationContext
_ = Language
l1 Language -> Language -> Bool
forall a. Eq a => a -> a -> Bool
== Language
l2 Bool -> Bool -> Bool
&& Map Text Integer
x Map Text Integer -> Map Text Integer -> Bool
forall a. Eq a => a -> a -> Bool
== Map Text Integer
y

instance Show CostModel where
  show :: CostModel -> String
show (CostModel Language
lang Map Text Integer
cm EvaluationContext
_) = String
"CostModel " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Language -> String
forall a. Show a => a -> String
show Language
lang String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Map Text Integer -> String
forall a. Show a => a -> String
show Map Text Integer
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 Map Text Integer
x EvaluationContext
_) (CostModel Language
l2 Map Text Integer
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
<> Map Text Integer -> Map Text Integer -> Ordering
forall a. Ord a => a -> a -> Ordering
compare Map Text Integer
x Map Text Integer
y

-- NOTE: Since cost model serializations need to be independently reproduced,
-- we use the 'canonical' serialization approach used in Byron.
instance ToCBOR CostModel where
  toCBOR :: CostModel -> Encoding
toCBOR (CostModel Language
_ Map Text Integer
cm EvaluationContext
_) = [Integer] -> Encoding
forall a (f :: * -> *). (ToCBOR a, Foldable f) => f a -> Encoding
encodeFoldableAsDefinite ([Integer] -> Encoding) -> [Integer] -> Encoding
forall a b. (a -> b) -> a -> b
$ Map Text Integer -> [Integer]
forall k a. Map k a -> [a]
Map.elems Map Text Integer
cm

instance SafeToHash CostModel where
  originalBytes :: CostModel -> ByteString
originalBytes = CostModel -> ByteString
forall a. ToCBOR a => a -> ByteString
serialize'

-- CostModel does not determine 'crypto' so make a HashWithCrypto
-- rather than a HashAnotated instance.

instance HashWithCrypto CostModel CostModel

instance NoThunks CostModel

instance NFData CostModel where
  rnf :: CostModel -> ()
rnf (CostModel Language
lang Map Text Integer
cm EvaluationContext
ectx) = Language
lang Language -> Map Text Integer -> Map Text Integer
forall a b. NFData a => a -> b -> b
`deepseq` Map Text Integer
cm Map Text Integer -> () -> ()
forall a b. NFData a => a -> b -> b
`deepseq` EvaluationContext -> ()
forall a. NFData a => a -> ()
rnf EvaluationContext
ectx

-- | Convert cost model parameters to a cost model, making use of the
--  conversion function mkEvaluationContext from the Plutus API.
mkCostModel :: Language -> Map Text Integer -> Either CostModelApplyError CostModel
mkCostModel :: Language
-> Map Text Integer -> Either CostModelApplyError CostModel
mkCostModel Language
PlutusV1 Map Text Integer
cm =
  case Map Text Integer -> Either CostModelApplyError EvaluationContext
forall (m :: * -> *).
MonadError CostModelApplyError m =>
Map Text Integer -> m EvaluationContext
PV1.mkEvaluationContext Map Text Integer
cm of
    Right EvaluationContext
evalCtx -> CostModel -> Either CostModelApplyError CostModel
forall a b. b -> Either a b
Right (Language -> Map Text Integer -> EvaluationContext -> CostModel
CostModel Language
PlutusV1 Map Text Integer
cm EvaluationContext
evalCtx)
    Left CostModelApplyError
e -> CostModelApplyError -> Either CostModelApplyError CostModel
forall a b. a -> Either a b
Left CostModelApplyError
e
mkCostModel Language
PlutusV2 Map Text Integer
cm =
  case Map Text Integer -> Either CostModelApplyError EvaluationContext
forall (m :: * -> *).
MonadError CostModelApplyError m =>
Map Text Integer -> m EvaluationContext
PV2.mkEvaluationContext Map Text Integer
cm of
    Right EvaluationContext
evalCtx -> CostModel -> Either CostModelApplyError CostModel
forall a b. b -> Either a b
Right (Language -> Map Text Integer -> EvaluationContext -> CostModel
CostModel Language
PlutusV2 Map Text Integer
cm EvaluationContext
evalCtx)
    Left CostModelApplyError
e -> CostModelApplyError -> Either CostModelApplyError CostModel
forall a b. a -> Either a b
Left CostModelApplyError
e

getCostModelLanguage :: CostModel -> Language
getCostModelLanguage :: CostModel -> Language
getCostModelLanguage (CostModel Language
lang Map Text Integer
_ EvaluationContext
_) = Language
lang

getCostModelParams :: CostModel -> Map Text Integer
getCostModelParams :: CostModel -> Map Text Integer
getCostModelParams (CostModel Language
_ Map Text Integer
cm EvaluationContext
_) = Map Text Integer
cm

decodeCostModelMap :: Decoder s (Map Language CostModel)
decodeCostModelMap :: Decoder s (Map Language CostModel)
decodeCostModelMap = Decoder s Language
-> (Language -> Decoder s CostModel)
-> Decoder s (Map Language CostModel)
forall t k v s.
(IsList t, Item t ~ (k, v)) =>
Decoder s k -> (k -> Decoder s v) -> Decoder s t
decodeMapByKey Decoder s Language
forall a s. FromCBOR a => Decoder s a
fromCBOR Language -> Decoder s CostModel
forall s. Language -> Decoder s CostModel
decodeCostModel

decodeCostModel :: Language -> Decoder s CostModel
decodeCostModel :: Language -> Decoder s CostModel
decodeCostModel Language
lang = do
  Either CostModelApplyError CostModel
checked <- Language
-> Map Text Integer -> Either CostModelApplyError CostModel
mkCostModel Language
lang (Map Text Integer -> Either CostModelApplyError CostModel)
-> Decoder s (Map Text Integer)
-> Decoder s (Either CostModelApplyError CostModel)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Set Text -> Decoder s Integer -> Decoder s (Map Text Integer)
forall a s b. Ord a => Set a -> Decoder s b -> Decoder s (Map a b)
decodeArrayAsMap Set Text
keys Decoder s Integer
forall a s. FromCBOR a => Decoder s a
fromCBOR
  case Either CostModelApplyError CostModel
checked of
    Left CostModelApplyError
e -> String -> Decoder s CostModel
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Decoder s CostModel) -> String -> Decoder s CostModel
forall a b. (a -> b) -> a -> b
$ CostModelApplyError -> String
forall a. Show a => a -> String
show CostModelApplyError
e
    Right CostModel
cm -> CostModel -> Decoder s CostModel
forall (f :: * -> *) a. Applicative f => a -> f a
pure CostModel
cm
  where
    keys :: Set Text
keys = case Language
lang of
      Language
PlutusV1 -> Set Text
PV1.costModelParamNames
      Language
PlutusV2 -> Set Text
PV2.costModelParamNames

decodeArrayAsMap :: Ord a => Set a -> Decoder s b -> Decoder s (Map a b)
decodeArrayAsMap :: Set a -> Decoder s b -> Decoder s (Map a b)
decodeArrayAsMap Set a
keys Decoder s b
decodeValue = do
  [b]
values <- Decoder s b -> Decoder s [b]
forall s a. Decoder s a -> Decoder s [a]
decodeList Decoder s b
decodeValue
  let numValues :: Int
numValues = [b] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [b]
values
      numKeys :: Int
numKeys = Set a -> Int
forall a. Set a -> Int
Set.size Set a
keys
  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
numKeys) (Decoder s () -> Decoder s ()) -> Decoder s () -> Decoder s ()
forall a b. (a -> b) -> a -> b
$
    String -> Decoder s ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Decoder s ()) -> String -> Decoder s ()
forall a b. (a -> b) -> a -> b
$
      String
"Expected array with " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show Int
numKeys
        String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" entries, but encoded array has "
        String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show Int
numValues
        String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" entries."
  Map a b -> Decoder s (Map a b)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Map a b -> Decoder s (Map a b)) -> Map a b -> Decoder s (Map a b)
forall a b. (a -> b) -> a -> b
$ [(a, b)] -> Map a b
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(a, b)] -> Map a b) -> [(a, b)] -> Map a b
forall a b. (a -> b) -> a -> b
$ [a] -> [b] -> [(a, b)]
forall a b. [a] -> [b] -> [(a, b)]
zip (Set a -> [a]
forall a. Set a -> [a]
Set.toAscList Set a
keys) [b]
values

-- CostModel is not parameterized by Crypto or Era so we use the
-- hashWithCrypto function, rather than hashAnnotated

hashCostModel ::
  forall e.
  Era e =>
  Proxy e ->
  CostModel ->
  SafeHash (Crypto e) CostModel
hashCostModel :: Proxy e -> CostModel -> SafeHash (Crypto e) CostModel
hashCostModel Proxy e
_proxy = Proxy (Crypto e) -> CostModel -> SafeHash (Crypto e) CostModel
forall x index crypto.
(HashWithCrypto x index, HasAlgorithm crypto) =>
Proxy crypto -> x -> SafeHash crypto index
hashWithCrypto (Proxy (Crypto e)
forall k (t :: k). Proxy t
Proxy @(Crypto e))

getEvaluationContext :: CostModel -> PV1.EvaluationContext
getEvaluationContext :: CostModel -> EvaluationContext
getEvaluationContext (CostModel Language
_ Map Text Integer
_ EvaluationContext
ec) = EvaluationContext
ec

newtype CostModels = CostModels {CostModels -> Map Language CostModel
unCostModels :: Map Language CostModel}
  deriving (CostModels -> CostModels -> Bool
(CostModels -> CostModels -> Bool)
-> (CostModels -> CostModels -> Bool) -> Eq CostModels
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, Int -> CostModels -> ShowS
[CostModels] -> ShowS
CostModels -> String
(Int -> CostModels -> ShowS)
-> (CostModels -> String)
-> ([CostModels] -> ShowS)
-> Show CostModels
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [CostModels] -> ShowS
$cshowList :: [CostModels] -> ShowS
show :: CostModels -> String
$cshow :: CostModels -> String
showsPrec :: Int -> CostModels -> ShowS
$cshowsPrec :: Int -> CostModels -> ShowS
Show, 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
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
$cp1Ord :: Eq CostModels
Ord, (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
$cto :: forall x. Rep CostModels x -> CostModels
$cfrom :: forall x. CostModels -> Rep CostModels x
Generic, CostModels -> ()
(CostModels -> ()) -> NFData CostModels
forall a. (a -> ()) -> NFData a
rnf :: CostModels -> ()
$crnf :: CostModels -> ()
NFData, Context -> CostModels -> IO (Maybe ThunkInfo)
Proxy CostModels -> String
(Context -> CostModels -> IO (Maybe ThunkInfo))
-> (Context -> CostModels -> IO (Maybe ThunkInfo))
-> (Proxy CostModels -> String)
-> NoThunks CostModels
forall a.
(Context -> a -> IO (Maybe ThunkInfo))
-> (Context -> a -> IO (Maybe ThunkInfo))
-> (Proxy a -> String)
-> NoThunks a
showTypeOf :: Proxy CostModels -> String
$cshowTypeOf :: Proxy CostModels -> String
wNoThunks :: Context -> CostModels -> IO (Maybe ThunkInfo)
$cwNoThunks :: Context -> CostModels -> IO (Maybe ThunkInfo)
noThunks :: Context -> CostModels -> IO (Maybe ThunkInfo)
$cnoThunks :: Context -> CostModels -> IO (Maybe ThunkInfo)
NoThunks)

instance FromCBOR CostModels where
  fromCBOR :: Decoder s CostModels
fromCBOR = Map Language CostModel -> CostModels
CostModels (Map Language CostModel -> CostModels)
-> Decoder s (Map Language CostModel) -> Decoder s CostModels
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Decoder s (Map Language CostModel)
forall s. Decoder s (Map Language CostModel)
decodeCostModelMap

instance ToCBOR CostModels where
  toCBOR :: CostModels -> Encoding
toCBOR = Map Language CostModel -> Encoding
forall a b. (ToCBOR a, ToCBOR b) => Map a b -> Encoding
mapToCBOR (Map Language CostModel -> Encoding)
-> (CostModels -> Map Language CostModel) -> CostModels -> Encoding
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CostModels -> Map Language CostModel
unCostModels

-- ==================================

-- | Prices per execution unit
data Prices = Prices
  { Prices -> NonNegativeInterval
prMem :: !NonNegativeInterval,
    Prices -> NonNegativeInterval
prSteps :: !NonNegativeInterval
  }
  deriving (Prices -> Prices -> Bool
(Prices -> Prices -> Bool)
-> (Prices -> Prices -> Bool) -> Eq Prices
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Prices -> Prices -> Bool
$c/= :: Prices -> Prices -> Bool
== :: Prices -> Prices -> Bool
$c== :: Prices -> Prices -> Bool
Eq, (forall x. Prices -> Rep Prices x)
-> (forall x. Rep Prices x -> Prices) -> Generic Prices
forall x. Rep Prices x -> Prices
forall x. Prices -> Rep Prices x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep Prices x -> Prices
$cfrom :: forall x. Prices -> Rep Prices x
Generic, Int -> Prices -> ShowS
[Prices] -> ShowS
Prices -> String
(Int -> Prices -> ShowS)
-> (Prices -> String) -> ([Prices] -> ShowS) -> Show Prices
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Prices] -> ShowS
$cshowList :: [Prices] -> ShowS
show :: Prices -> String
$cshow :: Prices -> String
showsPrec :: Int -> Prices -> ShowS
$cshowsPrec :: Int -> Prices -> ShowS
Show, Eq Prices
Eq Prices
-> (Prices -> Prices -> Ordering)
-> (Prices -> Prices -> Bool)
-> (Prices -> Prices -> Bool)
-> (Prices -> Prices -> Bool)
-> (Prices -> Prices -> Bool)
-> (Prices -> Prices -> Prices)
-> (Prices -> Prices -> Prices)
-> Ord Prices
Prices -> Prices -> Bool
Prices -> Prices -> Ordering
Prices -> Prices -> Prices
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 :: Prices -> Prices -> Prices
$cmin :: Prices -> Prices -> Prices
max :: Prices -> Prices -> Prices
$cmax :: Prices -> Prices -> Prices
>= :: Prices -> Prices -> Bool
$c>= :: Prices -> Prices -> Bool
> :: Prices -> Prices -> Bool
$c> :: Prices -> Prices -> Bool
<= :: Prices -> Prices -> Bool
$c<= :: Prices -> Prices -> Bool
< :: Prices -> Prices -> Bool
$c< :: Prices -> Prices -> Bool
compare :: Prices -> Prices -> Ordering
$ccompare :: Prices -> Prices -> Ordering
$cp1Ord :: Eq Prices
Ord)

instance NoThunks Prices

instance NFData Prices

-- | Compute the cost of a script based upon prices and the number of execution
-- units.
txscriptfee :: Prices -> ExUnits -> Coin
txscriptfee :: Prices -> ExUnits -> Coin
txscriptfee Prices {NonNegativeInterval
prMem :: NonNegativeInterval
prMem :: Prices -> NonNegativeInterval
prMem, NonNegativeInterval
prSteps :: NonNegativeInterval
prSteps :: Prices -> NonNegativeInterval
prSteps} ExUnits {exUnitsMem :: ExUnits -> Natural
exUnitsMem = Natural
m, exUnitsSteps :: ExUnits -> Natural
exUnitsSteps = Natural
s} =
  Integer -> Coin
Coin (Integer -> Coin) -> Integer -> Coin
forall a b. (a -> b) -> a -> b
$
    Rational -> Integer
forall a b. (RealFrac a, Integral b) => a -> b
ceiling (Rational -> Integer) -> Rational -> Integer
forall a b. (a -> b) -> a -> b
$
      (Natural -> Rational
forall a b. (Integral a, Num b) => a -> b
fromIntegral Natural
m Rational -> Rational -> Rational
forall a. Num a => a -> a -> a
* NonNegativeInterval -> Rational
forall r. BoundedRational r => r -> Rational
unboundRational NonNegativeInterval
prMem)
        Rational -> Rational -> Rational
forall a. Num a => a -> a -> a
+ (Natural -> Rational
forall a b. (Integral a, Num b) => a -> b
fromIntegral Natural
s Rational -> Rational -> Rational
forall a. Num a => a -> a -> a
* NonNegativeInterval -> Rational
forall r. BoundedRational r => r -> Rational
unboundRational NonNegativeInterval
prSteps)

--------------------------------------------------------------------------------
-- Serialisation
--------------------------------------------------------------------------------

tagToWord8 :: Tag -> Word8
tagToWord8 :: Tag -> Word8
tagToWord8 = Int -> Word8
forall a. Enum a => Int -> a
toEnum (Int -> Word8) -> (Tag -> Int) -> Tag -> Word8
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tag -> Int
forall a. Enum a => a -> Int
fromEnum

word8ToTag :: Word8 -> Maybe Tag
word8ToTag :: Word8 -> Maybe Tag
word8ToTag Word8
e
  | Word8 -> Int
forall a. Enum a => a -> Int
fromEnum Word8
e Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Tag -> Int
forall a. Enum a => a -> Int
fromEnum (Tag
forall a. Bounded a => a
Prelude.maxBound :: Tag) = Maybe Tag
forall a. Maybe a
Nothing
  | Word8 -> Int
forall a. Enum a => a -> Int
fromEnum Word8
e Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Tag -> Int
forall a. Enum a => a -> Int
fromEnum (Tag
forall a. Bounded a => a
minBound :: Tag) = Maybe Tag
forall a. Maybe a
Nothing
  | Bool
otherwise = Tag -> Maybe Tag
forall a. a -> Maybe a
Just (Tag -> Maybe Tag) -> Tag -> Maybe Tag
forall a b. (a -> b) -> a -> b
$ Int -> Tag
forall a. Enum a => Int -> a
toEnum (Word8 -> Int
forall a. Enum a => a -> Int
fromEnum Word8
e)

instance ToCBOR Tag where
  toCBOR :: Tag -> Encoding
toCBOR = Word8 -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR (Word8 -> Encoding) -> (Tag -> Word8) -> Tag -> Encoding
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tag -> Word8
tagToWord8

instance FromCBOR Tag where
  fromCBOR :: Decoder s Tag
fromCBOR =
    Word8 -> Maybe Tag
word8ToTag (Word8 -> Maybe Tag) -> Decoder s Word8 -> Decoder s (Maybe Tag)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Decoder s Word8
forall a s. FromCBOR a => Decoder s a
fromCBOR Decoder s (Maybe Tag)
-> (Maybe Tag -> Decoder s Tag) -> Decoder s Tag
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      Maybe Tag
Nothing -> DecoderError -> Decoder s Tag
forall e s a. Buildable e => e -> Decoder s a
cborError (DecoderError -> Decoder s Tag) -> DecoderError -> Decoder s Tag
forall a b. (a -> b) -> a -> b
$ Text -> Text -> DecoderError
DecoderErrorCustom Text
"Tag" Text
"Unknown redeemer tag"
      Just Tag
n -> Tag -> Decoder s Tag
forall (f :: * -> *) a. Applicative f => a -> f a
pure Tag
n

instance ToCBOR ExUnits where
  toCBOR :: ExUnits -> Encoding
toCBOR (ExUnits Natural
m Natural
s) = Encode ('Closed 'Dense) ExUnits -> Encoding
forall (w :: Wrapped) t. Encode w t -> Encoding
encode (Encode ('Closed 'Dense) ExUnits -> Encoding)
-> Encode ('Closed 'Dense) ExUnits -> Encoding
forall a b. (a -> b) -> a -> b
$ (Natural -> Natural -> ExUnits)
-> Encode ('Closed 'Dense) (Natural -> Natural -> ExUnits)
forall t. t -> Encode ('Closed 'Dense) t
Rec Natural -> Natural -> ExUnits
ExUnits Encode ('Closed 'Dense) (Natural -> Natural -> ExUnits)
-> Encode ('Closed 'Dense) Natural
-> Encode ('Closed 'Dense) (Natural -> ExUnits)
forall (w :: Wrapped) a t (r :: Density).
Encode w (a -> t) -> Encode ('Closed r) a -> Encode w t
!> Natural -> Encode ('Closed 'Dense) Natural
forall t. ToCBOR t => t -> Encode ('Closed 'Dense) t
To Natural
m Encode ('Closed 'Dense) (Natural -> ExUnits)
-> Encode ('Closed 'Dense) Natural
-> Encode ('Closed 'Dense) ExUnits
forall (w :: Wrapped) a t (r :: Density).
Encode w (a -> t) -> Encode ('Closed r) a -> Encode w t
!> Natural -> Encode ('Closed 'Dense) Natural
forall t. ToCBOR t => t -> Encode ('Closed 'Dense) t
To Natural
s

instance FromCBOR ExUnits where
  fromCBOR :: Decoder s ExUnits
fromCBOR = Decode ('Closed 'Dense) ExUnits -> Decoder s ExUnits
forall (w :: Wrapped) t s. Decode w t -> Decoder s t
decode (Decode ('Closed 'Dense) ExUnits -> Decoder s ExUnits)
-> Decode ('Closed 'Dense) ExUnits -> Decoder s ExUnits
forall a b. (a -> b) -> a -> b
$ (Natural -> Natural -> ExUnits)
-> Decode ('Closed 'Dense) (Natural -> Natural -> ExUnits)
forall t. t -> Decode ('Closed 'Dense) t
RecD Natural -> Natural -> ExUnits
ExUnits Decode ('Closed 'Dense) (Natural -> Natural -> ExUnits)
-> Decode ('Closed 'Dense) Natural
-> Decode ('Closed 'Dense) (Natural -> ExUnits)
forall (w1 :: Wrapped) a t (w :: Density).
Decode w1 (a -> t) -> Decode ('Closed w) a -> Decode w1 t
<! (forall s. Decoder s Natural) -> Decode ('Closed 'Dense) Natural
forall t. (forall s. Decoder s t) -> Decode ('Closed 'Dense) t
D forall s. Decoder s Natural
decNat Decode ('Closed 'Dense) (Natural -> ExUnits)
-> Decode ('Closed 'Dense) Natural
-> Decode ('Closed 'Dense) ExUnits
forall (w1 :: Wrapped) a t (w :: Density).
Decode w1 (a -> t) -> Decode ('Closed w) a -> Decode w1 t
<! (forall s. Decoder s Natural) -> Decode ('Closed 'Dense) Natural
forall t. (forall s. Decoder s t) -> Decode ('Closed 'Dense) t
D forall s. Decoder s Natural
decNat
    where
      decNat :: Decoder s Natural
      decNat :: Decoder s Natural
decNat = do
        Word64
x <- Decoder s Word64
forall a s. FromCBOR a => Decoder s a
fromCBOR
        Bool -> Decoder s () -> Decoder s ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when
          (Word64
x Word64 -> Word64 -> Bool
forall a. Ord a => a -> a -> Bool
> Int64 -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int64
forall a. Bounded a => a
Prelude.maxBound :: Int64))
          ( DecoderError -> Decoder s ()
forall e s a. Buildable e => e -> Decoder s a
cborError (DecoderError -> Decoder s ()) -> DecoderError -> Decoder s ()
forall a b. (a -> b) -> a -> b
$
              Text -> Text -> DecoderError
DecoderErrorCustom Text
"ExUnits field" Text
"values must not exceed maxBound :: Int64"
          )
        Natural -> Decoder s Natural
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Natural -> Decoder s Natural) -> Natural -> Decoder s Natural
forall a b. (a -> b) -> a -> b
$ Word64 -> Natural
wordToNatural Word64
x
      wordToNatural :: Word64 -> Natural
      wordToNatural :: Word64 -> Natural
wordToNatural = Word64 -> Natural
forall a b. (Integral a, Num b) => a -> b
fromIntegral

instance ToCBOR Prices where
  toCBOR :: Prices -> Encoding
toCBOR (Prices NonNegativeInterval
m NonNegativeInterval
s) = Encode ('Closed 'Dense) Prices -> Encoding
forall (w :: Wrapped) t. Encode w t -> Encoding
encode (Encode ('Closed 'Dense) Prices -> Encoding)
-> Encode ('Closed 'Dense) Prices -> Encoding
forall a b. (a -> b) -> a -> b
$ (NonNegativeInterval -> NonNegativeInterval -> Prices)
-> Encode
     ('Closed 'Dense)
     (NonNegativeInterval -> NonNegativeInterval -> Prices)
forall t. t -> Encode ('Closed 'Dense) t
Rec NonNegativeInterval -> NonNegativeInterval -> Prices
Prices Encode
  ('Closed 'Dense)
  (NonNegativeInterval -> NonNegativeInterval -> Prices)
-> Encode ('Closed 'Dense) NonNegativeInterval
-> Encode ('Closed 'Dense) (NonNegativeInterval -> Prices)
forall (w :: Wrapped) a t (r :: Density).
Encode w (a -> t) -> Encode ('Closed r) a -> Encode w t
!> NonNegativeInterval -> Encode ('Closed 'Dense) NonNegativeInterval
forall t. ToCBOR t => t -> Encode ('Closed 'Dense) t
To NonNegativeInterval
m Encode ('Closed 'Dense) (NonNegativeInterval -> Prices)
-> Encode ('Closed 'Dense) NonNegativeInterval
-> Encode ('Closed 'Dense) Prices
forall (w :: Wrapped) a t (r :: Density).
Encode w (a -> t) -> Encode ('Closed r) a -> Encode w t
!> NonNegativeInterval -> Encode ('Closed 'Dense) NonNegativeInterval
forall t. ToCBOR t => t -> Encode ('Closed 'Dense) t
To NonNegativeInterval
s

instance FromCBOR Prices where
  fromCBOR :: Decoder s Prices
fromCBOR = Decode ('Closed 'Dense) Prices -> Decoder s Prices
forall (w :: Wrapped) t s. Decode w t -> Decoder s t
decode (Decode ('Closed 'Dense) Prices -> Decoder s Prices)
-> Decode ('Closed 'Dense) Prices -> Decoder s Prices
forall a b. (a -> b) -> a -> b
$ (NonNegativeInterval -> NonNegativeInterval -> Prices)
-> Decode
     ('Closed 'Dense)
     (NonNegativeInterval -> NonNegativeInterval -> Prices)
forall t. t -> Decode ('Closed 'Dense) t
RecD NonNegativeInterval -> NonNegativeInterval -> Prices
Prices Decode
  ('Closed 'Dense)
  (NonNegativeInterval -> NonNegativeInterval -> Prices)
-> Decode ('Closed Any) NonNegativeInterval
-> Decode ('Closed 'Dense) (NonNegativeInterval -> Prices)
forall (w1 :: Wrapped) a t (w :: Density).
Decode w1 (a -> t) -> Decode ('Closed w) a -> Decode w1 t
<! Decode ('Closed Any) NonNegativeInterval
forall t (w :: Wrapped). FromCBOR t => Decode w t
From Decode ('Closed 'Dense) (NonNegativeInterval -> Prices)
-> Decode ('Closed Any) NonNegativeInterval
-> Decode ('Closed 'Dense) Prices
forall (w1 :: Wrapped) a t (w :: Density).
Decode w1 (a -> t) -> Decode ('Closed w) a -> Decode w1 t
<! Decode ('Closed Any) NonNegativeInterval
forall t (w :: Wrapped). FromCBOR t => Decode w t
From

instance forall era. (Typeable (Crypto era), Typeable era) => ToCBOR (Script era) where
  toCBOR :: Script era -> Encoding
toCBOR Script era
x = Encode 'Open (Script era) -> Encoding
forall (w :: Wrapped) t. Encode w t -> Encoding
encode (Script era -> Encode 'Open (Script era)
forall era.
Typeable (Crypto era) =>
Script era -> Encode 'Open (Script era)
encodeScript Script era
x)

encodeScript :: (Typeable (Crypto era)) => Script era -> Encode 'Open (Script era)
encodeScript :: Script era -> Encode 'Open (Script era)
encodeScript (TimelockScript Timelock (Crypto era)
i) = (Timelock (Crypto era) -> Script era)
-> Word -> Encode 'Open (Timelock (Crypto era) -> Script era)
forall t. t -> Word -> Encode 'Open t
Sum Timelock (Crypto era) -> Script era
forall era. Timelock (Crypto era) -> Script era
TimelockScript Word
0 Encode 'Open (Timelock (Crypto era) -> Script era)
-> Encode ('Closed 'Dense) (Timelock (Crypto era))
-> Encode 'Open (Script era)
forall (w :: Wrapped) a t (r :: Density).
Encode w (a -> t) -> Encode ('Closed r) a -> Encode w t
!> Timelock (Crypto era)
-> Encode ('Closed 'Dense) (Timelock (Crypto era))
forall t. ToCBOR t => t -> Encode ('Closed 'Dense) t
To Timelock (Crypto era)
i
-- Use the ToCBOR instance of ShortByteString:
encodeScript (PlutusScript Language
PlutusV1 ShortByteString
s) = (ShortByteString -> Script era)
-> Word -> Encode 'Open (ShortByteString -> Script era)
forall t. t -> Word -> Encode 'Open t
Sum (Language -> ShortByteString -> Script era
forall era. Language -> ShortByteString -> Script era
PlutusScript Language
PlutusV1) Word
1 Encode 'Open (ShortByteString -> Script era)
-> Encode ('Closed 'Dense) ShortByteString
-> Encode 'Open (Script era)
forall (w :: Wrapped) a t (r :: Density).
Encode w (a -> t) -> Encode ('Closed r) a -> Encode w t
!> ShortByteString -> Encode ('Closed 'Dense) ShortByteString
forall t. ToCBOR t => t -> Encode ('Closed 'Dense) t
To ShortByteString
s
encodeScript (PlutusScript Language
PlutusV2 ShortByteString
s) = (ShortByteString -> Script era)
-> Word -> Encode 'Open (ShortByteString -> Script era)
forall t. t -> Word -> Encode 'Open t
Sum (Language -> ShortByteString -> Script era
forall era. Language -> ShortByteString -> Script era
PlutusScript Language
PlutusV2) Word
2 Encode 'Open (ShortByteString -> Script era)
-> Encode ('Closed 'Dense) ShortByteString
-> Encode 'Open (Script era)
forall (w :: Wrapped) a t (r :: Density).
Encode w (a -> t) -> Encode ('Closed r) a -> Encode w t
!> ShortByteString -> Encode ('Closed 'Dense) ShortByteString
forall t. ToCBOR t => t -> Encode ('Closed 'Dense) t
To ShortByteString
s

instance
  (CC.Crypto (Crypto era), Typeable (Crypto era), Typeable era) =>
  FromCBOR (Annotator (Script era))
  where
  fromCBOR :: Decoder s (Annotator (Script era))
fromCBOR = Decode ('Closed 'Dense) (Annotator (Script era))
-> Decoder s (Annotator (Script era))
forall (w :: Wrapped) t s. Decode w t -> Decoder s t
decode (String
-> (Word -> Decode 'Open (Annotator (Script era)))
-> Decode ('Closed 'Dense) (Annotator (Script era))
forall t.
String -> (Word -> Decode 'Open t) -> Decode ('Closed 'Dense) t
Summands String
"Alonzo Script" Word -> Decode 'Open (Annotator (Script era))
decodeScript)
    where
      decodeScript :: Word -> Decode 'Open (Annotator (Script era))
      decodeScript :: Word -> Decode 'Open (Annotator (Script era))
decodeScript Word
0 = Decode 'Open (Timelock (Crypto era) -> Script era)
-> Decode 'Open (Annotator (Timelock (Crypto era) -> Script era))
forall (w :: Wrapped) t1. Decode w t1 -> Decode w (Annotator t1)
Ann ((Timelock (Crypto era) -> Script era)
-> Decode 'Open (Timelock (Crypto era) -> Script era)
forall t. t -> Decode 'Open t
SumD Timelock (Crypto era) -> Script era
forall era. Timelock (Crypto era) -> Script era
TimelockScript) Decode 'Open (Annotator (Timelock (Crypto era) -> Script era))
-> Decode ('Closed Any) (Annotator (Timelock (Crypto era)))
-> Decode 'Open (Annotator (Script era))
forall (w1 :: Wrapped) a t (d :: Density).
Decode w1 (Annotator (a -> t))
-> Decode ('Closed d) (Annotator a) -> Decode w1 (Annotator t)
<*! Decode ('Closed Any) (Annotator (Timelock (Crypto era)))
forall t (w :: Wrapped). FromCBOR t => Decode w t
From
      decodeScript Word
1 = Decode 'Open (ShortByteString -> Script era)
-> Decode 'Open (Annotator (ShortByteString -> Script era))
forall (w :: Wrapped) t1. Decode w t1 -> Decode w (Annotator t1)
Ann ((ShortByteString -> Script era)
-> Decode 'Open (ShortByteString -> Script era)
forall t. t -> Decode 'Open t
SumD ((ShortByteString -> Script era)
 -> Decode 'Open (ShortByteString -> Script era))
-> (ShortByteString -> Script era)
-> Decode 'Open (ShortByteString -> Script era)
forall a b. (a -> b) -> a -> b
$ Language -> ShortByteString -> Script era
forall era. Language -> ShortByteString -> Script era
PlutusScript Language
PlutusV1) Decode 'Open (Annotator (ShortByteString -> Script era))
-> Decode ('Closed Any) (Annotator ShortByteString)
-> Decode 'Open (Annotator (Script era))
forall (w1 :: Wrapped) a t (d :: Density).
Decode w1 (Annotator (a -> t))
-> Decode ('Closed d) (Annotator a) -> Decode w1 (Annotator t)
<*! Decode ('Closed Any) ShortByteString
-> Decode ('Closed Any) (Annotator ShortByteString)
forall (w :: Wrapped) t1. Decode w t1 -> Decode w (Annotator t1)
Ann Decode ('Closed Any) ShortByteString
forall t (w :: Wrapped). FromCBOR t => Decode w t
From
      decodeScript Word
2 = Decode 'Open (ShortByteString -> Script era)
-> Decode 'Open (Annotator (ShortByteString -> Script era))
forall (w :: Wrapped) t1. Decode w t1 -> Decode w (Annotator t1)
Ann ((ShortByteString -> Script era)
-> Decode 'Open (ShortByteString -> Script era)
forall t. t -> Decode 'Open t
SumD ((ShortByteString -> Script era)
 -> Decode 'Open (ShortByteString -> Script era))
-> (ShortByteString -> Script era)
-> Decode 'Open (ShortByteString -> Script era)
forall a b. (a -> b) -> a -> b
$ Language -> ShortByteString -> Script era
forall era. Language -> ShortByteString -> Script era
PlutusScript Language
PlutusV2) Decode 'Open (Annotator (ShortByteString -> Script era))
-> Decode ('Closed Any) (Annotator ShortByteString)
-> Decode 'Open (Annotator (Script era))
forall (w1 :: Wrapped) a t (d :: Density).
Decode w1 (Annotator (a -> t))
-> Decode ('Closed d) (Annotator a) -> Decode w1 (Annotator t)
<*! Decode ('Closed Any) ShortByteString
-> Decode ('Closed Any) (Annotator ShortByteString)
forall (w :: Wrapped) t1. Decode w t1 -> Decode w (Annotator t1)
Ann Decode ('Closed Any) ShortByteString
forall t (w :: Wrapped). FromCBOR t => Decode w t
From
      decodeScript Word
n = Word -> Decode 'Open (Annotator (Script era))
forall (w :: Wrapped) t. Word -> Decode w t
Invalid Word
n