From e84c9ca69a985adac48fc9e048cca36b0c8baf8a Mon Sep 17 00:00:00 2001 From: Sridhar Ratnakumar Date: Fri, 24 Dec 2021 15:53:38 -0500 Subject: [PATCH 1/4] Rename to Run.Budget --- bench/Bench.hs | 12 ++++---- exe/Main.hs | 6 ++-- pluton.cabal | 2 +- src/Pluton.hs | 2 +- src/Pluton/Run.hs | 2 +- src/Pluton/Run/{ScriptSize.hs => Budget.hs} | 33 +++++++++++++-------- 6 files changed, 32 insertions(+), 25 deletions(-) rename src/Pluton/Run/{ScriptSize.hs => Budget.hs} (73%) diff --git a/bench/Bench.hs b/bench/Bench.hs index ed10451..89edcf3 100644 --- a/bench/Bench.hs +++ b/bench/Bench.hs @@ -16,13 +16,13 @@ main = do exampleContractGift :: IO () exampleContractGift = do putStrLn "\n== Sample contract - Gift: sizes (haskell; pluto; plutarch) == " - print $ Run.emulatorTraceSize (GiftTest.smokeTrace Gift.haskellValidator) - print $ Run.emulatorTraceSize (GiftTest.smokeTrace Gift.plutoValidator) - print $ Run.emulatorTraceSize (GiftTest.smokeTrace Gift.plutarchValidator) + print $ Run.emulatorTraceBudget (GiftTest.smokeTrace Gift.haskellValidator) + print $ Run.emulatorTraceBudget (GiftTest.smokeTrace Gift.plutoValidator) + print $ Run.emulatorTraceBudget (GiftTest.smokeTrace Gift.plutarchValidator) putStrLn "==" - print $ Run.validatorSize Gift.haskellValidator - print $ Run.validatorSize Gift.plutoValidator - print $ Run.validatorSize Gift.plutarchValidator + print $ Run.validatorBudget Gift.haskellValidator + print $ Run.validatorBudget Gift.plutoValidator + print $ Run.validatorBudget Gift.plutarchValidator -- TODO: remove this after https://github.com/Plutonomicon/pluton/issues/26 placeholder :: IO () diff --git a/exe/Main.hs b/exe/Main.hs index 9f11332..2709718 100644 --- a/exe/Main.hs +++ b/exe/Main.hs @@ -15,9 +15,9 @@ main = do Pluton.smoke -- Gift contract example putStrLn "\n== Sample contract - Gift: sizes (haskell; pluto; plutarch) == " - print $ Run.validatorSize Gift.haskellValidator - print $ Run.validatorSize Gift.plutoValidator - print $ Run.validatorSize Gift.plutarchValidator + print $ Run.validatorBudget Gift.haskellValidator + print $ Run.validatorBudget Gift.plutoValidator + print $ Run.validatorBudget Gift.plutarchValidator putStrLn "\n== Sample contract - Gift: emulator == " Em.runEmulatorTraceIO $ GiftTest.smokeTrace Gift.plutarchValidator putStrLn "\n== Sample contract - Gift: tests == " diff --git a/pluton.cabal b/pluton.cabal index 622239b..37482e3 100644 --- a/pluton.cabal +++ b/pluton.cabal @@ -38,7 +38,7 @@ library Pluton Pluton.Run Pluton.Run.Evaluate - Pluton.Run.ScriptSize + Pluton.Run.Budget Pluton.Types.Builtin Pluton.Types.Builtin.Data Pluton.Types.Builtin.Fun diff --git a/src/Pluton.hs b/src/Pluton.hs index d8fabc2..f530032 100644 --- a/src/Pluton.hs +++ b/src/Pluton.hs @@ -35,7 +35,7 @@ smoke = do let eval :: ClosedTerm a -> IO () eval p = do print $ Smoke.evalPlutarch p - print $ Run.scriptSize $ Run.compile p + print $ Run.scriptBudget $ Run.compile p fourtyTwo = 42 :: Term s PInteger intNil = Plutarch.punsafeConstant $ diff --git a/src/Pluton/Run.hs b/src/Pluton/Run.hs index bd10db4..e8e4c46 100644 --- a/src/Pluton/Run.hs +++ b/src/Pluton/Run.hs @@ -1,4 +1,4 @@ module Pluton.Run (module X) where +import Pluton.Run.Budget as X import Pluton.Run.Evaluate as X -import Pluton.Run.ScriptSize as X diff --git a/src/Pluton/Run/ScriptSize.hs b/src/Pluton/Run/Budget.hs similarity index 73% rename from src/Pluton/Run/ScriptSize.hs rename to src/Pluton/Run/Budget.hs index 30fbb54..66bf4e9 100644 --- a/src/Pluton/Run/ScriptSize.hs +++ b/src/Pluton/Run/Budget.hs @@ -1,7 +1,11 @@ -module Pluton.Run.ScriptSize - ( scriptSize, - validatorSize, - emulatorTraceSize, +-- | Execution budget and script size for Plutus scripts +module Pluton.Run.Budget + ( -- | * Budget for an arbitraty Plutus script + scriptBudget, + -- | * Budget for a smart contract validator script + validatorBudget, + -- | * Budget for EmulatorTrace + emulatorTraceBudget, ) where @@ -12,7 +16,7 @@ import Control.Monad.Freer qualified as Freer import Data.ByteString.Lazy qualified as BSL import Data.ByteString.Lazy qualified as LB import Data.ByteString.Short qualified as SBS -import Data.Default +import Data.Default (Default (def)) import Data.Int (Int64) import Data.Maybe (fromJust) import Data.Monoid (Sum (..)) @@ -26,14 +30,14 @@ import Streaming.Prelude qualified as S import Wallet.Emulator.Folds qualified as Folds import Wallet.Emulator.Stream (foldEmulatorStreamM) --- | Return the exbudget and script size of the validator run inside an --- Emulator trace. +-- | Return the exbudget and script size of the *applied* validator run inside +-- an Emulator trace. -- -- The trace must have run the validation exactly once, else this will fail. We -- do this, because we are benchmarking a single run of the validator, not -- multiple runs. -emulatorTraceSize :: Em.EmulatorTrace a -> (ExBudget, Sum Int64) -emulatorTraceSize trace = +emulatorTraceBudget :: Em.EmulatorTrace a -> (ExBudget, Sum Int64) +emulatorTraceBudget trace = -- Most of the code here is taken from `Plutus.Trace.Emulator.Extract` (IOHK -- doesn't care to export it). let stream = Em.runEmulatorStream def trace @@ -54,11 +58,14 @@ emulatorTraceSize trace = exactlyOne _ = error "benchEmulatorTrace: expected exactly one validator run" -- | Return the script size in bytes along with execution budget. -validatorSize :: Validator -> (Plutus.ExBudget, Int) -validatorSize = (evalScriptCounting &&& SBS.length) . serialiseValidator +-- +-- NOTE: This calculates the budget for an *applied* validator. Use +-- @emulatorTraceBudget@ if you want to calculate on applied validators. +validatorBudget :: Validator -> (Plutus.ExBudget, Int) +validatorBudget = (evalScriptCounting &&& SBS.length) . serialiseValidator -scriptSize :: Script -> (Plutus.ExBudget, Int) -scriptSize = (evalScriptCounting &&& SBS.length) . serialiseScript +scriptBudget :: Script -> (Plutus.ExBudget, Int) +scriptBudget = (evalScriptCounting &&& SBS.length) . serialiseScript serialiseScript :: Script -> SBS.ShortByteString serialiseScript = SBS.toShort . LB.toStrict . serialise From 5fae6e1105acfa47a9502cb301a698b23f55806d Mon Sep 17 00:00:00 2001 From: Sridhar Ratnakumar Date: Fri, 24 Dec 2021 16:01:07 -0500 Subject: [PATCH 2/4] Add Budget type --- src/Pluton/Run/Budget.hs | 22 ++++++++++++++-------- 1 file changed, 14 insertions(+), 8 deletions(-) diff --git a/src/Pluton/Run/Budget.hs b/src/Pluton/Run/Budget.hs index 66bf4e9..c669c4e 100644 --- a/src/Pluton/Run/Budget.hs +++ b/src/Pluton/Run/Budget.hs @@ -1,6 +1,7 @@ -- | Execution budget and script size for Plutus scripts module Pluton.Run.Budget - ( -- | * Budget for an arbitraty Plutus script + ( Budget (..), + -- | * Budget for an arbitraty Plutus script scriptBudget, -- | * Budget for a smart contract validator script validatorBudget, @@ -19,7 +20,6 @@ import Data.ByteString.Short qualified as SBS import Data.Default (Default (def)) import Data.Int (Int64) import Data.Maybe (fromJust) -import Data.Monoid (Sum (..)) import Flat (flat) import GHC.Stack (HasCallStack) import Ledger.Index (ExBudget, ScriptValidationEvent (..), ValidatorMode (FullyAppliedValidators), getScript) @@ -30,13 +30,19 @@ import Streaming.Prelude qualified as S import Wallet.Emulator.Folds qualified as Folds import Wallet.Emulator.Stream (foldEmulatorStreamM) +data Budget = Budget + { exBudget :: ExBudget, + scriptSizeBytes :: Int64 + } + deriving stock (Show) + -- | Return the exbudget and script size of the *applied* validator run inside -- an Emulator trace. -- -- The trace must have run the validation exactly once, else this will fail. We -- do this, because we are benchmarking a single run of the validator, not -- multiple runs. -emulatorTraceBudget :: Em.EmulatorTrace a -> (ExBudget, Sum Int64) +emulatorTraceBudget :: Em.EmulatorTrace a -> Budget emulatorTraceBudget trace = -- Most of the code here is taken from `Plutus.Trace.Emulator.Extract` (IOHK -- doesn't care to export it). @@ -50,7 +56,7 @@ emulatorTraceBudget trace = let bytes = BSL.fromStrict . flat . unScript . getScript mode $ event byteSize = BSL.length bytes exBudget = either (error . show) fst sveResult - in (exBudget, Sum byteSize) + in Budget exBudget byteSize in f . exactlyOne $ getEvents Folds.scriptEvents where exactlyOne :: [a] -> a @@ -61,11 +67,11 @@ emulatorTraceBudget trace = -- -- NOTE: This calculates the budget for an *applied* validator. Use -- @emulatorTraceBudget@ if you want to calculate on applied validators. -validatorBudget :: Validator -> (Plutus.ExBudget, Int) -validatorBudget = (evalScriptCounting &&& SBS.length) . serialiseValidator +validatorBudget :: Validator -> Budget +validatorBudget = uncurry Budget . (evalScriptCounting &&& (fromInteger . toInteger . SBS.length)) . serialiseValidator -scriptBudget :: Script -> (Plutus.ExBudget, Int) -scriptBudget = (evalScriptCounting &&& SBS.length) . serialiseScript +scriptBudget :: Script -> Budget +scriptBudget = uncurry Budget . (evalScriptCounting &&& (fromInteger . toInteger . SBS.length)) . serialiseScript serialiseScript :: Script -> SBS.ShortByteString serialiseScript = SBS.toShort . LB.toStrict . serialise From 3c0c9042a9fc315e601ba02aa6d05ed6b531a4ee Mon Sep 17 00:00:00 2001 From: Sridhar Ratnakumar Date: Fri, 24 Dec 2021 16:11:26 -0500 Subject: [PATCH 3/4] remove unapplied validator budget --- bench/Bench.hs | 5 +---- exe/Main.hs | 4 ---- src/Pluton/Run/Budget.hs | 21 +++++---------------- 3 files changed, 6 insertions(+), 24 deletions(-) diff --git a/bench/Bench.hs b/bench/Bench.hs index 89edcf3..df8afaf 100644 --- a/bench/Bench.hs +++ b/bench/Bench.hs @@ -19,10 +19,7 @@ exampleContractGift = do print $ Run.emulatorTraceBudget (GiftTest.smokeTrace Gift.haskellValidator) print $ Run.emulatorTraceBudget (GiftTest.smokeTrace Gift.plutoValidator) print $ Run.emulatorTraceBudget (GiftTest.smokeTrace Gift.plutarchValidator) - putStrLn "==" - print $ Run.validatorBudget Gift.haskellValidator - print $ Run.validatorBudget Gift.plutoValidator - print $ Run.validatorBudget Gift.plutarchValidator + -- TODO: remove this after https://github.com/Plutonomicon/pluton/issues/26 placeholder :: IO () diff --git a/exe/Main.hs b/exe/Main.hs index 2709718..4173e9b 100644 --- a/exe/Main.hs +++ b/exe/Main.hs @@ -14,10 +14,6 @@ main :: IO () main = do Pluton.smoke -- Gift contract example - putStrLn "\n== Sample contract - Gift: sizes (haskell; pluto; plutarch) == " - print $ Run.validatorBudget Gift.haskellValidator - print $ Run.validatorBudget Gift.plutoValidator - print $ Run.validatorBudget Gift.plutarchValidator putStrLn "\n== Sample contract - Gift: emulator == " Em.runEmulatorTraceIO $ GiftTest.smokeTrace Gift.plutarchValidator putStrLn "\n== Sample contract - Gift: tests == " diff --git a/src/Pluton/Run/Budget.hs b/src/Pluton/Run/Budget.hs index c669c4e..28f9764 100644 --- a/src/Pluton/Run/Budget.hs +++ b/src/Pluton/Run/Budget.hs @@ -3,14 +3,12 @@ module Pluton.Run.Budget ( Budget (..), -- | * Budget for an arbitraty Plutus script scriptBudget, - -- | * Budget for a smart contract validator script - validatorBudget, -- | * Budget for EmulatorTrace emulatorTraceBudget, ) where -import Codec.Serialise (serialise) +import Codec.Serialise qualified as Codec import Control.Arrow ((&&&)) import Control.Foldl qualified as Foldl import Control.Monad.Freer qualified as Freer @@ -23,7 +21,8 @@ import Data.Maybe (fromJust) import Flat (flat) import GHC.Stack (HasCallStack) import Ledger.Index (ExBudget, ScriptValidationEvent (..), ValidatorMode (FullyAppliedValidators), getScript) -import Ledger.Scripts (Script (unScript), Validator) +import Ledger.Scripts (Script) +import Ledger.Scripts qualified as Scripts import Plutus.Trace.Emulator qualified as Em import Plutus.V1.Ledger.Api qualified as Plutus import Streaming.Prelude qualified as S @@ -53,7 +52,7 @@ emulatorTraceBudget trace = -- Note: This doesn't deal with minting policy scripts mode = FullyAppliedValidators f event@ScriptValidationEvent {sveResult} = - let bytes = BSL.fromStrict . flat . unScript . getScript mode $ event + let bytes = BSL.fromStrict . flat . Scripts.unScript . getScript mode $ event byteSize = BSL.length bytes exBudget = either (error . show) fst sveResult in Budget exBudget byteSize @@ -63,21 +62,11 @@ emulatorTraceBudget trace = exactlyOne [x] = x exactlyOne _ = error "benchEmulatorTrace: expected exactly one validator run" --- | Return the script size in bytes along with execution budget. --- --- NOTE: This calculates the budget for an *applied* validator. Use --- @emulatorTraceBudget@ if you want to calculate on applied validators. -validatorBudget :: Validator -> Budget -validatorBudget = uncurry Budget . (evalScriptCounting &&& (fromInteger . toInteger . SBS.length)) . serialiseValidator - scriptBudget :: Script -> Budget scriptBudget = uncurry Budget . (evalScriptCounting &&& (fromInteger . toInteger . SBS.length)) . serialiseScript serialiseScript :: Script -> SBS.ShortByteString -serialiseScript = SBS.toShort . LB.toStrict . serialise - -serialiseValidator :: Validator -> SBS.ShortByteString -serialiseValidator = SBS.toShort . LB.toStrict . serialise +serialiseScript = SBS.toShort . LB.toStrict . Codec.serialise -- Using `flat` here breaks `evalScriptCounting` evalScriptCounting :: HasCallStack => Plutus.SerializedScript -> Plutus.ExBudget evalScriptCounting script = do From 3a92675959aba939c29a14172b45bc0936a826ec Mon Sep 17 00:00:00 2001 From: Sridhar Ratnakumar Date: Fri, 24 Dec 2021 16:50:45 -0500 Subject: [PATCH 4/4] Report and write .csv of validator benchmarks --- README.md | 4 +-- bench/Bench.hs | 36 +++++++++++++++++++++------ exe/Main.hs | 3 --- flake.nix | 2 +- pluton.cabal | 9 ++++--- src/Pluton/Run/Budget.hs | 53 +++++++++++++++++++++++++++++++++------- 6 files changed, 81 insertions(+), 26 deletions(-) diff --git a/README.md b/README.md index 4456552..9ed7738 100644 --- a/README.md +++ b/README.md @@ -43,13 +43,13 @@ cabal run pluton ## Benchmarks -Note: Benchmarks are not implemented yet. This is only a placeholder. +Note: Benchmarks are work in progress; we intend to benchmark all examples in CI. ``` cabal bench ``` -This will write the benchmark report to `report.html`. +This will write the benchmark report to `bench.*`. ### Benchmarking a commit diff --git a/bench/Bench.hs b/bench/Bench.hs index df8afaf..651565f 100644 --- a/bench/Bench.hs +++ b/bench/Bench.hs @@ -1,29 +1,51 @@ +{-# LANGUAGE RecordWildCards #-} + module Main (main) where +import Control.Monad.Writer (MonadWriter, execWriterT, tell) import Criterion.Main import Criterion.Types +import Data.ByteString.Lazy qualified as BSL +import Data.Csv qualified as Csv +import Data.List qualified as List import Example.Contract.Gift.Test qualified as GiftTest import Example.Contract.Gift.Validator.Haskell qualified as Gift import Example.Contract.Gift.Validator.Plutarch qualified as Gift import Example.Contract.Gift.Validator.Pluto qualified as Gift +import Pluton.Run (Budget (..)) import Pluton.Run qualified as Run +import Text.PrettyPrint.Boxes qualified as B main :: IO () main = do exampleContractGift - placeholder exampleContractGift :: IO () exampleContractGift = do - putStrLn "\n== Sample contract - Gift: sizes (haskell; pluto; plutarch) == " - print $ Run.emulatorTraceBudget (GiftTest.smokeTrace Gift.haskellValidator) - print $ Run.emulatorTraceBudget (GiftTest.smokeTrace Gift.plutoValidator) - print $ Run.emulatorTraceBudget (GiftTest.smokeTrace Gift.plutarchValidator) + putStrLn "== Examples / Contract / Gift == " + budgets <- execWriterT $ do + let k = "examples:contract:gift:" + reportBudget (k <> "haskell") $ Run.emulatorTraceBudget (GiftTest.smokeTrace Gift.haskellValidator) + reportBudget (k <> "pluto") $ Run.emulatorTraceBudget (GiftTest.smokeTrace Gift.plutoValidator) + reportBudget (k <> "plutarch") $ Run.emulatorTraceBudget (GiftTest.smokeTrace Gift.plutarchValidator) + let csv = Csv.encodeDefaultOrderedByName budgets + BSL.writeFile "bench.csv" csv + putStrLn "Wrote to bench.csv:" + putStrLn $ B.render $ renderNamedBudgets budgets + +reportBudget :: (MonadWriter [Run.NamedBudget] m) => String -> Budget -> m () +reportBudget name budget = do + -- liftIO $ putStrLn $ "\t[" <> name <> "]\t\t " <> show exBudgetCPU <> " " <> show exBudgetMemory <> " " <> show scriptSizeBytes + tell [Run.NamedBudget (name, budget)] +renderNamedBudgets :: [Run.NamedBudget] -> B.Box +renderNamedBudgets bs = + let cols = List.transpose $ [[name, show cpu, show mem, show sz] | Run.NamedBudget (name, Run.Budget cpu mem sz) <- bs] + in B.hsep 2 B.left . map (B.vcat B.left . map B.text) $ cols -- TODO: remove this after https://github.com/Plutonomicon/pluton/issues/26 -placeholder :: IO () -placeholder = do +_placeholder :: IO () +_placeholder = do defaultMainWith cfg [ bgroup diff --git a/exe/Main.hs b/exe/Main.hs index 4173e9b..0809fb8 100644 --- a/exe/Main.hs +++ b/exe/Main.hs @@ -3,11 +3,8 @@ module Main (main) where import Example.Contract.Gift.Test qualified as GiftTest -import Example.Contract.Gift.Validator.Haskell qualified as Gift import Example.Contract.Gift.Validator.Plutarch qualified as Gift -import Example.Contract.Gift.Validator.Pluto qualified as Gift import Pluton qualified -import Pluton.Run qualified as Run import Plutus.Trace.Emulator qualified as Em main :: IO () diff --git a/flake.nix b/flake.nix index a391334..d716d6c 100644 --- a/flake.nix +++ b/flake.nix @@ -137,7 +137,7 @@ # We need to append the checks that come from haskell.nix to our own, # hence the need for flake.checks // {}. checks = flake.checks // { - benchmark = pkgs.runCommand "benchmark" {} "${self.apps.${system}.benchmark.program} | tee $out"; + benchmark = pkgs.runCommand "benchmark" { } "${self.apps.${system}.benchmark.program} | tee $out"; }; ciNix = inputs.flake-compat-ci.lib.recurseIntoFlakeWith { flake = self; diff --git a/pluton.cabal b/pluton.cabal index 37482e3..4afc9cc 100644 --- a/pluton.cabal +++ b/pluton.cabal @@ -37,8 +37,8 @@ library exposed-modules: Pluton Pluton.Run - Pluton.Run.Evaluate Pluton.Run.Budget + Pluton.Run.Evaluate Pluton.Types.Builtin Pluton.Types.Builtin.Data Pluton.Types.Builtin.Fun @@ -52,6 +52,7 @@ library , bytestring , cardano-api , cardano-ledger-alonzo + , cassava , containers , data-default , fin @@ -159,16 +160,16 @@ benchmark perf main-is: Bench.hs build-depends: , base + , boxes , bytestring + , cassava , criterion , data-default - , flat , foldl - , freer-simple + , mtl , pluton , pluton-examples , plutus-contract , plutus-core , plutus-ledger - , streaming , text diff --git a/src/Pluton/Run/Budget.hs b/src/Pluton/Run/Budget.hs index 28f9764..deb6de4 100644 --- a/src/Pluton/Run/Budget.hs +++ b/src/Pluton/Run/Budget.hs @@ -1,6 +1,11 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE RecordWildCards #-} + -- | Execution budget and script size for Plutus scripts module Pluton.Run.Budget ( Budget (..), + NamedBudget (..), -- | * Budget for an arbitraty Plutus script scriptBudget, -- | * Budget for EmulatorTrace @@ -15,12 +20,22 @@ import Control.Monad.Freer qualified as Freer import Data.ByteString.Lazy qualified as BSL import Data.ByteString.Lazy qualified as LB import Data.ByteString.Short qualified as SBS +import Data.Csv + ( DefaultOrdered (..), + ToField, + ToNamedRecord (..), + header, + namedRecord, + (.=), + ) import Data.Default (Default (def)) import Data.Int (Int64) import Data.Maybe (fromJust) import Flat (flat) +import GHC.Generics import GHC.Stack (HasCallStack) -import Ledger.Index (ExBudget, ScriptValidationEvent (..), ValidatorMode (FullyAppliedValidators), getScript) +import Ledger (ExBudget (ExBudget)) +import Ledger.Index (ExCPU, ExMemory, ScriptValidationEvent (..), ValidatorMode (FullyAppliedValidators), getScript) import Ledger.Scripts (Script) import Ledger.Scripts qualified as Scripts import Plutus.Trace.Emulator qualified as Em @@ -29,12 +44,6 @@ import Streaming.Prelude qualified as S import Wallet.Emulator.Folds qualified as Folds import Wallet.Emulator.Stream (foldEmulatorStreamM) -data Budget = Budget - { exBudget :: ExBudget, - scriptSizeBytes :: Int64 - } - deriving stock (Show) - -- | Return the exbudget and script size of the *applied* validator run inside -- an Emulator trace. -- @@ -55,7 +64,7 @@ emulatorTraceBudget trace = let bytes = BSL.fromStrict . flat . Scripts.unScript . getScript mode $ event byteSize = BSL.length bytes exBudget = either (error . show) fst sveResult - in Budget exBudget byteSize + in mkBudget exBudget byteSize in f . exactlyOne $ getEvents Folds.scriptEvents where exactlyOne :: [a] -> a @@ -63,7 +72,7 @@ emulatorTraceBudget trace = exactlyOne _ = error "benchEmulatorTrace: expected exactly one validator run" scriptBudget :: Script -> Budget -scriptBudget = uncurry Budget . (evalScriptCounting &&& (fromInteger . toInteger . SBS.length)) . serialiseScript +scriptBudget = uncurry mkBudget . (evalScriptCounting &&& (fromInteger . toInteger . SBS.length)) . serialiseScript serialiseScript :: Script -> SBS.ShortByteString serialiseScript = SBS.toShort . LB.toStrict . Codec.serialise -- Using `flat` here breaks `evalScriptCounting` @@ -75,3 +84,29 @@ evalScriptCounting script = do in case e of Left evalErr -> error ("Eval Error: " <> show evalErr) Right exbudget -> exbudget + +--- Types + +data Budget = Budget + { exBudgetCPU :: ExCPU, + exBudgetMemory :: ExMemory, + scriptSizeBytes :: ScriptSizeBytes + } + deriving stock (Show, Generic) + +newtype ScriptSizeBytes = ScriptSizeBytes Int64 + deriving stock (Eq, Ord, Show, Generic) + deriving newtype (Num, ToField) + +newtype NamedBudget = NamedBudget (String, Budget) + deriving stock (Show, Generic) + +instance ToNamedRecord NamedBudget where + toNamedRecord (NamedBudget (name, Budget {..})) = + namedRecord ["name" .= name, "cpu" .= exBudgetCPU, "mem" .= exBudgetMemory, "size" .= scriptSizeBytes] + +instance DefaultOrdered NamedBudget where + headerOrder _ = header ["name", "cpu", "mem", "size"] + +mkBudget :: ExBudget -> Int64 -> Budget +mkBudget (ExBudget cpu mem) = Budget cpu mem . ScriptSizeBytes