Merge pull request #209 from input-output-hk/newhoggy/delete-TxVotes

Delete `TxVotes` and `VotingEntry` and use `VotingProcedures` instead

cardano-api/cardano-api.cabal

@@ -67,7 +67,6 @@ library internal
                         Cardano.Api.Genesis
                         Cardano.Api.GenesisParameters
                         Cardano.Api.Governance.Actions.ProposalProcedure
-                        Cardano.Api.Governance.Actions.VotingEntry
                         Cardano.Api.Governance.Actions.VotingProcedure
                         Cardano.Api.Governance.Poll
                         Cardano.Api.Hash

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

@@ -148,7 +148,6 @@ import qualified Data.ByteString.Short as SBS
 import           Data.Coerce
 import           Data.Int (Int64)
 import           Data.Map.Strict (Map)
-import qualified Data.Map.Strict as Map
 import           Data.Maybe
 import           Data.Ratio (Ratio, (%))
 import           Data.String
@@ -672,7 +671,7 @@ genTxBodyContent era = do
   txMintValue <- genTxMintValue era
   txScriptValidity <- genTxScriptValidity era
   txGovernanceActions <- genTxGovernanceActions era
-  txVotes <- genTxVotes era
+  txVotingProcedures <- genMaybeFeaturedInEra genVotingProcedures era
   pure $ TxBodyContent
     { Api.txIns
     , Api.txInsCollateral
@@ -692,7 +691,7 @@ genTxBodyContent era = do
     , Api.txMintValue
     , Api.txScriptValidity
     , Api.txGovernanceActions
-    , Api.txVotes
+    , Api.txVotingProcedures
     }
 
 genTxInsCollateral :: CardanoEra era -> Gen (TxInsCollateral era)
@@ -750,12 +749,12 @@ genFeaturedInEra witness gen =
 genMaybeFeaturedInEra :: ()
   => FeatureInEra feature
   => Alternative f
-  => f a
+  => (feature era -> f a)
   -> CardanoEra era
   -> f (Maybe (Featured feature era a))
-genMaybeFeaturedInEra gen =
-  featureInEra (pure Nothing) $ \witness ->
-    pure Nothing <|> fmap Just (genFeaturedInEra witness gen)
+genMaybeFeaturedInEra f =
+  featureInEra (pure Nothing) $ \w ->
+    pure Nothing <|> fmap Just (genFeaturedInEra w (f w))
 
 genTxScriptValidity :: CardanoEra era -> Gen (TxScriptValidity era)
 genTxScriptValidity era = case txScriptValiditySupportedInCardanoEra era of
@@ -1123,22 +1122,7 @@ genTxGovernanceActions era = fromMaybe (pure TxGovernanceActionsNone) $ do
     genProposal = \case
       ConwayEraOnwardsConway -> fmap Proposal Q.arbitrary
 
-genTxVotes :: CardanoEra era -> Gen (TxVotes era)
-genTxVotes era = fromMaybe (pure TxVotesNone) $ do
-  w <- featureInEra Nothing Just era
-  let votes = Gen.list (Range.constant 0 10) $ genVote w
-  pure $ TxVotes w . Map.fromList <$> votes
-  where
-    genVote
-      :: ConwayEraOnwards era
-      -> Gen ( (Voter era, GovernanceActionId era)
-             , VotingProcedure era
-             )
-    genVote w =
-        conwayEraOnwardsConstraints w $
-        (,)
-          <$> ((,)
-                 <$> (fromVoterRole (conwayEraOnwardsToShelleyBasedEra w) <$> Q.arbitrary)
-                 <*> (GovernanceActionId <$> Q.arbitrary)
-              )
-          <*> (VotingProcedure <$> Q.arbitrary)
+genVotingProcedures :: ConwayEraOnwards era -> Gen (VotingProcedures era)
+genVotingProcedures w =
+  conwayEraOnwardsConstraints w
+    $ VotingProcedures <$> Q.arbitrary

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

@@ -7,6 +7,7 @@
 
 module Cardano.Api.Feature
   ( Featured (..)
+  , unFeatured
   , asFeaturedInEra
   , asFeaturedInShelleyBasedEra
   ) where
@@ -28,6 +29,9 @@ deriving instance (Show a, Show (feature era)) => Show (Featured feature era a)
 instance Functor (Featured feature era) where
   fmap f (Featured feature a) = Featured feature (f a)
 
+unFeatured :: Featured feature era a -> a
+unFeatured (Featured _ a) = a
+
 -- | Attempt to construct a 'FeatureValue' from a value and era.
 -- If the feature is not supported in the era, then 'NoFeatureValue' is returned.
 asFeaturedInEra :: ()

cardano-api/internal/Cardano/Api/Governance/Actions/VotingProcedure.hs

@@ -20,7 +20,6 @@ module Cardano.Api.Governance.Actions.VotingProcedure where
 import           Cardano.Api.Address
 import           Cardano.Api.Eras.Constraints
 import           Cardano.Api.Eras.Core
