Merge pull request #310 from input-output-hk/newhoggy/fewer-constrain…

…ts-in-functions Fewer constraints in functions
IntersectMBO · Oct 11, 2023 · 20a58e1 · 20a58e1
2 parents 38b33a3 + 78fa0d9
commit 20a58e1
Show file tree

Hide file tree

Showing 8 changed files with 232 additions and 302 deletions.
diff --git a/cardano-api/cardano-api.cabal b/cardano-api/cardano-api.cabal
@@ -169,6 +169,7 @@ library internal
                       , deepseq
                       , directory
                       , either
+                      , errors
                       , filepath
                       , formatting
                       , iproute

diff --git a/cardano-api/internal/Cardano/Api/Certificate.hs b/cardano-api/internal/Cardano/Api/Certificate.hs
@@ -252,76 +252,29 @@ data StakeAddressRequirements era where
     -> StakeCredential
     -> StakeAddressRequirements era
 
-
 makeStakeAddressRegistrationCertificate :: StakeAddressRequirements era -> Certificate era
-makeStakeAddressRegistrationCertificate req =
-  case req of
-    StakeAddrRegistrationPreConway atMostEra scred ->
-      shelleyToBabbageEraConstraints atMostEra
-        $ makeStakeAddressRegistrationCertificatePreConway atMostEra scred
-    StakeAddrRegistrationConway cOnwards ll scred ->
-      conwayEraOnwardsConstraints cOnwards
-        $ makeStakeAddressRegistrationCertificatePostConway cOnwards scred ll
- where
-  makeStakeAddressRegistrationCertificatePreConway :: ()
-    => EraCrypto (ShelleyLedgerEra era) ~ StandardCrypto
-    => Ledger.ShelleyEraTxCert (ShelleyLedgerEra era)
-    => Ledger.TxCert (ShelleyLedgerEra era) ~ Ledger.ShelleyTxCert (ShelleyLedgerEra era)
-    => ShelleyToBabbageEra era
-    -> StakeCredential
-    -> Certificate era
-  makeStakeAddressRegistrationCertificatePreConway atMostBabbage scred =
-    ShelleyRelatedCertificate atMostBabbage $ Ledger.mkRegTxCert $ toShelleyStakeCredential scred
-
-  makeStakeAddressRegistrationCertificatePostConway :: ()
-    => Ledger.TxCert (ShelleyLedgerEra era) ~ Ledger.ConwayTxCert (ShelleyLedgerEra era)
-    => Ledger.ConwayEraTxCert (ShelleyLedgerEra era)
-    => EraCrypto (ShelleyLedgerEra era) ~ StandardCrypto
-    => ConwayEraOnwards era
-    -> StakeCredential
-    -> Lovelace
-    -> Certificate era
-  makeStakeAddressRegistrationCertificatePostConway cWayEraOn scred deposit =
-    ConwayCertificate cWayEraOn
-        $ Ledger.mkRegDepositTxCert
-            (toShelleyStakeCredential scred)
-            (toShelleyLovelace deposit)
+makeStakeAddressRegistrationCertificate = \case
+  StakeAddrRegistrationPreConway w scred ->
+    shelleyToBabbageEraConstraints w
+      $ ShelleyRelatedCertificate w
+      $ Ledger.mkRegTxCert $ toShelleyStakeCredential scred
+  StakeAddrRegistrationConway cOnwards deposit scred ->
+    conwayEraOnwardsConstraints cOnwards
+      $ ConwayCertificate cOnwards
+      $ Ledger.mkRegDepositTxCert (toShelleyStakeCredential scred) (toShelleyLovelace deposit)
 
 makeStakeAddressUnregistrationCertificate :: StakeAddressRequirements era -> Certificate era
 makeStakeAddressUnregistrationCertificate req =
   case req of
-    StakeAddrRegistrationConway cOnwards ll scred ->
+    StakeAddrRegistrationConway cOnwards deposit scred ->
       conwayEraOnwardsConstraints cOnwards
