Merge pull request #663 from IntersectMBO/mgalazyn/feature/refactor-t…

…xmintvalue

Refactor `TxMintValue`

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
@@ -1320,10 +1321,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
@@ -1593,33 +1592,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

@@ -4,6 +4,7 @@
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE GADTs #-}
 {-# LANGUAGE InstanceSigs #-}
+{-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE PatternSynonyms #-}
@@ -47,25 +48,27 @@ module Cardano.Api.Script
     -- * Reference scripts
   , ReferenceScript (..)
   , refScriptToShelleyScript
-  , getScriptWitnessReferenceInput
 
     -- * Use of a script in an era as a witness
   , WitCtxTxIn
   , WitCtxMint
   , WitCtxStake
   , WitCtx (..)
   , ScriptWitness (..)
+  , getScriptWitnessReferenceInput
+  , getScriptWitnessScript
+  , getScriptWitnessReferenceInputOrScript
   , Witness (..)
   , KeyWitnessInCtx (..)
   , ScriptWitnessInCtx (..)
   , IsScriptWitnessInCtx (..)
   , ScriptDatum (..)
   , ScriptRedeemer
-  , scriptWitnessScript
 
     -- ** Languages supported in each era
   , ScriptLanguageInEra (..)
   , scriptLanguageSupportedInEra
+  , sbeToSimpleScriptLanguageInEra
   , languageOfScriptLanguageInEra
   , eraOfScriptLanguageInEra
 
@@ -228,7 +231,8 @@ instance HasTypeProxy PlutusScriptV3 where
 --
 data ScriptLanguage lang where
   SimpleScriptLanguage :: ScriptLanguage SimpleScript'
-  PlutusScriptLanguage :: PlutusScriptVersion lang -> ScriptLanguage lang
+  PlutusScriptLanguage
+    :: IsPlutusScriptLanguage lang => PlutusScriptVersion lang -> ScriptLanguage lang
 
 deriving instance (Eq (ScriptLanguage lang))
 
@@ -285,7 +289,8 @@ instance Bounded AnyScriptLanguage where
 
 data AnyPlutusScriptVersion where
   AnyPlutusScriptVersion
-    :: PlutusScriptVersion lang
+    :: IsPlutusScriptLanguage lang
+    => PlutusScriptVersion lang
     -> AnyPlutusScriptVersion
 
 deriving instance (Show AnyPlutusScriptVersion)
@@ -407,7 +412,8 @@ data Script lang where
     :: !SimpleScript
     -> Script SimpleScript'
   PlutusScript
-    :: !(PlutusScriptVersion lang)
+    :: IsPlutusScriptLanguage lang
+    => !(PlutusScriptVersion lang)
     -> !(PlutusScript lang)
     -> Script lang
 
@@ -576,18 +582,8 @@ scriptLanguageSupportedInEra
   -> Maybe (ScriptLanguageInEra lang era)
 scriptLanguageSupportedInEra era lang =
   case (era, lang) of
-    (ShelleyBasedEraShelley, SimpleScriptLanguage) ->
-      Just SimpleScriptInShelley
-    (ShelleyBasedEraAllegra, SimpleScriptLanguage) ->
-      Just SimpleScriptInAllegra
-    (ShelleyBasedEraMary, SimpleScriptLanguage) ->
-      Just SimpleScriptInMary
-    (ShelleyBasedEraAlonzo, SimpleScriptLanguage) ->
-      Just SimpleScriptInAlonzo
-    (ShelleyBasedEraBabbage, SimpleScriptLanguage) ->
-      Just SimpleScriptInBabbage
-    (ShelleyBasedEraConway, SimpleScriptLanguage) ->
-      Just SimpleScriptInConway
+    (sbe, SimpleScriptLanguage) ->
+      Just $ sbeToSimpleScriptLanguageInEra sbe
     (ShelleyBasedEraAlonzo, PlutusScriptLanguage PlutusScriptV1) ->
       Just PlutusScriptV1InAlonzo
     (ShelleyBasedEraBabbage, PlutusScriptLanguage PlutusScriptV1) ->
@@ -620,23 +616,33 @@ languageOfScriptLanguageInEra langInEra =
     PlutusScriptV2InConway -> PlutusScriptLanguage PlutusScriptV2
     PlutusScriptV3InConway -> PlutusScriptLanguage PlutusScriptV3
 
+sbeToSimpleScriptLanguageInEra
+  :: ShelleyBasedEra era
+  -> ScriptLanguageInEra SimpleScript' era
+sbeToSimpleScriptLanguageInEra = \case
+  ShelleyBasedEraShelley -> SimpleScriptInShelley
+  ShelleyBasedEraAllegra -> SimpleScriptInAllegra
+  ShelleyBasedEraMary -> SimpleScriptInMary
+  ShelleyBasedEraAlonzo -> SimpleScriptInAlonzo
+  ShelleyBasedEraBabbage -> SimpleScriptInBabbage
+  ShelleyBasedEraConway -> SimpleScriptInConway
+
 eraOfScriptLanguageInEra
   :: ScriptLanguageInEra lang era
   -> ShelleyBasedEra era
-eraOfScriptLanguageInEra langInEra =
-  case langInEra of
-    SimpleScriptInShelley -> ShelleyBasedEraShelley
-    SimpleScriptInAllegra -> ShelleyBasedEraAllegra
-    SimpleScriptInMary -> ShelleyBasedEraMary
-    SimpleScriptInAlonzo -> ShelleyBasedEraAlonzo
-    SimpleScriptInBabbage -> ShelleyBasedEraBabbage
-    SimpleScriptInConway -> ShelleyBasedEraConway
-    PlutusScriptV1InAlonzo -> ShelleyBasedEraAlonzo
-    PlutusScriptV1InBabbage -> ShelleyBasedEraBabbage
-    PlutusScriptV1InConway -> ShelleyBasedEraConway
-    PlutusScriptV2InBabbage -> ShelleyBasedEraBabbage
-    PlutusScriptV2InConway -> ShelleyBasedEraConway
-    PlutusScriptV3InConway -> ShelleyBasedEraConway
+eraOfScriptLanguageInEra = \case
+  SimpleScriptInShelley -> ShelleyBasedEraShelley
+  SimpleScriptInAllegra -> ShelleyBasedEraAllegra
+  SimpleScriptInMary -> ShelleyBasedEraMary
+  SimpleScriptInAlonzo -> ShelleyBasedEraAlonzo
+  SimpleScriptInBabbage -> ShelleyBasedEraBabbage
+  SimpleScriptInConway -> ShelleyBasedEraConway
+  PlutusScriptV1InAlonzo -> ShelleyBasedEraAlonzo
+  PlutusScriptV1InBabbage -> ShelleyBasedEraBabbage
+  PlutusScriptV1InConway -> ShelleyBasedEraConway
+  PlutusScriptV2InBabbage -> ShelleyBasedEraBabbage
+  PlutusScriptV2InConway -> ShelleyBasedEraConway
+  PlutusScriptV3InConway -> ShelleyBasedEraConway
 
 -- | Given a target era and a script in some language, check if the language is
 -- supported in that era, and if so return a 'ScriptInEra'.
@@ -682,27 +688,14 @@ data WitCtx witctx where
 -- or to mint tokens. This datatype encapsulates this concept.
 data PlutusScriptOrReferenceInput lang
   = PScript (PlutusScript 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 _)) =
-  Just txIn
-getScriptWitnessReferenceInput (PlutusScriptWitness _ _ (PReferenceScript txIn _) _ _ _) =
-  Just txIn
-getScriptWitnessReferenceInput (SimpleScriptWitness _ (SScript _)) = Nothing
-getScriptWitnessReferenceInput (PlutusScriptWitness _ _ (PScript _) _ _ _) = Nothing
-
 -- | A /use/ of a script within a transaction body to witness that something is
 -- being used in an authorised manner. That can be
 --
@@ -721,7 +714,8 @@ data ScriptWitness witctx era where
     -> SimpleScriptOrReferenceInput SimpleScript'
     -> ScriptWitness witctx era
   PlutusScriptWitness
-    :: ScriptLanguageInEra lang era
+    :: IsPlutusScriptLanguage lang
+    => ScriptLanguageInEra lang era
     -> PlutusScriptVersion lang
     -> PlutusScriptOrReferenceInput lang
     -> ScriptDatum witctx
@@ -782,28 +776,26 @@ deriving instance Eq (ScriptDatum witctx)
 
 deriving instance Show (ScriptDatum witctx)
 
--- We cannot always extract a script from a script witness due to reference scripts.
+getScriptWitnessReferenceInput :: ScriptWitness witctx era -> Maybe TxIn
+getScriptWitnessReferenceInput = either (const Nothing) Just . getScriptWitnessReferenceInputOrScript
+
+getScriptWitnessScript :: ScriptWitness witctx era -> Maybe (ScriptInEra era)
+getScriptWitnessScript = either Just (const Nothing) . getScriptWitnessReferenceInputOrScript
+
+-- | We cannot always extract a script from a script witness due to reference scripts.
 -- Reference scripts exist in the UTxO, so without access to the UTxO we cannot
 -- retrieve the script.
-scriptWitnessScript :: ScriptWitness witctx era -> Maybe (ScriptInEra era)
-scriptWitnessScript (SimpleScriptWitness SimpleScriptInShelley (SScript script)) =
-  Just $ ScriptInEra SimpleScriptInShelley (SimpleScript script)
-scriptWitnessScript (SimpleScriptWitness SimpleScriptInAllegra (SScript script)) =
-  Just $ ScriptInEra SimpleScriptInAllegra (SimpleScript script)
-scriptWitnessScript (SimpleScriptWitness SimpleScriptInMary (SScript script)) =
-  Just $ ScriptInEra SimpleScriptInMary (SimpleScript script)
-scriptWitnessScript (SimpleScriptWitness SimpleScriptInAlonzo (SScript script)) =
-  Just $ ScriptInEra SimpleScriptInAlonzo (SimpleScript script)
-scriptWitnessScript (SimpleScriptWitness SimpleScriptInBabbage (SScript script)) =
-  Just $ ScriptInEra SimpleScriptInBabbage (SimpleScript script)
-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 _ _)) =
-  Nothing
-scriptWitnessScript (PlutusScriptWitness _ _ (PReferenceScript _ _) _ _ _) =
-  Nothing
+-- So in the cases for script reference, the result contains @Right TxIn@.
+getScriptWitnessReferenceInputOrScript :: ScriptWitness witctx era -> Either (ScriptInEra era) TxIn
+getScriptWitnessReferenceInputOrScript = \case
+  SimpleScriptWitness (s :: (ScriptLanguageInEra SimpleScript' era)) (SScript script) ->
+    Left $ ScriptInEra s (SimpleScript script)
+  PlutusScriptWitness langInEra version (PScript script) _ _ _ ->
+    Left $ ScriptInEra langInEra (PlutusScript version script)
+  SimpleScriptWitness _ (SReferenceScript txIn) ->
+    Right txIn
+  PlutusScriptWitness _ _ (PReferenceScript txIn) _ _ _ ->
+    Right txIn
 
 -- ----------------------------------------------------------------------------
 -- The kind of witness to use, key (signature) or script