Refactor TxMintValue to better represent minting state

cardano-api/gen/Test/Gen/Cardano/Api/Typed.hs

@@ -662,11 +662,18 @@ genTxMintValue :: CardanoEra era -> Gen (TxMintValue BuildTx era)
 genTxMintValue =
   inEonForEra
     (pure TxMintNone)
-    $ \supported ->
+    $ \w -> do
+      policies <- Gen.list (Range.constant 1 3) genPolicyId
+      assets <- forM policies $ \policy ->
+        (,) policy <$>
+          Gen.list
+            (Range.constant 1 3)
+            ((,,) <$> genAssetName
+                  <*> genPositiveQuantity
+                  <*> fmap (fmap pure) genScriptWitnessForMint (maryEraOnwardsToShelleyBasedEra w))
       Gen.choice
         [ pure TxMintNone
-        -- TODO write a generator for the last parameter of 'TxMintValue' constructor
-        , TxMintValue supported <$> genValueForMinting <*> return (pure mempty)
+        , pure $ TxMintValue w (fromList assets)
         ]
 
 genTxBodyContent :: ShelleyBasedEra era -> Gen (TxBodyContent BuildTx era)
@@ -1196,13 +1203,13 @@ genScriptWitnessForStake sbe = do
     SimpleScript simpleScript -> do
       simpleScriptOrReferenceInput <- Gen.choice
         [ pure $ SScript simpleScript
-        , SReferenceScript <$> genTxIn <*> Gen.maybe genScriptHash
+        , SReferenceScript <$> genTxIn
         ]
       pure $ Api.SimpleScriptWitness scriptLangInEra simpleScriptOrReferenceInput
     PlutusScript plutusScriptVersion' plutusScript -> do
       plutusScriptOrReferenceInput <- Gen.choice
         [ pure $ PScript plutusScript
-        , PReferenceScript <$> genTxIn <*> Gen.maybe genScriptHash
+        , PReferenceScript <$> genTxIn
         ]
       scriptRedeemer <- genHashableScriptData
       PlutusScriptWitness
@@ -1213,6 +1220,27 @@ genScriptWitnessForStake sbe = do
         scriptRedeemer
         <$> genExecutionUnits
 
-
-
+genScriptWitnessForMint :: ShelleyBasedEra era -> Gen (Api.ScriptWitness WitCtxMint era)
+genScriptWitnessForMint sbe = do
+  ScriptInEra scriptLangInEra script' <- genScriptInEra sbe
+  case script' of
+    SimpleScript simpleScript -> do
+      simpleScriptOrReferenceInput <- Gen.choice
+        [ pure $ SScript simpleScript
+        , SReferenceScript <$> genTxIn
+        ]
+      pure $ Api.SimpleScriptWitness scriptLangInEra simpleScriptOrReferenceInput
+    PlutusScript plutusScriptVersion' plutusScript -> do
+      plutusScriptOrReferenceInput <- Gen.choice
+        [ pure $ PScript plutusScript
+        , PReferenceScript <$> genTxIn
+        ]
+      scriptRedeemer <- genHashableScriptData
+      PlutusScriptWitness
+        scriptLangInEra
+        plutusScriptVersion'
+        plutusScriptOrReferenceInput
+        NoScriptDatumForMint
+        scriptRedeemer
+        <$> genExecutionUnits
 

cardano-api/internal/Cardano/Api/Fees.hs

