Skip to content

Use Data backed ledger types for COOP #7235

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

Open
wants to merge 2 commits into
base: master
Choose a base branch
from
Open

Use Data backed ledger types for COOP #7235

Show file tree
Hide file tree
Changes from all commits
Commits
Show all changes
2 commits
Select commit Hold shift + click to select a range
0a1bdf4
Use Data backed ledger types for COOP
SeungheonOh Jul 24, 2025
df88c97
fix ci
SeungheonOh Jul 24, 2025
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
59 changes: 30 additions & 29 deletions plutus-benchmark/coop/src/PlutusBenchmark/Coop/Gen.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -24,15 +24,16 @@ import Data.Map qualified as Map
import Data.Set (Set)
import Data.Set qualified as Set
import Data.Traversable (for)
import PlutusLedgerApi.V1.Address (pubKeyHashAddress, scriptHashAddress)
import PlutusLedgerApi.V1.Value
import PlutusLedgerApi.V2 hiding (Map)
import PlutusTx.AssocMap qualified as AssocMap
import PlutusLedgerApi.Data.V2 hiding (Map)
import PlutusLedgerApi.V1.Data.Address (pubKeyHashAddress, scriptHashAddress)
import PlutusLedgerApi.V1.Data.Value
import PlutusTx.Builtins.HasOpaque (stringToBuiltinByteString)
import PlutusTx.Data.AssocMap qualified as AssocMap
import PlutusTx.Data.List qualified as Li

import PlutusBenchmark.Coop.Types
import PlutusLedgerApi.V1.Interval (interval)
import PlutusLedgerApi.V2 qualified as Value
import PlutusLedgerApi.Data.V2 qualified as Value
import PlutusLedgerApi.V1.Data.Interval (interval)
import PlutusTx.Prelude (Group (inv))

mkScriptContext :: ScriptPurpose -> [TxInInfo] -> [TxInInfo] -> Value -> [TxOut] -> [PubKeyHash] -> ScriptContext
Expand All @@ -49,11 +50,11 @@ mkTxInfo ins refs mints outs sigs =
, txInfoData = AssocMap.empty
, txInfoId = ""
, txInfoRedeemers = AssocMap.empty
, txInfoInputs = sortOn (\(TxInInfo i _) -> i) ins
, txInfoReferenceInputs = sortOn (\(TxInInfo i _) -> i) refs
, txInfoInputs = Li.fromSOP $ sortOn (\(TxInInfo i _) -> i) ins
, txInfoReferenceInputs = Li.fromSOP $ sortOn (\(TxInInfo i _) -> i) refs
, txInfoMint = normalizeValue mints
, txInfoOutputs = outs
, txInfoSignatories = sigs
, txInfoOutputs = Li.fromSOP outs
, txInfoSignatories = Li.fromSOP sigs
}

setValidity :: ScriptContext -> Value.POSIXTimeRange -> ScriptContext
Expand Down Expand Up @@ -413,14 +414,14 @@ genCorrectFsMpBurningCtx fsMpParams fsCs = do
fsMintCtx <- genCorrectFsMpMintingCtx fsMpParams fsCs
(otherIns, otherMint, otherOuts) <- genOthers 5

let fsVOuts = [out | out <- txInfoOutputs . scriptContextTxInfo $ fsMintCtx, txOutAddress out == fsVAddr]
let fsVOuts = Li.fromSOP [out | out <- Li.toSOP (txInfoOutputs . scriptContextTxInfo $ fsMintCtx), txOutAddress out == fsVAddr]

fsIns <- for fsVOuts (\fsOut -> TxInInfo <$> genTxOutRef <*> pure fsOut)
fsIns <- for (Li.toSOP fsVOuts) (\fsOut -> TxInInfo <$> genTxOutRef <*> pure fsOut)

