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

module Cardano.Ledger.Plutus.ExUnits (
  txscriptfee,
  pointWiseExUnits,
  zipSemiExUnits,
  ExUnits (ExUnits, exUnitsMem, exUnitsSteps, ..),
  ExUnits' (..),
  OrdExUnits (..),
  Prices (..),
) where

import Cardano.Ledger.BaseTypes (
  BoundedRational (unboundRational),
  NonNegativeInterval,
 )
import Cardano.Ledger.Binary (
  DecCBOR (decCBOR),
  Decoder,
  DecoderError (..),
  EncCBOR (encCBOR),
  cborError,
  decodeRecordNamed,
  ifDecoderVersionAtLeast,
  natVersion,
 )
import Cardano.Ledger.Binary.Coders (
  Decode (D, From, RecD),
  Encode (Rec, To),
  decode,
  encode,
  (!>),
  (<!),
 )
import Cardano.Ledger.Coin (Coin (..))
import Control.Applicative ((<|>))
import Control.DeepSeq (NFData (..))
import Control.Monad (when)
import Data.Aeson (
  FromJSON (..),
  ToJSON (..),
  object,
  withObject,
  (.:),
  (.=),
 )
import Data.Coerce (coerce)
import Data.DerivingVia (InstantiatedAt (..))
import Data.Int (Int64)
import Data.Measure (BoundedMeasure, Measure)
import Data.Semigroup (All (..))
import Data.Word (Word64)
import GHC.Generics (Generic)
import NoThunks.Class (NoThunks (..))
import Numeric.Natural (Natural)