@@ -8,6 +8,7 @@
 {-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE TupleSections #-}
 
 -- | Fee calculation
 module Cardano.Api.Fees
@@ -1325,10 +1326,8 @@ calculateChangeValue
   :: ShelleyBasedEra era -> Value -> TxBodyContent build era -> Value
 calculateChangeValue sbe incoming txbodycontent =
   let outgoing = calculateCreatedUTOValue sbe txbodycontent
-      minted = case txMintValue txbodycontent of
-        TxMintNone -> mempty
-        TxMintValue _ v _ -> v
-   in mconcat [incoming, minted, negateValue outgoing]
+      mintedValue = txMintValueToValue $ txMintValue txbodycontent
+   in mconcat [incoming, mintedValue, negateValue outgoing]
 
 -- | This is used in the balance calculation in the event where
 -- the user does not supply the UTxO(s) they intend to spend
@@ -1598,33 +1597,20 @@ substituteExecutionUnits
       :: TxMintValue BuildTx era
       -> Either (TxBodyErrorAutoBalance era) (TxMintValue BuildTx era)
     mapScriptWitnessesMinting TxMintNone = Right TxMintNone
-    mapScriptWitnessesMinting
-      ( TxMintValue
-          supported
-          value
-          (BuildTxWith witnesses)
-        ) =
-        -- TxMintValue supported value $ BuildTxWith $ fromList
-        let mappedScriptWitnesses
-              :: [(PolicyId, Either (TxBodyErrorAutoBalance era) (ScriptWitness WitCtxMint era))]
-            mappedScriptWitnesses =
-              [ (policyid, witness')
-              | -- The minting policies are indexed in policy id order in the value
-              let ValueNestedRep bundle = valueToNestedRep value
-              , (ix, ValueNestedBundle policyid _) <- zip [0 ..] bundle
-              , witness <- maybeToList (Map.lookup policyid witnesses)
-              , let witness' = substituteExecUnits (ScriptWitnessIndexMint ix) witness
-              ]
-         in do
-              final <- traverseScriptWitnesses mappedScriptWitnesses
-              Right . TxMintValue supported value . BuildTxWith $
-                fromList final
+    mapScriptWitnessesMinting txMintValue'@(TxMintValue w _) = do
+      let mappedScriptWitnesses =
+            [ (policyId, pure . (assetName',quantity,) <$> substitutedWitness)
+            | (ix, policyId, assetName', quantity, BuildTxWith witness) <- txMintValueToIndexed txMintValue'
+            , let substitutedWitness = BuildTxWith <$> substituteExecUnits ix witness
+            ]
+      final <- Map.fromListWith (<>) <$> traverseScriptWitnesses mappedScriptWitnesses
+      pure $ TxMintValue w final
 
 traverseScriptWitnesses
-  :: [(a, Either (TxBodyErrorAutoBalance era) (ScriptWitness ctx era))]
-  -> Either (TxBodyErrorAutoBalance era) [(a, ScriptWitness ctx era)]
+  :: [(a, Either (TxBodyErrorAutoBalance era) b)]
+  -> Either (TxBodyErrorAutoBalance era) [(a, b)]
 traverseScriptWitnesses =
-  traverse (\(item, eScriptWitness) -> eScriptWitness >>= (\sWit -> Right (item, sWit)))
+  traverse (\(item, eRes) -> eRes >>= (\res -> Right (item, res)))
 
 calculateMinimumUTxO
   :: ShelleyBasedEra era

cardano-api/internal/Cardano/Api/Script.hs

@@ -54,6 +54,7 @@ module Cardano.Api.Script
   , WitCtxMint
   , WitCtxStake
   , WitCtx (..)
+  , WitCtxMaybe (..)
   , ScriptWitness (..)
   , Witness (..)
   , KeyWitnessInCtx (..)
@@ -165,7 +166,7 @@ import           Data.String (IsString)
 import           Data.Text (Text)
 import qualified Data.Text as Text
 import qualified Data.Text.Encoding as Text
-import           Data.Type.Equality (TestEquality (..), (:~:) (Refl))
+import           Data.Type.Equality (TestEquality (..), type (==), (:~:) (Refl))
 import           Data.Typeable (Typeable)
 import           Data.Vector (Vector)
 import           GHC.Exts (IsList (..))
@@ -679,6 +680,17 @@ data WitCtx witctx where
   WitCtxMint :: WitCtx WitCtxMint
   WitCtxStake :: WitCtx WitCtxStake
 
+-- TODO: not needed anymore - remove
+
+-- | A typed version of a 'Maybe'. Allows to store value of type @a@ when @purpose ~ witctx@, otherwise it is empty.
+data WitCtxMaybe purpose witctx a where
+  WitCtxJust :: WitCtx purpose -> a -> WitCtxMaybe purpose purpose a
+  WitCtxNothing :: (purpose == witctx) ~ False => WitCtxMaybe purpose witctx a
+
+instance Show a => Show (WitCtxMaybe p w a) where
+  show (WitCtxJust _ a) = "WitCtxJust " <> show a
+  show WitCtxNothing = "WitCtxNothing"
+
 -- | Scripts can now exist in the UTxO at a transaction output. We can
 -- reference these scripts via specification of a reference transaction input
 -- in order to witness spending inputs, withdrawals, certificates
@@ -688,20 +700,18 @@ data PlutusScriptOrReferenceInput lang
   | -- | Needed to construct the redeemer pointer map
     -- in the case of minting reference scripts where we don't
     -- have direct access to the script
-    PReferenceScript
-      TxIn
-      (Maybe ScriptHash)
+    PReferenceScript TxIn
   deriving (Eq, Show)
 
 data SimpleScriptOrReferenceInput lang
   = SScript SimpleScript
-  | SReferenceScript TxIn (Maybe ScriptHash)
+  | SReferenceScript TxIn
   deriving (Eq, Show)
 
 getScriptWitnessReferenceInput :: ScriptWitness witctx era -> Maybe TxIn
-getScriptWitnessReferenceInput (SimpleScriptWitness _ (SReferenceScript txIn _)) =
+getScriptWitnessReferenceInput (SimpleScriptWitness _ (SReferenceScript txIn)) =
   Just txIn
-getScriptWitnessReferenceInput (PlutusScriptWitness _ _ (PReferenceScript txIn _) _ _ _) =
+getScriptWitnessReferenceInput (PlutusScriptWitness _ _ (PReferenceScript txIn) _ _ _) =
   Just txIn
 getScriptWitnessReferenceInput (SimpleScriptWitness _ (SScript _)) = Nothing
 getScriptWitnessReferenceInput (PlutusScriptWitness _ _ (PScript _) _ _ _) = Nothing
@@ -804,9 +814,9 @@ scriptWitnessScript (SimpleScriptWitness SimpleScriptInConway (SScript script))
   Just $ ScriptInEra SimpleScriptInConway (SimpleScript script)
 scriptWitnessScript (PlutusScriptWitness langInEra version (PScript script) _ _ _) =
   Just $ ScriptInEra langInEra (PlutusScript version script)
-scriptWitnessScript (SimpleScriptWitness _ (SReferenceScript _ _)) =
+scriptWitnessScript (SimpleScriptWitness _ (SReferenceScript _)) =
   Nothing
-scriptWitnessScript (PlutusScriptWitness _ _ (PReferenceScript _ _) _ _ _) =
+scriptWitnessScript (PlutusScriptWitness _ _ (PReferenceScript _) _ _ _) =
   Nothing
 
 -- ----------------------------------------------------------------------------

cardano-api/internal/Cardano/Api/Tx/Body.hs

@@ -111,6 +111,8 @@ module Cardano.Api.Tx.Body
   , TxCertificates (..)
   , TxUpdateProposal (..)
   , TxMintValue (..)
+  , txMintValueToValue
+  , txMintValueToIndexed
   , TxVotingProcedures (..)
   , mkTxVotingProcedures
   , TxProposalProcedures (..)
@@ -1248,16 +1250,46 @@ data TxMintValue build era where
   TxMintNone :: TxMintValue build era
   TxMintValue
     :: MaryEraOnwards era
-    -> Value
-    -> BuildTxWith
-        build
-        (Map PolicyId (ScriptWitness WitCtxMint era))
+    -> Map
+        PolicyId
+        [ ( AssetName
+          , Quantity
+          , BuildTxWith build (ScriptWitness WitCtxMint era)
+          )
+        ]
     -> TxMintValue build era
 
 deriving instance Eq (TxMintValue build era)
 
 deriving instance Show (TxMintValue build era)
 
+-- | Convert 'TxMintValue' to a more handy 'Value'.
+txMintValueToValue :: TxMintValue build era -> Value
+txMintValueToValue TxMintNone = mempty
+txMintValueToValue (TxMintValue _ policiesWithAssets) =
+  fromList
+    [ (AssetId policyId' assetName', quantity)
+    | (policyId', assets) <- toList policiesWithAssets
+    , (assetName', quantity, _) <- assets
+    ]
+
+-- | Index the assets with witnesses in the order of policy ids.
+txMintValueToIndexed
+  :: TxMintValue build era
+  -> [ ( ScriptWitnessIndex
+       , PolicyId
+       , AssetName
+       , Quantity
+       , BuildTxWith build (ScriptWitness WitCtxMint era)
+       )
+     ]
+txMintValueToIndexed TxMintNone = []
+txMintValueToIndexed (TxMintValue _ policiesWithAssets) =
+  [ (ScriptWitnessIndexMint ix, policyId', assetName', quantity, witness)
+  | (ix, (policyId', assets)) <- zip [0 ..] $ toList policiesWithAssets
+  , (assetName', quantity, witness) <- assets
+  ]
+
 -- ----------------------------------------------------------------------------
 -- Votes within transactions (era-dependent)
 --
@@ -1555,7 +1587,7 @@ data TxBodyError
   | TxBodyOutputNegative !Quantity !TxOutInAnyEra
   | TxBodyOutputOverflow !Quantity !TxOutInAnyEra
   | TxBodyMetadataError ![(Word64, TxMetadataRangeError)]
-  | TxBodyMintAdaError
+  | TxBodyMintAdaError -- TODO remove - case nonexistent
   | TxBodyInIxOverflow !TxIn
   | TxBodyMissingProtocolParams
   | TxBodyProtocolParamsConversionError !ProtocolParametersConversionError
@@ -1824,11 +1856,9 @@ validateTxOuts sbe txOuts = do
       | txout@(TxOut _ v _ _) <- txOuts
       ]
 
+-- TODO remove
 validateMintValue :: TxMintValue build era -> Either TxBodyError ()
-validateMintValue txMintValue =
-  case txMintValue of
-    TxMintNone -> return ()
-    TxMintValue _ v _ -> guard (selectLovelace v == 0) ?! TxBodyMintAdaError
+validateMintValue _txMintValue = pure ()
 
 inputIndexDoesNotExceedMax :: [(TxIn, a)] -> Either TxBodyError ()
 inputIndexDoesNotExceedMax txIns =
@@ -2285,20 +2315,20 @@ fromLedgerTxMintValue
   :: ShelleyBasedEra era
   -> Ledger.TxBody (ShelleyLedgerEra era)
   -> TxMintValue ViewTx era
-fromLedgerTxMintValue sbe body =
-  case sbe of
-    ShelleyBasedEraShelley -> TxMintNone
-    ShelleyBasedEraAllegra -> TxMintNone
-    ShelleyBasedEraMary -> toMintValue body MaryEraOnwardsMary
-    ShelleyBasedEraAlonzo -> toMintValue body MaryEraOnwardsAlonzo
-    ShelleyBasedEraBabbage -> toMintValue body MaryEraOnwardsBabbage
-    ShelleyBasedEraConway -> toMintValue body MaryEraOnwardsConway
- where
-  toMintValue txBody maInEra
-    | L.isZero mint = TxMintNone
-    | otherwise = TxMintValue maInEra (fromMaryValue mint) ViewTx
-   where
-    mint = MaryValue (Ledger.Coin 0) (txBody ^. L.mintTxBodyL)
+fromLedgerTxMintValue sbe body = forEraInEon (toCardanoEra sbe) TxMintNone $ \w ->
+  maryEraOnwardsConstraints w $ do
+    let mint = MaryValue (Ledger.Coin 0) (body ^. L.mintTxBodyL)
+    if L.isZero mint
+      then TxMintNone
+      else do
+        let assetMap = toList $ fromMaryValue mint
+        TxMintValue w $
+          Map.fromListWith
+            (<>)
+            [ (policyId', [(assetName', quantity, ViewTx)])
+            | -- only non-ada can be here
+            (AssetId policyId' assetName', quantity) <- toList assetMap
+            ]
 
 makeByronTransactionBody
   :: ()
@@ -2412,12 +2442,9 @@ convTxUpdateProposal sbe = \case
   TxUpdateProposal _ p -> bimap TxBodyProtocolParamsConversionError pure $ toLedgerUpdate sbe p
 
 convMintValue :: TxMintValue build era -> MultiAsset StandardCrypto
-convMintValue txMintValue =
-  case txMintValue of
-    TxMintNone -> mempty
-    TxMintValue _ v _ ->
-      case toMaryValue v of
-        MaryValue _ ma -> ma
+convMintValue txMintValue = do
+  let L.MaryValue _coin multiAsset = toMaryValue $ txMintValueToValue txMintValue
+  multiAsset
 
 convExtraKeyWitnesses
   :: TxExtraKeyWitnesses era -> Set (Shelley.KeyHash Shelley.Witness StandardCrypto)
@@ -3328,12 +3355,9 @@ collectTxBodyScriptWitnesses
       :: TxMintValue BuildTx era
       -> [(ScriptWitnessIndex, AnyScriptWitness era)]
     scriptWitnessesMinting TxMintNone = []
-    scriptWitnessesMinting (TxMintValue _ value (BuildTxWith witnesses)) =
-      [ (ScriptWitnessIndexMint ix, AnyScriptWitness witness)
-      | -- The minting policies are indexed in policy id order in the value
-      let ValueNestedRep bundle = valueToNestedRep value
-      , (ix, ValueNestedBundle policyid _) <- zip [0 ..] bundle
-      , witness <- maybeToList (Map.lookup policyid witnesses)
+    scriptWitnessesMinting txMintValue' =
+      [ (ix, AnyScriptWitness witness)
+      | (ix, _, _, _, BuildTxWith witness) <- txMintValueToIndexed txMintValue'
       ]
 
     scriptWitnessesVoting

cardano-api/internal/Cardano/Api/Value.hs

@@ -328,6 +328,7 @@ calcMinimumDeposit v =
 -- ----------------------------------------------------------------------------
 -- An alternative nested representation
 --
+-- TODO remove ? - it is now unused
 
 -- | An alternative nested representation for 'Value' that groups assets that
 -- share a 'PolicyId'.
@@ -358,7 +359,7 @@ valueToNestedRep v =
 
 valueFromNestedRep :: ValueNestedRep -> Value
 valueFromNestedRep (ValueNestedRep bundles) =
-  valueFromList
+  fromList
     [ (aId, q)
     | bundle <- bundles
     , (aId, q) <- case bundle of

cardano-api/src/Cardano/Api.hs

@@ -368,6 +368,8 @@ module Cardano.Api
   , TxCertificates (..)
   , TxUpdateProposal (..)
   , TxMintValue (..)
+  , txMintValueToValue
+  , txMintValueToIndexed
   , TxVotingProcedures (..)
   , mkTxVotingProcedures
   , TxProposalProcedures (..)
@@ -535,6 +537,7 @@ module Cardano.Api
   , WitCtxMint
   , WitCtxStake
   , WitCtx (..)
+  , WitCtxMaybe (..)
   , ScriptWitness (..)
   , Witness (..)
   , KeyWitnessInCtx (..)