let fsDatums = [fsDat | out <- fsVOuts, OutputDatum (Datum dat) <- [txOutDatum out], fsDat <- maybe [] pure (fromBuiltinData @FsDatum dat)]
gcAfter = maximum [fs'gcAfter fsDatum | fsDatum <- fsDatums]
submitters = [fs'submitter fsDatum | fsDatum <- fsDatums]
fsBurned = mconcat [inv $ txOutValue fsVOut | fsVOut <- fsVOuts]
let fsDatums = Li.fromSOP [fsDat | out <- Li.toSOP fsVOuts, OutputDatum (Datum dat) <- [txOutDatum out], fsDat <- maybe [] pure (fromBuiltinData @FsDatum dat)]
gcAfter = maximum [fs'gcAfter fsDatum | fsDatum <- Li.toSOP fsDatums]
submitters = [fs'submitter fsDatum | fsDatum <- Li.toSOP fsDatums]
fsBurned = mconcat [inv $ txOutValue fsVOut | fsVOut <- Li.toSOP fsVOuts]
ins = otherIns <> fsIns
mint = otherMint <> fsBurned
outs = otherOuts
Expand Down Expand Up @@ -609,8 +610,8 @@ doMintAndPayOtherTokenName cs ctx =
in ctx
{ scriptContextTxInfo =
txInfo
{ txInfoMint = txInfoMint txInfo <> assetClassValue otherAc (toInteger . length . txInfoOutputs $ txInfo)
, txInfoOutputs = txInfoOutputs txInfo <> [out {txOutValue = assetClassValue otherAc 1 <> txOutValue out} | out <- txInfoOutputs txInfo]
{ txInfoMint = txInfoMint txInfo <> assetClassValue otherAc (Li.length . txInfoOutputs $ txInfo)
, txInfoOutputs = txInfoOutputs txInfo <> Li.fromSOP [out {txOutValue = assetClassValue otherAc 1 <> txOutValue out} | out <- Li.toSOP (txInfoOutputs txInfo)]
}
}

Expand All @@ -623,7 +624,7 @@ doMintAndPayOtherTokenNameAddr cs addr ctx =
{ scriptContextTxInfo =
txInfo
{ txInfoMint = txInfoMint txInfo <> assetClassValue otherAc 1
, txInfoOutputs = txInfoOutputs txInfo <> [TxOut addr (assetClassValue otherAc 1) NoOutputDatum Nothing]
, txInfoOutputs = txInfoOutputs txInfo <> Li.fromSOP [TxOut addr (assetClassValue otherAc 1) NoOutputDatum Nothing]
}
}

Expand All @@ -634,7 +635,7 @@ doRemoveOutputDatum ctx =
in ctx
{ scriptContextTxInfo =
txInfo
{ txInfoOutputs = [out {txOutDatum = NoOutputDatum} | out <- txInfoOutputs txInfo]
{ txInfoOutputs = Li.fromSOP [out {txOutDatum = NoOutputDatum} | out <- Li.toSOP (txInfoOutputs txInfo)]
}
}

Expand All @@ -645,7 +646,7 @@ doPayToOtherAddress originalAddr otherAddr ctx =
in ctx
{ scriptContextTxInfo =
txInfo
{ txInfoOutputs = [out {txOutAddress = otherAddr} | out <- txInfoOutputs txInfo, txOutAddress out == originalAddr]
{ txInfoOutputs = Li.fromSOP [out {txOutAddress = otherAddr} | out <- Li.toSOP (txInfoOutputs txInfo), txOutAddress out == originalAddr]
}
}

Expand All @@ -656,7 +657,7 @@ doRemoveInputsWithToken ac ctx =
in ctx
{ scriptContextTxInfo =
txInfo
{ txInfoInputs = [inp | inp@(TxInInfo _ inOut) <- txInfoInputs txInfo, assetClassValueOf (txOutValue inOut) ac > 0]
{ txInfoInputs = Li.fromSOP [inp | inp@(TxInInfo _ inOut) <- Li.toSOP (txInfoInputs txInfo), assetClassValueOf (txOutValue inOut) ac > 0]
}
}

Expand All @@ -667,7 +668,7 @@ doRemoveRefInputsWithCurrency cs ctx =
in ctx
{ scriptContextTxInfo =
txInfo
{ txInfoReferenceInputs = [inp | inp@(TxInInfo _ inOut) <- txInfoReferenceInputs txInfo, not . AssocMap.member cs $ getValue (txOutValue inOut)]
{ txInfoReferenceInputs = Li.fromSOP [inp | inp@(TxInInfo _ inOut) <- Li.toSOP (txInfoReferenceInputs txInfo), not . AssocMap.member cs $ getValue (txOutValue inOut)]
}
}

Expand All @@ -678,7 +679,7 @@ doRemoveInputsWithCurrency cs ctx =
in ctx
{ scriptContextTxInfo =
txInfo
{ txInfoInputs = [inp | inp@(TxInInfo _ inOut) <- txInfoInputs txInfo, not . AssocMap.member cs $ getValue (txOutValue inOut)]
{ txInfoInputs = Li.fromSOP [inp | inp@(TxInInfo _ inOut) <- Li.toSOP (txInfoInputs txInfo), not . AssocMap.member cs $ getValue (txOutValue inOut)]
}
}

Expand All @@ -692,7 +693,7 @@ doPayInsteadOfBurn addr ctx =
{ scriptContextTxInfo =
txInfo
{ txInfoMint = mintedVal
, txInfoOutputs = txInfoOutputs txInfo <> [TxOut addr (inv burnedVal) NoOutputDatum Nothing]
, txInfoOutputs = txInfoOutputs txInfo <> (Li.singleton $ TxOut addr (inv burnedVal) NoOutputDatum Nothing)
}
}

Expand Down Expand Up @@ -724,17 +725,17 @@ _doNothing = id
-- TODO: Switch to mlabs-haskell/plutus-simple-model (that's why you need it)
normalizeValue :: Value -> Value
normalizeValue v =
Value . AssocMap.safeFromList . Map.toList . (AssocMap.safeFromList . Map.toList <$>) $
Value . AssocMap.safeFromSOPList . Map.toList . (AssocMap.safeFromSOPList . Map.toList <$>) $
Map.unionsWith
(Map.unionWith (+))
( [ Map.singleton cs (Map.singleton tn q)
| (cs, tokens) <- AssocMap.toList . getValue $ v
, (tn, q) <- AssocMap.toList tokens
| (cs, tokens) <- AssocMap.toSOPList . getValue $ v
, (tn, q) <- AssocMap.toSOPList tokens
Comment on lines +728 to +733
Copy link
Contributor

Choose a reason for hiding this comment

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

Again, Data <-> SOP conversions are expensive. Can this be avoided here? You won't be able to use the list comprehension, unfortunately, but there should be a way to write this code using builtins. Let me know if you need help with this and we can take a look together.

]
)

-- | Creates an interval with Extended bounds
interval' :: forall a. Extended a -> Extended a -> Interval a
interval' :: (ToData a, UnsafeFromData a) => Extended a -> Extended a -> Interval a
interval' from' to' = Interval (LowerBound from' False) (UpperBound to' False)

hashTxInputs :: [TxInInfo] -> ByteString
Expand Down
36 changes: 15 additions & 21 deletions plutus-benchmark/coop/src/PlutusBenchmark/Coop/Scripts.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -13,21 +13,15 @@ import PlutusTx.Plugin ()
import PlutusTx.Prelude
import Prelude ()

import PlutusLedgerApi.V1.Interval (contains)
import PlutusLedgerApi.V1.Value (AssetClass (AssetClass), isZero, unAssetClass, valueOf,
withCurrencySymbol)
import PlutusLedgerApi.V1.Value qualified as Value
import PlutusLedgerApi.V2 (Datum, Extended (PosInf), Interval (Interval, ivTo),
LedgerBytes (getLedgerBytes), LowerBound (LowerBound),
ScriptContext (ScriptContext), ScriptPurpose (Minting),
TokenName (TokenName), TxId (getTxId), TxInInfo (TxInInfo),
TxInfo (TxInfo, txInfoData, txInfoInputs, txInfoMint, txInfoOutputs, txInfoReferenceInputs, txInfoSignatories, txInfoValidRange),
TxOut (TxOut, txOutAddress, txOutDatum, txOutValue),
TxOutRef (TxOutRef, txOutRefId, txOutRefIdx), UpperBound (UpperBound),
Value (Value, getValue))
import PlutusTx.AssocMap qualified as AssocMap
import PlutusLedgerApi.Data.V2
import PlutusLedgerApi.V1.Data.Interval (contains)
import PlutusLedgerApi.V1.Data.Value (isZero, unAssetClass, valueOf, withCurrencySymbol)
import PlutusLedgerApi.V1.Data.Value qualified as Value

import PlutusTx.Builtins.Internal qualified as BI
import PlutusTx.List (elem, find, foldl, null)
import PlutusTx.Data.AssocMap qualified as AssocMap
import PlutusTx.Data.List (cons, elem, foldl, null)
import PlutusTx.List qualified as BIList

import PlutusBenchmark.Coop.Types
import PlutusBenchmark.Coop.Utils
Expand Down Expand Up @@ -113,14 +107,14 @@ fsMp'
let
predicate (CertDatum {..}) =
0 < valueOf txInVal ap'authTokenCs (TokenName $ getLedgerBytes cert'id)
in case find predicate validCerts of
in case BIList.find predicate validCerts of
Nothing -> traceError "$AUTH must be validated with a $CERT"
Just (CertDatum {..}) ->
let
shouldbeBurned' =
shouldBeBurned
<> Value.singleton ap'authTokenCs (TokenName $ getLedgerBytes cert'id) (-1)
in (txIn : validAuthInputs'', shouldbeBurned')
in (cons txIn validAuthInputs'', shouldbeBurned')
else acc

(validAuthInputs', authTokensToBurn) = foldl go' (mempty, mempty) txInfoInputs
Expand All @@ -147,9 +141,9 @@ fsMp'
in if (Value $ AssocMap.singleton ownCs ownCurrValue)
== Value.singleton ownCs fsTokenName 1
then (Just fsTokenName, unusedAuthInputs'')
else (Nothing, authInput : unusedAuthInputs'')
else (Nothing, cons authInput unusedAuthInputs'')
matchWithAuth (myFsTn', unusedAuthInputs'') authInput =
(myFsTn', (authInput : unusedAuthInputs''))
(myFsTn', (cons authInput unusedAuthInputs''))

(mayFsTn, unusedAuthInputs') = foldl matchWithAuth (Nothing, mempty) unusedAuthInputs
in case mayFsTn of
Expand Down Expand Up @@ -210,7 +204,7 @@ authMp'
"Must mint at least one $AUTH token:\n"
<> "Must have a specified CurrencySymbol in the Value"
Just tokenNameMap ->
case AssocMap.toList tokenNameMap of
case AssocMap.toSOPList tokenNameMap of
Copy link
Contributor

Choose a reason for hiding this comment

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

This may be one of the reasons there is a performance decrease. Data.AssocMap.toSOPList has to traverse the whole map, while the AssocMap.toList doesn't have any runtime cost. Can you avoid using toSOPList here?

[(k, v)] | k == (TokenName authId) ->
errorIfFalse "Must mint at least one $AUTH token" (0 < v)
_ ->
Expand All @@ -231,7 +225,7 @@ certMp'
let
tnBytes =
let
AssetClass (aaCs, aaTn) = cmp'authAuthorityAc
(aaCs, aaTn) = unAssetClass cmp'authAuthorityAc
go acc@(aaVal, tnBytes'') (TxInInfo (TxOutRef {txOutRefId = txId, txOutRefIdx = txIdx}) (TxOut {txOutValue = txInVal})) =
if hasCurrency aaCs txInVal
then (aaVal + valueOf txInVal aaCs aaTn, tnBytes'' <> consByteString txIdx (getTxId txId))
Expand Down Expand Up @@ -280,7 +274,7 @@ certMp'
contains
(Interval (LowerBound certValidUntil False) (UpperBound PosInf True))
txInfoValidRange
AssetClass (redeemerCs, redeemerName) = cert'redeemerAc
(redeemerCs, redeemerName) = unAssetClass cert'redeemerAc
inputSum =
foldl (\acc (TxInInfo _ (TxOut {txOutValue})) -> acc + txOutValue) mempty txInfoInputs
!_spendAtLeast =
Expand Down
6 changes: 3 additions & 3 deletions plutus-benchmark/coop/src/PlutusBenchmark/Coop/TestContext.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -13,9 +13,9 @@ module PlutusBenchmark.Coop.TestContext (
correctAuthMpBurningContext,
) where

import PlutusLedgerApi.V1.Address (scriptHashAddress)
import PlutusLedgerApi.V1.Value (AssetClass, CurrencySymbol (..), TokenName (..), assetClass)
import PlutusLedgerApi.V2 (Address, ScriptContext, ScriptHash (..))
import PlutusLedgerApi.Data.V2 (Address, ScriptContext, ScriptHash (..))
import PlutusLedgerApi.V1.Data.Address (scriptHashAddress)
import PlutusLedgerApi.V1.Data.Value (AssetClass, CurrencySymbol (..), TokenName (..), assetClass)

import Test.QuickCheck.Gen (Gen (unGen))
import Test.QuickCheck.Random (mkQCGen)
Expand Down
7 changes: 4 additions & 3 deletions plutus-benchmark/coop/src/PlutusBenchmark/Coop/Types.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -8,9 +8,10 @@ module PlutusBenchmark.Coop.Types where
import Prelude qualified as HS

import Control.Lens (makeFields)
import PlutusLedgerApi.V1.Value (AssetClass)
import PlutusLedgerApi.V3 (Address, CurrencySymbol, Extended, LedgerBytes, POSIXTime,
POSIXTimeRange, PubKeyHash)

import PlutusLedgerApi.Data.V2
import PlutusLedgerApi.V1.Data.Value (AssetClass)

import PlutusTx.IsData qualified as PlutusTx
import PlutusTx.Lift qualified as PlutusTx
import PlutusTx.Prelude
Expand Down
34 changes: 19 additions & 15 deletions plutus-benchmark/coop/src/PlutusBenchmark/Coop/Utils.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -7,27 +7,24 @@ module PlutusBenchmark.Coop.Utils where
import PlutusTx.Prelude
import Prelude ()

import PlutusLedgerApi.V1.Value (Value (Value), flattenValue, valueOf, withCurrencySymbol)
import PlutusLedgerApi.V2 (CurrencySymbol, Datum (Datum), DatumHash,
OutputDatum (NoOutputDatum, OutputDatum, OutputDatumHash),
ScriptContext (ScriptContext), ScriptPurpose (Spending), TxId (TxId),
TxInInfo (TxInInfo, txInInfoOutRef),
TxInfo (TxInfo, txInfoInputs, txInfoMint), TxOut (TxOut, txOutValue),
TxOutRef (TxOutRef))
import PlutusTx.AssocMap (Map, lookup)
import PlutusTx.AssocMap qualified as AssocMap
import PlutusLedgerApi.V1 (Datum (Datum), DatumHash)
import PlutusLedgerApi.V1.Data.Value
import PlutusLedgerApi.V2.Data.Contexts
import PlutusLedgerApi.V2.Data.Tx
import PlutusTx.Builtins.Internal qualified as BI
import PlutusTx.List (find)
import PlutusTx.Data.AssocMap (Map, lookup)
import PlutusTx.Data.AssocMap qualified as AssocMap
import PlutusTx.Data.List (List, find)

findOwnInput :: [TxInInfo] -> TxOutRef -> TxInInfo
findOwnInput inputs oref =
findOwnInput' :: List TxInInfo -> TxOutRef -> TxInInfo
findOwnInput' inputs oref =
case find (\i -> txInInfoOutRef i == oref) inputs of
Nothing -> traceError "findOwnInput: not found"
Just x -> x

mustBurnOwnSingletonValue :: ScriptContext -> BuiltinUnit
mustBurnOwnSingletonValue (ScriptContext (TxInfo {..}) (Spending oref)) =
let (TxInInfo _ (TxOut {txOutValue = ownInputValue})) = findOwnInput txInfoInputs oref
let (TxInInfo _ (TxOut {txOutValue = ownInputValue})) = findOwnInput' txInfoInputs oref
-- flattenValue actually reverses order. See plutus#7173.
in case flattenValue ownInputValue of
[(cs, tk, q), _ada] ->
Expand All @@ -47,25 +44,32 @@ resolveDatum datums outputDatum =
Nothing -> traceError "expected datum but given datum hash have no associated datum"
Just (Datum d) -> unsafeFromBuiltinData @a d
OutputDatum (Datum d) -> unsafeFromBuiltinData @a d
{-# INLINE resolveDatum #-}

currencyValue :: CurrencySymbol -> Value -> Value
currencyValue cs val = withCurrencySymbol cs val mempty (\v -> Value $ AssocMap.singleton cs v)
{-# INLINE currencyValue #-}

unsafeMergeMap :: AssocMap.Map k v -> AssocMap.Map k v -> AssocMap.Map k v
unsafeMergeMap x y = AssocMap.unsafeFromList (AssocMap.toList x <> AssocMap.toList y)
unsafeMergeMap :: (ToData k, ToData v, UnsafeFromData k, UnsafeFromData v) => AssocMap.Map k v -> AssocMap.Map k v -> AssocMap.Map k v
unsafeMergeMap x y = AssocMap.unsafeFromSOPList (AssocMap.toSOPList x <> AssocMap.toSOPList y)
{-# INLINE unsafeMergeMap #-}

hashInput :: TxInInfo -> BuiltinByteString
hashInput (TxInInfo (TxOutRef (TxId hash) idx) _)
| idx < 256 = blake2b_256 (consByteString idx hash)
| otherwise = traceError "hashInput: Transaction output index must fit in an octet"
{-# INLINE hashInput #-}

errorIfFalse :: BuiltinString -> Bool -> BuiltinUnit
errorIfFalse msg False = traceError msg
errorIfFalse _ True = BI.unitval
{-# INLINE errorIfFalse #-}

errorIfTrue :: BuiltinString -> Bool -> BuiltinUnit
errorIfTrue msg True = traceError msg
errorIfTrue _ False = BI.unitval
{-# INLINE errorIfTrue #-}

hasCurrency :: CurrencySymbol -> Value -> Bool
hasCurrency cs (Value val) = AssocMap.member cs val
{-# INLINE hasCurrency #-}
8 changes: 4 additions & 4 deletions plutus-benchmark/coop/test/9.6/authMpBurning.eval.golden
View file
Open in desktop
Original file line number Diff line number Diff line change
@@ -1,6 +1,6 @@
CPU: 275_949_863
Memory: 1_044_479
Term Size: 1_908
Flat Size: 5_925
CPU: 22_532_179
Memory: 58_279
Term Size: 908
Flat Size: 4_859

(con unit ())
8 changes: 4 additions & 4 deletions plutus-benchmark/coop/test/9.6/authMpMinting.eval.golden
View file
Open in desktop
Original file line number Diff line number Diff line change
@@ -1,6 +1,6 @@
CPU: 595_852_740
Memory: 2_373_857
Term Size: 1_908
Flat Size: 7_322
CPU: 321_845_423
Memory: 852_311
Term Size: 908
Flat Size: 6_260

(con unit ())
8 changes: 4 additions & 4 deletions plutus-benchmark/coop/test/9.6/certMpBurning.eval.golden
View file
Open in desktop
Original file line number Diff line number Diff line change
@@ -1,6 +1,6 @@
CPU: 2_041_041_180
Memory: 11_330_335
Term Size: 3_698
Flat Size: 8_707
CPU: 7_153_841_977
Memory: 23_035_266
Term Size: 3_856
Flat Size: 8_833

(con unit ())
8 changes: 4 additions & 4 deletions plutus-benchmark/coop/test/9.6/certMpMinting.eval.golden
View file
Open in desktop
Original file line number Diff line number Diff line change
@@ -1,6 +1,6 @@
CPU: 628_642_273
Memory: 2_544_349
Term Size: 3_698
Flat Size: 9_230
CPU: 450_505_963
Memory: 1_349_628
Term Size: 3_856
Flat Size: 9_355

(con unit ())
Loading