-- | 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
-- allows 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'
  { forall a. ExUnits' a -> a
exUnitsMem' :: !a
  , forall 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
$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
/= :: 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
$cfrom :: forall a x. ExUnits' a -> Rep (ExUnits' a) x
from :: forall x. ExUnits' a -> Rep (ExUnits' a) x
$cto :: forall a x. Rep (ExUnits' a) x -> ExUnits' a
to :: forall x. Rep (ExUnits' a) x -> ExUnits' a
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
$cshowsPrec :: forall a. Show a => Int -> ExUnits' a -> ShowS
showsPrec :: Int -> ExUnits' a -> ShowS
$cshow :: forall a. Show a => ExUnits' a -> String
show :: ExUnits' a -> String
$cshowList :: forall a. Show a => [ExUnits' a] -> ShowS
showList :: [ExUnits' a] -> ShowS
Show, (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
$cfmap :: forall a b. (a -> b) -> ExUnits' a -> ExUnits' b
fmap :: forall a b. (a -> b) -> ExUnits' a -> ExUnits' b
$c<$ :: forall a b. a -> ExUnits' b -> ExUnits' a
<$ :: forall a b. a -> ExUnits' b -> ExUnits' a
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
$czero :: forall a. Measure a => ExUnits' a
zero :: ExUnits' a
$cplus :: forall a. Measure a => ExUnits' a -> ExUnits' a -> ExUnits' a
plus :: ExUnits' a -> ExUnits' a -> ExUnits' a
$cmin :: forall a. Measure a => ExUnits' a -> ExUnits' a -> ExUnits' a
min :: ExUnits' a -> ExUnits' a -> ExUnits' a
$cmax :: forall a. Measure a => ExUnits' a -> ExUnits' a -> ExUnits' a
max :: ExUnits' a -> ExUnits' a -> ExUnits' a
Measure, Measure (ExUnits' a)
ExUnits' a
Measure (ExUnits' a) => ExUnits' a -> BoundedMeasure (ExUnits' a)
forall a. BoundedMeasure a => Measure (ExUnits' a)
forall a. BoundedMeasure a => ExUnits' a
forall a. Measure a => a -> BoundedMeasure a
$cmaxBound :: forall a. BoundedMeasure a => ExUnits' a
maxBound :: 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
$cmempty :: forall a. Measure a => ExUnits' a
mempty :: ExUnits' a
$cmappend :: forall a. Measure a => ExUnits' a -> ExUnits' a -> ExUnits' a
mappend :: ExUnits' a -> ExUnits' a -> ExUnits' a
$cmconcat :: forall a. Measure a => [ExUnits' a] -> ExUnits' a
mconcat :: [ExUnits' a] -> ExUnits' a
Monoid, 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
$c<> :: forall a. Measure a => ExUnits' a -> ExUnits' a -> ExUnits' a
<> :: ExUnits' a -> ExUnits' a -> ExUnits' a
$csconcat :: forall a. Measure a => NonEmpty (ExUnits' a) -> ExUnits' a
sconcat :: NonEmpty (ExUnits' a) -> ExUnits' a
$cstimes :: forall a b.
(Measure a, Integral b) =>
b -> ExUnits' a -> ExUnits' a
stimes :: forall b. Integral b => b -> ExUnits' a -> ExUnits' a
Semigroup)
    via (InstantiatedAt Measure (ExUnits' a))

instance NoThunks a => NoThunks (ExUnits' a)

instance NFData a => NFData (ExUnits' a)

deriving instance ToJSON a => ToJSON (ExUnits' a)

deriving instance FromJSON a => FromJSON (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
$c== :: ExUnits -> ExUnits -> Bool
== :: ExUnits -> ExUnits -> Bool
$c/= :: ExUnits -> ExUnits -> Bool
/= :: 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
$cfrom :: forall x. ExUnits -> Rep ExUnits x
from :: forall x. ExUnits -> Rep ExUnits x
$cto :: forall x. Rep ExUnits x -> ExUnits
to :: forall x. Rep ExUnits x -> ExUnits
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
$cshowsPrec :: Int -> ExUnits -> ShowS
showsPrec :: Int -> ExUnits -> ShowS
$cshow :: ExUnits -> String
show :: ExUnits -> String
$cshowList :: [ExUnits] -> ShowS
showList :: [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
$cmempty :: ExUnits
mempty :: ExUnits
$cmappend :: ExUnits -> ExUnits -> ExUnits
mappend :: ExUnits -> ExUnits -> ExUnits
$cmconcat :: [ExUnits] -> ExUnits
mconcat :: [ExUnits] -> ExUnits
Monoid, 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
$c<> :: ExUnits -> ExUnits -> ExUnits
<> :: ExUnits -> ExUnits -> ExUnits
$csconcat :: NonEmpty ExUnits -> ExUnits
sconcat :: NonEmpty ExUnits -> ExUnits
$cstimes :: forall b. Integral b => b -> ExUnits -> ExUnits
stimes :: forall b. Integral b => b -> ExUnits -> ExUnits
Semigroup)

instance NoThunks ExUnits

instance NFData ExUnits

instance ToJSON ExUnits where
  toJSON :: ExUnits -> Value
toJSON exUnits :: ExUnits
exUnits@(ExUnits Natural
_ Natural
_) =
    let ExUnits {Natural
exUnitsMem :: ExUnits -> Natural
exUnitsMem :: Natural
exUnitsMem, Natural
exUnitsSteps :: ExUnits -> Natural
exUnitsSteps :: Natural
exUnitsSteps} = ExUnits
exUnits
     in [Pair] -> Value
object
          [ Key
"memory" Key -> Value -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Natural -> Value
forall a. ToJSON a => a -> Value
toJSON Natural
exUnitsMem
          , Key
"steps" Key -> Value -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Natural -> Value
forall a. ToJSON a => a -> Value
toJSON Natural
exUnitsSteps
          ]

instance FromJSON ExUnits where
  parseJSON :: Value -> Parser ExUnits
parseJSON = String -> (Object -> Parser ExUnits) -> Value -> Parser ExUnits
forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject String
"exUnits" ((Object -> Parser ExUnits) -> Value -> Parser ExUnits)
-> (Object -> Parser ExUnits) -> Value -> Parser ExUnits
forall a b. (a -> b) -> a -> b
$ \Object
o -> do
    exUnitsMem <- Natural -> Parser Natural
forall {a} {f :: * -> *}.
(Ord a, Num a, MonadFail f, Show a) =>
a -> f a
checkWord64Bounds (Natural -> Parser Natural) -> Parser Natural -> Parser Natural
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (Object
o Object -> Key -> Parser Natural
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"memory" Parser Natural -> Parser Natural -> Parser Natural
forall a. Parser a -> Parser a -> Parser a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Object
o Object -> Key -> Parser Natural
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"exUnitsMem")
    exUnitsSteps <- checkWord64Bounds =<< (o .: "steps" <|> o .: "exUnitsSteps")
    pure $ ExUnits {exUnitsMem, exUnitsSteps}
    where
      checkWord64Bounds :: a -> f a
checkWord64Bounds a
n =
        if a
n a -> a -> Bool
forall a. Ord a => a -> a -> Bool
>= Word64 -> a
forall a b. (Integral a, Num b) => a -> b
fromIntegral (forall a. Bounded a => a
minBound @Word64)
          Bool -> Bool -> Bool
&& a
n a -> a -> Bool
forall a. Ord a => a -> a -> Bool
<= Word64 -> a
forall a b. (Integral a, Num b) => a -> b
fromIntegral (forall a. Bounded a => a
maxBound @Word64)
          then a -> f a
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
n
          else String -> f a
forall a. String -> f a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String
"Unit out of bounds for Word64: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> a -> String
forall a. Show a => a -> String
show a
n)

-- | 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 $mExUnits :: forall {r}.
ExUnits -> (Natural -> Natural -> r) -> ((# #) -> r) -> r
$bExUnits :: Natural -> Natural -> ExUnits
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. In case when `Ord`
--   instance like comparison is necessary you can use @`zipSemiExUnits` `compare`@,
--   or the `OrdExUnits` newtype defined below.
pointWiseExUnits :: (Natural -> Natural -> Bool) -> ExUnits -> ExUnits -> Bool
pointWiseExUnits :: (Natural -> Natural -> Bool) -> ExUnits -> ExUnits -> Bool
pointWiseExUnits Natural -> Natural -> Bool
f ExUnits
ex1 ExUnits
ex2 = All -> Bool
getAll ((Natural -> Natural -> All) -> ExUnits -> ExUnits -> All
forall a.
Semigroup a =>
(Natural -> Natural -> a) -> ExUnits -> ExUnits -> a
zipSemiExUnits (\Natural
x Natural
y -> Bool -> All
All (Natural -> Natural -> Bool
f Natural
x Natural
y)) ExUnits
ex1 ExUnits
ex2)

-- | Pointwise combine units into a semigroup and mappened the results.
zipSemiExUnits :: Semigroup a => (Natural -> Natural -> a) -> ExUnits -> ExUnits -> a
zipSemiExUnits :: forall a.
Semigroup a =>
(Natural -> Natural -> a) -> ExUnits -> ExUnits -> a
zipSemiExUnits Natural -> Natural -> a
f (ExUnits Natural
m1 Natural
s1) (ExUnits Natural
m2 Natural
s2) = (Natural
m1 Natural -> Natural -> a
`f` Natural
m2) a -> a -> a
forall a. Semigroup a => a -> a -> a
<> (Natural
s1 Natural -> Natural -> a
`f` Natural
s2)

-- | This is a helper type that allows us to define an `Ord` instance for executions units without
-- affecting the `ExUnits` type. This is needed in order to derive an `Ord` instance` for types
-- that need to contain an `ExUnits`. This is just a helper type and should not be used directly.
newtype OrdExUnits = OrdExUnits {OrdExUnits -> ExUnits
unOrdExUnits :: ExUnits}
  deriving (OrdExUnits -> OrdExUnits -> Bool
(OrdExUnits -> OrdExUnits -> Bool)
-> (OrdExUnits -> OrdExUnits -> Bool) -> Eq OrdExUnits
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: OrdExUnits -> OrdExUnits -> Bool
== :: OrdExUnits -> OrdExUnits -> Bool
$c/= :: OrdExUnits -> OrdExUnits -> Bool
/= :: OrdExUnits -> OrdExUnits -> Bool
Eq)
  deriving newtype (Int -> OrdExUnits -> ShowS
[OrdExUnits] -> ShowS
OrdExUnits -> String
(Int -> OrdExUnits -> ShowS)
-> (OrdExUnits -> String)
-> ([OrdExUnits] -> ShowS)
-> Show OrdExUnits
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> OrdExUnits -> ShowS
showsPrec :: Int -> OrdExUnits -> ShowS
$cshow :: OrdExUnits -> String
show :: OrdExUnits -> String
$cshowList :: [OrdExUnits] -> ShowS
showList :: [OrdExUnits] -> ShowS
Show, Context -> OrdExUnits -> IO (Maybe ThunkInfo)
Proxy OrdExUnits -> String
(Context -> OrdExUnits -> IO (Maybe ThunkInfo))
-> (Context -> OrdExUnits -> IO (Maybe ThunkInfo))
-> (Proxy OrdExUnits -> String)
-> NoThunks OrdExUnits
forall a.
(Context -> a -> IO (Maybe ThunkInfo))
-> (Context -> a -> IO (Maybe ThunkInfo))
-> (Proxy a -> String)
-> NoThunks a
$cnoThunks :: Context -> OrdExUnits -> IO (Maybe ThunkInfo)
noThunks :: Context -> OrdExUnits -> IO (Maybe ThunkInfo)
$cwNoThunks :: Context -> OrdExUnits -> IO (Maybe ThunkInfo)
wNoThunks :: Context -> OrdExUnits -> IO (Maybe ThunkInfo)
$cshowTypeOf :: Proxy OrdExUnits -> String
showTypeOf :: Proxy OrdExUnits -> String
NoThunks, OrdExUnits -> ()
(OrdExUnits -> ()) -> NFData OrdExUnits
forall a. (a -> ()) -> NFData a
$crnf :: OrdExUnits -> ()
rnf :: OrdExUnits -> ()
NFData, Typeable OrdExUnits
Typeable OrdExUnits =>
(forall s. Decoder s OrdExUnits)
-> (forall s. Proxy OrdExUnits -> Decoder s ())
-> (Proxy OrdExUnits -> Text)
-> DecCBOR OrdExUnits
Proxy OrdExUnits -> Text
forall s. Decoder s OrdExUnits
forall a.
Typeable a =>
(forall s. Decoder s a)
-> (forall s. Proxy a -> Decoder s ())
-> (Proxy a -> Text)
-> DecCBOR a
forall s. Proxy OrdExUnits -> Decoder s ()
$cdecCBOR :: forall s. Decoder s OrdExUnits
decCBOR :: forall s. Decoder s OrdExUnits
$cdropCBOR :: forall s. Proxy OrdExUnits -> Decoder s ()
dropCBOR :: forall s. Proxy OrdExUnits -> Decoder s ()
$clabel :: Proxy OrdExUnits -> Text
label :: Proxy OrdExUnits -> Text
DecCBOR, OrdExUnits -> Encoding
(OrdExUnits -> Encoding) -> EncCBOR OrdExUnits
forall a. (a -> Encoding) -> EncCBOR a
$cencCBOR :: OrdExUnits -> Encoding
encCBOR :: OrdExUnits -> Encoding
EncCBOR, Maybe OrdExUnits
Value -> Parser [OrdExUnits]
Value -> Parser OrdExUnits
(Value -> Parser OrdExUnits)
-> (Value -> Parser [OrdExUnits])
-> Maybe OrdExUnits
-> FromJSON OrdExUnits
forall a.
(Value -> Parser a)
-> (Value -> Parser [a]) -> Maybe a -> FromJSON a
$cparseJSON :: Value -> Parser OrdExUnits
parseJSON :: Value -> Parser OrdExUnits
$cparseJSONList :: Value -> Parser [OrdExUnits]
parseJSONList :: Value -> Parser [OrdExUnits]
$comittedField :: Maybe OrdExUnits
omittedField :: Maybe OrdExUnits
FromJSON, [OrdExUnits] -> Value
[OrdExUnits] -> Encoding
OrdExUnits -> Bool
OrdExUnits -> Value
OrdExUnits -> Encoding
(OrdExUnits -> Value)
-> (OrdExUnits -> Encoding)
-> ([OrdExUnits] -> Value)
-> ([OrdExUnits] -> Encoding)
-> (OrdExUnits -> Bool)
-> ToJSON OrdExUnits
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> (a -> Bool)
-> ToJSON a
$ctoJSON :: OrdExUnits -> Value
toJSON :: OrdExUnits -> Value
$ctoEncoding :: OrdExUnits -> Encoding
toEncoding :: OrdExUnits -> Encoding
$ctoJSONList :: [OrdExUnits] -> Value
toJSONList :: [OrdExUnits] -> Value
$ctoEncodingList :: [OrdExUnits] -> Encoding
toEncodingList :: [OrdExUnits] -> Encoding
$comitField :: OrdExUnits -> Bool
omitField :: OrdExUnits -> Bool
ToJSON)

instance Ord OrdExUnits where
  compare :: OrdExUnits -> OrdExUnits -> Ordering
compare = (ExUnits -> ExUnits -> Ordering)
-> OrdExUnits -> OrdExUnits -> Ordering
forall a b. Coercible a b => a -> b
coerce ((Natural -> Natural -> Ordering) -> ExUnits -> ExUnits -> Ordering
forall a.
Semigroup a =>
(Natural -> Natural -> a) -> ExUnits -> ExUnits -> a
zipSemiExUnits Natural -> Natural -> Ordering
forall a. Ord a => a -> a -> Ordering
compare)

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

-- | 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
$c== :: Prices -> Prices -> Bool
== :: Prices -> Prices -> Bool
$c/= :: Prices -> Prices -> Bool
/= :: 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
$cfrom :: forall x. Prices -> Rep Prices x
from :: forall x. Prices -> Rep Prices x
$cto :: forall x. Rep Prices x -> Prices
to :: forall x. Rep Prices x -> Prices
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
$cshowsPrec :: Int -> Prices -> ShowS
showsPrec :: Int -> Prices -> ShowS
$cshow :: Prices -> String
show :: Prices -> String
$cshowList :: [Prices] -> ShowS
showList :: [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
$ccompare :: Prices -> Prices -> Ordering
compare :: Prices -> Prices -> Ordering
$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
>= :: Prices -> Prices -> Bool
$cmax :: Prices -> Prices -> Prices
max :: Prices -> Prices -> Prices
$cmin :: Prices -> Prices -> Prices
min :: Prices -> Prices -> Prices
Ord)

instance NoThunks Prices

instance NFData Prices

instance ToJSON Prices where
  toJSON :: Prices -> Value
toJSON Prices {NonNegativeInterval
prSteps :: Prices -> NonNegativeInterval
prSteps :: NonNegativeInterval
prSteps, NonNegativeInterval
prMem :: Prices -> NonNegativeInterval
prMem :: NonNegativeInterval
prMem} =
    [Pair] -> Value
object
      [ Key
"priceSteps" Key -> NonNegativeInterval -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= NonNegativeInterval
prSteps
      , Key
"priceMemory" Key -> NonNegativeInterval -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= NonNegativeInterval
prMem
      ]

instance FromJSON Prices where
  parseJSON :: Value -> Parser Prices
parseJSON =
    String -> (Object -> Parser Prices) -> Value -> Parser Prices
forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject String
"prices" ((Object -> Parser Prices) -> Value -> Parser Prices)
-> (Object -> Parser Prices) -> Value -> Parser Prices
forall a b. (a -> b) -> a -> b
$ \Object
o -> do
      prSteps <- Object
o Object -> Key -> Parser NonNegativeInterval
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"priceSteps" Parser NonNegativeInterval
-> Parser NonNegativeInterval -> Parser NonNegativeInterval
forall a. Parser a -> Parser a -> Parser a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Object
o Object -> Key -> Parser NonNegativeInterval
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"prSteps"
      prMem <- o .: "priceMemory" <|> o .: "prMem"
      return Prices {prSteps, prMem}

-- | 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 :: Prices -> NonNegativeInterval
prMem :: NonNegativeInterval
prMem, NonNegativeInterval
prSteps :: Prices -> NonNegativeInterval
prSteps :: 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 b. Integral b => Rational -> b
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)

instance EncCBOR ExUnits where
  encCBOR :: ExUnits -> Encoding
encCBOR (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. EncCBOR 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. EncCBOR t => t -> Encode (Closed Dense) t
To Natural
s

instance DecCBOR ExUnits where
  decCBOR :: forall s. Decoder s ExUnits
decCBOR =
    Version
-> Decoder s ExUnits -> Decoder s ExUnits -> Decoder s ExUnits
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 @12) Decoder s ExUnits
forall s. Decoder s ExUnits
decodeExUnits (Decoder s ExUnits -> Decoder s ExUnits)
-> Decoder s ExUnits -> Decoder s ExUnits
forall a b. (a -> b) -> a -> b
$
      Decode (Closed Dense) ExUnits -> Decoder s ExUnits
forall t (w :: Wrapped) s. Typeable t => 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 a (w1 :: Wrapped) t (w :: Density).
Typeable a =>
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 Decoder s Natural
forall s. Decoder s Natural
decNat Decode (Closed Dense) (Natural -> ExUnits)
-> Decode (Closed Dense) Natural -> Decode (Closed Dense) ExUnits
forall a (w1 :: Wrapped) t (w :: Density).
Typeable a =>
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 Decoder s Natural
forall s. Decoder s Natural
decNat
    where
      decodeExUnits :: Decoder s ExUnits
decodeExUnits =
        Text -> (ExUnits -> Int) -> Decoder s ExUnits -> Decoder s ExUnits
forall a s. Text -> (a -> Int) -> Decoder s a -> Decoder s a
decodeRecordNamed Text
"ExUnits" (Int -> ExUnits -> Int
forall a b. a -> b -> a
const Int
2) (Decoder s ExUnits -> Decoder s ExUnits)
-> Decoder s ExUnits -> Decoder s ExUnits
forall a b. (a -> b) -> a -> b
$
          Natural -> Natural -> ExUnits
ExUnits (Natural -> Natural -> ExUnits)
-> Decoder s Natural -> Decoder s (Natural -> ExUnits)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Decoder s Natural
forall s. Decoder s Natural
decNat Decoder s (Natural -> ExUnits)
-> Decoder s Natural -> Decoder s ExUnits
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
<*> Decoder s Natural
forall s. Decoder s Natural
decNat
      decNat :: Decoder s Natural
      decNat :: forall s. Decoder s Natural
decNat = do
        x <- Decoder s Word64
forall s. Decoder s Word64
forall a s. DecCBOR a => Decoder s a
decCBOR
        when
          (x > fromIntegral (Prelude.maxBound :: Int64))
          ( cborError $
              DecoderErrorCustom "ExUnits field" "values must not exceed maxBound :: Int64"
          )
        pure $ wordToNatural x
      {-# INLINE decNat #-}
      wordToNatural :: Word64 -> Natural
      wordToNatural :: Word64 -> Natural
wordToNatural = Word64 -> Natural
forall a b. (Integral a, Num b) => a -> b
fromIntegral
      {-# INLINE wordToNatural #-}
  {-# INLINE decCBOR #-}

instance EncCBOR Prices where
  encCBOR :: Prices -> Encoding
encCBOR (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. EncCBOR 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. EncCBOR t => t -> Encode (Closed Dense) t
To NonNegativeInterval
s

instance DecCBOR Prices where
  decCBOR :: forall s. Decoder s Prices
decCBOR =
    Version -> Decoder s Prices -> Decoder s Prices -> Decoder s Prices
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 @12) Decoder s Prices
forall s. Decoder s Prices
decodePrices (Decoder s Prices -> Decoder s Prices)
-> Decoder s Prices -> Decoder s Prices
forall a b. (a -> b) -> a -> b
$
      Decode (Closed Dense) Prices -> Decoder s Prices
forall t (w :: Wrapped) s. Typeable t => 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 (ZonkAny 1)) NonNegativeInterval
-> Decode (Closed Dense) (NonNegativeInterval -> Prices)
forall a (w1 :: Wrapped) t (w :: Density).
Typeable a =>
Decode w1 (a -> t) -> Decode (Closed w) a -> Decode w1 t
<! Decode (Closed (ZonkAny 1)) NonNegativeInterval
forall t (w :: Wrapped). DecCBOR t => Decode w t
From Decode (Closed Dense) (NonNegativeInterval -> Prices)
-> Decode (Closed (ZonkAny MinVersion)) NonNegativeInterval
-> Decode (Closed Dense) Prices
forall a (w1 :: Wrapped) t (w :: Density).
Typeable a =>
Decode w1 (a -> t) -> Decode (Closed w) a -> Decode w1 t
<! Decode (Closed (ZonkAny MinVersion)) NonNegativeInterval
forall t (w :: Wrapped). DecCBOR t => Decode w t
From
    where
      decodePrices :: Decoder s Prices
decodePrices =
        Text -> (Prices -> Int) -> Decoder s Prices -> Decoder s Prices
forall a s. Text -> (a -> Int) -> Decoder s a -> Decoder s a
decodeRecordNamed Text
"Prices" (Int -> Prices -> Int
forall a b. a -> b -> a
const Int
2) (Decoder s Prices -> Decoder s Prices)
-> Decoder s Prices -> Decoder s Prices
forall a b. (a -> b) -> a -> b
$
          NonNegativeInterval -> NonNegativeInterval -> Prices
Prices (NonNegativeInterval -> NonNegativeInterval -> Prices)
-> Decoder s NonNegativeInterval
-> Decoder s (NonNegativeInterval -> Prices)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Decoder s NonNegativeInterval
forall s. Decoder s NonNegativeInterval
forall a s. DecCBOR a => Decoder s a
decCBOR Decoder s (NonNegativeInterval -> Prices)
-> Decoder s NonNegativeInterval -> Decoder s Prices
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
<*> Decoder s NonNegativeInterval
forall s. Decoder s NonNegativeInterval
forall a s. DecCBOR a => Decoder s a
decCBOR
  {-# INLINE decCBOR #-}