-import           Cardano.Api.Feature.ConwayEraOnwards (ConwayEraOnwards)
 import           Cardano.Api.Governance.Actions.ProposalProcedure
 import           Cardano.Api.HasTypeProxy
 import           Cardano.Api.Keys.Shelley
@@ -38,26 +37,11 @@ import           Cardano.Ledger.Crypto (StandardCrypto)
 import           Cardano.Ledger.Keys (HasKeyRole (..), KeyRole (DRepRole))
 
 import           Data.ByteString.Lazy (ByteString)
-import qualified Data.Map.Strict as Map
+import qualified Data.Map as Map
 import           Data.Text (Text)
 import qualified Data.Text.Encoding as Text
 import           GHC.Generics
 
--- | A representation of whether the era supports tx voting on governance actions.
---
--- The Conway and subsequent eras support tx voting on governance actions.
---
-data TxVotes era where
-  TxVotesNone :: TxVotes era
-
-  TxVotes
-    :: ConwayEraOnwards era
-    -> Map.Map (Voter era, GovernanceActionId era) (VotingProcedure era)
-    -> TxVotes era
-
-deriving instance Show (TxVotes era)
-deriving instance Eq (TxVotes era)
-
 newtype GovernanceActionId era = GovernanceActionId
   { unGovernanceActionId :: Ledger.GovActionId (EraCrypto (ShelleyLedgerEra era))
   }

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

@@ -190,6 +190,7 @@ import           Cardano.Api.Convenience.Constraints
 import           Cardano.Api.EraCast
 import           Cardano.Api.Eras
 import           Cardano.Api.Error
+import           Cardano.Api.Feature
 import           Cardano.Api.Feature.ConwayEraOnwards
 import           Cardano.Api.Governance.Actions.ProposalProcedure
 import           Cardano.Api.Governance.Actions.VotingProcedure
@@ -1758,7 +1759,7 @@ data TxBodyContent build era =
        txMintValue         :: TxMintValue    build era,
        txScriptValidity    :: TxScriptValidity era,
        txGovernanceActions :: TxGovernanceActions era,
-       txVotes             :: TxVotes era
+       txVotingProcedures  :: Maybe (Featured ConwayEraOnwards era (VotingProcedures era))
      }
      deriving (Eq, Show)
 
@@ -1782,7 +1783,7 @@ defaultTxBodyContent = TxBodyContent
     , txMintValue = TxMintNone
     , txScriptValidity = TxScriptValidityNone
     , txGovernanceActions = TxGovernanceActionsNone
-    , txVotes = TxVotesNone
+    , txVotingProcedures = Nothing
     }
 
 setTxIns :: TxIns build era -> TxBodyContent build era -> TxBodyContent build era
@@ -2718,8 +2719,8 @@ fromLedgerTxBody sbe scriptValidity body scriptdata mAux =
       , txMetadata
       , txAuxScripts
       , txScriptValidity    = scriptValidity
-      , txGovernanceActions = fromLedgerProposalProcedure sbe body
-      , txVotes             = fromLedgerTxVotes sbe body
+      , txGovernanceActions = fromLedgerProposalProcedure   sbe body
+      , txVotingProcedures             = fromLedgerVotingProcedures    sbe body
       }
   where
     (txMetadata, txAuxScripts) = fromLedgerTxAuxiliaryData sbe mAux
@@ -2743,24 +2744,20 @@ fromLedgerProposalProcedure sbe body =
         $ toList
         $ body_ ^. L.proposalProceduresTxBodyL
 
-fromLedgerTxVotes :: ShelleyBasedEra era -> Ledger.TxBody (ShelleyLedgerEra era) -> TxVotes era
-fromLedgerTxVotes sbe body =
-  case featureInShelleyBasedEra Nothing Just sbe of
-    Nothing -> TxVotesNone
-    Just w  -> getVotes w body
-  where
-    getVotes :: ConwayEraOnwards era
-             -> Ledger.TxBody (ShelleyLedgerEra era)
-             -> TxVotes era
-    getVotes w body_ =
+fromLedgerVotingProcedures :: ()
+  => ShelleyBasedEra era
+  -> Ledger.TxBody (ShelleyLedgerEra era)
+  -> Maybe (Featured ConwayEraOnwards era (VotingProcedures era))
+fromLedgerVotingProcedures sbe body =
+  featureInShelleyBasedEra
+    Nothing
+    (\w ->
       conwayEraOnwardsConstraints w
-        $ TxVotes w
-        $ foldMap (\(voter, innerMap) ->
-              Map.mapKeys (\govActId -> (fromVoterRole (conwayEraOnwardsToShelleyBasedEra w) voter, GovernanceActionId govActId))
-            $ Map.map VotingProcedure innerMap
-          )
-        $ (Map.toList . Gov.unVotingProcedures)
-        $ body_ ^. L.votingProceduresTxBodyL
+        $ Just
+        $ Featured w
+        $ VotingProcedures
+        $ body ^. L.votingProceduresTxBodyL)
+    sbe
 
 fromLedgerTxIns
   :: forall era.