-        $ makeStakeAddressDeregistrationCertificatePostConway cOnwards scred ll
+        $ ConwayCertificate cOnwards
+        $ Ledger.mkUnRegDepositTxCert (toShelleyStakeCredential scred) (toShelleyLovelace deposit)
 
     StakeAddrRegistrationPreConway atMostEra scred ->
       shelleyToBabbageEraConstraints atMostEra
-        $ makeStakeAddressDeregistrationCertificatePreConway atMostEra scred
- where
-  makeStakeAddressDeregistrationCertificatePreConway
-    :: Ledger.ShelleyEraTxCert (ShelleyLedgerEra era)
-    => Ledger.TxCert (ShelleyLedgerEra era) ~ Ledger.ShelleyTxCert (ShelleyLedgerEra era)
-    => EraCrypto (ShelleyLedgerEra era) ~ StandardCrypto
-    => ShelleyToBabbageEra era
-    -> StakeCredential
-    -> Certificate era
-  makeStakeAddressDeregistrationCertificatePreConway aMostBab scred =
-    ShelleyRelatedCertificate aMostBab
-      $ Ledger.mkUnRegTxCert $ toShelleyStakeCredential scred
-
-  makeStakeAddressDeregistrationCertificatePostConway
-    :: EraCrypto (ShelleyLedgerEra era) ~ StandardCrypto
-    => Ledger.TxCert (ShelleyLedgerEra era) ~ Ledger.ConwayTxCert (ShelleyLedgerEra era)
-    => Ledger.ConwayEraTxCert (ShelleyLedgerEra era)
-    => ConwayEraOnwards era
-    -> StakeCredential
-    -> Lovelace
-    -> Certificate era
-  makeStakeAddressDeregistrationCertificatePostConway cOn scred deposit  =
-    ConwayCertificate cOn
-      $ Ledger.mkUnRegDepositTxCert
-          (toShelleyStakeCredential scred)
-          (toShelleyLovelace deposit)
+        $ ShelleyRelatedCertificate atMostEra
+        $ Ledger.mkUnRegTxCert $ toShelleyStakeCredential scred
 
 data StakeDelegationRequirements era where
   StakeDelegationRequirementsConwayOnwards
@@ -336,19 +289,17 @@ data StakeDelegationRequirements era where
     -> PoolId
     -> StakeDelegationRequirements era
 
-
 makeStakeAddressDelegationCertificate :: StakeDelegationRequirements era -> Certificate era
-makeStakeAddressDelegationCertificate req =
-  case req of
-    StakeDelegationRequirementsConwayOnwards cOnwards scred delegatee ->
-      conwayEraOnwardsConstraints cOnwards
-        $ ConwayCertificate cOnwards
-        $ Ledger.mkDelegTxCert (toShelleyStakeCredential scred) delegatee
+makeStakeAddressDelegationCertificate = \case
+  StakeDelegationRequirementsConwayOnwards cOnwards scred delegatee ->
+    conwayEraOnwardsConstraints cOnwards
+      $ ConwayCertificate cOnwards
+      $ Ledger.mkDelegTxCert (toShelleyStakeCredential scred) delegatee
 
-    StakeDelegationRequirementsPreConway atMostBabbage scred pid ->
-      shelleyToBabbageEraConstraints atMostBabbage
-        $ ShelleyRelatedCertificate atMostBabbage
-        $ Ledger.mkDelegStakeTxCert (toShelleyStakeCredential scred) (unStakePoolKeyHash pid)
+  StakeDelegationRequirementsPreConway atMostBabbage scred pid ->
+    shelleyToBabbageEraConstraints atMostBabbage
+      $ ShelleyRelatedCertificate atMostBabbage
+      $ Ledger.mkDelegStakeTxCert (toShelleyStakeCredential scred) (unStakePoolKeyHash pid)
 
 data StakePoolRegistrationRequirements era where
   StakePoolRegistrationRequirementsConwayOnwards
