New modifiesLedgerTxBody function to aid type inference

IntersectMBO · Oct 20, 2023 · 37ecdc5 · 37ecdc5
1 parent 62acbc3
commit 37ecdc5
Showing 1 changed file with 72 additions and 55 deletions.
diff --git a/cardano-api/internal/Cardano/Api/TxBody.hs b/cardano-api/internal/Cardano/Api/TxBody.hs
@@ -1799,8 +1799,8 @@ instance Error TxBodyError where
     displayError (TxBodyProtocolParamsConversionError ppces) =
       "Errors in protocol parameters conversion: " ++ displayError ppces
 
-createTransactionBody
-  :: forall era. ShelleyBasedEra era
+createTransactionBody :: ()
+  => ShelleyBasedEra era
   -> TxBodyContent BuildTx era
   -> Either TxBodyError (TxBody era)
 createTransactionBody sbe txBodyContent =
@@ -1828,60 +1828,69 @@ createTransactionBody sbe txBodyContent =
         sData = convScriptData sbe apiTxOuts apiScriptWitnesses
 
     setUpdateProposal <-
-      caseShelleyToBabbageOrConwayEraOnwards
-        (\w -> do
-            update <- convTxUpdateProposal sbe (txUpdateProposal txBodyContent)
-            pure $ L.apiUpdateTxBodyL w .~ update)
-        (const $ pure id)
-        sbe
+      modifiesLedgerTxBody sbe $
+        caseShelleyToBabbageOrConwayEraOnwards
+          (\w -> do
+              update <- convTxUpdateProposal sbe (txUpdateProposal txBodyContent)
+              pure $ L.apiUpdateTxBodyL w .~ update)
+          (const $ pure id)
+          sbe
 
-    let setInvalidBefore =
-          caseShelleyEraOnlyOrAllegraEraOnwards
-            (const id)
-            (\aOn -> L.invalidBeforeTxBodyL aOn .~ convValidityLowerBound (txValidityLowerBound txBodyContent))
-            sbe
-
-    let setMint =
-          caseShelleyToAllegraOrMaryEraOnwards
-            (const id)
-            (const $ L.mintTxBodyL .~ convMintValue apiMintValue)
-            sbe
-
-    let setScriptIntegrityHash = id @(Ledger.TxBody (ShelleyLedgerEra era) -> Ledger.TxBody (ShelleyLedgerEra era)) $
-          caseShelleyToMaryOrAlonzoEraOnwards
-            (const id)
-            (const $ L.scriptIntegrityHashTxBodyL .~ getScriptIntegrityHash apiProtocolParameters languages sData)
-            sbe
-
-    let setCollateralInputs =
-          caseShelleyToMaryOrAlonzoEraOnwards
-            (const id)
-            (const $ L.collateralInputsTxBodyL .~ collTxIns)
-            sbe
-
-    let setReqSignerHashes = id @(Ledger.TxBody (ShelleyLedgerEra era) -> Ledger.TxBody (ShelleyLedgerEra era)) $
-          caseShelleyToMaryOrAlonzoEraOnwards
-            (const id)
-            (const $ L.reqSignerHashesTxBodyL .~ convExtraKeyWitnesses apiExtraKeyWitnesses)
-            sbe
-
-    let setReferenceInputs =
-          caseShelleyToAlonzoOrBabbageEraOnwards
-            (const id)
-            (const $ L.referenceInputsTxBodyL .~ refTxIns)
-            sbe
-
-    let setCollateralReturn = id @(Ledger.TxBody (ShelleyLedgerEra era) -> Ledger.TxBody (ShelleyLedgerEra era)) $
-          caseShelleyToAlonzoOrBabbageEraOnwards
-            (const id)
-            (const $ L.collateralReturnTxBodyL .~ returnCollateral)
-            sbe
-
-    let setTotalCollateral =
-          caseShelleyToAlonzoOrBabbageEraOnwards
-            (const id)
-            (const $ L.totalCollateralTxBodyL .~ totalCollateral)
-            sbe
+    setInvalidBefore <-
+      modifiesLedgerTxBody sbe $ pure $
+        caseShelleyEraOnlyOrAllegraEraOnwards
+          (const id)
+          (\aOn -> L.invalidBeforeTxBodyL aOn .~ convValidityLowerBound (txValidityLowerBound txBodyContent))
+          sbe
+
+    setMint <-
+      modifiesLedgerTxBody sbe $ pure $
+        caseShelleyToAllegraOrMaryEraOnwards
+          (const id)
+          (const $ L.mintTxBodyL .~ convMintValue apiMintValue)
+          sbe
+
+    setScriptIntegrityHash <-
+      modifiesLedgerTxBody sbe $ pure $
+        caseShelleyToMaryOrAlonzoEraOnwards
+          (const id)
+          (const $ L.scriptIntegrityHashTxBodyL .~ getScriptIntegrityHash apiProtocolParameters languages sData)
+          sbe
+
+    setCollateralInputs <-
+      modifiesLedgerTxBody sbe $ pure $
+        caseShelleyToMaryOrAlonzoEraOnwards
+          (const id)
+          (const $ L.collateralInputsTxBodyL .~ collTxIns)
+          sbe
+
+    setReqSignerHashes <-
+      modifiesLedgerTxBody sbe $ pure $
+        caseShelleyToMaryOrAlonzoEraOnwards
+          (const id)
+          (const $ L.reqSignerHashesTxBodyL .~ convExtraKeyWitnesses apiExtraKeyWitnesses)
+          sbe
+
+    setReferenceInputs <-
+      modifiesLedgerTxBody sbe $ pure $
+        caseShelleyToAlonzoOrBabbageEraOnwards
+          (const id)
+          (const $ L.referenceInputsTxBodyL .~ refTxIns)
+          sbe
+
+    setCollateralReturn <-
+      modifiesLedgerTxBody sbe $ pure $
+        caseShelleyToAlonzoOrBabbageEraOnwards
+          (const id)
+          (const $ L.collateralReturnTxBodyL .~ returnCollateral)
+          sbe
+
+    setTotalCollateral <-
+      modifiesLedgerTxBody sbe $ pure $
+        caseShelleyToAlonzoOrBabbageEraOnwards
+          (const id)
+          (const $ L.totalCollateralTxBodyL .~ totalCollateral)
+          sbe
 
     let mkTxBody :: ()
           => ShelleyBasedEra era
@@ -1915,6 +1924,14 @@ createTransactionBody sbe txBodyContent =
 
     pure $ ShelleyTxBody sbe ledgerTxBody scripts sData txAuxData apiScriptValidity
 
+-- | Aids type inference.  Use this function to ensure the return value is a function
+-- that modifies a ledger txbody.
+modifiesLedgerTxBody :: ()
+  => ShelleyBasedEra era
+  -> f (Ledger.TxBody (ShelleyLedgerEra era) -> Ledger.TxBody (ShelleyLedgerEra era))
+  -> f (Ledger.TxBody (ShelleyLedgerEra era) -> Ledger.TxBody (ShelleyLedgerEra era))
+modifiesLedgerTxBody _ = id
+
 getScriptIntegrityHash :: ()
   => BuildTxWith BuildTx (Maybe (LedgerProtocolParameters era))
   -> Set Alonzo.Language