@@ -3430,7 +3427,7 @@ getByronTxBodyContent (Annotated Byron.UnsafeTx{txInputs, txOutputs} _) =
   , txMintValue         = TxMintNone
   , txScriptValidity    = TxScriptValidityNone
   , txGovernanceActions = TxGovernanceActionsNone
-  , txVotes             = TxVotesNone
+  , txVotingProcedures             = Nothing
   }
 
 convTxIns :: TxIns BuildTx era -> Set (L.TxIn StandardCrypto)
@@ -3611,21 +3608,6 @@ convGovActions :: TxGovernanceActions era -> Seq.StrictSeq (Gov.ProposalProcedur
 convGovActions TxGovernanceActionsNone = Seq.empty
 convGovActions (TxGovernanceActions _ govActions) = Seq.fromList $ fmap unProposal govActions
 
-convVotes
-  :: (Ledger.EraCrypto (ShelleyLedgerEra era) ~ StandardCrypto)
-  => ShelleyBasedEra era
-  -> TxVotes era
-  -> Gov.VotingProcedures (ShelleyLedgerEra era)
-convVotes sbe = Gov.VotingProcedures . \case
-  TxVotesNone -> Map.empty
-  TxVotes _ votes ->
-    let combine = error "convVotes: impossible! `votes' contained the same key multiple times"
-    in
-    Map.fromListWith (Map.unionWith combine)
-      [ (toVoterRole sbe voter, unGovernanceActionId govActId `Map.singleton` unVotingProcedure vp)
-      | ((voter, govActId), vp) <- Map.toList votes
-      ]
-
 guardShelleyTxInsOverflow :: [TxIn] -> Either TxBodyError ()
 guardShelleyTxInsOverflow txIns = do
     for_ txIns $ \txin@(TxIn _ (TxIx txix)) ->
@@ -3654,8 +3636,8 @@ mkCommonTxBody sbe txIns txOuts txFee txWithdrawals txAuxData =
   & L.auxDataHashTxBodyL .~ maybe SNothing (SJust . Ledger.hashTxAuxData) txAuxData
 
 
-makeShelleyTransactionBody
-  :: ShelleyBasedEra era
+makeShelleyTransactionBody :: forall era. ()
+  => ShelleyBasedEra era
   -> TxBodyContent BuildTx era
   -> Either TxBodyError (TxBody era)
 makeShelleyTransactionBody sbe@ShelleyBasedEraShelley
@@ -3973,7 +3955,7 @@ makeShelleyTransactionBody sbe@ShelleyBasedEraConway
                              txCertificates,
                              txMintValue,
                              txScriptValidity,
-                             txVotes,
+                             txVotingProcedures,
                              txGovernanceActions
                            } = do
 
@@ -3994,7 +3976,7 @@ makeShelleyTransactionBody sbe@ShelleyBasedEraConway
            & L.reqSignerHashesTxBodyL     .~ convExtraKeyWitnesses txExtraKeyWits
            & L.mintTxBodyL                .~ convMintValue txMintValue
            & L.scriptIntegrityHashTxBodyL .~ scriptIntegrityHash
-           & L.votingProceduresTxBodyL    .~ convVotes sbe txVotes
+           & L.votingProceduresTxBodyL    .~ unVotingProcedures @era (maybe emptyVotingProcedures unFeatured txVotingProcedures)
            & L.proposalProceduresTxBodyL  .~ convGovActions txGovernanceActions
            -- TODO Conway: support optional network id in TxBodyContent
            -- & L.networkIdTxBodyL .~ SNothing

cardano-api/src/Cardano/Api.hs

@@ -285,9 +285,7 @@ module Cardano.Api (
     TxCertificates(..),
     TxUpdateProposal(..),
     TxMintValue(..),
-    TxVotes(..),
     TxGovernanceActions(..),
-    VotingEntry(..),
 
     -- ** Building vs viewing transactions
     BuildTxWith(..),
@@ -969,8 +967,6 @@ import           Cardano.Api.Fees
 import           Cardano.Api.Genesis
 import           Cardano.Api.GenesisParameters
 import           Cardano.Api.Governance.Actions.ProposalProcedure
-import           Cardano.Api.Governance.Actions.VotingEntry
-import           Cardano.Api.Governance.Actions.VotingProcedure
 import           Cardano.Api.Hash
 import           Cardano.Api.HasTypeProxy
 import           Cardano.Api.InMode

cardano-api/src/Cardano/Api/Shelley.hs

@@ -256,7 +256,6 @@ module Cardano.Api.Shelley
     GovernanceActionId(..),
     Proposal(..),
     TxGovernanceActions(..),
-    TxVotes(..),
     VotingProcedure(..),
     VotingProcedures(..),
     GovernancePoll(..),