From 5f9537f4f74a6613fce5df270099b4401cdf4c20 Mon Sep 17 00:00:00 2001 From: John Ky Date: Sun, 15 Oct 2023 00:03:40 +1100 Subject: [PATCH 1/4] Move ShelleyBasedEraConstraints and shelleyBasedEraConstraints to ShelleyBasedEra module --- cardano-api/internal/Cardano/Api/Block.hs | 1 - .../internal/Cardano/Api/Certificate.hs | 1 - .../Cardano/Api/Eon/ShelleyBasedEra.hs | 50 +++++++++++++++++ cardano-api/internal/Cardano/Api/Eras/Case.hs | 1 - .../internal/Cardano/Api/Eras/Constraints.hs | 53 ------------------- cardano-api/internal/Cardano/Api/Fees.hs | 1 - .../Governance/Actions/ProposalProcedure.hs | 1 - .../Api/Governance/Actions/VotingProcedure.hs | 2 - .../internal/Cardano/Api/LedgerState.hs | 1 - .../Cardano/Api/ProtocolParameters.hs | 1 - cardano-api/internal/Cardano/Api/Query.hs | 1 - .../internal/Cardano/Api/Query/Types.hs | 1 - cardano-api/internal/Cardano/Api/Tx.hs | 1 - cardano-api/src/Cardano/Api.hs | 1 - 14 files changed, 50 insertions(+), 66 deletions(-) diff --git a/cardano-api/internal/Cardano/Api/Block.hs b/cardano-api/internal/Cardano/Api/Block.hs index 6220a3b73f..addc47313b 100644 --- a/cardano-api/internal/Cardano/Api/Block.hs +++ b/cardano-api/internal/Cardano/Api/Block.hs @@ -53,7 +53,6 @@ module Cardano.Api.Block ( import Cardano.Api.Eon.ShelleyBasedEra import Cardano.Api.Eras -import Cardano.Api.Eras.Constraints import Cardano.Api.Hash import Cardano.Api.HasTypeProxy import Cardano.Api.Keys.Shelley diff --git a/cardano-api/internal/Cardano/Api/Certificate.hs b/cardano-api/internal/Cardano/Api/Certificate.hs index 579b769822..d86e0fda79 100644 --- a/cardano-api/internal/Cardano/Api/Certificate.hs +++ b/cardano-api/internal/Cardano/Api/Certificate.hs @@ -78,7 +78,6 @@ import Cardano.Api.Eon.ConwayEraOnwards import Cardano.Api.Eon.ShelleyBasedEra import Cardano.Api.Eon.ShelleyToBabbageEra import Cardano.Api.Eras -import Cardano.Api.Eras.Constraints import Cardano.Api.Governance.Actions.VotingProcedure import Cardano.Api.HasTypeProxy import Cardano.Api.Keys.Praos diff --git a/cardano-api/internal/Cardano/Api/Eon/ShelleyBasedEra.hs b/cardano-api/internal/Cardano/Api/Eon/ShelleyBasedEra.hs index 7cb2ee7a2c..1b315d2add 100644 --- a/cardano-api/internal/Cardano/Api/Eon/ShelleyBasedEra.hs +++ b/cardano-api/internal/Cardano/Api/Eon/ShelleyBasedEra.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} @@ -31,19 +32,34 @@ module Cardano.Api.Eon.ShelleyBasedEra -- ** Mapping to era types from the Shelley ledger library , ShelleyLedgerEra , eraProtVerLow + + , ShelleyBasedEraConstraints + , shelleyBasedEraConstraints ) where import Cardano.Api.Eras.Core +import Cardano.Api.Modes +import Cardano.Api.Orphans () +import qualified Cardano.Crypto.Hash.Blake2b as Blake2b +import qualified Cardano.Crypto.Hash.Class as C +import qualified Cardano.Crypto.VRF as C import qualified Cardano.Ledger.Api as L import qualified Cardano.Ledger.BaseTypes as L +import Cardano.Ledger.Binary (FromCBOR) +import qualified Cardano.Ledger.Core as L +import qualified Cardano.Ledger.SafeHash as L +import qualified Ouroboros.Consensus.Protocol.Abstract as Consensus +import qualified Ouroboros.Consensus.Protocol.Praos.Common as Consensus import Ouroboros.Consensus.Shelley.Eras as Consensus (StandardAllegra, StandardAlonzo, StandardBabbage, StandardConway, StandardMary, StandardShelley) +import qualified Ouroboros.Consensus.Shelley.Ledger as Consensus import Control.DeepSeq import Data.Aeson (FromJSON (..), ToJSON, toJSON, withText) import qualified Data.Text as Text import Data.Type.Equality (TestEquality (..), (:~:) (Refl)) +import Data.Typeable (Typeable) -- | Determine the value to use for a feature in a given 'ShelleyBasedEra'. inEonForShelleyBasedEra :: () @@ -176,6 +192,40 @@ instance IsShelleyBasedEra BabbageEra where instance IsShelleyBasedEra ConwayEra where shelleyBasedEra = ShelleyBasedEraConway +type ShelleyBasedEraConstraints era = + ( C.HashAlgorithm (L.HASH (L.EraCrypto (ShelleyLedgerEra era))) + , C.Signable (L.VRF (L.EraCrypto (ShelleyLedgerEra era))) L.Seed + , Consensus.PraosProtocolSupportsNode (ConsensusProtocol era) + , Consensus.ShelleyCompatible (ConsensusProtocol era) (ShelleyLedgerEra era) + , L.ADDRHASH (Consensus.PraosProtocolSupportsNodeCrypto (ConsensusProtocol era)) ~ Blake2b.Blake2b_224 + , L.Crypto (L.EraCrypto (ShelleyLedgerEra era)) + , L.Era (ShelleyLedgerEra era) + , L.EraCrypto (ShelleyLedgerEra era) ~ L.StandardCrypto + , L.EraPParams (ShelleyLedgerEra era) + , L.EraTx (ShelleyLedgerEra era) + , L.EraTxBody (ShelleyLedgerEra era) + , L.HashAnnotated (L.TxBody (ShelleyLedgerEra era)) L.EraIndependentTxBody L.StandardCrypto + , L.ShelleyEraTxBody (ShelleyLedgerEra era) + , L.ShelleyEraTxCert (ShelleyLedgerEra era) + , FromCBOR (Consensus.ChainDepState (ConsensusProtocol era)) + , IsCardanoEra era + , IsShelleyBasedEra era + , ToJSON (Consensus.ChainDepState (ConsensusProtocol era)) + , Typeable era + ) + +shelleyBasedEraConstraints :: () + => ShelleyBasedEra era + -> (ShelleyBasedEraConstraints era => a) + -> a +shelleyBasedEraConstraints = \case + ShelleyBasedEraShelley -> id + ShelleyBasedEraAllegra -> id + ShelleyBasedEraMary -> id + ShelleyBasedEraAlonzo -> id + ShelleyBasedEraBabbage -> id + ShelleyBasedEraConway -> id + data AnyShelleyBasedEra where AnyShelleyBasedEra :: IsShelleyBasedEra era -- Provide class constraint diff --git a/cardano-api/internal/Cardano/Api/Eras/Case.hs b/cardano-api/internal/Cardano/Api/Eras/Case.hs index 34986edb52..7192c39590 100644 --- a/cardano-api/internal/Cardano/Api/Eras/Case.hs +++ b/cardano-api/internal/Cardano/Api/Eras/Case.hs @@ -56,7 +56,6 @@ import Cardano.Api.Eon.ShelleyToAllegraEra import Cardano.Api.Eon.ShelleyToAlonzoEra import Cardano.Api.Eon.ShelleyToBabbageEra import Cardano.Api.Eon.ShelleyToMaryEra -import Cardano.Api.Eras.Constraints import Cardano.Api.Eras.Core -- | @caseByronOrShelleyBasedEra f g era@ applies @f@ to byron and @g@ to other eras. diff --git a/cardano-api/internal/Cardano/Api/Eras/Constraints.hs b/cardano-api/internal/Cardano/Api/Eras/Constraints.hs index 56d2ec59fa..5eee7687aa 100644 --- a/cardano-api/internal/Cardano/Api/Eras/Constraints.hs +++ b/cardano-api/internal/Cardano/Api/Eras/Constraints.hs @@ -6,34 +6,15 @@ {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilyDependencies #-} -{-# LANGUAGE TypeOperators #-} module Cardano.Api.Eras.Constraints ( cardanoEraConstraints - , shelleyBasedEraConstraints , CardanoEraConstraints - , ShelleyBasedEraConstraints ) where -import Cardano.Api.Eon.ShelleyBasedEra import Cardano.Api.Eras.Core -import Cardano.Api.Modes -import Cardano.Api.Orphans () -import qualified Cardano.Crypto.Hash.Blake2b as Blake2b -import qualified Cardano.Crypto.Hash.Class as C -import qualified Cardano.Crypto.VRF as C -import qualified Cardano.Ledger.Api as L -import qualified Cardano.Ledger.BaseTypes as L -import Cardano.Ledger.Binary (FromCBOR) -import qualified Cardano.Ledger.Core as L -import qualified Cardano.Ledger.SafeHash as L -import qualified Ouroboros.Consensus.Protocol.Abstract as Consensus -import qualified Ouroboros.Consensus.Protocol.Praos.Common as Consensus -import qualified Ouroboros.Consensus.Shelley.Ledger as Consensus - -import Data.Aeson (ToJSON) import Data.Typeable (Typeable) type CardanoEraConstraints era = @@ -53,37 +34,3 @@ cardanoEraConstraints = \case AlonzoEra -> id BabbageEra -> id ConwayEra -> id - -type ShelleyBasedEraConstraints era = - ( C.HashAlgorithm (L.HASH (L.EraCrypto (ShelleyLedgerEra era))) - , C.Signable (L.VRF (L.EraCrypto (ShelleyLedgerEra era))) L.Seed - , Consensus.PraosProtocolSupportsNode (ConsensusProtocol era) - , Consensus.ShelleyCompatible (ConsensusProtocol era) (ShelleyLedgerEra era) - , L.ADDRHASH (Consensus.PraosProtocolSupportsNodeCrypto (ConsensusProtocol era)) ~ Blake2b.Blake2b_224 - , L.Crypto (L.EraCrypto (ShelleyLedgerEra era)) - , L.Era (ShelleyLedgerEra era) - , L.EraCrypto (ShelleyLedgerEra era) ~ L.StandardCrypto - , L.EraPParams (ShelleyLedgerEra era) - , L.EraTx (ShelleyLedgerEra era) - , L.EraTxBody (ShelleyLedgerEra era) - , L.HashAnnotated (L.TxBody (ShelleyLedgerEra era)) L.EraIndependentTxBody L.StandardCrypto - , L.ShelleyEraTxBody (ShelleyLedgerEra era) - , L.ShelleyEraTxCert (ShelleyLedgerEra era) - , FromCBOR (Consensus.ChainDepState (ConsensusProtocol era)) - , IsCardanoEra era - , IsShelleyBasedEra era - , ToJSON (Consensus.ChainDepState (ConsensusProtocol era)) - , Typeable era - ) - -shelleyBasedEraConstraints :: () - => ShelleyBasedEra era - -> (ShelleyBasedEraConstraints era => a) - -> a -shelleyBasedEraConstraints = \case - ShelleyBasedEraShelley -> id - ShelleyBasedEraAllegra -> id - ShelleyBasedEraMary -> id - ShelleyBasedEraAlonzo -> id - ShelleyBasedEraBabbage -> id - ShelleyBasedEraConway -> id diff --git a/cardano-api/internal/Cardano/Api/Fees.hs b/cardano-api/internal/Cardano/Api/Fees.hs index d19af134be..783e706fc3 100644 --- a/cardano-api/internal/Cardano/Api/Fees.hs +++ b/cardano-api/internal/Cardano/Api/Fees.hs @@ -52,7 +52,6 @@ import Cardano.Api.Eon.MaryEraOnwards import Cardano.Api.Eon.ShelleyBasedEra import Cardano.Api.Eon.ShelleyToAllegraEra import Cardano.Api.Eras.Case -import Cardano.Api.Eras.Constraints import Cardano.Api.Eras.Core import Cardano.Api.Error import Cardano.Api.NetworkId diff --git a/cardano-api/internal/Cardano/Api/Governance/Actions/ProposalProcedure.hs b/cardano-api/internal/Cardano/Api/Governance/Actions/ProposalProcedure.hs index 4eebf3ef2d..88f133eab3 100644 --- a/cardano-api/internal/Cardano/Api/Governance/Actions/ProposalProcedure.hs +++ b/cardano-api/internal/Cardano/Api/Governance/Actions/ProposalProcedure.hs @@ -14,7 +14,6 @@ module Cardano.Api.Governance.Actions.ProposalProcedure where import Cardano.Api.Address import Cardano.Api.Eon.ShelleyBasedEra -import Cardano.Api.Eras.Constraints import Cardano.Api.HasTypeProxy import Cardano.Api.Keys.Shelley import Cardano.Api.ProtocolParameters diff --git a/cardano-api/internal/Cardano/Api/Governance/Actions/VotingProcedure.hs b/cardano-api/internal/Cardano/Api/Governance/Actions/VotingProcedure.hs index fc78c114c7..2c86b30ced 100644 --- a/cardano-api/internal/Cardano/Api/Governance/Actions/VotingProcedure.hs +++ b/cardano-api/internal/Cardano/Api/Governance/Actions/VotingProcedure.hs @@ -12,7 +12,6 @@ {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} module Cardano.Api.Governance.Actions.VotingProcedure where @@ -20,7 +19,6 @@ module Cardano.Api.Governance.Actions.VotingProcedure where import Cardano.Api.Address import Cardano.Api.Eon.ConwayEraOnwards import Cardano.Api.Eon.ShelleyBasedEra -import Cardano.Api.Eras.Constraints import Cardano.Api.Governance.Actions.ProposalProcedure import Cardano.Api.HasTypeProxy import Cardano.Api.Keys.Shelley diff --git a/cardano-api/internal/Cardano/Api/LedgerState.hs b/cardano-api/internal/Cardano/Api/LedgerState.hs index 21c52589f9..8df77d660a 100644 --- a/cardano-api/internal/Cardano/Api/LedgerState.hs +++ b/cardano-api/internal/Cardano/Api/LedgerState.hs @@ -85,7 +85,6 @@ import Cardano.Api.Block import Cardano.Api.Certificate import Cardano.Api.Eon.ShelleyBasedEra import Cardano.Api.Eras.Case -import Cardano.Api.Eras.Constraints import Cardano.Api.Error import Cardano.Api.Genesis import Cardano.Api.IO diff --git a/cardano-api/internal/Cardano/Api/ProtocolParameters.hs b/cardano-api/internal/Cardano/Api/ProtocolParameters.hs index bc68e62601..5d6a7d19aa 100644 --- a/cardano-api/internal/Cardano/Api/ProtocolParameters.hs +++ b/cardano-api/internal/Cardano/Api/ProtocolParameters.hs @@ -101,7 +101,6 @@ import Cardano.Api.Eon.AlonzoEraOnwards import Cardano.Api.Eon.BabbageEraOnwards import Cardano.Api.Eon.ShelleyBasedEra import Cardano.Api.Eras -import Cardano.Api.Eras.Constraints import Cardano.Api.Error import Cardano.Api.Hash import Cardano.Api.HasTypeProxy diff --git a/cardano-api/internal/Cardano/Api/Query.hs b/cardano-api/internal/Cardano/Api/Query.hs index 24180e29cb..5947134d33 100644 --- a/cardano-api/internal/Cardano/Api/Query.hs +++ b/cardano-api/internal/Cardano/Api/Query.hs @@ -82,7 +82,6 @@ import Cardano.Api.Address import Cardano.Api.Block import Cardano.Api.Certificate import Cardano.Api.Eon.ShelleyBasedEra -import Cardano.Api.Eras.Constraints import Cardano.Api.Eras.Core import Cardano.Api.GenesisParameters import Cardano.Api.IPC.Version diff --git a/cardano-api/internal/Cardano/Api/Query/Types.hs b/cardano-api/internal/Cardano/Api/Query/Types.hs index 10e8a30d77..9a61230d30 100644 --- a/cardano-api/internal/Cardano/Api/Query/Types.hs +++ b/cardano-api/internal/Cardano/Api/Query/Types.hs @@ -8,7 +8,6 @@ module Cardano.Api.Query.Types ) where import Cardano.Api.Eon.ShelleyBasedEra -import Cardano.Api.Eras.Constraints import Cardano.Api.Orphans () import Cardano.Binary diff --git a/cardano-api/internal/Cardano/Api/Tx.hs b/cardano-api/internal/Cardano/Api/Tx.hs index 2c1ade81cd..a70420dd4f 100644 --- a/cardano-api/internal/Cardano/Api/Tx.hs +++ b/cardano-api/internal/Cardano/Api/Tx.hs @@ -54,7 +54,6 @@ import Cardano.Api.Address import Cardano.Api.Certificate import Cardano.Api.Eon.ShelleyBasedEra import Cardano.Api.Eras -import Cardano.Api.Eras.Constraints import Cardano.Api.HasTypeProxy import Cardano.Api.Keys.Byron import Cardano.Api.Keys.Class diff --git a/cardano-api/src/Cardano/Api.hs b/cardano-api/src/Cardano/Api.hs index d1de133cec..802662242e 100644 --- a/cardano-api/src/Cardano/Api.hs +++ b/cardano-api/src/Cardano/Api.hs @@ -1041,7 +1041,6 @@ import Cardano.Api.Eon.ShelleyToBabbageEra import Cardano.Api.Eon.ShelleyToMaryEra import Cardano.Api.Eras import Cardano.Api.Eras.Case -import Cardano.Api.Eras.Constraints import Cardano.Api.Error import Cardano.Api.Feature import Cardano.Api.Fees From 99f27e80bc6ed07aab58edf4ccda7f8785c07384 Mon Sep 17 00:00:00 2001 From: John Ky Date: Sun, 15 Oct 2023 00:08:45 +1100 Subject: [PATCH 2/4] Move CardanoEraConstraints and cardanoraConstraints to Core module --- cardano-api/cardano-api.cabal | 1 - cardano-api/internal/Cardano/Api/Eras.hs | 1 - .../internal/Cardano/Api/Eras/Constraints.hs | 36 ------------------- cardano-api/internal/Cardano/Api/Eras/Core.hs | 22 ++++++++++++ cardano-api/internal/Cardano/Api/TxBody.hs | 1 - 5 files changed, 22 insertions(+), 39 deletions(-) delete mode 100644 cardano-api/internal/Cardano/Api/Eras/Constraints.hs diff --git a/cardano-api/cardano-api.cabal b/cardano-api/cardano-api.cabal index d7f8f517ee..3bab0d0024 100644 --- a/cardano-api/cardano-api.cabal +++ b/cardano-api/cardano-api.cabal @@ -76,7 +76,6 @@ library internal Cardano.Api.Eon.ShelleyToMaryEra Cardano.Api.Eras Cardano.Api.Eras.Case - Cardano.Api.Eras.Constraints Cardano.Api.Eras.Core Cardano.Api.Error Cardano.Api.Feature diff --git a/cardano-api/internal/Cardano/Api/Eras.hs b/cardano-api/internal/Cardano/Api/Eras.hs index 0788156076..b46454d7f2 100644 --- a/cardano-api/internal/Cardano/Api/Eras.hs +++ b/cardano-api/internal/Cardano/Api/Eras.hs @@ -49,5 +49,4 @@ module Cardano.Api.Eras ) where import Cardano.Api.Eras.Case -import Cardano.Api.Eras.Constraints import Cardano.Api.Eras.Core diff --git a/cardano-api/internal/Cardano/Api/Eras/Constraints.hs b/cardano-api/internal/Cardano/Api/Eras/Constraints.hs deleted file mode 100644 index 5eee7687aa..0000000000 --- a/cardano-api/internal/Cardano/Api/Eras/Constraints.hs +++ /dev/null @@ -1,36 +0,0 @@ -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilyDependencies #-} - -module Cardano.Api.Eras.Constraints - ( cardanoEraConstraints - - , CardanoEraConstraints - ) where - -import Cardano.Api.Eras.Core - -import Data.Typeable (Typeable) - -type CardanoEraConstraints era = - ( Typeable era - , IsCardanoEra era - ) - -cardanoEraConstraints :: () - => CardanoEra era - -> (CardanoEraConstraints era => a) - -> a -cardanoEraConstraints = \case - ByronEra -> id - ShelleyEra -> id - AllegraEra -> id - MaryEra -> id - AlonzoEra -> id - BabbageEra -> id - ConwayEra -> id diff --git a/cardano-api/internal/Cardano/Api/Eras/Core.hs b/cardano-api/internal/Cardano/Api/Eras/Core.hs index 1a0cde248b..a641f2627b 100644 --- a/cardano-api/internal/Cardano/Api/Eras/Core.hs +++ b/cardano-api/internal/Cardano/Api/Eras/Core.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} @@ -39,6 +40,9 @@ module Cardano.Api.Eras.Core -- * Data family instances , AsType(AsByronEra, AsShelleyEra, AsAllegraEra, AsMaryEra, AsAlonzoEra, AsBabbageEra, AsConwayEra) + + , CardanoEraConstraints + , cardanoEraConstraints ) where import Cardano.Api.HasTypeProxy @@ -269,6 +273,24 @@ instance IsCardanoEra BabbageEra where instance IsCardanoEra ConwayEra where cardanoEra = ConwayEra +type CardanoEraConstraints era = + ( Typeable era + , IsCardanoEra era + ) + +cardanoEraConstraints :: () + => CardanoEra era + -> (CardanoEraConstraints era => a) + -> a +cardanoEraConstraints = \case + ByronEra -> id + ShelleyEra -> id + AllegraEra -> id + MaryEra -> id + AlonzoEra -> id + BabbageEra -> id + ConwayEra -> id + data AnyCardanoEra where AnyCardanoEra :: IsCardanoEra era -- Provide class constraint => CardanoEra era -- and explicit value. diff --git a/cardano-api/internal/Cardano/Api/TxBody.hs b/cardano-api/internal/Cardano/Api/TxBody.hs index 2acf034358..ac0f6320b1 100644 --- a/cardano-api/internal/Cardano/Api/TxBody.hs +++ b/cardano-api/internal/Cardano/Api/TxBody.hs @@ -161,7 +161,6 @@ import Cardano.Api.Eon.ShelleyBasedEra import Cardano.Api.Eon.ShelleyEraOnly import Cardano.Api.Eon.ShelleyToBabbageEra import Cardano.Api.Eras.Case -import Cardano.Api.Eras.Constraints import Cardano.Api.Eras.Core import Cardano.Api.Error import Cardano.Api.Feature From d1d6341eeb8ea3092163fa274f7a4cf72d6879b8 Mon Sep 17 00:00:00 2001 From: John Ky Date: Sun, 15 Oct 2023 00:20:19 +1100 Subject: [PATCH 3/4] New functions anyShelleyBasedEra, inAnyCardanoEra and inAnyShelleyBasedEra --- .../internal/Cardano/Api/Convenience/Query.hs | 6 ++--- .../Cardano/Api/Eon/ShelleyBasedEra.hs | 13 ++++++++++ cardano-api/internal/Cardano/Api/Eras.hs | 3 ++- cardano-api/internal/Cardano/Api/Eras/Core.hs | 24 +++++++++++++------ cardano-api/src/Cardano/Api.hs | 5 +++- 5 files changed, 38 insertions(+), 13 deletions(-) diff --git a/cardano-api/internal/Cardano/Api/Convenience/Query.hs b/cardano-api/internal/Cardano/Api/Convenience/Query.hs index 848c62e6cd..a19231c62e 100644 --- a/cardano-api/internal/Cardano/Api/Convenience/Query.hs +++ b/cardano-api/internal/Cardano/Api/Convenience/Query.hs @@ -96,7 +96,7 @@ queryStateForBalancedTx era allTxIns certs = runExceptT $ do & onNothing (left ByronEraNotSupported) qeInMode <- pure (toEraInMode era CardanoMode) - & onNothing (left (EraConsensusModeMismatch (AnyConsensusMode CardanoMode) (cardanoEraConstraints era $ AnyCardanoEra era))) + & onNothing (left (EraConsensusModeMismatch (AnyConsensusMode CardanoMode) (anyCardanoEra era))) let stakeCreds = Set.fromList $ mapMaybe filterUnRegCreds certs drepCreds = Set.fromList $ mapMaybe filterUnRegDRepCreds certs @@ -175,9 +175,7 @@ executeQueryAnyMode era localNodeConnInfo q = runExceptT $ do let cMode = consensusModeOnly $ localConsensusModeParams localNodeConnInfo eraInMode <- pure (toEraInMode era cMode) - & onNothing (left $ EraConsensusModeMismatch - (AnyConsensusMode CardanoMode) - (cardanoEraConstraints era $ AnyCardanoEra era)) + & onNothing (left $ EraConsensusModeMismatch (AnyConsensusMode CardanoMode) (anyCardanoEra era)) case eraInMode of ByronEraInByronMode -> left ByronEraNotSupported diff --git a/cardano-api/internal/Cardano/Api/Eon/ShelleyBasedEra.hs b/cardano-api/internal/Cardano/Api/Eon/ShelleyBasedEra.hs index 1b315d2add..bc1c0c6fd7 100644 --- a/cardano-api/internal/Cardano/Api/Eon/ShelleyBasedEra.hs +++ b/cardano-api/internal/Cardano/Api/Eon/ShelleyBasedEra.hs @@ -14,7 +14,9 @@ module Cardano.Api.Eon.ShelleyBasedEra ShelleyBasedEra(..) , IsShelleyBasedEra(..) , AnyShelleyBasedEra(..) + , anyShelleyBasedEra , InAnyShelleyBasedEra(..) + , inAnyShelleyBasedEra , shelleyBasedToCardanoEra , inEonForShelleyBasedEra , inEonForShelleyBasedEraMaybe @@ -281,6 +283,11 @@ instance FromJSON AnyShelleyBasedEra where "Conway" -> pure $ AnyShelleyBasedEra ShelleyBasedEraConway wrong -> fail $ "Failed to parse unknown shelley-based era: " <> Text.unpack wrong +anyShelleyBasedEra :: () + => ShelleyBasedEra era + -> AnyShelleyBasedEra +anyShelleyBasedEra sbe = + shelleyBasedEraConstraints sbe $ AnyShelleyBasedEra sbe -- | This pairs up some era-dependent type with a 'ShelleyBasedEra' value that -- tells us what era it is, but hides the era type. This is useful when the era @@ -292,6 +299,12 @@ data InAnyShelleyBasedEra thing where -> thing era -> InAnyShelleyBasedEra thing +inAnyShelleyBasedEra :: () + => ShelleyBasedEra era + -> thing era + -> InAnyShelleyBasedEra thing +inAnyShelleyBasedEra sbe a = + shelleyBasedEraConstraints sbe $ InAnyShelleyBasedEra sbe a -- | Converts a 'ShelleyBasedEra' to the broader 'CardanoEra'. shelleyBasedToCardanoEra :: ShelleyBasedEra era -> CardanoEra era diff --git a/cardano-api/internal/Cardano/Api/Eras.hs b/cardano-api/internal/Cardano/Api/Eras.hs index b46454d7f2..f84f75bff0 100644 --- a/cardano-api/internal/Cardano/Api/Eras.hs +++ b/cardano-api/internal/Cardano/Api/Eras.hs @@ -15,8 +15,9 @@ module Cardano.Api.Eras , IsCardanoEra(..) , AnyCardanoEra(..) , anyCardanoEra - , cardanoEraConstraints , InAnyCardanoEra(..) + , inAnyCardanoEra + , cardanoEraConstraints , CardanoLedgerEra , ToCardanoEra(..) diff --git a/cardano-api/internal/Cardano/Api/Eras/Core.hs b/cardano-api/internal/Cardano/Api/Eras/Core.hs index a641f2627b..7c0d42f997 100644 --- a/cardano-api/internal/Cardano/Api/Eras/Core.hs +++ b/cardano-api/internal/Cardano/Api/Eras/Core.hs @@ -26,6 +26,7 @@ module Cardano.Api.Eras.Core , AnyCardanoEra(..) , anyCardanoEra , InAnyCardanoEra(..) + , inAnyCardanoEra , CardanoLedgerEra , ToCardanoEra(..) @@ -292,9 +293,10 @@ cardanoEraConstraints = \case ConwayEra -> id data AnyCardanoEra where - AnyCardanoEra :: IsCardanoEra era -- Provide class constraint - => CardanoEra era -- and explicit value. - -> AnyCardanoEra + AnyCardanoEra + :: IsCardanoEra era + => CardanoEra era + -> AnyCardanoEra deriving instance Show AnyCardanoEra @@ -368,10 +370,18 @@ anyCardanoEra = \case -- not statically known, for example when deserialising from a file. -- data InAnyCardanoEra thing where - InAnyCardanoEra :: IsCardanoEra era -- Provide class constraint - => CardanoEra era -- and explicit value. - -> thing era - -> InAnyCardanoEra thing + InAnyCardanoEra + :: IsCardanoEra era + => CardanoEra era + -> thing era + -> InAnyCardanoEra thing + +inAnyCardanoEra :: () + => CardanoEra era + -> thing era + -> InAnyCardanoEra thing +inAnyCardanoEra era a = + cardanoEraConstraints era $ InAnyCardanoEra era a -- ---------------------------------------------------------------------------- -- Conversion to ledger library types diff --git a/cardano-api/src/Cardano/Api.hs b/cardano-api/src/Cardano/Api.hs index 802662242e..156fca8aa4 100644 --- a/cardano-api/src/Cardano/Api.hs +++ b/cardano-api/src/Cardano/Api.hs @@ -23,8 +23,9 @@ module Cardano.Api ( IsCardanoEra(..), AnyCardanoEra(..), anyCardanoEra, - cardanoEraConstraints, InAnyCardanoEra(..), + inAnyCardanoEra, + cardanoEraConstraints, ToCardanoEra(..), -- * Eon support @@ -101,7 +102,9 @@ module Cardano.Api ( ShelleyBasedEra(..), IsShelleyBasedEra(..), AnyShelleyBasedEra(..), + anyShelleyBasedEra, InAnyShelleyBasedEra(..), + inAnyShelleyBasedEra, CardanoEraStyle(..), cardanoEraStyle, shelleyBasedToCardanoEra, From 43027e52e609840128b9501f92c326b7c0921187 Mon Sep 17 00:00:00 2001 From: John Ky Date: Wed, 18 Oct 2023 15:59:46 +1100 Subject: [PATCH 4/4] Use ShelleyBasedEra instead of IsShelleyBasedEra. Use CardanoEra instead of IsCardanoEra. --- cardano-api/gen/Test/Gen/Cardano/Api/Typed.hs | 63 +++---- cardano-api/internal/Cardano/Api/Address.hs | 63 ++++--- cardano-api/internal/Cardano/Api/Block.hs | 42 +++-- .../Cardano/Api/Convenience/Construction.hs | 12 +- .../Cardano/Api/Eon/ShelleyBasedEra.hs | 22 ++- cardano-api/internal/Cardano/Api/Fees.hs | 178 +++++++++--------- .../internal/Cardano/Api/LedgerState.hs | 6 +- .../Cardano/Api/ProtocolParameters.hs | 9 +- .../Cardano/Api/SerialiseLedgerCddl.hs | 51 +++-- cardano-api/internal/Cardano/Api/Tx.hs | 104 +++++----- cardano-api/internal/Cardano/Api/TxBody.hs | 95 +++++----- .../Test/Golden/ErrorsSpec.hs | 2 +- .../cardano-api-test/Test/Cardano/Api/Eras.hs | 4 +- .../Test/Cardano/Api/Typed/CBOR.hs | 10 +- .../Test/Cardano/Api/Typed/Ord.hs | 2 +- .../Test/Cardano/Api/Typed/TxBody.hs | 5 +- 16 files changed, 331 insertions(+), 337 deletions(-) diff --git a/cardano-api/gen/Test/Gen/Cardano/Api/Typed.hs b/cardano-api/gen/Test/Gen/Cardano/Api/Typed.hs index 748028f905..d45fc17668 100644 --- a/cardano-api/gen/Test/Gen/Cardano/Api/Typed.hs +++ b/cardano-api/gen/Test/Gen/Cardano/Api/Typed.hs @@ -188,10 +188,10 @@ genAddressInEra era = LegacyByronEra -> byronAddressInEra <$> genAddressByron - ShelleyBasedEra _ -> + ShelleyBasedEra sbe -> Gen.choice - [ byronAddressInEra <$> genAddressByron - , shelleyAddressInEra <$> genAddressShelley + [ byronAddressInEra <$> genAddressByron + , shelleyAddressInEra sbe <$> genAddressShelley ] genKESPeriod :: Gen KESPeriod @@ -717,9 +717,9 @@ genTxFee = (pure . TxFeeImplicit) (\w -> TxFeeExplicit w <$> genLovelace) -genTxBody :: IsCardanoEra era => CardanoEra era -> Gen (TxBody era) +genTxBody :: CardanoEra era -> Gen (TxBody era) genTxBody era = do - res <- Api.createAndValidateTransactionBody <$> genTxBodyContent era + res <- Api.createAndValidateTransactionBody era <$> genTxBodyContent era case res of Left err -> fail (displayError err) Right txBody -> pure txBody @@ -753,7 +753,9 @@ genTxScriptValidity = genScriptValidity :: Gen ScriptValidity genScriptValidity = Gen.element [ScriptInvalid, ScriptValid] -genTx :: forall era. IsCardanoEra era => CardanoEra era -> Gen (Tx era) +genTx :: () + => CardanoEra era + -> Gen (Tx era) genTx era = makeSignedTransaction <$> genWitnesses era @@ -762,12 +764,10 @@ genTx era = genWitnesses :: CardanoEra era -> Gen [KeyWitness era] genWitnesses era = case cardanoEraStyle era of - LegacyByronEra -> Gen.list (Range.constant 1 10) genByronKeyWitness - ShelleyBasedEra _ -> do - bsWits <- Gen.list (Range.constant 0 10) - (genShelleyBootstrapWitness era) - keyWits <- Gen.list (Range.constant 0 10) - (genShelleyKeyWitness era) + LegacyByronEra -> Gen.list (Range.constant 1 10) genByronKeyWitness + ShelleyBasedEra sbe -> do + bsWits <- Gen.list (Range.constant 0 10) (genShelleyBootstrapWitness sbe) + keyWits <- Gen.list (Range.constant 0 10) (genShelleyKeyWitness sbe) return $ bsWits ++ keyWits genVerificationKey :: () @@ -806,33 +806,30 @@ genWitnessNetworkIdOrByronAddress = , WitnessByronAddress <$> genAddressByron ] -genShelleyBootstrapWitness - :: IsShelleyBasedEra era - => CardanoEra era +genShelleyBootstrapWitness :: () + => ShelleyBasedEra era -> Gen (KeyWitness era) -genShelleyBootstrapWitness era = - makeShelleyBootstrapWitness +genShelleyBootstrapWitness sbe = + makeShelleyBootstrapWitness sbe <$> genWitnessNetworkIdOrByronAddress - <*> genTxBody era + <*> genTxBody (shelleyBasedToCardanoEra sbe) <*> genSigningKey AsByronKey -genShelleyKeyWitness - :: IsShelleyBasedEra era - => CardanoEra era +genShelleyKeyWitness :: () + => ShelleyBasedEra era -> Gen (KeyWitness era) -genShelleyKeyWitness era = - makeShelleyKeyWitness - <$> genTxBody era +genShelleyKeyWitness sbe = + makeShelleyKeyWitness sbe + <$> genTxBody (shelleyBasedToCardanoEra sbe) <*> genShelleyWitnessSigningKey -genShelleyWitness - :: IsShelleyBasedEra era - => CardanoEra era +genShelleyWitness :: () + => ShelleyBasedEra era -> Gen (KeyWitness era) -genShelleyWitness era = +genShelleyWitness sbe = Gen.choice - [ genShelleyKeyWitness era - , genShelleyBootstrapWitness era + [ genShelleyKeyWitness sbe + , genShelleyBootstrapWitness sbe ] genShelleyWitnessSigningKey :: Gen ShelleyWitnessSigningKey @@ -845,12 +842,12 @@ genShelleyWitnessSigningKey = , WitnessGenesisUTxOKey <$> genSigningKey AsGenesisUTxOKey ] -genCardanoKeyWitness - :: CardanoEra era +genCardanoKeyWitness :: () + => CardanoEra era -> Gen (KeyWitness era) genCardanoKeyWitness era = case cardanoEraStyle era of LegacyByronEra -> genByronKeyWitness - ShelleyBasedEra _ -> genShelleyWitness era + ShelleyBasedEra sbe -> genShelleyWitness sbe genSeed :: Int -> Gen Crypto.Seed genSeed n = Crypto.mkSeedFromBytes <$> Gen.bytes (Range.singleton n) diff --git a/cardano-api/internal/Cardano/Api/Address.hs b/cardano-api/internal/Cardano/Api/Address.hs index df00798c2b..9182d20008 100644 --- a/cardano-api/internal/Cardano/Api/Address.hs +++ b/cardano-api/internal/Cardano/Api/Address.hs @@ -6,6 +6,7 @@ {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {- HLINT ignore "Avoid lambda using `infix`" -} @@ -373,9 +374,11 @@ instance IsCardanoEra era => ToJSON (AddressInEra era) where toJSON = Aeson.String . serialiseAddress instance IsShelleyBasedEra era => FromJSON (AddressInEra era) where - parseJSON = withText "AddressInEra" $ \txt -> do - addressAny <- runParsecParser parseAddressAny txt - pure $ anyAddressInShelleyBasedEra addressAny + parseJSON = + let sbe = shelleyBasedEra @era in + withText "AddressInEra" $ \txt -> do + addressAny <- runParsecParser parseAddressAny txt + pure $ anyAddressInShelleyBasedEra sbe addressAny parseAddressAny :: Parsec.Parser AddressAny parseAddressAny = do @@ -467,15 +470,20 @@ byronAddressInEra :: Address ByronAddr -> AddressInEra era byronAddressInEra = AddressInEra ByronAddressInAnyEra -shelleyAddressInEra :: IsShelleyBasedEra era - => Address ShelleyAddr -> AddressInEra era -shelleyAddressInEra = AddressInEra (ShelleyAddressInEra shelleyBasedEra) - +shelleyAddressInEra :: () + => ShelleyBasedEra era + -> Address ShelleyAddr + -> AddressInEra era +shelleyAddressInEra sbe = + AddressInEra (ShelleyAddressInEra sbe) -anyAddressInShelleyBasedEra :: IsShelleyBasedEra era - => AddressAny -> AddressInEra era -anyAddressInShelleyBasedEra (AddressByron addr) = byronAddressInEra addr -anyAddressInShelleyBasedEra (AddressShelley addr) = shelleyAddressInEra addr +anyAddressInShelleyBasedEra :: () + => ShelleyBasedEra era + -> AddressAny + -> AddressInEra era +anyAddressInShelleyBasedEra sbe = \case + AddressByron addr -> byronAddressInEra addr + AddressShelley addr -> shelleyAddressInEra sbe addr anyAddressInEra :: CardanoEra era @@ -500,13 +508,14 @@ makeByronAddressInEra nw vk = byronAddressInEra (makeByronAddress nw vk) -makeShelleyAddressInEra :: IsShelleyBasedEra era - => NetworkId - -> PaymentCredential - -> StakeAddressReference - -> AddressInEra era -makeShelleyAddressInEra nw pc scr = - shelleyAddressInEra (makeShelleyAddress nw pc scr) +makeShelleyAddressInEra :: () + => ShelleyBasedEra era + -> NetworkId + -> PaymentCredential + -> StakeAddressReference + -> AddressInEra era +makeShelleyAddressInEra sbe nw pc scr = + shelleyAddressInEra sbe (makeShelleyAddress nw pc scr) -- ---------------------------------------------------------------------------- @@ -659,15 +668,15 @@ toShelleyStakeReference (StakeAddressByPointer ptr) = toShelleyStakeReference NoStakeAddress = Shelley.StakeRefNull -fromShelleyAddrIsSbe :: IsShelleyBasedEra era - => Shelley.Addr StandardCrypto -> AddressInEra era -fromShelleyAddrIsSbe (Shelley.AddrBootstrap (Shelley.BootstrapAddress addr)) = - AddressInEra ByronAddressInAnyEra (ByronAddress addr) - -fromShelleyAddrIsSbe (Shelley.Addr nw pc scr) = - AddressInEra - (ShelleyAddressInEra shelleyBasedEra) - (ShelleyAddress nw pc scr) +fromShelleyAddrIsSbe :: () + => ShelleyBasedEra era + -> Shelley.Addr StandardCrypto + -> AddressInEra era +fromShelleyAddrIsSbe sbe = \case + Shelley.AddrBootstrap (Shelley.BootstrapAddress addr) -> + AddressInEra ByronAddressInAnyEra (ByronAddress addr) + Shelley.Addr nw pc scr -> + AddressInEra (ShelleyAddressInEra sbe) (ShelleyAddress nw pc scr) fromShelleyAddr :: ShelleyBasedEra era diff --git a/cardano-api/internal/Cardano/Api/Block.hs b/cardano-api/internal/Cardano/Api/Block.hs index addc47313b..a1c3636002 100644 --- a/cardano-api/internal/Cardano/Api/Block.hs +++ b/cardano-api/internal/Cardano/Api/Block.hs @@ -199,7 +199,11 @@ getShelleyBlockTxs era (Ledger.Block _header txs) = -- different block types for all the eras. It is used in the ChainSync protocol. -- data BlockInMode mode where - BlockInMode :: IsCardanoEra era => Block era -> EraInMode era mode -> BlockInMode mode + BlockInMode + :: CardanoEra era + -> Block era + -> EraInMode era mode + -> BlockInMode mode deriving instance Show (BlockInMode mode) @@ -212,41 +216,41 @@ fromConsensusBlock :: ConsensusBlockForMode mode ~ block fromConsensusBlock ByronMode = \b -> case b of Consensus.DegenBlock b' -> - BlockInMode (ByronBlock b') ByronEraInByronMode + BlockInMode cardanoEra (ByronBlock b') ByronEraInByronMode fromConsensusBlock ShelleyMode = \b -> case b of Consensus.DegenBlock b' -> - BlockInMode (ShelleyBlock ShelleyBasedEraShelley b') + BlockInMode cardanoEra (ShelleyBlock ShelleyBasedEraShelley b') ShelleyEraInShelleyMode fromConsensusBlock CardanoMode = \b -> case b of Consensus.BlockByron b' -> - BlockInMode (ByronBlock b') ByronEraInCardanoMode + BlockInMode cardanoEra (ByronBlock b') ByronEraInCardanoMode Consensus.BlockShelley b' -> - BlockInMode (ShelleyBlock ShelleyBasedEraShelley b') + BlockInMode cardanoEra (ShelleyBlock ShelleyBasedEraShelley b') ShelleyEraInCardanoMode Consensus.BlockAllegra b' -> - BlockInMode (ShelleyBlock ShelleyBasedEraAllegra b') + BlockInMode cardanoEra (ShelleyBlock ShelleyBasedEraAllegra b') AllegraEraInCardanoMode Consensus.BlockMary b' -> - BlockInMode (ShelleyBlock ShelleyBasedEraMary b') + BlockInMode cardanoEra (ShelleyBlock ShelleyBasedEraMary b') MaryEraInCardanoMode Consensus.BlockAlonzo b' -> - BlockInMode (ShelleyBlock ShelleyBasedEraAlonzo b') + BlockInMode cardanoEra (ShelleyBlock ShelleyBasedEraAlonzo b') AlonzoEraInCardanoMode Consensus.BlockBabbage b' -> - BlockInMode (ShelleyBlock ShelleyBasedEraBabbage b') + BlockInMode cardanoEra (ShelleyBlock ShelleyBasedEraBabbage b') BabbageEraInCardanoMode Consensus.BlockConway b' -> - BlockInMode (ShelleyBlock ShelleyBasedEraConway b') + BlockInMode cardanoEra (ShelleyBlock ShelleyBasedEraConway b') ConwayEraInCardanoMode toConsensusBlock @@ -259,19 +263,19 @@ toConsensusBlock toConsensusBlock bInMode = case bInMode of -- Byron mode - BlockInMode (ByronBlock b') ByronEraInByronMode -> Consensus.DegenBlock b' + BlockInMode _ (ByronBlock b') ByronEraInByronMode -> Consensus.DegenBlock b' -- Shelley mode - BlockInMode (ShelleyBlock ShelleyBasedEraShelley b') ShelleyEraInShelleyMode -> Consensus.DegenBlock b' + BlockInMode _ (ShelleyBlock ShelleyBasedEraShelley b') ShelleyEraInShelleyMode -> Consensus.DegenBlock b' -- Cardano mode - BlockInMode (ByronBlock b') ByronEraInCardanoMode -> Consensus.BlockByron b' - BlockInMode (ShelleyBlock ShelleyBasedEraShelley b') ShelleyEraInCardanoMode -> Consensus.BlockShelley b' - BlockInMode (ShelleyBlock ShelleyBasedEraAllegra b') AllegraEraInCardanoMode -> Consensus.BlockAllegra b' - BlockInMode (ShelleyBlock ShelleyBasedEraMary b') MaryEraInCardanoMode -> Consensus.BlockMary b' - BlockInMode (ShelleyBlock ShelleyBasedEraAlonzo b') AlonzoEraInCardanoMode -> Consensus.BlockAlonzo b' - BlockInMode (ShelleyBlock ShelleyBasedEraBabbage b') BabbageEraInCardanoMode -> Consensus.BlockBabbage b' - BlockInMode (ShelleyBlock ShelleyBasedEraConway b') ConwayEraInCardanoMode -> Consensus.BlockConway b' + BlockInMode _ (ByronBlock b') ByronEraInCardanoMode -> Consensus.BlockByron b' + BlockInMode _ (ShelleyBlock ShelleyBasedEraShelley b') ShelleyEraInCardanoMode -> Consensus.BlockShelley b' + BlockInMode _ (ShelleyBlock ShelleyBasedEraAllegra b') AllegraEraInCardanoMode -> Consensus.BlockAllegra b' + BlockInMode _ (ShelleyBlock ShelleyBasedEraMary b') MaryEraInCardanoMode -> Consensus.BlockMary b' + BlockInMode _ (ShelleyBlock ShelleyBasedEraAlonzo b') AlonzoEraInCardanoMode -> Consensus.BlockAlonzo b' + BlockInMode _ (ShelleyBlock ShelleyBasedEraBabbage b') BabbageEraInCardanoMode -> Consensus.BlockBabbage b' + BlockInMode _ (ShelleyBlock ShelleyBasedEraConway b') ConwayEraInCardanoMode -> Consensus.BlockConway b' -- ---------------------------------------------------------------------------- -- Block headers diff --git a/cardano-api/internal/Cardano/Api/Convenience/Construction.hs b/cardano-api/internal/Cardano/Api/Convenience/Construction.hs index 16d3e5ddac..79cc8c1790 100644 --- a/cardano-api/internal/Cardano/Api/Convenience/Construction.hs +++ b/cardano-api/internal/Cardano/Api/Convenience/Construction.hs @@ -41,9 +41,9 @@ import qualified Data.Text as Text -- See Cardano.Api.Convenience.Query.queryStateForBalancedTx for a -- convenient way of querying the node to get the required arguements -- for constructBalancedTx. -constructBalancedTx - :: IsShelleyBasedEra era - => TxBodyContent BuildTx era +constructBalancedTx :: () + => ShelleyBasedEra era + -> TxBodyContent BuildTx era -> AddressInEra era -- ^ Change address -> Maybe Word -- ^ Override key witnesses -> UTxO era -- ^ Just the transaction inputs, not the entire 'UTxO'. @@ -55,17 +55,17 @@ constructBalancedTx -> Map.Map (L.Credential L.DRepRole L.StandardCrypto) Lovelace -> [ShelleyWitnessSigningKey] -> Either TxBodyErrorAutoBalance (Tx era) -constructBalancedTx txbodcontent changeAddr mOverrideWits utxo lpp +constructBalancedTx sbe txbodcontent changeAddr mOverrideWits utxo lpp ledgerEpochInfo systemStart stakePools stakeDelegDeposits drepDelegDeposits shelleyWitSigningKeys = do BalancedTxBody _ txbody _txBalanceOutput _fee <- makeTransactionBodyAutoBalance - systemStart ledgerEpochInfo + sbe systemStart ledgerEpochInfo lpp stakePools stakeDelegDeposits drepDelegDeposits utxo txbodcontent changeAddr mOverrideWits - let keyWits = map (makeShelleyKeyWitness txbody) shelleyWitSigningKeys + let keyWits = map (makeShelleyKeyWitness sbe txbody) shelleyWitSigningKeys return $ makeSignedTransaction keyWits txbody data TxInsExistError diff --git a/cardano-api/internal/Cardano/Api/Eon/ShelleyBasedEra.hs b/cardano-api/internal/Cardano/Api/Eon/ShelleyBasedEra.hs index bc1c0c6fd7..f5a98c8247 100644 --- a/cardano-api/internal/Cardano/Api/Eon/ShelleyBasedEra.hs +++ b/cardano-api/internal/Cardano/Api/Eon/ShelleyBasedEra.hs @@ -8,6 +8,7 @@ {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilyDependencies #-} +{-# LANGUAGE TypeOperators #-} module Cardano.Api.Eon.ShelleyBasedEra ( -- * Shelley-based eras @@ -230,8 +231,7 @@ shelleyBasedEraConstraints = \case data AnyShelleyBasedEra where AnyShelleyBasedEra - :: IsShelleyBasedEra era -- Provide class constraint - => ShelleyBasedEra era -- and explicit value. + :: ShelleyBasedEra era -> AnyShelleyBasedEra deriving instance Show AnyShelleyBasedEra @@ -294,10 +294,11 @@ anyShelleyBasedEra sbe = -- is not statically known, for example when deserialising from a file. -- data InAnyShelleyBasedEra thing where - InAnyShelleyBasedEra :: IsShelleyBasedEra era -- Provide class constraint - => ShelleyBasedEra era -- and explicit value. - -> thing era - -> InAnyShelleyBasedEra thing + InAnyShelleyBasedEra + :: IsShelleyBasedEra era + => ShelleyBasedEra era + -> thing era + -> InAnyShelleyBasedEra thing inAnyShelleyBasedEra :: () => ShelleyBasedEra era @@ -328,10 +329,11 @@ shelleyBasedToCardanoEra ShelleyBasedEraConway = ConwayEra -- the Shelley-based eras can often be treated uniformly. -- data CardanoEraStyle era where - LegacyByronEra :: CardanoEraStyle ByronEra - ShelleyBasedEra :: IsShelleyBasedEra era -- Also provide class constraint - => ShelleyBasedEra era - -> CardanoEraStyle era + LegacyByronEra :: CardanoEraStyle ByronEra + + ShelleyBasedEra + :: ShelleyBasedEra era + -> CardanoEraStyle era deriving instance Eq (CardanoEraStyle era) deriving instance Ord (CardanoEraStyle era) diff --git a/cardano-api/internal/Cardano/Api/Fees.hs b/cardano-api/internal/Cardano/Api/Fees.hs index 783e706fc3..9bac30a656 100644 --- a/cardano-api/internal/Cardano/Api/Fees.hs +++ b/cardano-api/internal/Cardano/Api/Fees.hs @@ -106,22 +106,21 @@ import Prettyprinter.Render.String -- This function is simple, but if you are doing input selection then you -- probably want to consider estimateTransactionFee. -- -transactionFee :: forall era. - IsShelleyBasedEra era - => Lovelace -- ^ The fixed tx fee - -> Lovelace -- ^ The tx fee per byte - -> Tx era - -> Lovelace -transactionFee txFeeFixed txFeePerByte tx = +transactionFee :: () + => ShelleyBasedEra era + -> Lovelace -- ^ The fixed tx fee + -> Lovelace -- ^ The tx fee per byte + -> Tx era + -> Lovelace +transactionFee sbe txFeeFixed txFeePerByte tx = let a = toInteger txFeePerByte b = toInteger txFeeFixed - in case tx of - ShelleyTx _ tx' -> - let x = shelleyBasedEraConstraints (shelleyBasedEra @era) $ tx' ^. L.sizeTxF - in Lovelace (a * x + b) - --TODO: This can be made to work for Byron txs too. Do that: fill in this case - -- and remove the IsShelleyBasedEra constraint. - ByronTx _ -> case shelleyBasedEra @era of {} + in + case tx of + ShelleyTx _ tx' -> + let x = shelleyBasedEraConstraints sbe $ tx' ^. L.sizeTxF in Lovelace (a * x + b) + --TODO: This can be made to work for Byron txs too. + ByronTx _ -> case sbe of {} {-# DEPRECATED transactionFee "Use 'evaluateTransactionFee' instead" #-} @@ -136,30 +135,34 @@ transactionFee txFeeFixed txFeePerByte tx = -- contain all the things not subject to coin selection (such as script inputs, -- metadata, withdrawals, certs etc) -- -estimateTransactionFee :: forall era. - IsShelleyBasedEra era - => NetworkId - -> Lovelace -- ^ The fixed tx fee - -> Lovelace -- ^ The tx fee per byte - -> Tx era - -> Int -- ^ The number of extra UTxO transaction inputs - -> Int -- ^ The number of extra transaction outputs - -> Int -- ^ The number of extra Shelley key witnesses - -> Int -- ^ The number of extra Byron key witnesses - -> Lovelace -estimateTransactionFee nw txFeeFixed txFeePerByte (ShelleyTx era tx) = - let Lovelace baseFee = transactionFee txFeeFixed txFeePerByte (ShelleyTx era tx) - in \nInputs nOutputs nShelleyKeyWitnesses nByronKeyWitnesses -> - - --TODO: this is fragile. Move something like this to the ledger and - -- make it robust, based on the txsize calculation. - let extraBytes :: Int - extraBytes = nInputs * sizeInput - + nOutputs * sizeOutput - + nByronKeyWitnesses * sizeByronKeyWitnesses - + nShelleyKeyWitnesses * sizeShelleyKeyWitnesses - - in Lovelace (baseFee + toInteger txFeePerByte * toInteger extraBytes) +estimateTransactionFee :: () + => ShelleyBasedEra era + -> NetworkId + -> Lovelace -- ^ The fixed tx fee + -> Lovelace -- ^ The tx fee per byte + -> Tx era + -> Int -- ^ The number of extra UTxO transaction inputs + -> Int -- ^ The number of extra transaction outputs + -> Int -- ^ The number of extra Shelley key witnesses + -> Int -- ^ The number of extra Byron key witnesses + -> Lovelace +estimateTransactionFee sbe nw txFeeFixed txFeePerByte = \case + -- TODO: This can be made to work for Byron txs too. + ByronTx _ -> + case sbe of {} + ShelleyTx era tx -> + let Lovelace baseFee = transactionFee sbe txFeeFixed txFeePerByte (ShelleyTx era tx) + in \nInputs nOutputs nShelleyKeyWitnesses nByronKeyWitnesses -> + --TODO: this is fragile. Move something like this to the ledger and + -- make it robust, based on the txsize calculation. + let extraBytes :: Int + extraBytes = + nInputs * sizeInput + + nOutputs * sizeOutput + + nByronKeyWitnesses * sizeByronKeyWitnesses + + nShelleyKeyWitnesses * sizeShelleyKeyWitnesses + + in Lovelace (baseFee + toInteger txFeePerByte * toInteger extraBytes) where sizeInput = smallArray + uint + hashObj sizeOutput = smallArray + uint + address @@ -192,11 +195,6 @@ estimateTransactionFee nw txFeeFixed txFeePerByte (ShelleyTx era tx) = Byron.aaNetworkMagic = toByronNetworkMagic nw } ---TODO: This can be made to work for Byron txs too. Do that: fill in this case --- and remove the IsShelleyBasedEra constraint. -estimateTransactionFee _ _ _ (ByronTx _) = - case shelleyBasedEra @era of {} - --TODO: also deprecate estimateTransactionFee: --{-# DEPRECATED estimateTransactionFee "Use 'evaluateTransactionFee' instead" #-} @@ -207,25 +205,23 @@ estimateTransactionFee _ _ _ (ByronTx _) = -- -- TODO: we need separate args for Shelley vs Byron key sigs -- -evaluateTransactionFee :: forall era. - IsShelleyBasedEra era - => Ledger.PParams (ShelleyLedgerEra era) - -> TxBody era - -> Word -- ^ The number of Shelley key witnesses - -> Word -- ^ The number of Byron key witnesses - -> Lovelace -evaluateTransactionFee _ _ _ byronwitcount | byronwitcount > 0 = +evaluateTransactionFee :: forall era. () + => ShelleyBasedEra era + -> Ledger.PParams (ShelleyLedgerEra era) + -> TxBody era + -> Word -- ^ The number of Shelley key witnesses + -> Word -- ^ The number of Byron key witnesses + -> Lovelace +evaluateTransactionFee _ _ _ _ byronwitcount | byronwitcount > 0 = error "evaluateTransactionFee: TODO support Byron key witnesses" -evaluateTransactionFee pp txbody keywitcount _byronwitcount = +evaluateTransactionFee sbe pp txbody keywitcount _byronwitcount = + shelleyBasedEraConstraints sbe $ case makeSignedTransaction [] txbody of - ByronTx{} -> case shelleyBasedEra :: ShelleyBasedEra era of {} + ByronTx{} -> case sbe of {} --TODO: we could actually support Byron here, it'd be different but simpler - ShelleyTx sbe tx -> - shelleyBasedEraConstraints sbe - $ fromShelleyLovelace - $ Ledger.evaluateTransactionFee pp tx keywitcount + ShelleyTx _ tx -> fromShelleyLovelace $ Ledger.evaluateTransactionFee pp tx keywitcount -- | Give an approximate count of the number of key witnesses (i.e. signatures) -- a transaction will need. @@ -561,21 +557,20 @@ evaluateTransactionExecutionUnitsShelley sbe systemstart epochInfo (LedgerProtoc -- Finding the (non-zero) balance of partially constructed transaction is -- useful for adjusting a transaction to be fully balanced. -- -evaluateTransactionBalance :: forall era. - IsShelleyBasedEra era - => Ledger.PParams (ShelleyLedgerEra era) +evaluateTransactionBalance :: forall era. () + => ShelleyBasedEra era + -> Ledger.PParams (ShelleyLedgerEra era) -> Set PoolId -> Map StakeCredential Lovelace -> Map (Ledger.Credential Ledger.DRepRole Ledger.StandardCrypto) Lovelace -> UTxO era -> TxBody era -> TxOutValue era -evaluateTransactionBalance _ _ _ _ _ (ByronTxBody _) = - case shelleyBasedEra :: ShelleyBasedEra era of {} - --TODO: we could actually support Byron here, it'd be different but simpler +evaluateTransactionBalance sbe _ _ _ _ _ (ByronTxBody _) = + -- TODO: we could actually support Byron here, it'd be different but simpler + case sbe of {} -evaluateTransactionBalance pp poolids stakeDelegDeposits drepDelegDeposits utxo - (ShelleyTxBody sbe txbody _ _ _ _) = +evaluateTransactionBalance sbe pp poolids stakeDelegDeposits drepDelegDeposits utxo (ShelleyTxBody _ txbody _ _ _ _) = caseShelleyToAllegraOrMaryEraOnwards evalAdaOnly evalMultiAsset @@ -771,10 +766,9 @@ data BalancedTxBody era -- To do this it needs more information than 'makeTransactionBody', all of -- which can be queried from a local node. -- -makeTransactionBodyAutoBalance - :: forall era. - IsShelleyBasedEra era - => SystemStart +makeTransactionBodyAutoBalance :: forall era. () + => ShelleyBasedEra era + -> SystemStart -> LedgerEpochInfo -> LedgerProtocolParameters era -> Set PoolId -- ^ The set of registered stake pools, that are being @@ -790,7 +784,7 @@ makeTransactionBodyAutoBalance -> AddressInEra era -- ^ Change address -> Maybe Word -- ^ Override key witnesses -> Either TxBodyErrorAutoBalance (BalancedTxBody era) -makeTransactionBodyAutoBalance systemstart history lpp@(LedgerProtocolParameters pp) poolids stakeDelegDeposits +makeTransactionBodyAutoBalance sbe systemstart history lpp@(LedgerProtocolParameters pp) poolids stakeDelegDeposits drepDelegDeposits utxo txbodycontent changeaddr mnkeys = do -- Our strategy is to: -- 1. evaluate all the scripts to get the exec units, update with ex units @@ -798,9 +792,9 @@ makeTransactionBodyAutoBalance systemstart history lpp@(LedgerProtocolParameters -- 3. update tx with fees -- 4. balance the transaction and update tx change output txbody0 <- - first TxBodyError $ createAndValidateTransactionBody txbodycontent + first TxBodyError $ createAndValidateTransactionBody era txbodycontent { txOuts = txOuts txbodycontent ++ - [TxOut changeaddr (lovelaceToTxOutValue 0) TxOutDatumNone ReferenceScriptNone] + [TxOut changeaddr (lovelaceToTxOutValue era 0) TxOutDatumNone ReferenceScriptNone] --TODO: think about the size of the change output -- 1,2,4 or 8 bytes? } @@ -845,13 +839,13 @@ makeTransactionBodyAutoBalance systemstart history lpp@(LedgerProtocolParameters ] let changeTxOut = caseByronToAllegraOrMaryEraOnwards - (const (lovelaceToTxOutValue $ Lovelace (2^(64 :: Integer)) - 1)) + (const $ lovelaceToTxOutValue era $ Lovelace (2^(64 :: Integer)) - 1) (\w -> TxOutValue w (lovelaceToValue (Lovelace (2^(64 :: Integer)) - 1) <> nonAdaChange)) - (cardanoEra @era) + era let (dummyCollRet, dummyTotColl) = maybeDummyTotalCollAndCollReturnOutput txbodycontent changeaddr txbody1 <- first TxBodyError $ -- TODO: impossible to fail now - createAndValidateTransactionBody txbodycontent1 { + createAndValidateTransactionBody era txbodycontent1 { txFee = TxFeeExplicit sbe $ Lovelace (2^(32 :: Integer) - 1), txOuts = TxOut changeaddr changeTxOut @@ -864,7 +858,7 @@ makeTransactionBodyAutoBalance systemstart history lpp@(LedgerProtocolParameters let nkeys = fromMaybe (estimateTransactionKeyWitnessCount txbodycontent1) mnkeys - fee = evaluateTransactionFee pp txbody1 nkeys 0 --TODO: byron keys + fee = evaluateTransactionFee sbe pp txbody1 nkeys 0 --TODO: byron keys (retColl, reqCol) = caseShelleyToAlonzoOrBabbageEraOnwards (const (TxReturnCollateralNone, TxTotalCollateralNone)) @@ -880,12 +874,12 @@ makeTransactionBodyAutoBalance systemstart history lpp@(LedgerProtocolParameters -- Here we do not want to start with any change output, since that's what -- we need to calculate. txbody2 <- first TxBodyError $ -- TODO: impossible to fail now - createAndValidateTransactionBody txbodycontent1 { + createAndValidateTransactionBody era txbodycontent1 { txFee = TxFeeExplicit sbe fee, txReturnCollateral = retColl, txTotalCollateral = reqCol } - let balance = evaluateTransactionBalance pp poolids stakeDelegDeposits drepDelegDeposits utxo txbody2 + let balance = evaluateTransactionBalance sbe pp poolids stakeDelegDeposits drepDelegDeposits utxo txbody2 forM_ (txOuts txbodycontent1) $ \txout -> checkMinUTxOValue txout pp @@ -913,7 +907,7 @@ makeTransactionBodyAutoBalance systemstart history lpp@(LedgerProtocolParameters first TxBodyError $ -- TODO: impossible to fail now. We need to implement a function -- that simply creates a transaction body because we have already -- validated the transaction body earlier within makeTransactionBodyAutoBalance - createAndValidateTransactionBody finalTxBodyContent + createAndValidateTransactionBody era finalTxBodyContent return (BalancedTxBody finalTxBodyContent txbody3 (TxOut changeaddr balance TxOutDatumNone ReferenceScriptNone) fee) where -- Essentially we check for the existence of collateral inputs. If they exist we @@ -925,13 +919,13 @@ makeTransactionBodyAutoBalance systemstart history lpp@(LedgerProtocolParameters case txInsCollateral of TxInsCollateralNone -> (TxReturnCollateralNone, TxTotalCollateralNone) TxInsCollateral{} -> - forEraInEon era' + forEraInEon era (TxReturnCollateralNone, TxTotalCollateralNone) (\w -> let dummyRetCol = TxReturnCollateral w ( TxOut cAddr - (lovelaceToTxOutValue $ Lovelace (2^(64 :: Integer)) - 1) + (lovelaceToTxOutValue era $ Lovelace (2^(64 :: Integer)) - 1) TxOutDatumNone ReferenceScriptNone ) dummyTotCol = TxTotalCollateral w (Lovelace (2^(32 :: Integer) - 1)) @@ -956,7 +950,8 @@ makeTransactionBodyAutoBalance systemstart history lpp@(LedgerProtocolParameters -> (TxReturnCollateral CtxTx era, TxTotalCollateral era) calcReturnAndTotalCollateral _ _ _ TxInsCollateralNone _ _ _ _= (TxReturnCollateralNone, TxTotalCollateralNone) calcReturnAndTotalCollateral _ _ _ _ rc@TxReturnCollateral{} tc@TxTotalCollateral{} _ _ = (rc,tc) - calcReturnAndTotalCollateral retColSup fee pp' (TxInsCollateral _ collIns) txReturnCollateral txTotalCollateral cAddr (UTxO utxo') = do + calcReturnAndTotalCollateral retColSup fee pp' (TxInsCollateral _ collIns) txReturnCollateral txTotalCollateral cAddr (UTxO utxo') = + shelleyBasedEraConstraints sbe $ do let colPerc = pp' ^. Ledger.ppCollateralPercentageL -- We must first figure out how much lovelace we have committed -- as collateral and we must determine if we have enough lovelace at our @@ -991,16 +986,13 @@ makeTransactionBodyAutoBalance systemstart history lpp@(LedgerProtocolParameters then ( TxReturnCollateral retColSup - (TxOut cAddr (lovelaceToTxOutValue returnCollateral) TxOutDatumNone ReferenceScriptNone) + (TxOut cAddr (lovelaceToTxOutValue era returnCollateral) TxOutDatumNone ReferenceScriptNone) , totalCollateral ) else (TxReturnCollateralNone, TxTotalCollateralNone) - sbe :: ShelleyBasedEra era - sbe = shelleyBasedEra - - era' :: CardanoEra era - era' = cardanoEra + era :: CardanoEra era + era = shelleyBasedToCardanoEra sbe -- In the event of spending the exact amount of lovelace in -- the specified input(s), this function excludes the change @@ -1039,12 +1031,10 @@ makeTransactionBodyAutoBalance systemstart history lpp@(LedgerProtocolParameters -> Ledger.PParams (ShelleyLedgerEra era) -> Either TxBodyErrorAutoBalance () checkMinUTxOValue txout@(TxOut _ v _ _) bpp = do - let minUTxO = calculateMinimumUTxO sbe txout bpp - if txOutValueToLovelace v >= minUTxO - then Right () - else Left $ TxBodyErrorMinUTxONotMet - (txOutInAnyEra txout) - minUTxO + let minUTxO = calculateMinimumUTxO sbe txout bpp + if txOutValueToLovelace v >= minUTxO + then Right () + else Left $ TxBodyErrorMinUTxONotMet (txOutInAnyEra era txout) minUTxO substituteExecutionUnits :: Map ScriptWitnessIndex ExecutionUnits -> TxBodyContent BuildTx era diff --git a/cardano-api/internal/Cardano/Api/LedgerState.hs b/cardano-api/internal/Cardano/Api/LedgerState.hs index 8df77d660a..564355b89a 100644 --- a/cardano-api/internal/Cardano/Api/LedgerState.hs +++ b/cardano-api/internal/Cardano/Api/LedgerState.hs @@ -472,7 +472,7 @@ foldBlocks nodeConfigFilePath socketPath validationMode state0 accumulate = do -> CSP.ClientStNext n (BlockInMode CardanoMode) ChainPoint ChainTip IO () clientNextN n knownLedgerStates = CSP.ClientStNext { - CSP.recvMsgRollForward = \blockInMode@(BlockInMode block@(Block (BlockHeader slotNo _ currBlockNo) _) _era) serverChainTip -> do + CSP.recvMsgRollForward = \blockInMode@(BlockInMode _ block@(Block (BlockHeader slotNo _ currBlockNo) _) _era) serverChainTip -> do let newLedgerStateE = applyBlock env (maybe @@ -588,7 +588,7 @@ chainSyncClientWithLedgerState env ledgerState0 validationMode (CS.ChainSyncClie goClientStIdle (Left err) <$> CS.runChainSyncClient (recvMsgRollBackward point tip) ) goClientStNext (Right history) (CS.ClientStNext recvMsgRollForward recvMsgRollBackward) = CS.ClientStNext - (\blkInMode@(BlockInMode blk@(Block (BlockHeader slotNo _ _) _) _) tip -> CS.ChainSyncClient $ let + (\blkInMode@(BlockInMode _ blk@(Block (BlockHeader slotNo _ _) _) _) tip -> CS.ChainSyncClient $ let newLedgerStateE = case Seq.lookup 0 history of Nothing -> error "Impossible! History should always be non-empty" Just (_, Left err, _) -> Left err @@ -676,7 +676,7 @@ chainSyncClientPipelinedWithLedgerState env ledgerState0 validationMode (CSP.Cha goClientPipelinedStIdle (Left err) n <$> recvMsgRollBackward point tip ) goClientStNext (Right history) n (CSP.ClientStNext recvMsgRollForward recvMsgRollBackward) = CSP.ClientStNext - (\blkInMode@(BlockInMode blk@(Block (BlockHeader slotNo _ _) _) _) tip -> let + (\blkInMode@(BlockInMode _ blk@(Block (BlockHeader slotNo _ _) _) _) tip -> let newLedgerStateE = case Seq.lookup 0 history of Nothing -> error "Impossible! History should always be non-empty" Just (_, Left err, _) -> Left err diff --git a/cardano-api/internal/Cardano/Api/ProtocolParameters.hs b/cardano-api/internal/Cardano/Api/ProtocolParameters.hs index 5d6a7d19aa..89335827da 100644 --- a/cardano-api/internal/Cardano/Api/ProtocolParameters.hs +++ b/cardano-api/internal/Cardano/Api/ProtocolParameters.hs @@ -1839,8 +1839,7 @@ fromConwayPParams :: BabbageEraPParams ledgerera -> ProtocolParameters fromConwayPParams = fromBabbagePParams -checkProtocolParameters - :: forall era. IsCardanoEra era +checkProtocolParameters :: () => ShelleyBasedEra era -> ProtocolParameters -> Either ProtocolParametersError () @@ -1853,7 +1852,6 @@ checkProtocolParameters sbe ProtocolParameters{..} = ShelleyBasedEraBabbage -> checkBabbageParams ShelleyBasedEraConway -> checkBabbageParams where - era :: CardanoEra era era = shelleyBasedToCardanoEra sbe costPerWord = isJust protocolParamUTxOCostPerWord @@ -1911,9 +1909,8 @@ checkProtocolParameters sbe ProtocolParameters{..} = checkMinUTxOVal :: Either ProtocolParametersError () checkMinUTxOVal = if isJust protocolParamMinUTxOValue - then return () - else Left . PParamsErrorMissingMinUTxoValue - $ AnyCardanoEra era + then return () + else Left . PParamsErrorMissingMinUTxoValue $ cardanoEraConstraints era $ AnyCardanoEra era data ProtocolParametersError diff --git a/cardano-api/internal/Cardano/Api/SerialiseLedgerCddl.hs b/cardano-api/internal/Cardano/Api/SerialiseLedgerCddl.hs index ce3b6c938d..275dea6c8f 100644 --- a/cardano-api/internal/Cardano/Api/SerialiseLedgerCddl.hs +++ b/cardano-api/internal/Cardano/Api/SerialiseLedgerCddl.hs @@ -123,14 +123,15 @@ instance Error TextEnvelopeCddlError where displayError TextEnvelopeCddlErrByronKeyWitnessUnsupported = "TextEnvelopeCddl error: Byron key witnesses are currently unsupported." -serialiseTxLedgerCddl :: forall era. IsCardanoEra era => Tx era -> TextEnvelopeCddl -serialiseTxLedgerCddl tx = - TextEnvelopeCddl - { teCddlType = genType tx - , teCddlDescription = "Ledger Cddl Format" - , teCddlRawCBOR = serialiseToCBOR tx - -- The SerialiseAsCBOR (Tx era) instance serializes to the Cddl format - } +serialiseTxLedgerCddl :: CardanoEra era -> Tx era -> TextEnvelopeCddl +serialiseTxLedgerCddl era tx = + cardanoEraConstraints era $ + TextEnvelopeCddl + { teCddlType = genType tx + , teCddlDescription = "Ledger Cddl Format" + , teCddlRawCBOR = serialiseToCBOR tx + -- The SerialiseAsCBOR (Tx era) instance serializes to the Cddl format + } where genType :: Tx era -> Text genType tx' = case getTxWitnesses tx' of @@ -138,7 +139,7 @@ serialiseTxLedgerCddl tx = _ -> "Witnessed " <> genTxType genTxType :: Text genTxType = - case cardanoEra :: CardanoEra era of + case era of ByronEra -> "Tx ByronEra" ShelleyEra -> "Tx ShelleyEra" AllegraEra -> "Tx AllegraEra" @@ -147,27 +148,23 @@ serialiseTxLedgerCddl tx = BabbageEra -> "Tx BabbageEra" ConwayEra -> "Tx ConwayEra" -deserialiseTxLedgerCddl - :: IsCardanoEra era +deserialiseTxLedgerCddl :: () => CardanoEra era -> TextEnvelopeCddl -> Either TextEnvelopeCddlError (Tx era) deserialiseTxLedgerCddl era tec = first TextEnvelopeCddlErrCBORDecodingError . deserialiseTx era $ teCddlRawCBOR tec -deserialiseTx - :: forall era. IsCardanoEra era +deserialiseTx :: () => CardanoEra era -> ByteString -> Either DecoderError (Tx era) deserialiseTx era bs = case era of - ByronEra -> ByronTx <$> CBOR.decodeFullAnnotatedBytes - CBOR.byronProtVer "Byron Tx" CBOR.decCBOR (LBS.fromStrict bs) - _ -> deserialiseFromCBOR (AsTx ttoken) bs - where - ttoken :: AsType era - ttoken = proxyToAsType Proxy + ByronEra -> + ByronTx + <$> CBOR.decodeFullAnnotatedBytes CBOR.byronProtVer "Byron Tx" CBOR.decCBOR (LBS.fromStrict bs) + _ -> cardanoEraConstraints era $ deserialiseFromCBOR (AsTx (proxyToAsType Proxy)) bs serialiseWitnessLedgerCddl :: forall era. ShelleyBasedEra era -> KeyWitness era -> TextEnvelopeCddl serialiseWitnessLedgerCddl sbe kw = @@ -216,16 +213,16 @@ deserialiseWitnessLedgerCddl sbe TextEnvelopeCddl{teCddlRawCBOR,teCddlDescriptio Right $ ShelleyKeyWitness sbe w _ -> Left TextEnvelopeCddlUnknownKeyWitness -writeTxFileTextEnvelopeCddl - :: IsCardanoEra era - => File content Out +writeTxFileTextEnvelopeCddl :: () + => CardanoEra era + -> File content Out -> Tx era -> IO (Either (FileError ()) ()) -writeTxFileTextEnvelopeCddl path tx = +writeTxFileTextEnvelopeCddl era path tx = runExceptT $ do handleIOExceptT (FileIOError (unFile path)) $ LBS.writeFile (unFile path) txJson - where - txJson = encodePretty' textEnvelopeCddlJSONConfig (serialiseTxLedgerCddl tx) <> "\n" + where + txJson = encodePretty' textEnvelopeCddlJSONConfig (serialiseTxLedgerCddl era tx) <> "\n" writeTxWitnessFileTextEnvelopeCddl :: ShelleyBasedEra era @@ -235,8 +232,8 @@ writeTxWitnessFileTextEnvelopeCddl writeTxWitnessFileTextEnvelopeCddl sbe path w = runExceptT $ do handleIOExceptT (FileIOError (unFile path)) $ LBS.writeFile (unFile path) txJson - where - txJson = encodePretty' textEnvelopeCddlJSONConfig (serialiseWitnessLedgerCddl sbe w) <> "\n" + where + txJson = encodePretty' textEnvelopeCddlJSONConfig (serialiseWitnessLedgerCddl sbe w) <> "\n" textEnvelopeCddlJSONConfig :: Config textEnvelopeCddlJSONConfig = diff --git a/cardano-api/internal/Cardano/Api/Tx.hs b/cardano-api/internal/Cardano/Api/Tx.hs index a70420dd4f..f9a6cdf6c6 100644 --- a/cardano-api/internal/Cardano/Api/Tx.hs +++ b/cardano-api/internal/Cardano/Api/Tx.hs @@ -3,6 +3,7 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} @@ -620,29 +621,23 @@ data WitnessNetworkIdOrByronAddress -- both the network ID and derivation path will be extracted from the -- address and used in the construction of the witness. -makeShelleyBootstrapWitness :: forall era. - IsShelleyBasedEra era - => WitnessNetworkIdOrByronAddress - -> TxBody era - -> SigningKey ByronKey - -> KeyWitness era -makeShelleyBootstrapWitness _ ByronTxBody{} _ = - case shelleyBasedEra :: ShelleyBasedEra era of {} - -makeShelleyBootstrapWitness nwOrAddr (ShelleyTxBody sbe txbody _ _ _ _) sk = - shelleyBasedEraConstraints sbe $ - makeShelleyBasedBootstrapWitness sbe nwOrAddr txbody sk - -makeShelleyBasedBootstrapWitness :: forall era. - (Ledger.HashAnnotated - (Ledger.TxBody (ShelleyLedgerEra era)) - Ledger.EraIndependentTxBody - StandardCrypto) - => ShelleyBasedEra era - -> WitnessNetworkIdOrByronAddress - -> Ledger.TxBody (ShelleyLedgerEra era) - -> SigningKey ByronKey - -> KeyWitness era +makeShelleyBootstrapWitness :: forall era. () + => ShelleyBasedEra era + -> WitnessNetworkIdOrByronAddress + -> TxBody era + -> SigningKey ByronKey + -> KeyWitness era +makeShelleyBootstrapWitness sbe nwOrAddr txBody sk = + case txBody of + ByronTxBody{} -> case sbe of {} + ShelleyTxBody _ txbody _ _ _ _ -> makeShelleyBasedBootstrapWitness sbe nwOrAddr txbody sk + +makeShelleyBasedBootstrapWitness :: forall era. () + => ShelleyBasedEra era + -> WitnessNetworkIdOrByronAddress + -> Ledger.TxBody (ShelleyLedgerEra era) + -> SigningKey ByronKey + -> KeyWitness era makeShelleyBasedBootstrapWitness sbe nwOrAddr txbody (ByronSigningKey sk) = ShelleyBootstrapWitness sbe $ -- Byron era witnesses were weird. This reveals all that weirdness. @@ -674,7 +669,7 @@ makeShelleyBasedBootstrapWitness sbe nwOrAddr txbody (ByronSigningKey sk) = (ShelleyExtendedSigningKey (Byron.unSigningKey sk)) txhash :: Shelley.Hash StandardCrypto Ledger.EraIndependentTxBody - txhash = Ledger.extractHash (Ledger.hashAnnotated txbody) + txhash = shelleyBasedEraConstraints sbe $ Ledger.extractHash (Ledger.hashAnnotated txbody) --TODO: use Shelley.eraIndTxBodyHash txbody once that function has a -- suitably general type. @@ -732,34 +727,26 @@ data ShelleyWitnessSigningKey = | WitnessCommitteeHotKey (SigningKey CommitteeHotKey) -makeShelleyKeyWitness :: forall era - . IsShelleyBasedEra era - => TxBody era - -> ShelleyWitnessSigningKey - -> KeyWitness era -makeShelleyKeyWitness (ShelleyTxBody sbe txbody _ _ _ _) = - shelleyBasedEraConstraints sbe $ makeShelleyBasedKeyWitness txbody - where - makeShelleyBasedKeyWitness :: Ledger.HashAnnotated (Ledger.TxBody (ShelleyLedgerEra era)) Ledger.EraIndependentTxBody StandardCrypto - => Ledger.TxBody (ShelleyLedgerEra era) - -> ShelleyWitnessSigningKey - -> KeyWitness era - makeShelleyBasedKeyWitness txbody' = - - let txhash :: Shelley.Hash StandardCrypto Ledger.EraIndependentTxBody - txhash = Ledger.extractHash @StandardCrypto (Ledger.hashAnnotated txbody') - - -- To allow sharing of the txhash computation across many signatures we - -- define and share the txhash outside the lambda for the signing key: - in \wsk -> - let sk = toShelleySigningKey wsk - vk = getShelleyKeyWitnessVerificationKey sk - signature = makeShelleySignature txhash sk - in ShelleyKeyWitness sbe $ - L.WitVKey vk signature - -makeShelleyKeyWitness ByronTxBody{} = - case shelleyBasedEra :: ShelleyBasedEra era of {} +makeShelleyKeyWitness :: forall era. () + => ShelleyBasedEra era + -> TxBody era + -> ShelleyWitnessSigningKey + -> KeyWitness era +makeShelleyKeyWitness sbe = \case + ShelleyTxBody _ txbody _ _ _ _ -> + shelleyBasedEraConstraints sbe $ + let txhash :: Shelley.Hash StandardCrypto Ledger.EraIndependentTxBody + txhash = Ledger.extractHash @StandardCrypto (Ledger.hashAnnotated txbody) + + -- To allow sharing of the txhash computation across many signatures we + -- define and share the txhash outside the lambda for the signing key: + in \wsk -> + let sk = toShelleySigningKey wsk + vk = getShelleyKeyWitnessVerificationKey sk + signature = makeShelleySignature txhash sk + in ShelleyKeyWitness sbe $ + L.WitVKey vk signature + ByronTxBody{} -> case sbe of {} -- | We support making key witnesses with both normal and extended signing keys. @@ -862,12 +849,13 @@ signByronTransaction nw txbody sks = witnesses = map (makeByronKeyWitness nw txbody) sks -- signing keys is a set -signShelleyTransaction :: IsShelleyBasedEra era - => TxBody era - -> [ShelleyWitnessSigningKey] - -> Tx era -signShelleyTransaction txbody sks = +signShelleyTransaction :: () + => ShelleyBasedEra era + -> TxBody era + -> [ShelleyWitnessSigningKey] + -> Tx era +signShelleyTransaction sbe txbody sks = makeSignedTransaction witnesses txbody where - witnesses = map (makeShelleyKeyWitness txbody) sks + witnesses = map (makeShelleyKeyWitness sbe txbody) sks diff --git a/cardano-api/internal/Cardano/Api/TxBody.hs b/cardano-api/internal/Cardano/Api/TxBody.hs index ac0f6320b1..42681ee074 100644 --- a/cardano-api/internal/Cardano/Api/TxBody.hs +++ b/cardano-api/internal/Cardano/Api/TxBody.hs @@ -339,8 +339,8 @@ instance Eq TxOutInAnyEra where Nothing -> False -- | Convenience constructor for 'TxOutInAnyEra' -txOutInAnyEra :: IsCardanoEra era => TxOut CtxTx era -> TxOutInAnyEra -txOutInAnyEra = TxOutInAnyEra cardanoEra +txOutInAnyEra :: CardanoEra era -> TxOut CtxTx era -> TxOutInAnyEra +txOutInAnyEra = TxOutInAnyEra toCtxUTxOTxOut :: TxOut CtxTx era -> TxOut CtxUTxO era toCtxUTxOTxOut (TxOut addr val d refS) = @@ -937,12 +937,15 @@ instance IsCardanoEra era => FromJSON (TxOutValue era) where Nothing -> fail $ "Expected a Bounded number but got: " <> show sci decodeQuantity wrong = fail $ "Expected aeson Number but got: " <> show wrong -lovelaceToTxOutValue :: IsCardanoEra era => Lovelace -> TxOutValue era -lovelaceToTxOutValue l = +lovelaceToTxOutValue :: () + => CardanoEra era + -> Lovelace + -> TxOutValue era +lovelaceToTxOutValue era l = caseByronToAllegraOrMaryEraOnwards (\w -> TxOutAdaOnly w l) (\w -> TxOutValue w (lovelaceToValue l)) - cardanoEra + era txOutValueToLovelace :: TxOutValue era -> Lovelace txOutValueToLovelace tv = @@ -1051,12 +1054,11 @@ data TxFee era where deriving instance Eq (TxFee era) deriving instance Show (TxFee era) -defaultTxFee :: forall era. IsCardanoEra era => TxFee era +defaultTxFee :: CardanoEra era -> TxFee era defaultTxFee = caseByronOrShelleyBasedEra TxFeeImplicit (\w -> TxFeeExplicit w mempty) - (cardanoEra @era) -- ---------------------------------------------------------------------------- -- Transaction validity range @@ -1077,12 +1079,13 @@ data TxValidityUpperBound era where deriving instance Eq (TxValidityUpperBound era) deriving instance Show (TxValidityUpperBound era) -defaultTxValidityUpperBound :: forall era. IsCardanoEra era => TxValidityUpperBound era +defaultTxValidityUpperBound :: () + => CardanoEra era + -> TxValidityUpperBound era defaultTxValidityUpperBound = caseByronAndAllegraEraOnwardsOrShelleyEraOnly TxValidityNoUpperBound (\w -> TxValidityUpperBound (shelleyEraOnlyToShelleyBasedEra w) maxBound) - (cardanoEra @era) data TxValidityLowerBound era where @@ -1240,16 +1243,18 @@ data TxBodyContent build era = } deriving (Eq, Show) -defaultTxBodyContent :: IsCardanoEra era => TxBodyContent BuildTx era -defaultTxBodyContent = TxBodyContent +defaultTxBodyContent :: () + => CardanoEra era + -> TxBodyContent BuildTx era +defaultTxBodyContent era = TxBodyContent { txIns = [] , txInsCollateral = TxInsCollateralNone , txInsReference = TxInsReferenceNone , txOuts = [] , txTotalCollateral = TxTotalCollateralNone , txReturnCollateral = TxReturnCollateralNone - , txFee = defaultTxFee - , txValidityRange = (TxValidityNoLowerBound, defaultTxValidityUpperBound) + , txFee = defaultTxFee era + , txValidityRange = (TxValidityNoLowerBound, defaultTxValidityUpperBound era) , txMetadata = TxMetadataNone , txAuxScripts = TxAuxScriptsNone , txExtraKeyWits = TxExtraKeyWitnessesNone @@ -2054,13 +2059,15 @@ validateTxInsCollateral txInsCollateral languages = guardShelleyTxInsOverflow collateralTxIns validateTxOuts :: ShelleyBasedEra era -> [TxOut CtxTx era] -> Either TxBodyError () -validateTxOuts era txOuts = do - let cEra = shelleyBasedToCardanoEra era - cardanoEraConstraints cEra $ - sequence_ [ do positiveOutput (txOutValueToValue v) txout - outputDoesNotExceedMax (txOutValueToValue v) txout - | txout@(TxOut _ v _ _) <- txOuts - ] +validateTxOuts sbe txOuts = do + let era = shelleyBasedToCardanoEra sbe + cardanoEraConstraints era $ + sequence_ + [ do + positiveOutput era (txOutValueToValue v) txout + outputDoesNotExceedMax era (txOutValueToValue v) txout + | txout@(TxOut _ v _ _) <- txOuts + ] validateMintValue :: TxMintValue build era -> Either TxBodyError () validateMintValue txMintValue = @@ -2074,20 +2081,25 @@ inputIndexDoesNotExceedMax txIns = for_ txIns $ \(txin@(TxIn _ (TxIx txix)), _) -> guard (fromIntegral txix <= maxShelleyTxInIx) ?! TxBodyInIxOverflow txin -outputDoesNotExceedMax - :: IsCardanoEra era => Value -> TxOut CtxTx era -> Either TxBodyError () -outputDoesNotExceedMax v txout = +outputDoesNotExceedMax :: () + => CardanoEra era + -> Value + -> TxOut CtxTx era + -> Either TxBodyError () +outputDoesNotExceedMax era v txout = case [ q | (_,q) <- valueToList v, q > maxTxOut ] of [] -> Right () - q:_ -> Left (TxBodyOutputOverflow q (txOutInAnyEra txout)) + q:_ -> Left (TxBodyOutputOverflow q (txOutInAnyEra era txout)) -positiveOutput - :: IsCardanoEra era - => Value -> TxOut CtxTx era -> Either TxBodyError () -positiveOutput v txout = - case [ q | (_, q) <- valueToList v, q < 0 ] of - [] -> Right () - q:_ -> Left (TxBodyOutputNegative q (txOutInAnyEra txout)) +positiveOutput :: () + => CardanoEra era + -> Value + -> TxOut CtxTx era + -> Either TxBodyError () +positiveOutput era v txout = + case [ q | (_, q) <- valueToList v, q < 0 ] of + [] -> Right () + q:_ -> Left (TxBodyOutputNegative q (txOutInAnyEra era txout)) txBodyContentHasTxIns :: TxIns BuildTx era -> Either TxBodyError () txBodyContentHasTxIns txIns = guard (not (null txIns)) ?! TxBodyEmptyTxIns @@ -2098,15 +2110,14 @@ maxShelleyTxInIx = fromIntegral $ maxBound @Word16 maxTxOut :: Quantity maxTxOut = fromIntegral (maxBound :: Word64) -createAndValidateTransactionBody - :: forall era. - IsCardanoEra era - => TxBodyContent BuildTx era +createAndValidateTransactionBody :: () + => CardanoEra era + -> TxBodyContent BuildTx era -> Either TxBodyError (TxBody era) -createAndValidateTransactionBody = - case cardanoEraStyle (cardanoEra :: CardanoEra era) of - LegacyByronEra -> makeByronTransactionBody - ShelleyBasedEra sbe -> makeShelleyTransactionBody sbe +createAndValidateTransactionBody era = + case cardanoEraStyle era of + LegacyByronEra -> makeByronTransactionBody + ShelleyBasedEra sbe -> makeShelleyTransactionBody sbe pattern TxBody :: TxBodyContent ViewTx era -> TxBody era pattern TxBody txbodycontent <- (getTxBodyContent -> txbodycontent) @@ -2569,10 +2580,8 @@ makeByronTransactionBody TxBodyContent { txIns, txOuts } = do classifyRangeError txout@(TxOut (AddressInEra ByronAddressInAnyEra ByronAddress{}) (TxOutAdaOnly ByronToAllegraEraByron value) _ _) - | value < 0 = TxBodyOutputNegative (lovelaceToQuantity value) - (txOutInAnyEra txout) - | otherwise = TxBodyOutputOverflow (lovelaceToQuantity value) - (txOutInAnyEra txout) + | value < 0 = TxBodyOutputNegative (lovelaceToQuantity value) (txOutInAnyEra ByronEra txout) + | otherwise = TxBodyOutputOverflow (lovelaceToQuantity value) (txOutInAnyEra ByronEra txout) classifyRangeError (TxOut (AddressInEra ByronAddressInAnyEra (ByronAddress _)) diff --git a/cardano-api/test/cardano-api-golden/Test/Golden/ErrorsSpec.hs b/cardano-api/test/cardano-api-golden/Test/Golden/ErrorsSpec.hs index 45977d3561..bcdf002a7a 100644 --- a/cardano-api/test/cardano-api-golden/Test/Golden/ErrorsSpec.hs +++ b/cardano-api/test/cardano-api-golden/Test/Golden/ErrorsSpec.hs @@ -122,7 +122,7 @@ txout1 :: TxOut ctx AllegraEra txout1 = TxOut changeaddr1 txOutValue1 TxOutDatumNone ReferenceScriptNone txOutInAnyEra1 :: TxOutInAnyEra -txOutInAnyEra1 = txOutInAnyEra txout1 +txOutInAnyEra1 = txOutInAnyEra AllegraEra txout1 poolId :: Hash StakePoolKey poolId = fromJust $ hush $ deserialiseFromRawBytesHex (AsHash AsStakePoolKey) diff --git a/cardano-api/test/cardano-api-test/Test/Cardano/Api/Eras.hs b/cardano-api/test/cardano-api-test/Test/Cardano/Api/Eras.hs index 445c01c22e..682dae78aa 100644 --- a/cardano-api/test/cardano-api-test/Test/Cardano/Api/Eras.hs +++ b/cardano-api/test/cardano-api-test/Test/Cardano/Api/Eras.hs @@ -23,7 +23,7 @@ prop_maxBound_CardanoMatchesShelley = property $ do AnyCardanoEra era <- forAll $ Gen.element [maxBound] AnyShelleyBasedEra sbe <- forAll $ Gen.element [maxBound] - fromEnum (AnyCardanoEra era) === fromEnum (AnyCardanoEra (shelleyBasedToCardanoEra sbe)) + fromEnum (anyCardanoEra era) === fromEnum (anyCardanoEra (shelleyBasedToCardanoEra sbe)) -------------------------------------------------------------------------------- -- Aeson instances @@ -44,7 +44,7 @@ prop_toJSON_CardanoMatchesShelley :: Property prop_toJSON_CardanoMatchesShelley = property $ do AnyShelleyBasedEra sbe <- forAll $ Gen.element [minBound..maxBound] - toJSON (AnyShelleyBasedEra sbe) === toJSON (AnyCardanoEra (shelleyBasedToCardanoEra sbe)) + toJSON (anyShelleyBasedEra sbe) === toJSON (anyCardanoEra (shelleyBasedToCardanoEra sbe)) tests :: TestTree tests = testGroup "Test.Cardano.Api.Json" diff --git a/cardano-api/test/cardano-api-test/Test/Cardano/Api/Typed/CBOR.hs b/cardano-api/test/cardano-api-test/Test/Cardano/Api/Typed/CBOR.hs index ad5544d877..511306e998 100644 --- a/cardano-api/test/cardano-api-test/Test/Cardano/Api/Typed/CBOR.hs +++ b/cardano-api/test/cardano-api-test/Test/Cardano/Api/Typed/CBOR.hs @@ -32,19 +32,19 @@ prop_roundtrip_txbody_CBOR :: Property prop_roundtrip_txbody_CBOR = H.property $ do AnyCardanoEra era <- H.forAll $ Gen.element [minBound..AnyCardanoEra BabbageEra] x <- H.forAll $ makeSignedTransaction [] <$> genTxBody era - H.tripping x serialiseTxLedgerCddl (deserialiseTxLedgerCddl era) + H.tripping x (serialiseTxLedgerCddl era) (deserialiseTxLedgerCddl era) prop_roundtrip_tx_CBOR :: Property prop_roundtrip_tx_CBOR = H.property $ do AnyCardanoEra era <- H.forAll $ Gen.element [minBound..AnyCardanoEra BabbageEra] x <- H.forAll $ genTx era - H.trippingCbor (proxyToAsType Proxy) x + cardanoEraConstraints era $ H.trippingCbor (proxyToAsType Proxy) x prop_roundtrip_witness_CBOR :: Property prop_roundtrip_witness_CBOR = H.property $ do AnyCardanoEra era <- H.forAll $ Gen.element [minBound..maxBound] x <- H.forAll $ genCardanoKeyWitness era - H.trippingCbor (AsKeyWitness (proxyToAsType Proxy)) x + cardanoEraConstraints era $ H.trippingCbor (AsKeyWitness (proxyToAsType Proxy)) x prop_roundtrip_operational_certificate_CBOR :: Property prop_roundtrip_operational_certificate_CBOR = H.property $ do @@ -171,12 +171,12 @@ prop_roundtrip_Tx_Cddl :: Property prop_roundtrip_Tx_Cddl = H.property $ do AnyCardanoEra era <- H.forAll $ Gen.element [minBound..maxBound] x <- forAll $ genTx era - H.tripping x serialiseTxLedgerCddl (deserialiseTxLedgerCddl era) + H.tripping x (serialiseTxLedgerCddl era) (deserialiseTxLedgerCddl era) prop_roundtrip_TxWitness_Cddl :: Property prop_roundtrip_TxWitness_Cddl = H.property $ do AnyShelleyBasedEra sbe <- H.forAll $ Gen.element [minBound..maxBound] - x <- forAll $ genShelleyKeyWitness $ shelleyBasedToCardanoEra sbe + x <- forAll $ genShelleyKeyWitness sbe tripping x (serialiseWitnessLedgerCddl sbe) (deserialiseWitnessLedgerCddl sbe) prop_roundtrip_GovernancePoll_CBOR :: Property diff --git a/cardano-api/test/cardano-api-test/Test/Cardano/Api/Typed/Ord.hs b/cardano-api/test/cardano-api-test/Test/Cardano/Api/Typed/Ord.hs index 8a780268f5..5a5bb95d8a 100644 --- a/cardano-api/test/cardano-api-test/Test/Cardano/Api/Typed/Ord.hs +++ b/cardano-api/test/cardano-api-test/Test/Cardano/Api/Typed/Ord.hs @@ -38,7 +38,7 @@ prop_ord_distributive_Address = ord_distributive genAddressShelley (toShelleyAddr . toAddressInAnyEra) where toAddressInAnyEra :: Address ShelleyAddr -> AddressInEra ShelleyEra - toAddressInAnyEra = anyAddressInShelleyBasedEra . toAddressAny + toAddressInAnyEra = anyAddressInShelleyBasedEra ShelleyBasedEraShelley . toAddressAny prop_ord_distributive_StakeAddress :: Property prop_ord_distributive_StakeAddress = diff --git a/cardano-api/test/cardano-api-test/Test/Cardano/Api/Typed/TxBody.hs b/cardano-api/test/cardano-api-test/Test/Cardano/Api/Typed/TxBody.hs index 6261216b76..5474c45b99 100644 --- a/cardano-api/test/cardano-api-test/Test/Cardano/Api/Typed/TxBody.hs +++ b/cardano-api/test/cardano-api-test/Test/Cardano/Api/Typed/TxBody.hs @@ -25,9 +25,10 @@ import Test.Tasty.Hedgehog (testProperty) prop_roundtrip_txbodycontent_txouts:: Property prop_roundtrip_txbodycontent_txouts = H.property $ do - content <- H.forAll $ genTxBodyContent BabbageEra + let era = BabbageEra + content <- H.forAll $ genTxBodyContent era -- Create the ledger body & auxiliaries - body <- case createAndValidateTransactionBody content of + body <- case createAndValidateTransactionBody era content of Left err -> annotateShow err >> failure Right body -> pure body annotateShow body