Merge pull request #115 from input-output-hk/mgalazyn/fix/fix-eq-show…

…-proposal-type Fix Eq, Show for Proposal type
IntersectMBO · Jul 12, 2023 · a6f40d5 · a6f40d5
2 parents 5ed6b57 + e2fef97
commit a6f40d5
Show file tree

Hide file tree

Showing 2 changed files with 61 additions and 64 deletions.
diff --git a/cardano-api/internal/Cardano/Api/Governance/Actions/ProposalProcedure.hs b/cardano-api/internal/Cardano/Api/Governance/Actions/ProposalProcedure.hs
@@ -2,6 +2,7 @@
 {-# LANGUAGE ExistentialQuantification #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE GADTs #-}
+{-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE StandaloneDeriving #-}
 {-# LANGUAGE TypeApplications #-}
 {-# LANGUAGE TypeFamilies #-}
@@ -37,16 +38,11 @@ data TxGovernanceActions era where
 
   TxGovernanceActions
     :: TxGovernanceActionSupportedInEra era
-    -- (deposit, return address, governance action)
-    -- TODO: Conway era - This should be [Proposal era]
-    -- however when defining Eq and Show instances for Proposal era
-    -- There is a ledger class constraint that needs to be propagated
-    -- across several types which is unacceptable.
-    -> [(Lovelace, Hash StakeKey, GovernanceAction)]
+    -> [Proposal era]
     -> TxGovernanceActions era
 
-deriving instance Show (TxGovernanceActions era)
-deriving instance Eq (TxGovernanceActions era)
+deriving instance IsShelleyBasedEra era => Show (TxGovernanceActions era)
+deriving instance IsShelleyBasedEra era => Eq (TxGovernanceActions era)
 
 
 -- | A representation of whether the era supports transactions with governance
@@ -61,7 +57,7 @@ data TxGovernanceActionSupportedInEra era where
 deriving instance Show (TxGovernanceActionSupportedInEra era)
 deriving instance Eq (TxGovernanceActionSupportedInEra era)
 
-governanceActionsSupportedInEra :: ShelleyBasedEra  era -> Maybe (TxGovernanceActionSupportedInEra era)
+governanceActionsSupportedInEra :: ShelleyBasedEra era -> Maybe (TxGovernanceActionSupportedInEra era)
 governanceActionsSupportedInEra ShelleyBasedEraShelley = Nothing
 governanceActionsSupportedInEra ShelleyBasedEraAllegra = Nothing
 governanceActionsSupportedInEra ShelleyBasedEraMary    = Nothing
@@ -100,28 +96,25 @@ fromGovernanceAction _ _ = error "fromGovernanceAction Conway: not implemented y
 
 newtype Proposal era = Proposal { unProposal :: Gov.ProposalProcedure (ShelleyLedgerEra era) }
 
-deriving instance (Shelley.EraPParams (ShelleyLedgerEra era)) => Show (Proposal era)
-deriving instance (Shelley.EraPParams (ShelleyLedgerEra era)) => Eq (Proposal era)
+instance IsShelleyBasedEra era => Show (Proposal era) where
+  show (Proposal pp) = do
+    let ppStr = withShelleyBasedEraConstraintsForLedger (shelleyBasedEra @era) $ show pp
+    "Proposal {unProposal = " <> ppStr <> "}"
 
-instance (IsShelleyBasedEra era, Shelley.EraPParams (ShelleyLedgerEra era)) => ToCBOR (Proposal era) where
-  toCBOR (Proposal vp) = Shelley.toEraCBOR @Conway.Conway vp
+instance IsShelleyBasedEra era => Eq (Proposal era) where
+  (Proposal pp1) == (Proposal pp2) = withShelleyBasedEraConstraintsForLedger (shelleyBasedEra @era) $ pp1 == pp2
 
-instance ( IsShelleyBasedEra era
-         , Shelley.EraPParams (ShelleyLedgerEra era)
-         ) => FromCBOR (Proposal era) where
-  fromCBOR = Proposal <$> Shelley.fromEraCBOR @Conway.Conway
+instance IsShelleyBasedEra era => ToCBOR (Proposal era) where
+  toCBOR (Proposal vp) = withShelleyBasedEraConstraintsForLedger (shelleyBasedEra @era) $ Shelley.toEraCBOR @Conway.Conway vp
 
-instance ( IsShelleyBasedEra era
-         , Shelley.EraPParams (ShelleyLedgerEra era)
-         ) => SerialiseAsCBOR (Proposal era) where
+instance IsShelleyBasedEra era => FromCBOR (Proposal era) where
+  fromCBOR = Proposal <$> withShelleyBasedEraConstraintsForLedger (shelleyBasedEra @era) (Shelley.fromEraCBOR @Conway.Conway)
 
-  serialiseToCBOR = CBOR.serialize'
-  deserialiseFromCBOR _proxy = CBOR.decodeFull'
+instance IsShelleyBasedEra era => SerialiseAsCBOR (Proposal era) where
+  serialiseToCBOR = withShelleyBasedEraConstraintsForLedger (shelleyBasedEra @era) CBOR.serialize'
+  deserialiseFromCBOR _proxy = withShelleyBasedEraConstraintsForLedger (shelleyBasedEra @era) CBOR.decodeFull'
 
-
-instance ( IsShelleyBasedEra era
-         , Shelley.EraPParams (ShelleyLedgerEra era)
-         ) => HasTextEnvelope (Proposal era) where
+instance IsShelleyBasedEra era => HasTextEnvelope (Proposal era) where
   textEnvelopeType _ = "Governance proposal"
 
 instance HasTypeProxy era => HasTypeProxy (Proposal era) where

diff --git a/cardano-api/internal/Cardano/Api/TxBody.hs b/cardano-api/internal/Cardano/Api/TxBody.hs
@@ -224,7 +224,6 @@ import           Cardano.Ledger.Binary (Annotated (..), reAnnotate, recoverBytes
 import qualified Cardano.Ledger.Binary as CBOR
 import qualified Cardano.Ledger.Block as Ledger
 import qualified Cardano.Ledger.Conway.Core as L
-import qualified Cardano.Ledger.Conway.Governance as Conway
 import qualified Cardano.Ledger.Conway.Governance as Gov
 import qualified Cardano.Ledger.Core as Core
 import qualified Cardano.Ledger.Core as Ledger
@@ -2712,46 +2711,55 @@ fromLedgerTxBody
   -> TxBodyContent ViewTx era
 fromLedgerTxBody sbe scriptValidity body scriptdata mAux =
     TxBodyContent
-      { txIns              = fromLedgerTxIns               sbe body
-      , txInsCollateral    = fromLedgerTxInsCollateral     sbe body
-      , txInsReference     = fromLedgerTxInsReference      sbe body
-      , txOuts             = fromLedgerTxOuts              sbe body scriptdata
-      , txTotalCollateral  = fromLedgerTxTotalCollateral   sbe body
-      , txReturnCollateral = fromLedgerTxReturnCollateral  sbe body
-      , txFee              = fromLedgerTxFee               sbe body
-      , txValidityRange    = fromLedgerTxValidityRange     sbe body
-      , txWithdrawals      = fromLedgerTxWithdrawals       sbe body
-      , txCertificates     = fromLedgerTxCertificates      sbe body
-      , txUpdateProposal   = fromLedgerTxUpdateProposal    sbe body
-      , txMintValue        = fromLedgerTxMintValue         sbe body
-      , txExtraKeyWits     = fromLedgerTxExtraKeyWitnesses sbe body
-      , txProtocolParams   = ViewTx
+      { txIns               = fromLedgerTxIns               sbe body
+      , txInsCollateral     = fromLedgerTxInsCollateral     sbe body
+      , txInsReference      = fromLedgerTxInsReference      sbe body
+      , txOuts              = fromLedgerTxOuts              sbe body scriptdata
+      , txTotalCollateral   = fromLedgerTxTotalCollateral   sbe body
+      , txReturnCollateral  = fromLedgerTxReturnCollateral  sbe body
+      , txFee               = fromLedgerTxFee               sbe body
+      , txValidityRange     = fromLedgerTxValidityRange     sbe body
+      , txWithdrawals       = fromLedgerTxWithdrawals       sbe body
+      , txCertificates      = fromLedgerTxCertificates      sbe body
+      , txUpdateProposal    = fromLedgerTxUpdateProposal    sbe body
+      , txMintValue         = fromLedgerTxMintValue         sbe body
+      , txExtraKeyWits      = fromLedgerTxExtraKeyWitnesses sbe body
+      , txProtocolParams    = ViewTx
       , txMetadata
       , txAuxScripts
-      , txScriptValidity   = scriptValidity
+      , txScriptValidity    = scriptValidity
       , txGovernanceActions = fromLedgerProposalProcedure sbe body
-      , txVotes = error "fromLedgerTxBody.txVotes: TODO: Conway"
+      , txVotes             = fromLedgerTxVotes sbe body
       }
   where
     (txMetadata, txAuxScripts) = fromLedgerTxAuxiliaryData sbe mAux
 
--- TODO: Conway
+
 fromLedgerProposalProcedure
   :: ShelleyBasedEra era
   -> Ledger.TxBody (ShelleyLedgerEra era)
   -> TxGovernanceActions era
-fromLedgerProposalProcedure _ _bdy = TxGovernanceActionsNone
- where
-   _proposalProcedures
-     :: ShelleyBasedEra era
-     -> Ledger.TxBody (ShelleyLedgerEra era)
-     -> Seq.StrictSeq (Conway.ProposalProcedure era)
-   _proposalProcedures ShelleyBasedEraShelley _bdy = mempty
-   _proposalProcedures ShelleyBasedEraAllegra _bdy = mempty
-   _proposalProcedures ShelleyBasedEraMary _bdy = mempty
-   _proposalProcedures ShelleyBasedEraAlonzo _bdy = mempty
-   _proposalProcedures ShelleyBasedEraBabbage _bdy = mempty
-   _proposalProcedures ShelleyBasedEraConway _bdy = mempty
+fromLedgerProposalProcedure sbe body =
+  case governanceActionsSupportedInEra sbe of
+    Nothing     -> TxGovernanceActionsNone
+    Just gasice -> TxGovernanceActions gasice (getProposals gasice body)
+  where
+    getProposals :: TxGovernanceActionSupportedInEra era
+                 -> Ledger.TxBody (ShelleyLedgerEra era)
+                 -> [Proposal era]
+    getProposals GovernanceActionsSupportedInConwayEra body_ = fmap Proposal . toList $ body_ ^. L.proposalProceduresTxBodyL
+
+
+fromLedgerTxVotes :: ShelleyBasedEra era -> Ledger.TxBody (ShelleyLedgerEra era) -> TxVotes era
+fromLedgerTxVotes sbe body =
+  case votesSupportedInEra sbe of
+    Nothing    -> TxVotesNone
+    Just vsice -> TxVotes vsice (getVotes vsice body)
+  where
+    getVotes :: TxVotesSupportedInEra era
+             -> Ledger.TxBody (ShelleyLedgerEra era)
+             -> [Vote era]
+    getVotes VotesSupportedInConwayEra body_ = fmap Vote . toList $ body_ ^. L.votingProceduresTxBodyL
 
 fromLedgerTxIns
   :: forall era.
@@ -3598,13 +3606,9 @@ convReferenceInputs txInsReference =
     TxInsReferenceNone -> mempty
     TxInsReference _ refTxins -> Set.fromList $ map toShelleyTxIn refTxins
 
-convGovActions :: ShelleyBasedEra era -> TxGovernanceActions era -> Seq.StrictSeq (Gov.ProposalProcedure (ShelleyLedgerEra era))
-convGovActions _ TxGovernanceActionsNone = Seq.empty
-convGovActions sbe (TxGovernanceActions _ govActions) =
-  Seq.fromList
-    [ unProposal $ createProposalProcedure sbe deposit stakeCred action
-    | (deposit, stakeCred, action) <- govActions
-    ]
+convGovActions :: TxGovernanceActions era -> Seq.StrictSeq (Gov.ProposalProcedure (ShelleyLedgerEra era))
+convGovActions TxGovernanceActionsNone = Seq.empty
+convGovActions (TxGovernanceActions _ govActions) = Seq.fromList $ fmap unProposal govActions
 
 convVotes :: ShelleyBasedEra era -> TxVotes era -> Seq.StrictSeq (Gov.VotingProcedure (ShelleyLedgerEra era))
 convVotes _ TxVotesNone = Seq.empty
@@ -3979,7 +3983,7 @@ makeShelleyTransactionBody sbe@ShelleyBasedEraConway
            & L.mintTxBodyL                .~ convMintValue txMintValue
            & L.scriptIntegrityHashTxBodyL .~ scriptIntegrityHash
            & L.votingProceduresTxBodyL    .~ convVotes sbe txVotes
-           & L.proposalProceduresTxBodyL  .~ convGovActions sbe txGovernanceActions
+           & L.proposalProceduresTxBodyL  .~ convGovActions txGovernanceActions
            -- TODO Conway: support optional network id in TxBodyContent
            -- & L.networkIdTxBodyL .~ SNothing
         )