@@ -364,16 +315,15 @@ data StakePoolRegistrationRequirements era where
 makeStakePoolRegistrationCertificate :: ()
   => StakePoolRegistrationRequirements era
   -> Certificate era
-makeStakePoolRegistrationCertificate req =
-  case req of
-    StakePoolRegistrationRequirementsConwayOnwards cOnwards poolParams ->
-      conwayEraOnwardsConstraints cOnwards
-        $ ConwayCertificate cOnwards
-        $ Ledger.mkRegPoolTxCert poolParams
-    StakePoolRegistrationRequirementsPreConway atMostBab poolParams ->
-      shelleyToBabbageEraConstraints atMostBab
-        $ ShelleyRelatedCertificate atMostBab
-        $ Ledger.mkRegPoolTxCert poolParams
+makeStakePoolRegistrationCertificate = \case
+  StakePoolRegistrationRequirementsConwayOnwards cOnwards poolParams ->
+    conwayEraOnwardsConstraints cOnwards
+      $ ConwayCertificate cOnwards
+      $ Ledger.mkRegPoolTxCert poolParams
+  StakePoolRegistrationRequirementsPreConway atMostBab poolParams ->
+    shelleyToBabbageEraConstraints atMostBab
+      $ ShelleyRelatedCertificate atMostBab
+      $ Ledger.mkRegPoolTxCert poolParams
 
 data StakePoolRetirementRequirements era where
   StakePoolRetirementRequirementsConwayOnwards

diff --git a/cardano-api/internal/Cardano/Api/Fees.hs b/cardano-api/internal/Cardano/Api/Fees.hs
@@ -223,19 +223,10 @@ evaluateTransactionFee pp txbody keywitcount _byronwitcount =
       ByronTx{} -> case shelleyBasedEra :: ShelleyBasedEra era of {}
       --TODO: we could actually support Byron here, it'd be different but simpler
 
-      ShelleyTx sbe tx -> shelleyBasedEraConstraints sbe (evalShelleyBasedEra tx)
-  where
-    evalShelleyBasedEra :: forall ledgerera.
-                           ShelleyLedgerEra era ~ ledgerera
-                        => L.EraTx ledgerera
-                        => Ledger.Tx ledgerera
-                        -> Lovelace
-    evalShelleyBasedEra tx =
-      fromShelleyLovelace $
-        Ledger.evaluateTransactionFee
-          pp
-          tx
-          keywitcount
+      ShelleyTx sbe tx ->
+        shelleyBasedEraConstraints sbe
+          $ fromShelleyLovelace
+          $ Ledger.evaluateTransactionFee pp tx keywitcount
 
 -- | Give an approximate count of the number of key witnesses (i.e. signatures)
 -- a transaction will need.
@@ -1208,9 +1199,5 @@ calculateMinimumUTxO
   -> Lovelace
 calculateMinimumUTxO sbe txout pp =
   shelleyBasedEraConstraints sbe
-    $ calcMinUTxO pp (toShelleyTxOutAny sbe txout)
- where
-   calcMinUTxO :: L.EraTxOut ledgerera => L.PParams ledgerera -> L.TxOut ledgerera -> Lovelace
-   calcMinUTxO pp' txOut =
-      let txOutWithMinCoin = L.setMinCoinTxOut pp' txOut
+    $ let txOutWithMinCoin = L.setMinCoinTxOut pp (toShelleyTxOutAny sbe txout)
       in fromShelleyLovelace (txOutWithMinCoin ^. L.coinTxOutL)
diff --git a/cardano-api/internal/Cardano/Api/Governance/Actions/ProposalProcedure.hs b/cardano-api/internal/Cardano/Api/Governance/Actions/ProposalProcedure.hs
@@ -67,38 +67,40 @@ data GovernanceAction
   deriving (Eq, Show)
 
 
