diff --git a/cardano-cli/src/Cardano/CLI/Byron/Tx.hs b/cardano-cli/src/Cardano/CLI/Byron/Tx.hs index 2a57161cb3..517dcc26bd 100644 --- a/cardano-cli/src/Cardano/CLI/Byron/Tx.hs +++ b/cardano-cli/src/Cardano/CLI/Byron/Tx.hs @@ -107,7 +107,7 @@ genesisUTxOTxIn gc vk genAddr = where initialUtxo :: Map Common.Address (UTxO.TxIn, UTxO.TxOut) initialUtxo = - Map.fromList + fromList . mapMaybe (\(inp, out) -> mkEntry inp genAddr <$> keyMatchesUTxO vk out) . fromCompactTxInTxOutList . toList diff --git a/cardano-cli/src/Cardano/CLI/EraBased/Options/Common.hs b/cardano-cli/src/Cardano/CLI/EraBased/Options/Common.hs index 652d35591c..a3309d3ce0 100644 --- a/cardano-cli/src/Cardano/CLI/EraBased/Options/Common.hs +++ b/cardano-cli/src/Cardano/CLI/EraBased/Options/Common.hs @@ -35,14 +35,13 @@ import Data.Foldable import Data.Functor (($>)) import qualified Data.IP as IP import Data.List.NonEmpty (NonEmpty) -import qualified Data.List.NonEmpty as NE import Data.Maybe -import qualified Data.Set as Set import Data.Text (Text) import qualified Data.Text as Text import Data.Time.Clock (UTCTime) import Data.Time.Format (defaultTimeLocale, parseTimeOrError) import Data.Word +import GHC.Exts (IsList (..)) import GHC.Natural (Natural) import Network.Socket (PortNumber) import Options.Applicative hiding (help, str) @@ -328,7 +327,7 @@ readVerificationKey asType = Opt.eitherReader deserialiseFromBech32OrHex where keyFormats :: NonEmpty (InputFormat (VerificationKey keyrole)) - keyFormats = NE.fromList [InputFormatBech32, InputFormatHex] + keyFormats = fromList [InputFormatBech32, InputFormatHex] deserialiseFromBech32OrHex :: String @@ -2747,7 +2746,7 @@ pQueryUTxOFilter = ] pQueryUTxOByAddress :: Parser QueryUTxOFilter - pQueryUTxOByAddress = QueryUTxOByAddress . Set.fromList <$> some pByAddress + pQueryUTxOByAddress = QueryUTxOByAddress . fromList <$> some pByAddress pByAddress :: Parser AddressAny pByAddress = @@ -2759,7 +2758,7 @@ pQueryUTxOFilter = ] pQueryUTxOByTxIn :: Parser QueryUTxOFilter - pQueryUTxOByTxIn = QueryUTxOByTxIn . Set.fromList <$> some pByTxIn + pQueryUTxOByTxIn = QueryUTxOByTxIn . fromList <$> some pByTxIn pByTxIn :: Parser TxIn pByTxIn = diff --git a/cardano-cli/src/Cardano/CLI/EraBased/Run/Genesis.hs b/cardano-cli/src/Cardano/CLI/EraBased/Run/Genesis.hs index d0e5b8ed0a..f1d6551c9f 100644 --- a/cardano-cli/src/Cardano/CLI/EraBased/Run/Genesis.hs +++ b/cardano-cli/src/Cardano/CLI/EraBased/Run/Genesis.hs @@ -370,7 +370,7 @@ generateShelleyNodeSecrets shelleyDelegateKeys shelleyGenesisvkeys = do -> (Hash GenesisKey, (Hash GenesisDelegateKey, Hash VrfKey)) hashKeys (genesis, delegate, vrf) = (verificationKeyHash genesis, (verificationKeyHash delegate, verificationKeyHash vrf)) delegateMap :: Map (Hash GenesisKey) (Hash GenesisDelegateKey, Hash VrfKey) - delegateMap = Map.fromList . map hashKeys $ combinedMap + delegateMap = fromList . map hashKeys $ combinedMap return (delegateMap, vrfKeys, kesKeys, opCerts) @@ -769,7 +769,7 @@ updateOutputTemplate , sgMaxLovelaceSupply = fromIntegral $ nonDelegCoin + delegCoin , sgGenDelegs = shelleyDelKeys , sgInitialFunds = - ListMap.fromList + fromList [ (toShelleyAddr addr, v) | (addr, v) <- distribute (nonDelegCoin - subtractForTreasury) nUtxoAddrsNonDeleg utxoAddrsNonDeleg @@ -806,7 +806,7 @@ updateOutputTemplate L.Coin minUtxoVal = sgProtocolParams ^. L.ppMinUTxOValueL shelleyDelKeys = - Map.fromList + fromList [ (gh, L.GenDelegPair gdh h) | ( GenesisKeyHash gh , (GenesisDelegateKeyHash gdh, VrfKeyHash h) @@ -956,7 +956,7 @@ buildPoolParams nw dir index specifiedRelays = do lookupPoolRelay m = case index of Nothing -> mempty - Just index' -> maybe mempty Seq.fromList (Map.lookup index' m) + Just index' -> maybe mempty fromList (Map.lookup index' m) strIndex = maybe "" show index poolColdVKF = File $ dir "cold" ++ strIndex ++ ".vkey" @@ -1080,7 +1080,7 @@ updateTemplate , sgMaxLovelaceSupply = fromIntegral $ nonDelegCoin + delegCoin , sgGenDelegs = shelleyDelKeys , sgInitialFunds = - ListMap.fromList + fromList [ (toShelleyAddr addr, v) | (addr, v) <- distribute (nonDelegCoin - subtractForTreasury) utxoAddrsNonDeleg @@ -1090,7 +1090,7 @@ updateTemplate , sgStaking = ShelleyGenesisStaking { sgsPools = - ListMap.fromList + fromList [ (L.ppId poolParams, poolParams) | poolParams <- Map.elems poolSpecs ] @@ -1133,7 +1133,7 @@ updateTemplate L.Coin minUtxoVal = sgProtocolParams template ^. L.ppMinUTxOValueL shelleyDelKeys = - Map.fromList + fromList [ (gh, L.GenDelegPair gdh h) | ( GenesisKeyHash gh , (GenesisDelegateKeyHash gdh, VrfKeyHash h) @@ -1218,7 +1218,7 @@ readGenDelegsMap gendir deldir = do (Hash GenesisKey) (Hash GenesisDelegateKey, Hash VrfKey) delegsMap = - Map.fromList + fromList [ (gh, (dh, vh)) | (g, (d, v)) <- Map.elems combinedMap , let gh = verificationKeyHash g @@ -1243,7 +1243,7 @@ readGenesisKeys gendir = do , takeExtension file == ".vkey" ] firstExceptT GenesisCmdTextEnvReadFileError $ - Map.fromList + fromList <$> sequence [ (,) ix <$> readKey (File file) | (file, ix) <- fileIxs @@ -1268,7 +1268,7 @@ readDelegateKeys deldir = do , takeExtensions file == ".vkey" ] firstExceptT GenesisCmdTextEnvReadFileError $ - Map.fromList + fromList <$> sequence [ (,) ix <$> readKey (File file) | (file, ix) <- fileIxs @@ -1293,7 +1293,7 @@ readDelegateVrfKeys deldir = do , takeExtensions file == ".vrf.vkey" ] firstExceptT GenesisCmdTextEnvReadFileError $ - Map.fromList + fromList <$> sequence [ (,) ix <$> readKey (File file) | (file, ix) <- fileIxs diff --git a/cardano-cli/src/Cardano/CLI/EraBased/Run/Genesis/CreateTestnetData.hs b/cardano-cli/src/Cardano/CLI/EraBased/Run/Genesis/CreateTestnetData.hs index f12c6c7588..c970693536 100644 --- a/cardano-cli/src/Cardano/CLI/EraBased/Run/Genesis/CreateTestnetData.hs +++ b/cardano-cli/src/Cardano/CLI/EraBased/Run/Genesis/CreateTestnetData.hs @@ -57,8 +57,7 @@ import qualified Data.Aeson as Aeson import Data.Bifunctor (Bifunctor (..)) import qualified Data.ByteString.Lazy.Char8 as LBS import Data.ListMap (ListMap (..)) -import qualified Data.ListMap as ListMap -import Data.Map.Strict (Map, fromList, toList) +import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map import Data.Maybe (fromMaybe) import qualified Data.Sequence.Strict as Seq @@ -66,6 +65,7 @@ import Data.String (fromString) import qualified Data.Text as Text import Data.Tuple (swap) import Data.Word (Word64) +import GHC.Exts (IsList (..)) import GHC.Generics (Generic) import GHC.Num (Natural) import Lens.Micro ((^.)) @@ -350,7 +350,7 @@ runGenesisCreateTestNetDataCmd :: [(VerificationKey StakeKey, VerificationKey DRepKey)] -> ListMap (L.Credential L.Staking L.StandardCrypto) (L.Delegatee L.StandardCrypto) delegs = - ListMap.fromList + fromList . map ( bimap verificationKeytoStakeCredential @@ -362,7 +362,7 @@ runGenesisCreateTestNetDataCmd -> [VerificationKey DRepKey] -> ListMap (L.Credential L.DRepRole L.StandardCrypto) (L.DRepState L.StandardCrypto) initialDReps minDeposit = - ListMap.fromList + fromList . map ( \c -> ( verificationKeyToDRepCredential c @@ -627,7 +627,7 @@ buildPoolParams nw dir index specifiedRelays = do } where lookupPoolRelay :: Map Word [L.StakePoolRelay] -> Seq.StrictSeq L.StakePoolRelay - lookupPoolRelay m = Seq.fromList $ Map.findWithDefault [] index m + lookupPoolRelay m = fromList $ Map.findWithDefault [] index m poolColdVKF = File $ dir "cold.vkey" poolVrfVKF = File $ dir "vrf.vkey" poolRewardVKF = File $ dir "staking-reward.vkey" @@ -705,7 +705,7 @@ updateOutputTemplate , sgMaxLovelaceSupply = totalSupply , sgGenDelegs = shelleyDelKeys , sgInitialFunds = - ListMap.fromList + fromList [ (toShelleyAddr addr, v) | (addr, v) <- distribute nonDelegCoin nUtxoAddrsNonDeleg utxoAddrsNonDeleg @@ -754,7 +754,7 @@ updateOutputTemplate where L.Coin minUtxoVal = sgProtocolParams ^. L.ppMinUTxOValueL shelleyDelKeys = - Map.fromList + fromList [ (gh, L.GenDelegPair gdh h) | ( GenesisKeyHash gh , (GenesisDelegateKeyHash gdh, VrfKeyHash h) @@ -811,7 +811,7 @@ readGenDelegsMap genesisKeys delegateKeys delegateVrfKeys = do (Hash GenesisKey) (Hash GenesisDelegateKey, Hash VrfKey) delegsMap = - Map.fromList + fromList [ (gh, (dh, vh)) | (g, (d, v)) <- Map.elems combinedMap , let gh = verificationKeyHash g @@ -832,7 +832,7 @@ readKeys -> ExceptT GenesisCmdError IO (Map k a) readKeys asType genesisVKeys = do firstExceptT GenesisCmdTextEnvReadFileError $ - Map.fromList + fromList <$> sequence [ (,) ix <$> readKey (File file) | (ix, file) <- toList genesisVKeys diff --git a/cardano-cli/src/Cardano/CLI/EraBased/Run/Governance.hs b/cardano-cli/src/Cardano/CLI/EraBased/Run/Governance.hs index 328cefd02c..18bd606d4d 100644 --- a/cardano-cli/src/Cardano/CLI/EraBased/Run/Governance.hs +++ b/cardano-cli/src/Cardano/CLI/EraBased/Run/Governance.hs @@ -31,7 +31,7 @@ import Cardano.CLI.Types.Errors.GovernanceCmdError import Control.Monad import Data.Function -import qualified Data.Map.Strict as Map +import GHC.Exts (IsList (..)) runGovernanceCmds :: () @@ -84,7 +84,7 @@ runGovernanceMIRCertificatePayStakeAddrs w mirPot sAddrs rwdAmts oFp = do let sCreds = map stakeAddressCredential sAddrs mirTarget = L.StakeAddressesMIR $ - Map.fromList + fromList [ (toShelleyStakeCredential scred, L.toDeltaCoin rwdAmt) | (scred, rwdAmt) <- zip sCreds rwdAmts ] diff --git a/cardano-cli/src/Cardano/CLI/EraBased/Run/Query.hs b/cardano-cli/src/Cardano/CLI/EraBased/Run/Query.hs index 417dc1799f..39d84ffee7 100644 --- a/cardano-cli/src/Cardano/CLI/EraBased/Run/Query.hs +++ b/cardano-cli/src/Cardano/CLI/EraBased/Run/Query.hs @@ -697,7 +697,7 @@ runQueryPoolStateCmd let poolFilter = case allOrOnlyPoolIds of All -> Nothing - Only poolIds -> Just $ Set.fromList poolIds + Only poolIds -> Just $ fromList poolIds result <- lift (queryPoolState beo poolFilter) @@ -834,7 +834,7 @@ runQueryStakeSnapshotCmd let poolFilter = case allOrOnlyPoolIds of All -> Nothing - Only poolIds -> Just $ Set.fromList poolIds + Only poolIds -> Just $ fromList poolIds beo <- requireEon BabbageEra era @@ -1102,16 +1102,17 @@ writePoolState mOutFile serialisedCurrentEpochState = do pure (decodePoolState serialisedCurrentEpochState) & onLeft (left . QueryCmdPoolStateDecodeError) - let hks = + let hks :: [L.KeyHash L.StakePool StandardCrypto] + hks = toList $ - Set.fromList $ + fromList @(Set (L.KeyHash L.StakePool StandardCrypto)) $ Map.keys (L.psStakePoolParams poolState) <> Map.keys (L.psFutureStakePoolParams poolState) <> Map.keys (L.psRetiring poolState) let poolStates :: Map (L.KeyHash 'L.StakePool StandardCrypto) (Params StandardCrypto) poolStates = - Map.fromList $ + fromList $ hks <&> ( \hk -> ( hk @@ -1642,13 +1643,13 @@ runQueryDRepState let drepHashSources = case drepHashSources' of All -> []; Only l -> l drepCreds <- modifyError QueryCmdDRepKeyError $ mapM readDRepCredential drepHashSources - drepState <- runQuery localNodeConnInfo target $ queryDRepState eon $ Set.fromList drepCreds + drepState <- runQuery localNodeConnInfo target $ queryDRepState eon $ fromList drepCreds drepStakeDistribution <- case includeStake of Cmd.WithStake -> runQuery localNodeConnInfo target $ - queryDRepStakeDistribution eon (Set.fromList $ L.DRepCredential <$> drepCreds) + queryDRepStakeDistribution eon (fromList $ L.DRepCredential <$> drepCreds) Cmd.NoStake -> return mempty writeOutput mOutFile $ @@ -1695,7 +1696,7 @@ runQueryDRepStakeDistribution drepHashSources = case drepHashSources' of All -> [] Only l -> l - dreps <- Set.fromList <$> mapM drepFromSource drepHashSources + dreps <- fromList <$> mapM drepFromSource drepHashSources drepStakeDistribution <- runQuery localNodeConnInfo target $ queryDRepStakeDistribution eon dreps writeOutput mOutFile $ @@ -1721,16 +1722,16 @@ runQueryCommitteeMembersState let coldKeysFromVerKeyHashOrFile = modifyError QueryCmdCommitteeColdKeyError . readVerificationKeyOrHashOrFileOrScriptHash AsCommitteeColdKey unCommitteeColdKeyHash - coldKeys <- Set.fromList <$> mapM coldKeysFromVerKeyHashOrFile coldCredKeys + coldKeys <- fromList <$> mapM coldKeysFromVerKeyHashOrFile coldCredKeys let hotKeysFromVerKeyHashOrFile = modifyError QueryCmdCommitteeHotKeyError . readVerificationKeyOrHashOrFileOrScriptHash AsCommitteeHotKey unCommitteeHotKeyHash - hotKeys <- Set.fromList <$> mapM hotKeysFromVerKeyHashOrFile hotCredKeys + hotKeys <- fromList <$> mapM hotKeysFromVerKeyHashOrFile hotCredKeys committeeState <- runQuery localNodeConnInfo target $ - queryCommitteeMembersState eon coldKeys hotKeys (Set.fromList memberStatuses) + queryCommitteeMembersState eon coldKeys hotKeys (fromList memberStatuses) writeOutput mOutFile $ A.toJSON committeeState runQueryTreasuryValue diff --git a/cardano-cli/src/Cardano/CLI/EraBased/Run/Transaction.hs b/cardano-cli/src/Cardano/CLI/EraBased/Run/Transaction.hs index fb135e0d5c..9046e30b36 100644 --- a/cardano-cli/src/Cardano/CLI/EraBased/Run/Transaction.hs +++ b/cardano-cli/src/Cardano/CLI/EraBased/Run/Transaction.hs @@ -67,7 +67,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 (..)) +import Data.Foldable (foldl') import Data.Function ((&)) import qualified Data.List as List import Data.Map.Strict (Map) @@ -78,6 +78,7 @@ import qualified Data.Set as Set import qualified Data.Text as Text import qualified Data.Text.IO as Text import Data.Type.Equality (TestEquality (..)) +import GHC.Exts (IsList (..)) import Lens.Micro ((^.)) import qualified System.IO as IO @@ -199,7 +200,7 @@ runTransactionBuildCmd <$> readTxGovernanceActions eon proposalFiles -- the same collateral input can be used for several plutus scripts - let filteredTxinsc = toList $ Set.fromList txinsc + let filteredTxinsc = toList @(Set _) $ fromList txinsc let allReferenceInputs = getAllReferenceInputs @@ -377,7 +378,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.fromList txInsCollateral + let filteredTxinsc = toList @(Set _) $ fromList txInsCollateral -- Conway related votingProceduresAndMaybeScriptWits <- @@ -430,12 +431,12 @@ runTransactionBuildEstimateCmd -- TODO change type votingProceduresAndMaybeScriptWits proposals currentTreasuryValueAndDonation - let stakeCredentialsToDeregisterMap = Map.fromList $ catMaybes [getStakeDeregistrationInfo cert | (cert, _) <- certsAndMaybeScriptWits] - drepsToDeregisterMap = Map.fromList $ catMaybes [getDRepDeregistrationInfo cert | (cert, _) <- certsAndMaybeScriptWits] - poolsToDeregister = Set.fromList $ catMaybes [getPoolDeregistrationInfo cert | (cert, _) <- certsAndMaybeScriptWits] + let stakeCredentialsToDeregisterMap = fromList $ catMaybes [getStakeDeregistrationInfo cert | (cert, _) <- certsAndMaybeScriptWits] + drepsToDeregisterMap = fromList $ catMaybes [getDRepDeregistrationInfo cert | (cert, _) <- certsAndMaybeScriptWits] + poolsToDeregister = fromList $ catMaybes [getPoolDeregistrationInfo cert | (cert, _) <- certsAndMaybeScriptWits] totCol = fromMaybe 0 plutusCollateral pScriptExecUnits = - Map.fromList + fromList [ (sWitIndex, execUnits) | (sWitIndex, AnyScriptWitness (PlutusScriptWitness _ _ _ _ _ execUnits)) <- collectTxBodyScriptWitnesses sbe txBodyContent @@ -616,7 +617,7 @@ runTransactionBuildRawCmd txOuts <- mapM (toTxOutInAnyEra eon) txouts -- the same collateral input can be used for several plutus scripts - let filteredTxinsc = toList $ Set.fromList txInsCollateral + let filteredTxinsc = toList @(Set _) $ fromList txInsCollateral -- Conway related votingProceduresAndMaybeScriptWits <- @@ -849,7 +850,8 @@ constructTxBodyContent validatedTxScriptValidity <- first TxCmdNotSupportedInEraValidationError $ validateTxScriptValidity sbe mScriptValidity validatedVotingProcedures <- - first TxCmdTxGovDuplicateVotes $ convertToTxVotingProcedures votingProcedures + first (TxCmdTxGovDuplicateVotes . TxGovDuplicateVotes) $ + mkTxVotingProcedures @BuildTx (fromList votingProcedures) validatedCurrentTreasuryValue <- first TxCmdNotSupportedInEraValidationError @@ -859,7 +861,8 @@ constructTxBodyContent TxCmdNotSupportedInEraValidationError (validateTxTreasuryDonation sbe (snd <$> mCurrentTreasuryValueAndDonation)) return $ - shelleyBasedEraConstraints sbe $ + shelleyBasedEraConstraints + sbe ( defaultTxBodyContent sbe & setTxIns (validateTxIns inputsAndMaybeScriptWits) & setTxInsCollateral validatedCollateralTxIns @@ -879,14 +882,11 @@ constructTxBodyContent & setTxUpdateProposal txUpdateProposal & setTxMintValue validatedMintValue & setTxScriptValidity validatedTxScriptValidity + & setTxVotingProcedures (mkFeatured validatedVotingProcedures) + & setTxProposalProcedures (mkFeatured $ mkTxProposalProcedures (fromList proposals)) + & 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)) @@ -1073,7 +1073,7 @@ convertCertificates sbe certsAndScriptWitnesses = TxCertificates sbe certs $ BuildTxWith reqWits where certs = map fst certsAndScriptWitnesses - reqWits = Map.fromList $ mapMaybe convert certsAndScriptWitnesses + reqWits = fromList $ mapMaybe convert certsAndScriptWitnesses convert :: (Certificate era, Maybe (ScriptWitness WitCtxStake era)) -> Maybe (StakeCredential, Witness WitCtxStake era) @@ -1130,7 +1130,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) @@ -1161,16 +1161,16 @@ getAllReferenceInputs votesWitByRefInputs = [getReferenceInput sWit | (_, Just sWit) <- votingProceduresAndMaybeScriptWits] propsWitByRefInputs = [getReferenceInput sWit | (_, Just sWit) <- propProceduresAnMaybeScriptWits] - catMaybes $ - concat - [ txinsWitByRefInputs - , mintingRefInputs - , certsWitByRefInputs - , withdrawalsWitByRefInputs - , votesWitByRefInputs - , propsWitByRefInputs - , map Just readOnlyRefIns - ] + concatMap + catMaybes + [ txinsWitByRefInputs + , mintingRefInputs + , certsWitByRefInputs + , withdrawalsWitByRefInputs + , votesWitByRefInputs + , propsWitByRefInputs + , map Just readOnlyRefIns + ] where getReferenceInput :: ScriptWitness witctx era -> Maybe TxIn @@ -1334,10 +1334,10 @@ createTxMintValue era (val, scriptWitnesses) = -- The set of policy ids for which we need witnesses: let witnessesNeededSet :: Set PolicyId witnessesNeededSet = - Set.fromList [pid | (AssetId pid _, _) <- valueToList val] + fromList [pid | (AssetId pid _, _) <- valueToList val] let witnessesProvidedMap :: Map PolicyId (ScriptWitness WitCtxMint era) - witnessesProvidedMap = Map.fromList $ gatherMintingWitnesses scriptWitnesses + witnessesProvidedMap = fromList $ gatherMintingWitnesses scriptWitnesses witnessesProvidedSet = Map.keysSet witnessesProvidedMap -- Check not too many, nor too few: diff --git a/cardano-cli/src/Cardano/CLI/Json/Friendly.hs b/cardano-cli/src/Cardano/CLI/Json/Friendly.hs index b9cf5c6fe1..70d7f51b9a 100644 --- a/cardano-cli/src/Cardano/CLI/Json/Friendly.hs +++ b/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,9 +42,10 @@ 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), - ShelleyLedgerEra, StakeAddress (..), fromShelleyPaymentCredential, - fromShelleyStakeReference, toShelleyStakeCredential) + KeyWitness (ShelleyBootstrapWitness, ShelleyKeyWitness), + Proposal (Proposal, unProposal), ShelleyLedgerEra, StakeAddress (..), + fromShelleyPaymentCredential, fromShelleyStakeReference, + toShelleyStakeCredential) import Cardano.CLI.Types.Common (ViewOutputFormat (..)) import Cardano.CLI.Types.MonadWarning (MonadWarning, eitherToWarning, runWarningIO) @@ -62,10 +66,9 @@ 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 qualified Data.Vector as Vector import Data.Yaml (array) import Data.Yaml.Pretty (setConfCompare) import qualified Data.Yaml.Pretty as Yaml @@ -73,7 +76,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 @@ -247,11 +249,12 @@ 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 _ proposals) -> fromMaybe [] $ do + lProposals <- map (unProposal . fst) . toList <$> getProposalProcedures proposals + pure ["governance actions" .= friendlyLedgerProposals cOnwards lProposals] ) ) ++ ( monoidForEraInEon @ConwayEraOnwards @@ -277,7 +280,7 @@ friendlyTxBodyImpl friendlyLedgerProposals :: ConwayEraOnwards era -> [L.ProposalProcedure (ShelleyLedgerEra era)] -> Aeson.Value friendlyLedgerProposals cOnwards proposalProcedures = - Array $ Vector.fromList $ map (friendlyLedgerProposal cOnwards) proposalProcedures + Array $ fromList $ map (friendlyLedgerProposal cOnwards) proposalProcedures friendlyLedgerProposal :: ConwayEraOnwards era -> L.ProposalProcedure (ShelleyLedgerEra era) -> Aeson.Value @@ -773,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 diff --git a/cardano-cli/src/Cardano/CLI/Types/Errors/TxValidationError.hs b/cardano-cli/src/Cardano/CLI/Types/Errors/TxValidationError.hs index ae6615b6e4..5cd1c6a2ca 100644 --- a/cardano-cli/src/Cardano/CLI/Types/Errors/TxValidationError.hs +++ b/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 diff --git a/cardano-cli/src/Cardano/CLI/Types/Key.hs b/cardano-cli/src/Cardano/CLI/Types/Key.hs index 5fb56aa5fe..1f96066b00 100644 --- a/cardano-cli/src/Cardano/CLI/Types/Key.hs +++ b/cardano-cli/src/Cardano/CLI/Types/Key.hs @@ -50,9 +50,9 @@ import Cardano.CLI.Types.Common import Data.Bifunctor (Bifunctor (..)) import qualified Data.ByteString as BS -import qualified Data.List.NonEmpty as NE import Data.Text (Text) import qualified Data.Text.Encoding as Text +import GHC.Exts (IsList (..)) ------------------------------------------------------------------------------ -- Verification key deserialisation @@ -94,7 +94,7 @@ readVerificationKeyOrFile asType verKeyOrFile = hoistIOEither $ readKeyFile (AsVerificationKey asType) - (NE.fromList [InputFormatBech32, InputFormatHex, InputFormatTextEnvelope]) + (fromList [InputFormatBech32, InputFormatHex, InputFormatTextEnvelope]) fp -- | Read a verification key or verification key file and return a diff --git a/cardano-cli/test/cardano-cli-golden/Test/Golden/CreateTestnetData.hs b/cardano-cli/test/cardano-cli-golden/Test/Golden/CreateTestnetData.hs index 8cd2d32e66..c7ca5a7bb9 100644 --- a/cardano-cli/test/cardano-cli-golden/Test/Golden/CreateTestnetData.hs +++ b/cardano-cli/test/cardano-cli-golden/Test/Golden/CreateTestnetData.hs @@ -11,9 +11,9 @@ import qualified Cardano.Ledger.Shelley.API as L import Control.Monad import Control.Monad.IO.Class import Data.List (intercalate, sort) -import qualified Data.ListMap as ListMap import qualified Data.Sequence.Strict as Seq import Data.Word (Word32) +import GHC.Exts (IsList (..)) import System.Directory import System.Directory.Extra (listDirectories) import System.FilePath @@ -177,7 +177,7 @@ hprop_golden_create_testnet_data_deleg_non_deleg = -- Because we don't test this elsewhere in this file: (L.sgMaxLovelaceSupply genesis) H.=== (fromIntegral totalSupply) - let initialFunds = ListMap.toList $ L.sgInitialFunds genesis + let initialFunds = toList $ L.sgInitialFunds genesis -- This checks that there is actually only one funded address (length initialFunds) H.=== 1 diff --git a/cardano-cli/test/cardano-cli-golden/Test/Golden/Shelley/Genesis/Create.hs b/cardano-cli/test/cardano-cli-golden/Test/Golden/Shelley/Genesis/Create.hs index 49b1012715..cdec6c7ed3 100644 --- a/cardano-cli/test/cardano-cli-golden/Test/Golden/Shelley/Genesis/Create.hs +++ b/cardano-cli/test/cardano-cli-golden/Test/Golden/Shelley/Genesis/Create.hs @@ -42,7 +42,7 @@ parseSystemStart :: J.Value -> J.Parser String parseSystemStart = J.withObject "Object" $ \o -> o J..: "systemStart" parseHashMap :: J.Value -> J.Parser (HM.HashMap String J.Value) -parseHashMap (J.Object hm) = pure $ HM.fromList $ fmap (first J.toString) (toList hm) +parseHashMap (J.Object hm) = pure $ fromList $ fmap (first J.toString) (toList hm) parseHashMap v = J.typeMismatch "Object" v parseDelegateCount :: J.Value -> J.Parser Int @@ -134,12 +134,12 @@ hprop_golden_shelleyGenesisCreate = propertyOnce $ do -- required for stake pool rewards. -- Check uniqueness and count of hash keys - S.size (S.fromList actualHashKeys) === length actualHashKeys -- This isn't strictly necessary because we use aeson which guarantees uniqueness of keys - S.size (S.fromList actualHashKeys) === delegateCount + S.size (fromList actualHashKeys) === length actualHashKeys -- This isn't strictly necessary because we use aeson which guarantees uniqueness of keys + S.size (fromList actualHashKeys) === delegateCount -- Check uniqueness and count of hash keys - S.size (S.fromList actualDelegateKeys) === length actualDelegateKeys - S.size (S.fromList actualDelegateKeys) === delegateCount + S.size (fromList actualDelegateKeys) === length actualDelegateKeys + S.size (fromList actualDelegateKeys) === delegateCount for_ [1 .. delegateCount] $ \i -> do -- Check Genesis keys @@ -230,12 +230,12 @@ hprop_golden_shelleyGenesisCreate = propertyOnce $ do -- We don't use the entire supply so there is ada in the treasury. This is -- required for stake pool rewards. -- Check uniqueness and count of hash keys - S.size (S.fromList actualHashKeys) === length actualHashKeys -- This isn't strictly necessary because we use aeson which guarantees uniqueness of keys - S.size (S.fromList actualHashKeys) === delegateCount + S.size (fromList actualHashKeys) === length actualHashKeys -- This isn't strictly necessary because we use aeson which guarantees uniqueness of keys + S.size (fromList actualHashKeys) === delegateCount -- Check uniqueness and count of hash keys - S.size (S.fromList actualDelegateKeys) === length actualDelegateKeys - S.size (S.fromList actualDelegateKeys) === delegateCount + S.size (fromList actualDelegateKeys) === length actualDelegateKeys + S.size (fromList actualDelegateKeys) === delegateCount for_ [1 .. delegateCount] $ \i -> do -- Check Genesis keys diff --git a/cardano-cli/test/cardano-cli-test/Test/Cli/JSON.hs b/cardano-cli/test/cardano-cli-test/Test/Cli/JSON.hs index e199661b5c..dcf2b3e24c 100644 --- a/cardano-cli/test/cardano-cli-test/Test/Cli/JSON.hs +++ b/cardano-cli/test/cardano-cli-test/Test/Cli/JSON.hs @@ -16,6 +16,7 @@ import qualified Data.Map.Strict as Map import Data.Time import Data.Time.Clock.POSIX (posixSecondsToUTCTime) import Data.Word (Word64) +import GHC.Exts (IsList (..)) import Test.Gen.Cardano.Api.Typed (genLovelace, genSlotNo, genStakeAddress, genVerificationKeyHash) @@ -36,9 +37,9 @@ genDelegationsAndRewards = do let r = Range.constant 0 3 sAddrs <- Gen.list r genStakeAddress sLovelace <- Gen.list r genLovelace - let delegMapAmt = Map.fromList $ zip sAddrs sLovelace + let delegMapAmt = fromList $ zip sAddrs sLovelace poolIDs <- Gen.list r genPoolId - let delegMapPool = Map.fromList $ zip sAddrs poolIDs + let delegMapPool = fromList $ zip sAddrs poolIDs return $ DelegationsAndRewards (delegMapAmt, delegMapPool) genOpCertIntervalInformation :: Gen OpCertIntervalInformation