MintValue (IntersectMBO#6609)

* MintValue * Test properties of MintValue
mlabs-haskell · Oct 31, 2024 · 373de94 · 373de94
1 parent 9a38bd7
commit 373de94
Show file tree

Hide file tree

Showing 21 changed files with 292 additions and 39 deletions.
diff --git 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
@@ -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
@@ -1,2 +1,2 @@
-({cpu: 11100264187581
-| mem: 11100001066437})
+({cpu: 11100263419581
+| mem: 11100001061637})
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
@@ -1,2 +1,2 @@
-({cpu: 3100079463709
-| mem: 3100000324645})
+({cpu: 3100079207709
+| mem: 3100000323045})
diff --git 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
@@ -1 +1 @@
-3221
+3218
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
@@ -1,2 +1,2 @@
-({cpu: 11100253887109
-| mem: 11100001016294})
+({cpu: 11100253119109
+| mem: 11100001011494})
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
@@ -1,2 +1,2 @@
-({cpu: 3100076414565
-| mem: 3100000309734})
+({cpu: 3100076158565
+| mem: 3100000308134})
diff --git 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
@@ -1 +1 @@
-3157
+3154
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
@@ -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
@@ -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
@@ -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
@@ -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
@@ -58,23 +58,23 @@ 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
 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
@@ -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
@@ -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 =