From 373de94441f249fc26b1540bcf2a876aa12c1101 Mon Sep 17 00:00:00 2001 From: Yura Lazarev <1009751+Unisay@users.noreply.github.com> Date: Thu, 31 Oct 2024 20:51:38 +0100 Subject: [PATCH] MintValue (#6609) * MintValue * Test properties of MintValue --- .../PlutusLedgerApi/V3/ArbitraryContexts.hs | 2 +- .../src/PlutusBenchmark/ScriptContexts.hs | 4 +- .../9.6/checkScriptContext1-20.budget.golden | 4 +- .../9.6/checkScriptContext1-4.budget.golden | 4 +- .../test/9.6/checkScriptContext1.pir.golden | 19 +-- .../test/9.6/checkScriptContext1.size.golden | 2 +- .../9.6/checkScriptContext2-20.budget.golden | 4 +- .../9.6/checkScriptContext2-4.budget.golden | 4 +- .../test/9.6/checkScriptContext2.pir.golden | 19 +-- .../test/9.6/checkScriptContext2.size.golden | 2 +- ...241031_172446_Yuriy.Lazaryev_mint_value.md | 4 + .../exe/analyse-script-events/Main.hs | 4 +- plutus-ledger-api/plutus-ledger-api.cabal | 3 + plutus-ledger-api/src/PlutusLedgerApi/V3.hs | 8 ++ .../src/PlutusLedgerApi/V3/Contexts.hs | 8 +- .../src/PlutusLedgerApi/V3/MintValue.hs | 126 ++++++++++++++++++ .../test-plugin/Spec/ScriptSize.hs | 3 +- plutus-ledger-api/test/Spec.hs | 2 + plutus-ledger-api/test/Spec/V1/Value.hs | 2 - plutus-ledger-api/test/Spec/V3/MintValue.hs | 63 +++++++++ .../PlutusLedgerApi/Test/V3/MintValue.hs | 44 ++++++ 21 files changed, 292 insertions(+), 39 deletions(-) create mode 100644 plutus-ledger-api/changelog.d/20241031_172446_Yuriy.Lazaryev_mint_value.md create mode 100644 plutus-ledger-api/src/PlutusLedgerApi/V3/MintValue.hs create mode 100644 plutus-ledger-api/test/Spec/V3/MintValue.hs create mode 100644 plutus-ledger-api/testlib/PlutusLedgerApi/Test/V3/MintValue.hs diff --git a/cardano-constitution/test/PlutusLedgerApi/V3/ArbitraryContexts.hs b/cardano-constitution/test/PlutusLedgerApi/V3/ArbitraryContexts.hs index 57aaa60e470..86718788f55 100644 --- a/cardano-constitution/test/PlutusLedgerApi/V3/ArbitraryContexts.hs +++ b/cardano-constitution/test/PlutusLedgerApi/V3/ArbitraryContexts.hs @@ -68,7 +68,7 @@ memptyTxInfo = TxInfo , txInfoReferenceInputs = mempty , txInfoOutputs = mempty , txInfoFee = zero - , txInfoMint = mempty + , txInfoMint = emptyMintValue , txInfoTxCerts = mempty , txInfoWdrl = AssocMap.unsafeFromList mempty , txInfoValidRange = always diff --git a/plutus-benchmark/script-contexts/src/PlutusBenchmark/ScriptContexts.hs b/plutus-benchmark/script-contexts/src/PlutusBenchmark/ScriptContexts.hs index 479b75e3689..ed641da725d 100644 --- a/plutus-benchmark/script-contexts/src/PlutusBenchmark/ScriptContexts.hs +++ b/plutus-benchmark/script-contexts/src/PlutusBenchmark/ScriptContexts.hs @@ -9,7 +9,7 @@ import PlutusLedgerApi.V1.Address import PlutusLedgerApi.V1.Value import PlutusLedgerApi.V3 (OutputDatum (NoOutputDatum), PubKeyHash (..), Redeemer (..), ScriptContext (..), ScriptInfo (SpendingScript), TxId (..), TxInfo (..), - TxOut (..), TxOutRef (..), always) + TxOut (..), TxOutRef (..), always, emptyMintValue) import PlutusTx qualified import PlutusTx.AssocMap qualified as Map import PlutusTx.Builtins qualified as PlutusTx @@ -32,7 +32,7 @@ mkTxInfo i = TxInfo { txInfoReferenceInputs=mempty, txInfoOutputs=fmap mkTxOut [1..i], txInfoFee=10000, - txInfoMint=mempty, + txInfoMint=emptyMintValue, txInfoTxCerts=mempty, txInfoWdrl=Map.empty, txInfoValidRange=always, diff --git a/plutus-benchmark/script-contexts/test/9.6/checkScriptContext1-20.budget.golden b/plutus-benchmark/script-contexts/test/9.6/checkScriptContext1-20.budget.golden index 853f70358f8..4df6ef26a00 100644 --- a/plutus-benchmark/script-contexts/test/9.6/checkScriptContext1-20.budget.golden +++ b/plutus-benchmark/script-contexts/test/9.6/checkScriptContext1-20.budget.golden @@ -1,2 +1,2 @@ -({cpu: 11100264187581 -| mem: 11100001066437}) \ No newline at end of file +({cpu: 11100263419581 +| mem: 11100001061637}) \ No newline at end of file diff --git a/plutus-benchmark/script-contexts/test/9.6/checkScriptContext1-4.budget.golden b/plutus-benchmark/script-contexts/test/9.6/checkScriptContext1-4.budget.golden index 91815276ecc..779e93ab6dd 100644 --- a/plutus-benchmark/script-contexts/test/9.6/checkScriptContext1-4.budget.golden +++ b/plutus-benchmark/script-contexts/test/9.6/checkScriptContext1-4.budget.golden @@ -1,2 +1,2 @@ -({cpu: 3100079463709 -| mem: 3100000324645}) \ No newline at end of file +({cpu: 3100079207709 +| mem: 3100000323045}) \ No newline at end of file diff --git a/plutus-benchmark/script-contexts/test/9.6/checkScriptContext1.pir.golden b/plutus-benchmark/script-contexts/test/9.6/checkScriptContext1.pir.golden index 81906b60cf2..715e0ef6d50 100644 --- a/plutus-benchmark/script-contexts/test/9.6/checkScriptContext1.pir.golden +++ b/plutus-benchmark/script-contexts/test/9.6/checkScriptContext1.pir.golden @@ -778,13 +778,6 @@ (go xs)) in let - ~`$fUnsafeFromDataValue` : - data -> (\k v -> List (Tuple2 k v)) bytestring integer - = `$fUnsafeFromDataMap_$cunsafeFromBuiltinData` - {bytestring} - {integer} - unBData - unIData !`$fUnsafeFromDataTxOut_$cunsafeFromBuiltinData` : data -> TxOut = \(eta : data) -> @@ -866,7 +859,11 @@ {bytestring} {(\k v -> List (Tuple2 k v)) bytestring integer} unBData - `$fUnsafeFromDataValue` + (`$fUnsafeFromDataMap_$cunsafeFromBuiltinData` + {bytestring} + {integer} + unBData + unIData) (headList {data} l)) (let !tup : pair integer (list data) @@ -1179,7 +1176,11 @@ {bytestring} {(\k v -> List (Tuple2 k v)) bytestring integer} unBData - `$fUnsafeFromDataValue` + (`$fUnsafeFromDataMap_$cunsafeFromBuiltinData` + {bytestring} + {integer} + unBData + unIData) (headList {data} l)) (let !d : data = headList {data} l diff --git a/plutus-benchmark/script-contexts/test/9.6/checkScriptContext1.size.golden b/plutus-benchmark/script-contexts/test/9.6/checkScriptContext1.size.golden index 6496f603eb9..f8035a6b440 100644 --- a/plutus-benchmark/script-contexts/test/9.6/checkScriptContext1.size.golden +++ b/plutus-benchmark/script-contexts/test/9.6/checkScriptContext1.size.golden @@ -1 +1 @@ -3221 \ No newline at end of file +3218 \ No newline at end of file diff --git a/plutus-benchmark/script-contexts/test/9.6/checkScriptContext2-20.budget.golden b/plutus-benchmark/script-contexts/test/9.6/checkScriptContext2-20.budget.golden index 93d4a85de53..32dca36b004 100644 --- a/plutus-benchmark/script-contexts/test/9.6/checkScriptContext2-20.budget.golden +++ b/plutus-benchmark/script-contexts/test/9.6/checkScriptContext2-20.budget.golden @@ -1,2 +1,2 @@ -({cpu: 11100253887109 -| mem: 11100001016294}) \ No newline at end of file +({cpu: 11100253119109 +| mem: 11100001011494}) \ No newline at end of file diff --git a/plutus-benchmark/script-contexts/test/9.6/checkScriptContext2-4.budget.golden b/plutus-benchmark/script-contexts/test/9.6/checkScriptContext2-4.budget.golden index 1890a0031f0..29fec21fcb6 100644 --- a/plutus-benchmark/script-contexts/test/9.6/checkScriptContext2-4.budget.golden +++ b/plutus-benchmark/script-contexts/test/9.6/checkScriptContext2-4.budget.golden @@ -1,2 +1,2 @@ -({cpu: 3100076414565 -| mem: 3100000309734}) \ No newline at end of file +({cpu: 3100076158565 +| mem: 3100000308134}) \ No newline at end of file diff --git a/plutus-benchmark/script-contexts/test/9.6/checkScriptContext2.pir.golden b/plutus-benchmark/script-contexts/test/9.6/checkScriptContext2.pir.golden index 9d69fe6b4ce..3cfe475670e 100644 --- a/plutus-benchmark/script-contexts/test/9.6/checkScriptContext2.pir.golden +++ b/plutus-benchmark/script-contexts/test/9.6/checkScriptContext2.pir.golden @@ -747,13 +747,6 @@ (go xs)) in let - ~`$fUnsafeFromDataValue` : - data -> (\k v -> List (Tuple2 k v)) bytestring integer - = `$fUnsafeFromDataMap_$cunsafeFromBuiltinData` - {bytestring} - {integer} - unBData - unIData data StakingCredential | StakingCredential_match where StakingHash : Credential -> StakingCredential StakingPtr : integer -> integer -> integer -> StakingCredential @@ -853,7 +846,11 @@ {bytestring} {(\k v -> List (Tuple2 k v)) bytestring integer} unBData - `$fUnsafeFromDataValue` + (`$fUnsafeFromDataMap_$cunsafeFromBuiltinData` + {bytestring} + {integer} + unBData + unIData) (headList {data} l)) (let !tup : pair integer (list data) @@ -1168,7 +1165,11 @@ {bytestring} {(\k v -> List (Tuple2 k v)) bytestring integer} unBData - `$fUnsafeFromDataValue` + (`$fUnsafeFromDataMap_$cunsafeFromBuiltinData` + {bytestring} + {integer} + unBData + unIData) (headList {data} l)) (let !d : data = headList {data} l diff --git a/plutus-benchmark/script-contexts/test/9.6/checkScriptContext2.size.golden b/plutus-benchmark/script-contexts/test/9.6/checkScriptContext2.size.golden index 50e9648605c..79aafa0e780 100644 --- a/plutus-benchmark/script-contexts/test/9.6/checkScriptContext2.size.golden +++ b/plutus-benchmark/script-contexts/test/9.6/checkScriptContext2.size.golden @@ -1 +1 @@ -3157 \ No newline at end of file +3154 \ No newline at end of file diff --git a/plutus-ledger-api/changelog.d/20241031_172446_Yuriy.Lazaryev_mint_value.md b/plutus-ledger-api/changelog.d/20241031_172446_Yuriy.Lazaryev_mint_value.md new file mode 100644 index 00000000000..35343e93df5 --- /dev/null +++ b/plutus-ledger-api/changelog.d/20241031_172446_Yuriy.Lazaryev_mint_value.md @@ -0,0 +1,4 @@ +### Changed + +- 'txInfoMint' function now returns 'MintValue' instead of 'Value' for minted values. This change +addresses problem described in the issue #5781. diff --git a/plutus-ledger-api/exe/analyse-script-events/Main.hs b/plutus-ledger-api/exe/analyse-script-events/Main.hs index 8758413c26b..2e873cd64b6 100644 --- a/plutus-ledger-api/exe/analyse-script-events/Main.hs +++ b/plutus-ledger-api/exe/analyse-script-events/Main.hs @@ -112,7 +112,9 @@ analyseTxInfoV3 i = do putStr "Fee: " print $ V3.txInfoFee i putStr "Mint: " - analyseValue $ V3.txInfoMint i + analyseValue $ V3.mintValueMinted (V3.txInfoMint i) + putStr "Burn: " + analyseValue $ V3.mintValueBurned (V3.txInfoMint i) analyseOutputs (V3.txInfoOutputs i) V3.txOutValue analyseScriptContext :: EventAnalyser diff --git a/plutus-ledger-api/plutus-ledger-api.cabal b/plutus-ledger-api/plutus-ledger-api.cabal index e5cf081b9a8..4f0231b3463 100644 --- a/plutus-ledger-api/plutus-ledger-api.cabal +++ b/plutus-ledger-api/plutus-ledger-api.cabal @@ -89,6 +89,7 @@ library PlutusLedgerApi.V3.Contexts PlutusLedgerApi.V3.Data.Contexts PlutusLedgerApi.V3.EvaluationContext + PlutusLedgerApi.V3.MintValue PlutusLedgerApi.V3.ParamName PlutusLedgerApi.V3.Tx @@ -133,6 +134,7 @@ library plutus-ledger-api-testlib PlutusLedgerApi.Test.V2.EvaluationContext PlutusLedgerApi.Test.V3.Data.EvaluationContext PlutusLedgerApi.Test.V3.EvaluationContext + PlutusLedgerApi.Test.V3.MintValue build-depends: , barbies @@ -169,6 +171,7 @@ test-suite plutus-ledger-api-test Spec.ScriptDecodeError Spec.V1.Data.Value Spec.V1.Value + Spec.V3.MintValue Spec.Versions build-depends: diff --git a/plutus-ledger-api/src/PlutusLedgerApi/V3.hs b/plutus-ledger-api/src/PlutusLedgerApi/V3.hs index 21de2d427a0..6b00a3dff89 100644 --- a/plutus-ledger-api/src/PlutusLedgerApi/V3.hs +++ b/plutus-ledger-api/src/PlutusLedgerApi/V3.hs @@ -85,6 +85,13 @@ module PlutusLedgerApi.V3 ( V2.adaToken, V2.Lovelace (..), + -- *** Mint Value + MintValue.MintValue, + MintValue.emptyMintValue, + MintValue.mintValueToMap, + MintValue.mintValueMinted, + MintValue.mintValueBurned, + -- *** Time V2.POSIXTime (..), V2.POSIXTimeRange, @@ -152,6 +159,7 @@ import PlutusLedgerApi.Common qualified as Common import PlutusLedgerApi.V2 qualified as V2 import PlutusLedgerApi.V3.Contexts qualified as Contexts import PlutusLedgerApi.V3.EvaluationContext qualified as EvaluationContext +import PlutusLedgerApi.V3.MintValue qualified as MintValue import PlutusLedgerApi.V3.ParamName qualified as ParamName import PlutusLedgerApi.V3.Tx qualified as Tx import PlutusTx.Ratio qualified as Ratio diff --git a/plutus-ledger-api/src/PlutusLedgerApi/V3/Contexts.hs b/plutus-ledger-api/src/PlutusLedgerApi/V3/Contexts.hs index 57737538bdb..3c174057186 100644 --- a/plutus-ledger-api/src/PlutusLedgerApi/V3/Contexts.hs +++ b/plutus-ledger-api/src/PlutusLedgerApi/V3/Contexts.hs @@ -58,6 +58,7 @@ import Data.Function ((&)) import Data.Maybe (Maybe (..)) import GHC.Generics (Generic) import PlutusLedgerApi.V2 qualified as V2 +import PlutusLedgerApi.V3.MintValue qualified as V3 import PlutusLedgerApi.V3.Tx qualified as V3 import PlutusTx (makeIsDataSchemaIndexed) import PlutusTx qualified @@ -65,16 +66,15 @@ import PlutusTx.AssocMap (Map, lookup, toList) import PlutusTx.Blueprint (HasBlueprintDefinition, HasBlueprintSchema, HasSchemaDefinition, Schema (SchemaBuiltInData), SchemaInfo (..), emptySchemaInfo) import PlutusTx.Blueprint.Class (HasBlueprintSchema (..)) +import PlutusTx.Blueprint.Definition.Derive (definitionRef) import PlutusTx.Blueprint.Schema (withSchemaInfo) import PlutusTx.Lift (makeLift) import PlutusTx.Prelude qualified as PlutusTx import PlutusTx.Ratio (Rational) +import Prelude qualified as Haskell import Prettyprinter (nest, vsep, (<+>)) import Prettyprinter.Extras (Pretty (pretty), PrettyShow (PrettyShow)) -import PlutusTx.Blueprint.Definition.Derive (definitionRef) -import Prelude qualified as Haskell - newtype ColdCommitteeCredential = ColdCommitteeCredential V2.Credential deriving stock (Generic) deriving anyclass (HasBlueprintDefinition) @@ -480,7 +480,7 @@ data TxInfo = TxInfo , txInfoReferenceInputs :: [TxInInfo] , txInfoOutputs :: [V2.TxOut] , txInfoFee :: V2.Lovelace - , txInfoMint :: V2.Value + , txInfoMint :: V3.MintValue -- ^ The 'Value' minted by this transaction. -- -- /Invariant:/ This field does not contain Ada with zero quantity, unlike diff --git a/plutus-ledger-api/src/PlutusLedgerApi/V3/MintValue.hs b/plutus-ledger-api/src/PlutusLedgerApi/V3/MintValue.hs new file mode 100644 index 00000000000..20667dfd05a --- /dev/null +++ b/plutus-ledger-api/src/PlutusLedgerApi/V3/MintValue.hs @@ -0,0 +1,126 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# OPTIONS_GHC -fexpose-all-unfoldings #-} +{-# OPTIONS_GHC -fno-omit-interface-pragmas #-} +{-# OPTIONS_GHC -fno-spec-constr #-} +{-# OPTIONS_GHC -fno-specialise #-} + +module PlutusLedgerApi.V3.MintValue + ( MintValue (..) -- Constructor is exported for testing + , emptyMintValue + , mintValueToMap + , mintValueMinted + , mintValueBurned + ) +where + +import PlutusTx.Prelude + +import Control.DeepSeq (NFData) +import Data.Data (Data, Typeable) +import GHC.Generics (Generic) +import PlutusLedgerApi.V1.Value (CurrencySymbol, TokenName, Value (..)) +import PlutusTx (FromData (..), ToData (..), UnsafeFromData (..)) +import PlutusTx.AssocMap (Map) +import PlutusTx.AssocMap qualified as Map +import PlutusTx.Blueprint.Class (HasBlueprintSchema (..)) +import PlutusTx.Blueprint.Definition (HasBlueprintDefinition (..), definitionIdFromType, + definitionRef) +import PlutusTx.Blueprint.Schema (MapSchema (..), Schema (..)) +import PlutusTx.Blueprint.Schema.Annotation (emptySchemaInfo, title) +import PlutusTx.Lift (makeLift) +import Prelude qualified as Haskell +import Prettyprinter (Pretty) +import Prettyprinter.Extras (PrettyShow (PrettyShow)) + +{- Note [MintValue vs Value] + +'MintValue' differs conceptually from 'Value' in how negative quantities are interpreted: + +In 'MintValue', negative quantities are interpreted as assets being burned. For 'Value', +negative quantities are either don't make sense (e.g. in a transaction output) or interpreted +as a negative balance. + +We want to distinguish these at the type level to avoid using 'MintValue' where 'Value' is assumed. +Users should project 'MintValue' into 'Value' using 'mintValueMinted' or 'mintValueBurned'. +-} + +-- | A 'MintValue' represents assets that are minted and burned in a transaction. +newtype MintValue = UnsafeMintValue (Map CurrencySymbol (Map TokenName Integer)) + deriving stock (Generic, Data, Typeable, Haskell.Show) + deriving anyclass (NFData) + deriving newtype (ToData, FromData, UnsafeFromData) + deriving (Pretty) via (PrettyShow MintValue) + +instance Haskell.Eq MintValue where + l == r = mintValueMinted l == mintValueMinted r && mintValueBurned l == mintValueBurned r + +instance HasBlueprintDefinition MintValue where + type Unroll MintValue = '[MintValue, CurrencySymbol, TokenName, Integer] + definitionId = definitionIdFromType @MintValue + +instance HasBlueprintSchema MintValue referencedTypes where + {-# INLINEABLE schema #-} + schema = + SchemaMap + emptySchemaInfo{title = Just "MintValue"} + MkMapSchema + { keySchema = definitionRef @CurrencySymbol + , valueSchema = + SchemaMap + emptySchemaInfo + MkMapSchema + { keySchema = definitionRef @TokenName + , valueSchema = definitionRef @Integer + , minItems = Nothing + , maxItems = Nothing + } + , minItems = Nothing + , maxItems = Nothing + } + +{-# INLINEABLE emptyMintValue #-} +emptyMintValue :: MintValue +emptyMintValue = UnsafeMintValue Map.empty + +{-# INLINEABLE mintValueToMap #-} +mintValueToMap :: MintValue -> Map CurrencySymbol (Map TokenName Integer) +mintValueToMap (UnsafeMintValue m) = m + +-- | Get the 'Value' minted by the 'MintValue'. +{-# INLINEABLE mintValueMinted #-} +mintValueMinted :: MintValue -> Value +mintValueMinted (UnsafeMintValue values) = filterQuantities (\x -> [x | x > 0]) values + +{- | Get the 'Value' burned by the 'MintValue'. +All the negative quantities in the 'MintValue' become positive in the resulting 'Value'. +-} +{-# INLINEABLE mintValueBurned #-} +mintValueBurned :: MintValue -> Value +mintValueBurned (UnsafeMintValue values) = filterQuantities (\x -> [abs x | x < 0]) values + +{-# INLINEABLE filterQuantities #-} +filterQuantities :: (Integer -> [Integer]) -> Map CurrencySymbol (Map TokenName Integer) -> Value +filterQuantities mapQuantity values = + Value (Map.unsafeFromList (foldr filterTokenQuantities [] (Map.toList values))) + where + {-# INLINEABLE filterTokenQuantities #-} + filterTokenQuantities + :: (CurrencySymbol, Map TokenName Integer) + -> [(CurrencySymbol, Map TokenName Integer)] + -> [(CurrencySymbol, Map TokenName Integer)] + filterTokenQuantities (currency, tokenQuantities) = + case concatMap (traverse mapQuantity) (Map.toList tokenQuantities) of + [] -> id + quantities -> ((currency, Map.unsafeFromList quantities) :) + +---------------------------------------------------------------------------------------------------- +-- TH Splices -------------------------------------------------------------------------------------- + +$(makeLift ''MintValue) diff --git a/plutus-ledger-api/test-plugin/Spec/ScriptSize.hs b/plutus-ledger-api/test-plugin/Spec/ScriptSize.hs index 2f9a948b89a..e5b1466de0f 100644 --- a/plutus-ledger-api/test-plugin/Spec/ScriptSize.hs +++ b/plutus-ledger-api/test-plugin/Spec/ScriptSize.hs @@ -16,6 +16,7 @@ import PlutusCore.Evaluation.Machine.ExBudgetingDefaults (defaultCekParametersFo import PlutusCore.StdLib.Data.Unit (unitval) import PlutusLedgerApi.V2 qualified as V2 import PlutusLedgerApi.V3 qualified as V3 +import PlutusLedgerApi.V3.MintValue (emptyMintValue) import PlutusTx (CompiledCode, liftCodeDef, unsafeApplyCode) import PlutusTx.AssocMap qualified as Map import PlutusTx.Builtins.Internal qualified as BI @@ -164,7 +165,7 @@ dummyScriptContext = , V3.txInfoReferenceInputs = [] , V3.txInfoOutputs = [] , V3.txInfoFee = 1000000 :: V3.Lovelace - , V3.txInfoMint = mempty + , V3.txInfoMint = emptyMintValue , V3.txInfoTxCerts = [] , V3.txInfoWdrl = Map.empty , V3.txInfoValidRange = diff --git a/plutus-ledger-api/test/Spec.hs b/plutus-ledger-api/test/Spec.hs index 772faf953f5..dfabde4319d 100644 --- a/plutus-ledger-api/test/Spec.hs +++ b/plutus-ledger-api/test/Spec.hs @@ -20,6 +20,7 @@ import Spec.Interval qualified import Spec.ScriptDecodeError qualified import Spec.V1.Data.Value qualified as Data.Value import Spec.V1.Value qualified as Value +import Spec.V3.MintValue qualified as MintValue import Spec.Versions qualified import Test.Tasty @@ -136,6 +137,7 @@ tests = testGroup "plutus-ledger-api" , Spec.CostModelParams.tests , Spec.ContextDecoding.tests , Value.test_Value + , MintValue.tests ] , testGroup "Data" [ Spec.Data.Eval.tests diff --git a/plutus-ledger-api/test/Spec/V1/Value.hs b/plutus-ledger-api/test/Spec/V1/Value.hs index 422bc740752..1f817bbed15 100644 --- a/plutus-ledger-api/test/Spec/V1/Value.hs +++ b/plutus-ledger-api/test/Spec/V1/Value.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE MultiWayIf #-} - module Spec.V1.Value where import PlutusLedgerApi.Test.V1.Value as Value diff --git a/plutus-ledger-api/test/Spec/V3/MintValue.hs b/plutus-ledger-api/test/Spec/V3/MintValue.hs new file mode 100644 index 00000000000..ab9eb0042ff --- /dev/null +++ b/plutus-ledger-api/test/Spec/V3/MintValue.hs @@ -0,0 +1,63 @@ +{-# LANGUAGE BlockArguments #-} + +module Spec.V3.MintValue where + +import Data.Set (Set) +import Data.Set qualified as Set +import PlutusLedgerApi.Test.V1.Value () +import PlutusLedgerApi.Test.V3.MintValue () +import PlutusLedgerApi.V1.Value (AssetClass (..), Value (..), flattenValue) +import PlutusLedgerApi.V3.MintValue (MintValue, mintValueBurned, mintValueMinted) +import PlutusTx.AssocMap qualified as Map +import PlutusTx.IsData.Class (toBuiltinData) +import Spec.V1.Data.Value (scaleTestsBy) +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.QuickCheck (testProperty, (===)) +import Unsafe.Coerce (unsafeCoerce) + +tests :: TestTree +tests = + testGroup + "MintValue" + [ test_MintValueBuiltinData + , test_AssetClassIsEitherMintedOrBurned + , test_MintValueMintedIsPositive + , test_MintValueBurnedIsPositive + ] + +test_MintValueBuiltinData :: TestTree +test_MintValueBuiltinData = + testProperty "Builtin data representation of MintValue and Value is the same" $ + scaleTestsBy 5 \(values :: Either Value MintValue) -> do + let (value, mintValue) = + case values of + Left v -> (v, unsafeCoerce v) + Right mv -> (unsafeCoerce mv, mv) + toBuiltinData mintValue === toBuiltinData value + +test_AssetClassIsEitherMintedOrBurned :: TestTree +test_AssetClassIsEitherMintedOrBurned = + testProperty "Asset class is either minted or burned" $ + scaleTestsBy 5 \(mintValue :: MintValue) -> + Set.null $ + Set.intersection + (valueAssetClasses (mintValueMinted mintValue)) + (valueAssetClasses (mintValueBurned mintValue)) + where + valueAssetClasses :: Value -> Set AssetClass + valueAssetClasses value = + Set.fromList [AssetClass (cs, tn) | (cs, tn, _q) <- flattenValue value] + +test_MintValueMintedIsPositive :: TestTree +test_MintValueMintedIsPositive = + testProperty "MintValue minted is positive" $ + scaleTestsBy 5 \(mintValue :: MintValue) -> + let Value minted = mintValueMinted mintValue + in all (all (> 0) . Map.elems) (Map.elems minted) + +test_MintValueBurnedIsPositive :: TestTree +test_MintValueBurnedIsPositive = + testProperty "MintValue burned is positive" $ + scaleTestsBy 5 \(mintValue :: MintValue) -> + let Value burned = mintValueBurned mintValue + in all (all (> 0) . Map.elems) (Map.elems burned) diff --git a/plutus-ledger-api/testlib/PlutusLedgerApi/Test/V3/MintValue.hs b/plutus-ledger-api/testlib/PlutusLedgerApi/Test/V3/MintValue.hs new file mode 100644 index 00000000000..f8f87b39ad9 --- /dev/null +++ b/plutus-ledger-api/testlib/PlutusLedgerApi/Test/V3/MintValue.hs @@ -0,0 +1,44 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE TypeApplications #-} +{-# OPTIONS_GHC -Wno-orphans #-} + +module PlutusLedgerApi.Test.V3.MintValue where + +import Data.Coerce (coerce) +import PlutusCore.Generators.QuickCheck.Split (multiSplit0) +import PlutusLedgerApi.Test.V1.Value (NoArbitrary (..), uniqueNames) +import PlutusLedgerApi.V1.Value (CurrencySymbol (..), TokenName (..)) +import PlutusLedgerApi.V3.MintValue (MintValue (..)) +import PlutusTx.AssocMap qualified as Map +import PlutusTx.List qualified as List +import Test.QuickCheck (Arbitrary (..)) + +instance Arbitrary MintValue where + arbitrary = do + -- Generate values for all of the 'TokenName's in the final 'MintValue' + -- and split them into a list of lists. + faceValues <- multiSplit0 0.2 . map unQuantity =<< arbitrary + -- Generate 'TokenName's and 'CurrencySymbol's. + currencies <- + uniqueNames CurrencySymbol + =<< traverse (uniqueNames TokenName) faceValues + pure $ listsToMintValue currencies + + shrink = + map listsToMintValue + . coerce + (shrink @[(NoArbitrary CurrencySymbol, [(NoArbitrary TokenName, Integer)])]) + . mintValueToLists + +-- | Convert a list representation of a 'MintValue' to the 'MintValue'. +listsToMintValue :: [(CurrencySymbol, [(TokenName, Integer)])] -> MintValue +listsToMintValue = coerce . Map.unsafeFromList . List.map (fmap Map.unsafeFromList) + +-- | Convert a 'MintValue' to its list representation. +mintValueToLists :: MintValue -> [(CurrencySymbol, [(TokenName, Integer)])] +mintValueToLists = List.map (fmap Map.toList) . Map.toList . coerce + +newtype Quantity = Quantity {unQuantity :: Integer} + deriving newtype (Arbitrary, Show)