Skip to content
New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Jump to bottom

make ExUnit type parameteric, but hide details #2515

Merged
merged 1 commit into from
Oct 12, 2021
Merged

make ExUnit type parameteric, but hide details #2515

Changes from all commits
Commits
Show all changes
1 commit
Select commit
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Jump to
Jump to file
Failed to load files.
Diff view
Diff view
62 changes: 49 additions & 13 deletions eras/alonzo/impl/src/Cardano/Ledger/Alonzo/Scripts.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
@@ -1,12 +1,15 @@
{-# 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 #-}
Expand All @@ -26,7 +29,7 @@ module Cardano.Ledger.Alonzo.Scripts

-- * Cost Model
CostModel (..),
ExUnits (..),
ExUnits (ExUnits, exUnitsMem, exUnitsSteps, ..),
Prices (..),
hashCostModel,
validateCostModelParams,
Expand Down Expand Up @@ -77,7 +80,7 @@ import Data.DerivingVia (InstantiatedAt (..))
import Data.Int (Int64)
import Data.Map (Map)
import qualified Data.Map as Map
import Data.Measure (Measure)
import Data.Measure (BoundedMeasure, Measure)
import Data.Set (Set)
import qualified Data.Set as Set
import Data.Text (Text)
Expand Down Expand Up @@ -147,24 +150,57 @@ isPlutusScript (TimelockScript _) = False

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

-- | Arbitrary execution unit in which we measure the cost of scripts.
data ExUnits = ExUnits
{ exUnitsMem :: !Natural,
exUnitsSteps :: !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
-- 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'
{ exUnitsMem' :: !a,
exUnitsSteps' :: !a
}
deriving (Eq, Generic, Show)
deriving (Eq, Generic, Show, Functor)
-- It is deliberate that there is no Ord instance, use `pointWiseExUnits` instead.
deriving
(Measure)
via (InstantiatedAt Generic ExUnits)
(Measure, BoundedMeasure)
via (InstantiatedAt Generic (ExUnits' a))
deriving
(Monoid, Semigroup)
via (InstantiatedAt Measure ExUnits)
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 {unWrap :: ExUnits' Natural}
deriving (Eq, Generic, Show)
deriving newtype (Monoid, 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
Copy link
Contributor

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

I think we might want some comments here explaining why this is needed, otherwise it's a bit weird!

Copy link
Contributor Author

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

great point!

Copy link
Contributor Author

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

I've added some prose. Let me know if you think it makes sense.

pattern ExUnits {exUnitsMem, exUnitsSteps} <-
WrapExUnits (ExUnits' exUnitsMem exUnitsSteps)
where
ExUnits m s = WrapExUnits (ExUnits' m 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
Expand Down Expand Up @@ -263,11 +299,11 @@ instance NFData Prices
-- | Compute the cost of a script based upon prices and the number of execution
-- units.
txscriptfee :: Prices -> ExUnits -> Coin
txscriptfee Prices {prMem, prSteps} ExUnits {exUnitsMem, exUnitsSteps} =
txscriptfee Prices {prMem, prSteps} ExUnits {exUnitsMem = m, exUnitsSteps = s} =
Coin $
ceiling $
(fromIntegral exUnitsMem * unboundRational prMem)
+ (fromIntegral exUnitsSteps * unboundRational prSteps)
(fromIntegral m * unboundRational prMem)
+ (fromIntegral s * unboundRational prSteps)

--------------------------------------------------------------------------------
-- Serialisation
Expand Down