{-# 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' (..),
  Prices (..),
) where

import Cardano.Ledger.BaseTypes (
  BoundedRational (unboundRational),
  NonNegativeInterval,
 )
import Cardano.Ledger.Binary (
  DecCBOR (decCBOR),
  Decoder,
  DecoderError (..),
  EncCBOR (encCBOR),
  cborError,
 )
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.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
    Natural
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")
    Natural
exUnitsSteps <- 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
"steps" 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
"exUnitsSteps")
    ExUnits -> Parser ExUnits
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ExUnits -> Parser ExUnits) -> ExUnits -> Parser ExUnits
forall a b. (a -> b) -> a -> b
$ ExUnits {Natural
exUnitsMem :: Natural
exUnitsMem :: Natural
exUnitsMem, Natural
exUnitsSteps :: Natural
exUnitsSteps :: Natural
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`@
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)

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

-- | 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
      NonNegativeInterval
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"
      NonNegativeInterval
prMem <- Object
o Object -> Key -> Parser NonNegativeInterval
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"priceMemory" 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
"prMem"
      Prices -> Parser Prices
forall a. a -> Parser a
forall (m :: * -> *) a. Monad m => a -> m a
return Prices {NonNegativeInterval
prSteps :: NonNegativeInterval
prSteps :: NonNegativeInterval
prSteps, NonNegativeInterval
prMem :: NonNegativeInterval
prMem :: NonNegativeInterval
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 = 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
      decNat :: Decoder s Natural
      decNat :: forall s. Decoder s Natural
decNat = do
        Word64
x <- Decoder s Word64
forall s. Decoder s Word64
forall a s. DecCBOR a => Decoder s a
decCBOR
        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 (m :: * -> *) e a. (MonadFail m, Buildable e) => e -> m 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 a. a -> Decoder s a
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
      {-# 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 = 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 Any) 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 Any) NonNegativeInterval
forall t (w :: Wrapped). DecCBOR t => Decode w t
From Decode ('Closed 'Dense) (NonNegativeInterval -> Prices)
-> Decode ('Closed Any) 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 Any) NonNegativeInterval
forall t (w :: Wrapped). DecCBOR t => Decode w t
From
  {-# INLINE decCBOR #-}