-toGovernanceAction
-  :: EraCrypto ledgerera ~ StandardCrypto
-  => ShelleyLedgerEra era ~ ledgerera
+toGovernanceAction :: ()
   => ShelleyBasedEra era
   -> GovernanceAction
-  -> Gov.GovAction ledgerera
-toGovernanceAction _ (MotionOfNoConfidence prevGovId) = Gov.NoConfidence prevGovId
-toGovernanceAction _ (ProposeNewConstitution prevGovAction anchor) =
-  Gov.NewConstitution prevGovAction Gov.Constitution
-    { Gov.constitutionAnchor = anchor
-    , Gov.constitutionScript = SNothing   -- TODO: Conway era
-    }
-toGovernanceAction _ (ProposeNewCommittee prevGovId oldCommitteeMembers newCommitteeMembers quor) =
-  Gov.UpdateCommittee
-    prevGovId -- previous governance action id
-    (Set.fromList $ map toCommitteeMember oldCommitteeMembers) -- members to remove
-    (Map.mapKeys toCommitteeMember newCommitteeMembers) -- members to add
-    (fromMaybe (error $ mconcat ["toGovernanceAction: the given quorum "
-                               , show quor
-                               , " was outside of the unit interval!"
-                               ])
-          $ boundRational @UnitInterval quor)
-toGovernanceAction _ InfoAct = Gov.InfoAction
-toGovernanceAction _ (TreasuryWithdrawal withdrawals) =
-  let m = Map.fromList [(L.mkRwdAcnt nw (toShelleyStakeCredential sc), toShelleyLovelace l) | (nw,sc,l) <- withdrawals]
-  in Gov.TreasuryWithdrawals m
-toGovernanceAction _ (InitiateHardfork prevGovId pVer) =
-  Gov.HardForkInitiation prevGovId pVer
-toGovernanceAction sbe (UpdatePParams preGovId ppup) =
-  case toLedgerPParamsUpdate sbe ppup of
-    Left e -> error $ "toGovernanceAction: " <> show e
-    Right ppup' -> Gov.ParameterChange preGovId ppup'
+  -> Gov.GovAction (ShelleyLedgerEra era)
+toGovernanceAction sbe =
+  shelleyBasedEraConstraints sbe $ \case
+    MotionOfNoConfidence prevGovId ->
+      Gov.NoConfidence prevGovId
+    ProposeNewConstitution prevGovAction anchor ->
+      Gov.NewConstitution prevGovAction Gov.Constitution
+        { Gov.constitutionAnchor = anchor
+        , Gov.constitutionScript = SNothing   -- TODO: Conway era
+        }
+    ProposeNewCommittee prevGovId oldCommitteeMembers newCommitteeMembers quor ->
+      Gov.UpdateCommittee
+        prevGovId -- previous governance action id
+        (Set.fromList $ map toCommitteeMember oldCommitteeMembers) -- members to remove
+        (Map.mapKeys toCommitteeMember newCommitteeMembers) -- members to add
+        (fromMaybe (error $ mconcat ["toGovernanceAction: the given quorum "
+                                  , show quor
+                                  , " was outside of the unit interval!"
+                                  ])
+              $ boundRational @UnitInterval quor)
+    InfoAct ->
+      Gov.InfoAction
+    TreasuryWithdrawal withdrawals ->
+      let m = Map.fromList [(L.mkRwdAcnt nw (toShelleyStakeCredential sc), toShelleyLovelace l) | (nw,sc,l) <- withdrawals]
+      in Gov.TreasuryWithdrawals m
+    InitiateHardfork prevGovId pVer ->
+      Gov.HardForkInitiation prevGovId pVer
+    UpdatePParams preGovId ppup ->
+      case toLedgerPParamsUpdate sbe ppup of
+        Left e -> error $ "toGovernanceAction: " <> show e
+        Right ppup' -> Gov.ParameterChange preGovId ppup'
 
 fromGovernanceAction
   :: EraCrypto (ShelleyLedgerEra era) ~ StandardCrypto