Remove redundant voting proposal conversion functions

cardano-cli/src/Cardano/CLI/EraBased/Run/Transaction.hs

@@ -65,7 +65,7 @@ import qualified Data.ByteString as Data.Bytestring
 import qualified Data.ByteString.Char8 as BS
 import qualified Data.ByteString.Lazy.Char8 as LBS
 import           Data.Data ((:~:) (..))
-import           Data.Foldable (Foldable (foldl'))
+import           Data.Foldable (foldl')
 import           Data.Function ((&))
 import qualified Data.List as List
 import           Data.Map.Strict (Map)
@@ -377,7 +377,7 @@ runTransactionBuildEstimateCmd -- TODO change type
     txOuts <- mapM (toTxOutInAnyEra sbe) txouts
 
     -- the same collateral input can be used for several plutus scripts
-    let filteredTxinsc = toList @(Set _) $ Set.fromList txInsCollateral
+    let filteredTxinsc = toList @(Set _) $ fromList txInsCollateral
 
     -- Conway related
     votingProceduresAndMaybeScriptWits <-
@@ -761,7 +761,8 @@ runTxBuildRaw
     first TxCmdTxBodyError $ createAndValidateTransactionBody sbe txBodyContent
 
 constructTxBodyContent
-  :: ShelleyBasedEra era
+  :: forall era
+   . ShelleyBasedEra era
   -> Maybe ScriptValidity
   -> Maybe (L.PParams (ShelleyLedgerEra era))
   -> [(TxIn, Maybe (ScriptWitness WitCtxTxIn era))]
@@ -849,7 +850,12 @@ constructTxBodyContent
       validatedTxScriptValidity <-
         first TxCmdNotSupportedInEraValidationError $ validateTxScriptValidity sbe mScriptValidity
       validatedVotingProcedures <-
-        first TxCmdTxGovDuplicateVotes $ convertToTxVotingProcedures votingProcedures
+        first (TxCmdTxGovDuplicateVotes . TxGovDuplicateVotes) $
+          mkTxVotingProcedures @BuildTx (fromList votingProcedures)
+      let txProposals = forShelleyBasedEraInEonMaybe sbe $ \w -> do
+            let txp :: TxProposalProcedures BuildTx era
+                txp = conwayEraOnwardsConstraints w $ mkTxProposalProcedures $ map (first unProposal) proposals
+            Featured w txp
       validatedCurrentTreasuryValue <-
         first
           TxCmdNotSupportedInEraValidationError
@@ -859,7 +865,8 @@ constructTxBodyContent
           TxCmdNotSupportedInEraValidationError
           (validateTxTreasuryDonation sbe (snd <$> mCurrentTreasuryValueAndDonation))
       return $
-        shelleyBasedEraConstraints sbe $
+        shelleyBasedEraConstraints
+          sbe
           ( defaultTxBodyContent sbe
               & setTxIns (validateTxIns inputsAndMaybeScriptWits)
               & setTxInsCollateral validatedCollateralTxIns
@@ -879,14 +886,11 @@ constructTxBodyContent
               & setTxUpdateProposal txUpdateProposal
               & setTxMintValue validatedMintValue
               & setTxScriptValidity validatedTxScriptValidity
+              & setTxVotingProcedures (mkFeatured validatedVotingProcedures)
+              & setTxProposalProcedures txProposals
+              & setTxCurrentTreasuryValue validatedCurrentTreasuryValue
+              & setTxTreasuryDonation validatedTreasuryDonation
           )
-            { -- TODO: Create set* function for proposal procedures and voting procedures
-              txProposalProcedures =
-                forShelleyBasedEraInEonMaybe sbe (`Featured` convToTxProposalProcedures proposals)
-            , txVotingProcedures = forShelleyBasedEraInEonMaybe sbe (`Featured` validatedVotingProcedures)
-            }
-            & setTxCurrentTreasuryValue validatedCurrentTreasuryValue
-            & setTxTreasuryDonation validatedTreasuryDonation
    where
     convertWithdrawals
       :: (StakeAddress, L.Coin, Maybe (ScriptWitness WitCtxStake era))
@@ -1130,7 +1134,7 @@ validateTxInsCollateral era txins = do
 validateTxInsReference
   :: ShelleyBasedEra era
   -> [TxIn]
-  -> Either TxCmdError (TxInsReference BuildTx era)
+  -> Either TxCmdError (TxInsReference era)
 validateTxInsReference _ [] = return TxInsReferenceNone
 validateTxInsReference sbe allRefIns = do
   forShelleyBasedEraInEonMaybe sbe (\supported -> TxInsReference supported allRefIns)

cardano-cli/src/Cardano/CLI/Json/Friendly.hs

@@ -5,6 +5,9 @@
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TypeApplications #-}
 {-# LANGUAGE TypeOperators #-}
+{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}
+
+{-# HLINT ignore "Redundant bracket" #-}
 
 -- | User-friendly pretty-printing for textual user interfaces (TUI)
 module Cardano.CLI.Json.Friendly
@@ -39,7 +42,7 @@ import           Cardano.Api as Api
 import           Cardano.Api.Byron (KeyWitness (ByronKeyWitness))
 import qualified Cardano.Api.Ledger as L
 import           Cardano.Api.Shelley (Address (ShelleyAddress), Hash (..),
-                   KeyWitness (ShelleyBootstrapWitness, ShelleyKeyWitness), Proposal (Proposal),
+                   KeyWitness (ShelleyBootstrapWitness, ShelleyKeyWitness), Proposal (..),
                    ShelleyLedgerEra, StakeAddress (..), fromShelleyPaymentCredential,
                    fromShelleyStakeReference, toShelleyStakeCredential)
 
@@ -62,7 +65,7 @@ import           Data.Char (isAscii)
 import           Data.Function ((&))
 import           Data.Functor ((<&>))
 import qualified Data.Map.Strict as Map
-import           Data.Maybe (catMaybes, isJust, maybeToList)
+import           Data.Maybe
 import           Data.Ratio (numerator)
 import qualified Data.Text as Text
 import           Data.Yaml (array)
@@ -72,7 +75,6 @@ import           GHC.Exts (IsList (..))
 import           GHC.Real (denominator)
 import           GHC.Unicode (isAlphaNum)
 
-{- HLINT ignore "Redundant bracket" -}
 {- HLINT ignore "Move brackets to avoid $" -}
 
 data FriendlyFormat = FriendlyJson | FriendlyYaml
@@ -246,11 +248,13 @@ friendlyTxBodyImpl
               ++ ( monoidForEraInEon @ConwayEraOnwards
                     era
                     ( \cOnwards ->
-                        case txProposalProcedures of
-                          Nothing -> []
-                          Just (Featured _ TxProposalProceduresNone) -> []
-                          Just (Featured _ (TxProposalProcedures lProposals _witnesses)) ->
-                            ["governance actions" .= (friendlyLedgerProposals cOnwards $ toList lProposals)]
+                        conwayEraOnwardsConstraints cOnwards $
+                          case txProposalProcedures of
+                            Nothing -> []
+                            Just (Featured _ TxProposalProceduresNone) -> []
+                            Just (Featured _ (TxProposalProcedures pp bWits)) -> do
+                              let lProposals = toList pp <> maybe [] Map.keys (buildTxWithToMaybe bWits)
+                              ["governance actions" .= (friendlyLedgerProposals cOnwards lProposals)]
                     )
                  )
               ++ ( monoidForEraInEon @ConwayEraOnwards
@@ -702,7 +706,7 @@ friendlyFee = \case
   TxFeeExplicit _ fee -> friendlyLovelace fee
 
 friendlyLovelace :: L.Coin -> Aeson.Value
-friendlyLovelace (L.Coin value) = String $ docToText (pretty value)
+friendlyLovelace value = String $ docToText (pretty value)
 
 friendlyMintValue :: TxMintValue ViewTx era -> Aeson.Value
 friendlyMintValue = \case
@@ -772,7 +776,7 @@ friendlyAuxScripts = \case
   TxAuxScriptsNone -> Null
   TxAuxScripts _ scripts -> String $ textShow scripts
 
-friendlyReferenceInputs :: TxInsReference build era -> Aeson.Value
+friendlyReferenceInputs :: TxInsReference era -> Aeson.Value
 friendlyReferenceInputs TxInsReferenceNone = Null
 friendlyReferenceInputs (TxInsReference _ txins) = toJSON txins
 

cardano-cli/src/Cardano/CLI/Types/Errors/TxValidationError.hs

@@ -10,8 +10,6 @@ module Cardano.CLI.Types.Errors.TxValidationError
   ( TxAuxScriptsValidationError (..)
   , TxGovDuplicateVotes (..)
   , TxNotSupportedInEraValidationError (..)
-  , convToTxProposalProcedures
-  , convertToTxVotingProcedures
   , validateScriptSupportedInEra
   , validateTxAuxScripts
   , validateRequiredSigners
@@ -33,12 +31,7 @@ import           Cardano.CLI.Types.Common
 
 import           Prelude
 
-import           Control.Monad (foldM)
 import           Data.Bifunctor (first)
-import           Data.Map.Strict (Map)
-import qualified Data.Map.Strict as Map
-import           Data.Maybe
-import qualified Data.OSet.Strict as OSet
 import qualified Data.Text as T
 import           Prettyprinter (viaShow)
 
@@ -107,14 +100,16 @@ validateTxCurrentTreasuryValue
   :: ()
   => ShelleyBasedEra era
   -> Maybe TxCurrentTreasuryValue
-  -> Either (TxNotSupportedInEraValidationError era) (Maybe (Featured ConwayEraOnwards era L.Coin))
+  -> Either
+      (TxNotSupportedInEraValidationError era)
+      (Maybe (Featured ConwayEraOnwards era (Maybe L.Coin)))
 validateTxCurrentTreasuryValue sbe mCurrentTreasuryValue =
   case mCurrentTreasuryValue of
     Nothing -> Right Nothing
     Just (TxCurrentTreasuryValue{unTxCurrentTreasuryValue}) ->
       caseShelleyToBabbageOrConwayEraOnwards
-        (const $ Left $ TxNotSupportedInShelleyBasedEraValidationError "Current treasury value" sbe)
-        (\cOnwards -> Right $ Just $ Featured cOnwards unTxCurrentTreasuryValue)
+        (const . Left $ TxNotSupportedInShelleyBasedEraValidationError "Current treasury value" sbe)
+        (const . pure . mkFeatured $ pure unTxCurrentTreasuryValue)
         sbe
 
 validateTxTreasuryDonation
@@ -127,8 +122,8 @@ validateTxTreasuryDonation sbe mTreasuryDonation =
     Nothing -> Right Nothing
     Just (TxTreasuryDonation{unTxTreasuryDonation}) ->
       caseShelleyToBabbageOrConwayEraOnwards
-        (const $ Left $ TxNotSupportedInShelleyBasedEraValidationError "Treasury donation" sbe)
-        (\cOnwards -> Right $ Just $ Featured cOnwards unTxTreasuryDonation)
+        (const . Left $ TxNotSupportedInShelleyBasedEraValidationError "Treasury donation" sbe)
+        (const . pure $ mkFeatured unTxTreasuryDonation)
         sbe
 
 validateTxReturnCollateral
@@ -224,21 +219,6 @@ conjureWitness era errF =
   maybe (cardanoEraConstraints era $ Left . errF $ AnyCardanoEra era) Right $
     forEraMaybeEon era
 
-getVotingScriptCredentials
-  :: VotingProcedures era
-  -> Maybe (L.Voter (L.EraCrypto (ShelleyLedgerEra era)))
-getVotingScriptCredentials (VotingProcedures (L.VotingProcedures m)) =
-  listToMaybe $ Map.keys m
-
-votingScriptWitnessSingleton
-  :: VotingProcedures era
-  -> Maybe (ScriptWitness WitCtxStake era)
-  -> Map (L.Voter (L.EraCrypto (ShelleyLedgerEra era))) (ScriptWitness WitCtxStake era)
-votingScriptWitnessSingleton _ Nothing = Map.empty
-votingScriptWitnessSingleton votingProcedures (Just scriptWitness) =
-  let voter = fromJust $ getVotingScriptCredentials votingProcedures
-   in Map.singleton voter scriptWitness
-
 newtype TxGovDuplicateVotes era
   = TxGovDuplicateVotes (VotesMergingConflict era)
 
@@ -247,40 +227,3 @@ instance Error (TxGovDuplicateVotes era) where
     "Trying to merge votes with similar action identifiers: "
       <> viaShow actionIds
       <> ". This would cause ignoring some of the votes, so not proceeding."
-
--- TODO: We fold twice, we can do it in a single fold
-convertToTxVotingProcedures
-  :: [(VotingProcedures era, Maybe (ScriptWitness WitCtxStake era))]
-  -> Either (TxGovDuplicateVotes era) (TxVotingProcedures BuildTx era)
-convertToTxVotingProcedures votingProcedures = do
-  VotingProcedures procedure <-
-    first TxGovDuplicateVotes $
-      foldM f emptyVotingProcedures votingProcedures
-  pure $ TxVotingProcedures procedure (BuildTxWith votingScriptWitnessMap)
- where
-  votingScriptWitnessMap =
-    foldl
-      (\acc next -> acc `Map.union` uncurry votingScriptWitnessSingleton next)
-      Map.empty
-      votingProcedures
-  f acc (procedure, _witness) = mergeVotingProcedures acc procedure
-
-proposingScriptWitnessSingleton
-  :: Proposal era
-  -> Maybe (ScriptWitness WitCtxStake era)
-  -> Map (L.ProposalProcedure (ShelleyLedgerEra era)) (ScriptWitness WitCtxStake era)
-proposingScriptWitnessSingleton _ Nothing = Map.empty
-proposingScriptWitnessSingleton (Proposal proposalProcedure) (Just scriptWitness) =
-  Map.singleton proposalProcedure scriptWitness
-
-convToTxProposalProcedures
-  :: L.EraPParams (ShelleyLedgerEra era)
-  => [(Proposal era, Maybe (ScriptWitness WitCtxStake era))]
-  -> TxProposalProcedures BuildTx era
-convToTxProposalProcedures proposalProcedures =
-  -- TODO: Ledger does not export snoc so we can't fold here.
-  let proposals = OSet.fromFoldable $ map (unProposal . fst) proposalProcedures
-      sWitMap = BuildTxWith $ foldl sWitMapFolder Map.empty proposalProcedures
-   in TxProposalProcedures proposals sWitMap
- where
-  sWitMapFolder sWitMapAccum nextSWit = sWitMapAccum `Map.union` uncurry proposingScriptWitnessSingleton nextSWit