From 2082f16b17b1e03596aa54551c7c53d42f7e9d07 Mon Sep 17 00:00:00 2001 From: John Ky Date: Thu, 27 Jul 2023 18:15:09 +1000 Subject: [PATCH 1/3] Provide additional constraints in shelleyBasedEraConstraints --- cardano-api/internal/Cardano/Api/Eras.hs | 12 +++++++++++- .../internal/Cardano/Api/Feature/ShelleyBasedEra.hs | 2 ++ 2 files changed, 13 insertions(+), 1 deletion(-) create mode 100644 cardano-api/internal/Cardano/Api/Feature/ShelleyBasedEra.hs diff --git a/cardano-api/internal/Cardano/Api/Eras.hs b/cardano-api/internal/Cardano/Api/Eras.hs index 334257e850..6089d1685b 100644 --- a/cardano-api/internal/Cardano/Api/Eras.hs +++ b/cardano-api/internal/Cardano/Api/Eras.hs @@ -69,6 +69,7 @@ module Cardano.Api.Eras import Cardano.Api.HasTypeProxy +import qualified Cardano.Crypto.Hash.Class as C import qualified Cardano.Ledger.Api as L import qualified Cardano.Ledger.BaseTypes as L import Ouroboros.Consensus.Shelley.Eras as Consensus (StandardAllegra, StandardAlonzo, @@ -623,7 +624,16 @@ cardanoEraConstraints = \case shelleyBasedEraConstraints :: () => ShelleyBasedEra era - -> (Typeable era => IsShelleyBasedEra era => a) + -> (() + => Typeable era + => IsShelleyBasedEra era + => L.EraCrypto (ShelleyLedgerEra era) ~ L.StandardCrypto + => L.Crypto (L.EraCrypto (ShelleyLedgerEra era)) + => L.EraPParams (ShelleyLedgerEra era) + => IsShelleyBasedEra era + => L.Era (ShelleyLedgerEra era) + => C.HashAlgorithm (L.HASH (L.EraCrypto (ShelleyLedgerEra era))) + => a) -> a shelleyBasedEraConstraints = \case ShelleyBasedEraShelley -> id diff --git a/cardano-api/internal/Cardano/Api/Feature/ShelleyBasedEra.hs b/cardano-api/internal/Cardano/Api/Feature/ShelleyBasedEra.hs new file mode 100644 index 0000000000..b62399944c --- /dev/null +++ b/cardano-api/internal/Cardano/Api/Feature/ShelleyBasedEra.hs @@ -0,0 +1,2 @@ +module Cardano.Api.Features.ShelleyBasedEra + () where From f198e8e985217894c02dcc0fe9ee58973ca77b27 Mon Sep 17 00:00:00 2001 From: John Ky Date: Thu, 27 Jul 2023 22:57:37 +1000 Subject: [PATCH 2/3] Split Cardano.Api.Eras into Cardano.Api.Eras.Core and Cardano.Api.Eras.Constraints. This allows more constraints to be added without creating cycling dependencies --- cardano-api/cardano-api.cabal | 2 + cardano-api/internal/Cardano/Api/Eras.hs | 577 +---------------- .../internal/Cardano/Api/Eras/Constraints.hs | 74 +++ cardano-api/internal/Cardano/Api/Eras/Core.hs | 589 ++++++++++++++++++ 4 files changed, 667 insertions(+), 575 deletions(-) create mode 100644 cardano-api/internal/Cardano/Api/Eras/Constraints.hs create mode 100644 cardano-api/internal/Cardano/Api/Eras/Core.hs diff --git a/cardano-api/cardano-api.cabal b/cardano-api/cardano-api.cabal index 8185bac740..cd70907069 100644 --- a/cardano-api/cardano-api.cabal +++ b/cardano-api/cardano-api.cabal @@ -57,6 +57,8 @@ library internal Cardano.Api.DRepMetadata Cardano.Api.EraCast Cardano.Api.Eras + Cardano.Api.Eras.Constraints + Cardano.Api.Eras.Core Cardano.Api.Error Cardano.Api.Feature Cardano.Api.Feature.ConwayEraOnwards diff --git a/cardano-api/internal/Cardano/Api/Eras.hs b/cardano-api/internal/Cardano/Api/Eras.hs index 6089d1685b..a420e4fa4d 100644 --- a/cardano-api/internal/Cardano/Api/Eras.hs +++ b/cardano-api/internal/Cardano/Api/Eras.hs @@ -67,578 +67,5 @@ module Cardano.Api.Eras , withShelleyBasedEraConstraintsForLedger ) where -import Cardano.Api.HasTypeProxy - -import qualified Cardano.Crypto.Hash.Class as C -import qualified Cardano.Ledger.Api as L -import qualified Cardano.Ledger.BaseTypes as L -import Ouroboros.Consensus.Shelley.Eras as Consensus (StandardAllegra, StandardAlonzo, - StandardBabbage, StandardConway, StandardMary, StandardShelley) - -import Control.DeepSeq -import Data.Aeson (FromJSON (..), ToJSON, toJSON, withText) -import Data.Kind -import qualified Data.Text as Text -import Data.Type.Equality (TestEquality (..), (:~:) (Refl)) -import Data.Typeable (Typeable) - --- ---------------------------------------------------------------------------- --- Eras - --- | A type used as a tag to distinguish the Byron era. -data ByronEra - --- | A type used as a tag to distinguish the Shelley era. -data ShelleyEra - --- | A type used as a tag to distinguish the Allegra era. -data AllegraEra - --- | A type used as a tag to distinguish the Mary era. -data MaryEra - --- | A type used as a tag to distinguish the Alonzo era. -data AlonzoEra - --- | A type used as a tag to distinguish the Babbage era. -data BabbageEra - --- | A type used as a tag to distinguish the Conway era. -data ConwayEra - -instance HasTypeProxy ByronEra where - data AsType ByronEra = AsByronEra - proxyToAsType _ = AsByronEra - -instance HasTypeProxy ShelleyEra where - data AsType ShelleyEra = AsShelleyEra - proxyToAsType _ = AsShelleyEra - -instance HasTypeProxy AllegraEra where - data AsType AllegraEra = AsAllegraEra - proxyToAsType _ = AsAllegraEra - -instance HasTypeProxy MaryEra where - data AsType MaryEra = AsMaryEra - proxyToAsType _ = AsMaryEra - -instance HasTypeProxy AlonzoEra where - data AsType AlonzoEra = AsAlonzoEra - proxyToAsType _ = AsAlonzoEra - -instance HasTypeProxy BabbageEra where - data AsType BabbageEra = AsBabbageEra - proxyToAsType _ = AsBabbageEra - -instance HasTypeProxy ConwayEra where - data AsType ConwayEra = AsConwayEra - proxyToAsType _ = AsConwayEra - --- ---------------------------------------------------------------------------- --- FeatureInEra - --- | A class for producing values for features that are supported in some eras --- but not others. -class FeatureInEra (feature :: Type -> Type) where - -- | Determine the value to use for a feature in a given 'CardanoEra'. - -- Note that the negative case is the first argument, and the positive case is the second as per - -- the 'either' function convention. - featureInEra :: () - => a -- ^ Value to use if the feature is not supported in the era - -> (feature era -> a) -- ^ Function to get thealue to use if the feature is supported in the era - -> CardanoEra era -- ^ Era to check - -> a -- ^ The value to use - -maybeFeatureInEra :: () - => FeatureInEra feature - => CardanoEra era -- ^ Era to check - -> Maybe (feature era) -- ^ The feature if supported in the era -maybeFeatureInEra = featureInEra Nothing Just - --- | Determine the value to use for a feature in a given 'ShelleyBasedEra'. -featureInShelleyBasedEra :: () - => FeatureInEra feature - => a - -> (feature era -> a) - -> ShelleyBasedEra era - -> a -featureInShelleyBasedEra no yes = - featureInEra no yes . shelleyBasedToCardanoEra - --- ---------------------------------------------------------------------------- --- Deprecated aliases --- - -type Byron = ByronEra -type Shelley = ShelleyEra -type Allegra = AllegraEra -type Mary = MaryEra - -{-# DEPRECATED Byron "Use 'ByronEra' or 'ByronAddr' as appropriate" #-} -{-# DEPRECATED Shelley "Use 'ShelleyEra' or 'ShelleyAddr' as appropriate" #-} -{-# DEPRECATED Allegra "Use 'AllegraEra' instead" #-} -{-# DEPRECATED Mary "Use 'MaryEra' instead" #-} - -pattern AsByron :: AsType ByronEra -pattern AsByron = AsByronEra - -pattern AsShelley :: AsType ShelleyEra -pattern AsShelley = AsShelleyEra - -pattern AsAllegra :: AsType AllegraEra -pattern AsAllegra = AsAllegraEra - -pattern AsMary :: AsType MaryEra -pattern AsMary = AsMaryEra - - -pattern AsAlonzo :: AsType AlonzoEra -pattern AsAlonzo = AsAlonzoEra - -pattern AsBabbage :: AsType BabbageEra -pattern AsBabbage = AsBabbageEra - -pattern AsConway :: AsType ConwayEra -pattern AsConway = AsConwayEra - -{-# DEPRECATED AsByron "Use 'AsByronEra' instead" #-} -{-# DEPRECATED AsShelley "Use 'AsShelleyEra' instead" #-} -{-# DEPRECATED AsAllegra "Use 'AsAllegraEra' instead" #-} -{-# DEPRECATED AsMary "Use 'AsMaryEra' instead" #-} - --- ---------------------------------------------------------------------------- --- Value level representation for Cardano eras --- - --- | This GADT provides a value-level representation of all the Cardano eras. --- This enables pattern matching on the era to allow them to be treated in a --- non-uniform way. --- --- This can be used in combination with the 'IsCardanoEra' class to get access --- to this value. --- --- In combination this can often enable code that handles all eras, and does --- so uniformly where possible, and non-uniformly where necessary. --- -data CardanoEra era where - ByronEra :: CardanoEra ByronEra - ShelleyEra :: CardanoEra ShelleyEra - AllegraEra :: CardanoEra AllegraEra - MaryEra :: CardanoEra MaryEra - AlonzoEra :: CardanoEra AlonzoEra - BabbageEra :: CardanoEra BabbageEra - ConwayEra :: CardanoEra ConwayEra - -- when you add era here, change `instance Bounded AnyCardanoEra` - -deriving instance Eq (CardanoEra era) -deriving instance Ord (CardanoEra era) -deriving instance Show (CardanoEra era) - -instance ToJSON (CardanoEra era) where - toJSON ByronEra = "Byron" - toJSON ShelleyEra = "Shelley" - toJSON AllegraEra = "Allegra" - toJSON MaryEra = "Mary" - toJSON AlonzoEra = "Alonzo" - toJSON BabbageEra = "Babbage" - toJSON ConwayEra = "Conway" - -instance TestEquality CardanoEra where - testEquality ByronEra ByronEra = Just Refl - testEquality ShelleyEra ShelleyEra = Just Refl - testEquality AllegraEra AllegraEra = Just Refl - testEquality MaryEra MaryEra = Just Refl - testEquality AlonzoEra AlonzoEra = Just Refl - testEquality BabbageEra BabbageEra = Just Refl - testEquality ConwayEra ConwayEra = Just Refl - testEquality _ _ = Nothing - - --- | The class of Cardano eras. This allows uniform handling of all Cardano --- eras, but also non-uniform by making case distinctions on the 'CardanoEra' --- constructors, or the 'CardanoEraStyle' constructors via `cardanoEraStyle`. --- -class HasTypeProxy era => IsCardanoEra era where - cardanoEra :: CardanoEra era - -instance IsCardanoEra ByronEra where - cardanoEra = ByronEra - -instance IsCardanoEra ShelleyEra where - cardanoEra = ShelleyEra - -instance IsCardanoEra AllegraEra where - cardanoEra = AllegraEra - -instance IsCardanoEra MaryEra where - cardanoEra = MaryEra - -instance IsCardanoEra AlonzoEra where - cardanoEra = AlonzoEra - -instance IsCardanoEra BabbageEra where - cardanoEra = BabbageEra - -instance IsCardanoEra ConwayEra where - cardanoEra = ConwayEra - -data AnyCardanoEra where - AnyCardanoEra :: IsCardanoEra era -- Provide class constraint - => CardanoEra era -- and explicit value. - -> AnyCardanoEra - -deriving instance Show AnyCardanoEra - -instance Eq AnyCardanoEra where - AnyCardanoEra era == AnyCardanoEra era' = - case testEquality era era' of - Nothing -> False - Just Refl -> True -- since no constructors share types - -instance Bounded AnyCardanoEra where - minBound = AnyCardanoEra ByronEra - maxBound = AnyCardanoEra ConwayEra - -instance Enum AnyCardanoEra where - - -- [e..] = [e..maxBound] - enumFrom e = enumFromTo e maxBound - - fromEnum = \case - AnyCardanoEra ByronEra -> 0 - AnyCardanoEra ShelleyEra -> 1 - AnyCardanoEra AllegraEra -> 2 - AnyCardanoEra MaryEra -> 3 - AnyCardanoEra AlonzoEra -> 4 - AnyCardanoEra BabbageEra -> 5 - AnyCardanoEra ConwayEra -> 6 - - toEnum = \case - 0 -> AnyCardanoEra ByronEra - 1 -> AnyCardanoEra ShelleyEra - 2 -> AnyCardanoEra AllegraEra - 3 -> AnyCardanoEra MaryEra - 4 -> AnyCardanoEra AlonzoEra - 5 -> AnyCardanoEra BabbageEra - 6 -> AnyCardanoEra ConwayEra - n -> - error $ - "AnyCardanoEra.toEnum: " <> show n - <> " does not correspond to any known enumerated era." - -instance ToJSON AnyCardanoEra where - toJSON (AnyCardanoEra era) = toJSON era - -instance FromJSON AnyCardanoEra where - parseJSON = withText "AnyCardanoEra" - $ \case - "Byron" -> pure $ AnyCardanoEra ByronEra - "Shelley" -> pure $ AnyCardanoEra ShelleyEra - "Allegra" -> pure $ AnyCardanoEra AllegraEra - "Mary" -> pure $ AnyCardanoEra MaryEra - "Alonzo" -> pure $ AnyCardanoEra AlonzoEra - "Babbage" -> pure $ AnyCardanoEra BabbageEra - "Conway" -> pure $ AnyCardanoEra ConwayEra - wrong -> fail $ "Failed to parse unknown era: " <> Text.unpack wrong - - --- | Like the 'AnyCardanoEra' constructor but does not demand a 'IsCardanoEra' --- class constraint. --- -anyCardanoEra :: CardanoEra era -> AnyCardanoEra -anyCardanoEra ByronEra = AnyCardanoEra ByronEra -anyCardanoEra ShelleyEra = AnyCardanoEra ShelleyEra -anyCardanoEra AllegraEra = AnyCardanoEra AllegraEra -anyCardanoEra MaryEra = AnyCardanoEra MaryEra -anyCardanoEra AlonzoEra = AnyCardanoEra AlonzoEra -anyCardanoEra BabbageEra = AnyCardanoEra BabbageEra -anyCardanoEra ConwayEra = AnyCardanoEra ConwayEra - --- | This pairs up some era-dependent type with a 'CardanoEra' value that tells --- us what era it is, but hides the era type. This is useful when the era is --- 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 - - --- ---------------------------------------------------------------------------- --- Shelley-based eras --- - --- | While the Byron and Shelley eras are quite different, there are several --- eras that are based on Shelley with only minor differences. It is useful --- to be able to treat the Shelley-based eras in a mostly-uniform way. --- --- Values of this type witness the fact that the era is Shelley-based. This --- can be used to constrain the era to being a Shelley-based on. It allows --- non-uniform handling making case distinctions on the constructor. --- -data ShelleyBasedEra era where - ShelleyBasedEraShelley :: ShelleyBasedEra ShelleyEra - ShelleyBasedEraAllegra :: ShelleyBasedEra AllegraEra - ShelleyBasedEraMary :: ShelleyBasedEra MaryEra - ShelleyBasedEraAlonzo :: ShelleyBasedEra AlonzoEra - ShelleyBasedEraBabbage :: ShelleyBasedEra BabbageEra - ShelleyBasedEraConway :: ShelleyBasedEra ConwayEra - -instance NFData (ShelleyBasedEra era) where - rnf = \case - ShelleyBasedEraShelley -> () - ShelleyBasedEraAllegra -> () - ShelleyBasedEraMary -> () - ShelleyBasedEraAlonzo -> () - ShelleyBasedEraBabbage -> () - ShelleyBasedEraConway -> () - -deriving instance Eq (ShelleyBasedEra era) -deriving instance Ord (ShelleyBasedEra era) -deriving instance Show (ShelleyBasedEra era) - -instance ToJSON (ShelleyBasedEra era) where - toJSON = toJSON . shelleyBasedToCardanoEra - -instance TestEquality ShelleyBasedEra where - testEquality ShelleyBasedEraShelley ShelleyBasedEraShelley = Just Refl - testEquality ShelleyBasedEraAllegra ShelleyBasedEraAllegra = Just Refl - testEquality ShelleyBasedEraMary ShelleyBasedEraMary = Just Refl - testEquality ShelleyBasedEraAlonzo ShelleyBasedEraAlonzo = Just Refl - testEquality ShelleyBasedEraBabbage ShelleyBasedEraBabbage = Just Refl - testEquality ShelleyBasedEraConway ShelleyBasedEraConway = Just Refl - testEquality _ _ = Nothing - --- | The class of eras that are based on Shelley. This allows uniform handling --- of Shelley-based eras, but also non-uniform by making case distinctions on --- the 'ShelleyBasedEra' constructors. --- -class IsCardanoEra era => IsShelleyBasedEra era where - shelleyBasedEra :: ShelleyBasedEra era - -instance IsShelleyBasedEra ShelleyEra where - shelleyBasedEra = ShelleyBasedEraShelley - -instance IsShelleyBasedEra AllegraEra where - shelleyBasedEra = ShelleyBasedEraAllegra - -instance IsShelleyBasedEra MaryEra where - shelleyBasedEra = ShelleyBasedEraMary - -instance IsShelleyBasedEra AlonzoEra where - shelleyBasedEra = ShelleyBasedEraAlonzo - -instance IsShelleyBasedEra BabbageEra where - shelleyBasedEra = ShelleyBasedEraBabbage - -instance IsShelleyBasedEra ConwayEra where - shelleyBasedEra = ShelleyBasedEraConway - -data AnyShelleyBasedEra where - AnyShelleyBasedEra - :: IsShelleyBasedEra era -- Provide class constraint - => ShelleyBasedEra era -- and explicit value. - -> AnyShelleyBasedEra - -deriving instance Show AnyShelleyBasedEra - -instance Eq AnyShelleyBasedEra where - AnyShelleyBasedEra sbe == AnyShelleyBasedEra sbe' = - case testEquality sbe sbe' of - Nothing -> False - Just Refl -> True -- since no constructors share types - -instance Bounded AnyShelleyBasedEra where - minBound = AnyShelleyBasedEra ShelleyBasedEraShelley - maxBound = AnyShelleyBasedEra ShelleyBasedEraConway - -instance Enum AnyShelleyBasedEra where - enumFrom e = enumFromTo e maxBound - - fromEnum = \case - AnyShelleyBasedEra ShelleyBasedEraShelley -> 1 - AnyShelleyBasedEra ShelleyBasedEraAllegra -> 2 - AnyShelleyBasedEra ShelleyBasedEraMary -> 3 - AnyShelleyBasedEra ShelleyBasedEraAlonzo -> 4 - AnyShelleyBasedEra ShelleyBasedEraBabbage -> 5 - AnyShelleyBasedEra ShelleyBasedEraConway -> 6 - - toEnum = \case - 1 -> AnyShelleyBasedEra ShelleyBasedEraShelley - 2 -> AnyShelleyBasedEra ShelleyBasedEraAllegra - 3 -> AnyShelleyBasedEra ShelleyBasedEraMary - 4 -> AnyShelleyBasedEra ShelleyBasedEraAlonzo - 5 -> AnyShelleyBasedEra ShelleyBasedEraBabbage - 6 -> AnyShelleyBasedEra ShelleyBasedEraConway - n -> - error $ - "AnyShelleyBasedEra.toEnum: " <> show n - <> " does not correspond to any known enumerated era." - -instance ToJSON AnyShelleyBasedEra where - toJSON (AnyShelleyBasedEra sbe) = toJSON sbe - -instance FromJSON AnyShelleyBasedEra where - parseJSON = withText "AnyShelleyBasedEra" - $ \case - "Shelley" -> pure $ AnyShelleyBasedEra ShelleyBasedEraShelley - "Allegra" -> pure $ AnyShelleyBasedEra ShelleyBasedEraAllegra - "Mary" -> pure $ AnyShelleyBasedEra ShelleyBasedEraMary - "Alonzo" -> pure $ AnyShelleyBasedEra ShelleyBasedEraAlonzo - "Babbage" -> pure $ AnyShelleyBasedEra ShelleyBasedEraBabbage - "Conway" -> pure $ AnyShelleyBasedEra ShelleyBasedEraConway - wrong -> fail $ "Failed to parse unknown shelley-based era: " <> Text.unpack wrong - - --- | 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 --- 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 - - --- | Converts a 'ShelleyBasedEra' to the broader 'CardanoEra'. -shelleyBasedToCardanoEra :: ShelleyBasedEra era -> CardanoEra era -shelleyBasedToCardanoEra ShelleyBasedEraShelley = ShelleyEra -shelleyBasedToCardanoEra ShelleyBasedEraAllegra = AllegraEra -shelleyBasedToCardanoEra ShelleyBasedEraMary = MaryEra -shelleyBasedToCardanoEra ShelleyBasedEraAlonzo = AlonzoEra -shelleyBasedToCardanoEra ShelleyBasedEraBabbage = BabbageEra -shelleyBasedToCardanoEra ShelleyBasedEraConway = ConwayEra - --- ---------------------------------------------------------------------------- --- Cardano eras factored as Byron vs Shelley-based --- - --- | This is the same essential information as 'CardanoEra' but instead of a --- flat set of alternative eras, it is factored into the legcy Byron era and --- the current Shelley-based eras. --- --- This way of factoring the eras is useful because in many cases the --- major differences are between the Byron and Shelley-based eras, and --- 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 - -deriving instance Eq (CardanoEraStyle era) -deriving instance Ord (CardanoEraStyle era) -deriving instance Show (CardanoEraStyle era) - --- | The 'CardanoEraStyle' for a 'CardanoEra'. --- -cardanoEraStyle :: CardanoEra era -> CardanoEraStyle era -cardanoEraStyle ByronEra = LegacyByronEra -cardanoEraStyle ShelleyEra = ShelleyBasedEra ShelleyBasedEraShelley -cardanoEraStyle AllegraEra = ShelleyBasedEra ShelleyBasedEraAllegra -cardanoEraStyle MaryEra = ShelleyBasedEra ShelleyBasedEraMary -cardanoEraStyle AlonzoEra = ShelleyBasedEra ShelleyBasedEraAlonzo -cardanoEraStyle BabbageEra = ShelleyBasedEra ShelleyBasedEraBabbage -cardanoEraStyle ConwayEra = ShelleyBasedEra ShelleyBasedEraConway - --- ---------------------------------------------------------------------------- --- Conversion to Shelley ledger library types --- - --- | A type family that connects our era type tags to equivalent type tags used --- in the Shelley ledger library. --- --- This type mapping connect types from this API with types in the Shelley --- ledger library which allows writing conversion functions in a more generic --- way. --- -type family ShelleyLedgerEra era where - - ShelleyLedgerEra ShelleyEra = Consensus.StandardShelley - ShelleyLedgerEra AllegraEra = Consensus.StandardAllegra - ShelleyLedgerEra MaryEra = Consensus.StandardMary - ShelleyLedgerEra AlonzoEra = Consensus.StandardAlonzo - ShelleyLedgerEra BabbageEra = Consensus.StandardBabbage - ShelleyLedgerEra ConwayEra = Consensus.StandardConway - -type family CardanoLedgerEra era where - CardanoLedgerEra ByronEra = L.ByronEra L.StandardCrypto - CardanoLedgerEra ShelleyEra = L.ShelleyEra L.StandardCrypto - CardanoLedgerEra AllegraEra = L.AllegraEra L.StandardCrypto - CardanoLedgerEra MaryEra = L.MaryEra L.StandardCrypto - CardanoLedgerEra AlonzoEra = L.AlonzoEra L.StandardCrypto - CardanoLedgerEra BabbageEra = L.BabbageEra L.StandardCrypto - CardanoLedgerEra ConwayEra = L.ConwayEra L.StandardCrypto - --- | Lookup the lower major protocol version for the shelley based era. In other words --- this is the major protocol version that the era has started in. -eraProtVerLow :: ShelleyBasedEra era -> L.Version -eraProtVerLow = \case - ShelleyBasedEraShelley -> L.eraProtVerLow @L.Shelley - ShelleyBasedEraAllegra -> L.eraProtVerLow @L.Allegra - ShelleyBasedEraMary -> L.eraProtVerLow @L.Mary - ShelleyBasedEraAlonzo -> L.eraProtVerLow @L.Alonzo - ShelleyBasedEraBabbage -> L.eraProtVerLow @L.Babbage - ShelleyBasedEraConway -> L.eraProtVerLow @L.Conway - -requireShelleyBasedEra :: () - => Applicative m - => CardanoEra era - -> m (Maybe (ShelleyBasedEra era)) -requireShelleyBasedEra era = - case cardanoEraStyle era of - LegacyByronEra -> pure Nothing - ShelleyBasedEra sbe -> pure (Just sbe) - -withShelleyBasedEraConstraintsForLedger :: () - => ShelleyLedgerEra era ~ ledgerera - => ShelleyBasedEra era - -> ( () - => L.EraCrypto ledgerera ~ L.StandardCrypto - => L.EraTx ledgerera - => L.EraTxBody ledgerera - => L.Era ledgerera - => a - ) - -> a -withShelleyBasedEraConstraintsForLedger = \case - ShelleyBasedEraShelley -> id - ShelleyBasedEraAllegra -> id - ShelleyBasedEraMary -> id - ShelleyBasedEraAlonzo -> id - ShelleyBasedEraBabbage -> id - ShelleyBasedEraConway -> id - -cardanoEraConstraints :: CardanoEra era -> (Typeable era => IsCardanoEra era => a) -> a -cardanoEraConstraints = \case - ByronEra -> id - ShelleyEra -> id - AllegraEra -> id - MaryEra -> id - AlonzoEra -> id - BabbageEra -> id - ConwayEra -> id - -shelleyBasedEraConstraints :: () - => ShelleyBasedEra era - -> (() - => Typeable era - => IsShelleyBasedEra era - => L.EraCrypto (ShelleyLedgerEra era) ~ L.StandardCrypto - => L.Crypto (L.EraCrypto (ShelleyLedgerEra era)) - => L.EraPParams (ShelleyLedgerEra era) - => IsShelleyBasedEra era - => L.Era (ShelleyLedgerEra era) - => C.HashAlgorithm (L.HASH (L.EraCrypto (ShelleyLedgerEra era))) - => a) - -> a -shelleyBasedEraConstraints = \case - ShelleyBasedEraShelley -> id - ShelleyBasedEraAllegra -> id - ShelleyBasedEraMary -> id - ShelleyBasedEraAlonzo -> id - ShelleyBasedEraBabbage -> id - ShelleyBasedEraConway -> id +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 new file mode 100644 index 0000000000..33bca02f71 --- /dev/null +++ b/cardano-api/internal/Cardano/Api/Eras/Constraints.hs @@ -0,0 +1,74 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilyDependencies #-} +{-# LANGUAGE TypeOperators #-} + + +-- | Cardano eras, sometimes we have to distinguish them. +-- +module Cardano.Api.Eras.Constraints + ( withShelleyBasedEraConstraintsForLedger + , cardanoEraConstraints + , shelleyBasedEraConstraints + ) where + +import Cardano.Api.Eras.Core + +import qualified Cardano.Crypto.Hash.Class as C +import qualified Cardano.Ledger.Api as L + +import Data.Typeable (Typeable) + +withShelleyBasedEraConstraintsForLedger :: () + => ShelleyLedgerEra era ~ ledgerera + => ShelleyBasedEra era + -> ( () + => L.EraCrypto ledgerera ~ L.StandardCrypto + => L.EraTx ledgerera + => L.EraTxBody ledgerera + => L.Era ledgerera + => a + ) + -> a +withShelleyBasedEraConstraintsForLedger = \case + ShelleyBasedEraShelley -> id + ShelleyBasedEraAllegra -> id + ShelleyBasedEraMary -> id + ShelleyBasedEraAlonzo -> id + ShelleyBasedEraBabbage -> id + ShelleyBasedEraConway -> id + +cardanoEraConstraints :: CardanoEra era -> (Typeable era => IsCardanoEra era => a) -> a +cardanoEraConstraints = \case + ByronEra -> id + ShelleyEra -> id + AllegraEra -> id + MaryEra -> id + AlonzoEra -> id + BabbageEra -> id + ConwayEra -> id + +shelleyBasedEraConstraints :: () + => ShelleyBasedEra era + -> (() + => Typeable era + => IsShelleyBasedEra era + => L.EraCrypto (ShelleyLedgerEra era) ~ L.StandardCrypto + => L.Crypto (L.EraCrypto (ShelleyLedgerEra era)) + => L.EraPParams (ShelleyLedgerEra era) + => IsShelleyBasedEra era + => L.Era (ShelleyLedgerEra era) + => C.HashAlgorithm (L.HASH (L.EraCrypto (ShelleyLedgerEra 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/Eras/Core.hs b/cardano-api/internal/Cardano/Api/Eras/Core.hs new file mode 100644 index 0000000000..9ae27747a3 --- /dev/null +++ b/cardano-api/internal/Cardano/Api/Eras/Core.hs @@ -0,0 +1,589 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilyDependencies #-} +{-# LANGUAGE TypeOperators #-} + + +-- | Cardano eras, sometimes we have to distinguish them. +-- +module Cardano.Api.Eras.Core + ( -- * Eras + ByronEra + , ShelleyEra + , AllegraEra + , MaryEra + , AlonzoEra + , BabbageEra + , ConwayEra + , CardanoEra(..) + , IsCardanoEra(..) + , AnyCardanoEra(..) + , anyCardanoEra + , InAnyCardanoEra(..) + , CardanoLedgerEra + + -- * FeatureInEra + , FeatureInEra(..) + , maybeFeatureInEra + , featureInShelleyBasedEra + + -- * Deprecated aliases + , Byron + , Shelley + , Allegra + , Mary + + -- * Shelley-based eras + , ShelleyBasedEra(..) + , IsShelleyBasedEra(..) + , AnyShelleyBasedEra(..) + , InAnyShelleyBasedEra(..) + , shelleyBasedToCardanoEra + + -- ** Mapping to era types from the Shelley ledger library + , ShelleyLedgerEra + , eraProtVerLow + + -- * Cardano eras, as Byron vs Shelley-based + , CardanoEraStyle(..) + , cardanoEraStyle + + -- * Data family instances + , AsType(AsByronEra, AsShelleyEra, AsAllegraEra, AsMaryEra, AsAlonzoEra, AsBabbageEra, AsConwayEra, + AsByron, AsShelley, AsAllegra, AsMary, AsAlonzo, AsBabbage, AsConway) + + -- * Assertions on era + , requireShelleyBasedEra + + ) where + +import Cardano.Api.HasTypeProxy + +import qualified Cardano.Ledger.Api as L +import qualified Cardano.Ledger.BaseTypes as L +import Ouroboros.Consensus.Shelley.Eras as Consensus (StandardAllegra, StandardAlonzo, + StandardBabbage, StandardConway, StandardMary, StandardShelley) + +import Control.DeepSeq +import Data.Aeson (FromJSON (..), ToJSON, toJSON, withText) +import Data.Kind +import qualified Data.Text as Text +import Data.Type.Equality (TestEquality (..), (:~:) (Refl)) + +-- ---------------------------------------------------------------------------- +-- Eras + +-- | A type used as a tag to distinguish the Byron era. +data ByronEra + +-- | A type used as a tag to distinguish the Shelley era. +data ShelleyEra + +-- | A type used as a tag to distinguish the Allegra era. +data AllegraEra + +-- | A type used as a tag to distinguish the Mary era. +data MaryEra + +-- | A type used as a tag to distinguish the Alonzo era. +data AlonzoEra + +-- | A type used as a tag to distinguish the Babbage era. +data BabbageEra + +-- | A type used as a tag to distinguish the Conway era. +data ConwayEra + +instance HasTypeProxy ByronEra where + data AsType ByronEra = AsByronEra + proxyToAsType _ = AsByronEra + +instance HasTypeProxy ShelleyEra where + data AsType ShelleyEra = AsShelleyEra + proxyToAsType _ = AsShelleyEra + +instance HasTypeProxy AllegraEra where + data AsType AllegraEra = AsAllegraEra + proxyToAsType _ = AsAllegraEra + +instance HasTypeProxy MaryEra where + data AsType MaryEra = AsMaryEra + proxyToAsType _ = AsMaryEra + +instance HasTypeProxy AlonzoEra where + data AsType AlonzoEra = AsAlonzoEra + proxyToAsType _ = AsAlonzoEra + +instance HasTypeProxy BabbageEra where + data AsType BabbageEra = AsBabbageEra + proxyToAsType _ = AsBabbageEra + +instance HasTypeProxy ConwayEra where + data AsType ConwayEra = AsConwayEra + proxyToAsType _ = AsConwayEra + +-- ---------------------------------------------------------------------------- +-- FeatureInEra + +-- | A class for producing values for features that are supported in some eras +-- but not others. +class FeatureInEra (feature :: Type -> Type) where + -- | Determine the value to use for a feature in a given 'CardanoEra'. + -- Note that the negative case is the first argument, and the positive case is the second as per + -- the 'either' function convention. + featureInEra :: () + => a -- ^ Value to use if the feature is not supported in the era + -> (feature era -> a) -- ^ Function to get thealue to use if the feature is supported in the era + -> CardanoEra era -- ^ Era to check + -> a -- ^ The value to use + +maybeFeatureInEra :: () + => FeatureInEra feature + => CardanoEra era -- ^ Era to check + -> Maybe (feature era) -- ^ The feature if supported in the era +maybeFeatureInEra = featureInEra Nothing Just + +-- | Determine the value to use for a feature in a given 'ShelleyBasedEra'. +featureInShelleyBasedEra :: () + => FeatureInEra feature + => a + -> (feature era -> a) + -> ShelleyBasedEra era + -> a +featureInShelleyBasedEra no yes = + featureInEra no yes . shelleyBasedToCardanoEra + +-- ---------------------------------------------------------------------------- +-- Deprecated aliases +-- + +type Byron = ByronEra +type Shelley = ShelleyEra +type Allegra = AllegraEra +type Mary = MaryEra + +{-# DEPRECATED Byron "Use 'ByronEra' or 'ByronAddr' as appropriate" #-} +{-# DEPRECATED Shelley "Use 'ShelleyEra' or 'ShelleyAddr' as appropriate" #-} +{-# DEPRECATED Allegra "Use 'AllegraEra' instead" #-} +{-# DEPRECATED Mary "Use 'MaryEra' instead" #-} + +pattern AsByron :: AsType ByronEra +pattern AsByron = AsByronEra + +pattern AsShelley :: AsType ShelleyEra +pattern AsShelley = AsShelleyEra + +pattern AsAllegra :: AsType AllegraEra +pattern AsAllegra = AsAllegraEra + +pattern AsMary :: AsType MaryEra +pattern AsMary = AsMaryEra + + +pattern AsAlonzo :: AsType AlonzoEra +pattern AsAlonzo = AsAlonzoEra + +pattern AsBabbage :: AsType BabbageEra +pattern AsBabbage = AsBabbageEra + +pattern AsConway :: AsType ConwayEra +pattern AsConway = AsConwayEra + +{-# DEPRECATED AsByron "Use 'AsByronEra' instead" #-} +{-# DEPRECATED AsShelley "Use 'AsShelleyEra' instead" #-} +{-# DEPRECATED AsAllegra "Use 'AsAllegraEra' instead" #-} +{-# DEPRECATED AsMary "Use 'AsMaryEra' instead" #-} + +-- ---------------------------------------------------------------------------- +-- Value level representation for Cardano eras +-- + +-- | This GADT provides a value-level representation of all the Cardano eras. +-- This enables pattern matching on the era to allow them to be treated in a +-- non-uniform way. +-- +-- This can be used in combination with the 'IsCardanoEra' class to get access +-- to this value. +-- +-- In combination this can often enable code that handles all eras, and does +-- so uniformly where possible, and non-uniformly where necessary. +-- +data CardanoEra era where + ByronEra :: CardanoEra ByronEra + ShelleyEra :: CardanoEra ShelleyEra + AllegraEra :: CardanoEra AllegraEra + MaryEra :: CardanoEra MaryEra + AlonzoEra :: CardanoEra AlonzoEra + BabbageEra :: CardanoEra BabbageEra + ConwayEra :: CardanoEra ConwayEra + -- when you add era here, change `instance Bounded AnyCardanoEra` + +deriving instance Eq (CardanoEra era) +deriving instance Ord (CardanoEra era) +deriving instance Show (CardanoEra era) + +instance ToJSON (CardanoEra era) where + toJSON ByronEra = "Byron" + toJSON ShelleyEra = "Shelley" + toJSON AllegraEra = "Allegra" + toJSON MaryEra = "Mary" + toJSON AlonzoEra = "Alonzo" + toJSON BabbageEra = "Babbage" + toJSON ConwayEra = "Conway" + +instance TestEquality CardanoEra where + testEquality ByronEra ByronEra = Just Refl + testEquality ShelleyEra ShelleyEra = Just Refl + testEquality AllegraEra AllegraEra = Just Refl + testEquality MaryEra MaryEra = Just Refl + testEquality AlonzoEra AlonzoEra = Just Refl + testEquality BabbageEra BabbageEra = Just Refl + testEquality ConwayEra ConwayEra = Just Refl + testEquality _ _ = Nothing + + +-- | The class of Cardano eras. This allows uniform handling of all Cardano +-- eras, but also non-uniform by making case distinctions on the 'CardanoEra' +-- constructors, or the 'CardanoEraStyle' constructors via `cardanoEraStyle`. +-- +class HasTypeProxy era => IsCardanoEra era where + cardanoEra :: CardanoEra era + +instance IsCardanoEra ByronEra where + cardanoEra = ByronEra + +instance IsCardanoEra ShelleyEra where + cardanoEra = ShelleyEra + +instance IsCardanoEra AllegraEra where + cardanoEra = AllegraEra + +instance IsCardanoEra MaryEra where + cardanoEra = MaryEra + +instance IsCardanoEra AlonzoEra where + cardanoEra = AlonzoEra + +instance IsCardanoEra BabbageEra where + cardanoEra = BabbageEra + +instance IsCardanoEra ConwayEra where + cardanoEra = ConwayEra + +data AnyCardanoEra where + AnyCardanoEra :: IsCardanoEra era -- Provide class constraint + => CardanoEra era -- and explicit value. + -> AnyCardanoEra + +deriving instance Show AnyCardanoEra + +instance Eq AnyCardanoEra where + AnyCardanoEra era == AnyCardanoEra era' = + case testEquality era era' of + Nothing -> False + Just Refl -> True -- since no constructors share types + +instance Bounded AnyCardanoEra where + minBound = AnyCardanoEra ByronEra + maxBound = AnyCardanoEra ConwayEra + +instance Enum AnyCardanoEra where + + -- [e..] = [e..maxBound] + enumFrom e = enumFromTo e maxBound + + fromEnum = \case + AnyCardanoEra ByronEra -> 0 + AnyCardanoEra ShelleyEra -> 1 + AnyCardanoEra AllegraEra -> 2 + AnyCardanoEra MaryEra -> 3 + AnyCardanoEra AlonzoEra -> 4 + AnyCardanoEra BabbageEra -> 5 + AnyCardanoEra ConwayEra -> 6 + + toEnum = \case + 0 -> AnyCardanoEra ByronEra + 1 -> AnyCardanoEra ShelleyEra + 2 -> AnyCardanoEra AllegraEra + 3 -> AnyCardanoEra MaryEra + 4 -> AnyCardanoEra AlonzoEra + 5 -> AnyCardanoEra BabbageEra + 6 -> AnyCardanoEra ConwayEra + n -> + error $ + "AnyCardanoEra.toEnum: " <> show n + <> " does not correspond to any known enumerated era." + +instance ToJSON AnyCardanoEra where + toJSON (AnyCardanoEra era) = toJSON era + +instance FromJSON AnyCardanoEra where + parseJSON = withText "AnyCardanoEra" + $ \case + "Byron" -> pure $ AnyCardanoEra ByronEra + "Shelley" -> pure $ AnyCardanoEra ShelleyEra + "Allegra" -> pure $ AnyCardanoEra AllegraEra + "Mary" -> pure $ AnyCardanoEra MaryEra + "Alonzo" -> pure $ AnyCardanoEra AlonzoEra + "Babbage" -> pure $ AnyCardanoEra BabbageEra + "Conway" -> pure $ AnyCardanoEra ConwayEra + wrong -> fail $ "Failed to parse unknown era: " <> Text.unpack wrong + + +-- | Like the 'AnyCardanoEra' constructor but does not demand a 'IsCardanoEra' +-- class constraint. +-- +anyCardanoEra :: CardanoEra era -> AnyCardanoEra +anyCardanoEra ByronEra = AnyCardanoEra ByronEra +anyCardanoEra ShelleyEra = AnyCardanoEra ShelleyEra +anyCardanoEra AllegraEra = AnyCardanoEra AllegraEra +anyCardanoEra MaryEra = AnyCardanoEra MaryEra +anyCardanoEra AlonzoEra = AnyCardanoEra AlonzoEra +anyCardanoEra BabbageEra = AnyCardanoEra BabbageEra +anyCardanoEra ConwayEra = AnyCardanoEra ConwayEra + +-- | This pairs up some era-dependent type with a 'CardanoEra' value that tells +-- us what era it is, but hides the era type. This is useful when the era is +-- 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 + + +-- ---------------------------------------------------------------------------- +-- Shelley-based eras +-- + +-- | While the Byron and Shelley eras are quite different, there are several +-- eras that are based on Shelley with only minor differences. It is useful +-- to be able to treat the Shelley-based eras in a mostly-uniform way. +-- +-- Values of this type witness the fact that the era is Shelley-based. This +-- can be used to constrain the era to being a Shelley-based on. It allows +-- non-uniform handling making case distinctions on the constructor. +-- +data ShelleyBasedEra era where + ShelleyBasedEraShelley :: ShelleyBasedEra ShelleyEra + ShelleyBasedEraAllegra :: ShelleyBasedEra AllegraEra + ShelleyBasedEraMary :: ShelleyBasedEra MaryEra + ShelleyBasedEraAlonzo :: ShelleyBasedEra AlonzoEra + ShelleyBasedEraBabbage :: ShelleyBasedEra BabbageEra + ShelleyBasedEraConway :: ShelleyBasedEra ConwayEra + +instance NFData (ShelleyBasedEra era) where + rnf = \case + ShelleyBasedEraShelley -> () + ShelleyBasedEraAllegra -> () + ShelleyBasedEraMary -> () + ShelleyBasedEraAlonzo -> () + ShelleyBasedEraBabbage -> () + ShelleyBasedEraConway -> () + +deriving instance Eq (ShelleyBasedEra era) +deriving instance Ord (ShelleyBasedEra era) +deriving instance Show (ShelleyBasedEra era) + +instance ToJSON (ShelleyBasedEra era) where + toJSON = toJSON . shelleyBasedToCardanoEra + +instance TestEquality ShelleyBasedEra where + testEquality ShelleyBasedEraShelley ShelleyBasedEraShelley = Just Refl + testEquality ShelleyBasedEraAllegra ShelleyBasedEraAllegra = Just Refl + testEquality ShelleyBasedEraMary ShelleyBasedEraMary = Just Refl + testEquality ShelleyBasedEraAlonzo ShelleyBasedEraAlonzo = Just Refl + testEquality ShelleyBasedEraBabbage ShelleyBasedEraBabbage = Just Refl + testEquality ShelleyBasedEraConway ShelleyBasedEraConway = Just Refl + testEquality _ _ = Nothing + +-- | The class of eras that are based on Shelley. This allows uniform handling +-- of Shelley-based eras, but also non-uniform by making case distinctions on +-- the 'ShelleyBasedEra' constructors. +-- +class IsCardanoEra era => IsShelleyBasedEra era where + shelleyBasedEra :: ShelleyBasedEra era + +instance IsShelleyBasedEra ShelleyEra where + shelleyBasedEra = ShelleyBasedEraShelley + +instance IsShelleyBasedEra AllegraEra where + shelleyBasedEra = ShelleyBasedEraAllegra + +instance IsShelleyBasedEra MaryEra where + shelleyBasedEra = ShelleyBasedEraMary + +instance IsShelleyBasedEra AlonzoEra where + shelleyBasedEra = ShelleyBasedEraAlonzo + +instance IsShelleyBasedEra BabbageEra where + shelleyBasedEra = ShelleyBasedEraBabbage + +instance IsShelleyBasedEra ConwayEra where + shelleyBasedEra = ShelleyBasedEraConway + +data AnyShelleyBasedEra where + AnyShelleyBasedEra + :: IsShelleyBasedEra era -- Provide class constraint + => ShelleyBasedEra era -- and explicit value. + -> AnyShelleyBasedEra + +deriving instance Show AnyShelleyBasedEra + +instance Eq AnyShelleyBasedEra where + AnyShelleyBasedEra sbe == AnyShelleyBasedEra sbe' = + case testEquality sbe sbe' of + Nothing -> False + Just Refl -> True -- since no constructors share types + +instance Bounded AnyShelleyBasedEra where + minBound = AnyShelleyBasedEra ShelleyBasedEraShelley + maxBound = AnyShelleyBasedEra ShelleyBasedEraConway + +instance Enum AnyShelleyBasedEra where + enumFrom e = enumFromTo e maxBound + + fromEnum = \case + AnyShelleyBasedEra ShelleyBasedEraShelley -> 1 + AnyShelleyBasedEra ShelleyBasedEraAllegra -> 2 + AnyShelleyBasedEra ShelleyBasedEraMary -> 3 + AnyShelleyBasedEra ShelleyBasedEraAlonzo -> 4 + AnyShelleyBasedEra ShelleyBasedEraBabbage -> 5 + AnyShelleyBasedEra ShelleyBasedEraConway -> 6 + + toEnum = \case + 1 -> AnyShelleyBasedEra ShelleyBasedEraShelley + 2 -> AnyShelleyBasedEra ShelleyBasedEraAllegra + 3 -> AnyShelleyBasedEra ShelleyBasedEraMary + 4 -> AnyShelleyBasedEra ShelleyBasedEraAlonzo + 5 -> AnyShelleyBasedEra ShelleyBasedEraBabbage + 6 -> AnyShelleyBasedEra ShelleyBasedEraConway + n -> + error $ + "AnyShelleyBasedEra.toEnum: " <> show n + <> " does not correspond to any known enumerated era." + +instance ToJSON AnyShelleyBasedEra where + toJSON (AnyShelleyBasedEra sbe) = toJSON sbe + +instance FromJSON AnyShelleyBasedEra where + parseJSON = withText "AnyShelleyBasedEra" + $ \case + "Shelley" -> pure $ AnyShelleyBasedEra ShelleyBasedEraShelley + "Allegra" -> pure $ AnyShelleyBasedEra ShelleyBasedEraAllegra + "Mary" -> pure $ AnyShelleyBasedEra ShelleyBasedEraMary + "Alonzo" -> pure $ AnyShelleyBasedEra ShelleyBasedEraAlonzo + "Babbage" -> pure $ AnyShelleyBasedEra ShelleyBasedEraBabbage + "Conway" -> pure $ AnyShelleyBasedEra ShelleyBasedEraConway + wrong -> fail $ "Failed to parse unknown shelley-based era: " <> Text.unpack wrong + + +-- | 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 +-- 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 + + +-- | Converts a 'ShelleyBasedEra' to the broader 'CardanoEra'. +shelleyBasedToCardanoEra :: ShelleyBasedEra era -> CardanoEra era +shelleyBasedToCardanoEra ShelleyBasedEraShelley = ShelleyEra +shelleyBasedToCardanoEra ShelleyBasedEraAllegra = AllegraEra +shelleyBasedToCardanoEra ShelleyBasedEraMary = MaryEra +shelleyBasedToCardanoEra ShelleyBasedEraAlonzo = AlonzoEra +shelleyBasedToCardanoEra ShelleyBasedEraBabbage = BabbageEra +shelleyBasedToCardanoEra ShelleyBasedEraConway = ConwayEra + +-- ---------------------------------------------------------------------------- +-- Cardano eras factored as Byron vs Shelley-based +-- + +-- | This is the same essential information as 'CardanoEra' but instead of a +-- flat set of alternative eras, it is factored into the legcy Byron era and +-- the current Shelley-based eras. +-- +-- This way of factoring the eras is useful because in many cases the +-- major differences are between the Byron and Shelley-based eras, and +-- 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 + +deriving instance Eq (CardanoEraStyle era) +deriving instance Ord (CardanoEraStyle era) +deriving instance Show (CardanoEraStyle era) + +-- | The 'CardanoEraStyle' for a 'CardanoEra'. +-- +cardanoEraStyle :: CardanoEra era -> CardanoEraStyle era +cardanoEraStyle ByronEra = LegacyByronEra +cardanoEraStyle ShelleyEra = ShelleyBasedEra ShelleyBasedEraShelley +cardanoEraStyle AllegraEra = ShelleyBasedEra ShelleyBasedEraAllegra +cardanoEraStyle MaryEra = ShelleyBasedEra ShelleyBasedEraMary +cardanoEraStyle AlonzoEra = ShelleyBasedEra ShelleyBasedEraAlonzo +cardanoEraStyle BabbageEra = ShelleyBasedEra ShelleyBasedEraBabbage +cardanoEraStyle ConwayEra = ShelleyBasedEra ShelleyBasedEraConway + +-- ---------------------------------------------------------------------------- +-- Conversion to Shelley ledger library types +-- + +-- | A type family that connects our era type tags to equivalent type tags used +-- in the Shelley ledger library. +-- +-- This type mapping connect types from this API with types in the Shelley +-- ledger library which allows writing conversion functions in a more generic +-- way. +-- +type family ShelleyLedgerEra era where + + ShelleyLedgerEra ShelleyEra = Consensus.StandardShelley + ShelleyLedgerEra AllegraEra = Consensus.StandardAllegra + ShelleyLedgerEra MaryEra = Consensus.StandardMary + ShelleyLedgerEra AlonzoEra = Consensus.StandardAlonzo + ShelleyLedgerEra BabbageEra = Consensus.StandardBabbage + ShelleyLedgerEra ConwayEra = Consensus.StandardConway + +type family CardanoLedgerEra era where + CardanoLedgerEra ByronEra = L.ByronEra L.StandardCrypto + CardanoLedgerEra ShelleyEra = L.ShelleyEra L.StandardCrypto + CardanoLedgerEra AllegraEra = L.AllegraEra L.StandardCrypto + CardanoLedgerEra MaryEra = L.MaryEra L.StandardCrypto + CardanoLedgerEra AlonzoEra = L.AlonzoEra L.StandardCrypto + CardanoLedgerEra BabbageEra = L.BabbageEra L.StandardCrypto + CardanoLedgerEra ConwayEra = L.ConwayEra L.StandardCrypto + +-- | Lookup the lower major protocol version for the shelley based era. In other words +-- this is the major protocol version that the era has started in. +eraProtVerLow :: ShelleyBasedEra era -> L.Version +eraProtVerLow = \case + ShelleyBasedEraShelley -> L.eraProtVerLow @L.Shelley + ShelleyBasedEraAllegra -> L.eraProtVerLow @L.Allegra + ShelleyBasedEraMary -> L.eraProtVerLow @L.Mary + ShelleyBasedEraAlonzo -> L.eraProtVerLow @L.Alonzo + ShelleyBasedEraBabbage -> L.eraProtVerLow @L.Babbage + ShelleyBasedEraConway -> L.eraProtVerLow @L.Conway + +requireShelleyBasedEra :: () + => Applicative m + => CardanoEra era + -> m (Maybe (ShelleyBasedEra era)) +requireShelleyBasedEra era = + case cardanoEraStyle era of + LegacyByronEra -> pure Nothing + ShelleyBasedEra sbe -> pure (Just sbe) From f3d05c83188211a3b0286a3ed6a104eb43e03a82 Mon Sep 17 00:00:00 2001 From: John Ky Date: Fri, 28 Jul 2023 00:38:50 +1000 Subject: [PATCH 3/3] More constraints for the standard features ShelleyBasedEra, ShelleyToBabbageEra and BabbageEraOnwards. --- cardano-api/cardano-api.cabal | 2 +- cardano-api/internal/Cardano/Api/Block.hs | 9 +- .../internal/Cardano/Api/Certificate.hs | 15 ++-- .../internal/Cardano/Api/Eras/Constraints.hs | 88 ++++++++++++------- cardano-api/internal/Cardano/Api/Eras/Core.hs | 2 - .../Cardano/Api/Feature/ConwayEraOnwards.hs | 46 +++++++--- .../Cardano/Api/Feature/ShelleyBasedEra.hs | 2 - .../Api/Feature/ShelleyToBabbageEra.hs | 44 ++++++++-- cardano-api/internal/Cardano/Api/Modes.hs | 19 +--- .../internal/Cardano/Api/Query/Types.hs | 2 +- cardano-api/internal/Cardano/Api/Utils.hs | 44 +++------- 11 files changed, 151 insertions(+), 122 deletions(-) delete mode 100644 cardano-api/internal/Cardano/Api/Feature/ShelleyBasedEra.hs diff --git a/cardano-api/cardano-api.cabal b/cardano-api/cardano-api.cabal index cd70907069..7c02051f47 100644 --- a/cardano-api/cardano-api.cabal +++ b/cardano-api/cardano-api.cabal @@ -162,7 +162,7 @@ library internal , ouroboros-consensus >= 0.9 , ouroboros-consensus-cardano >= 0.7 , ouroboros-consensus-diffusion >= 0.7 - , ouroboros-consensus-protocol >= 0.5 + , ouroboros-consensus-protocol >= 0.5.0.4 , ouroboros-network , ouroboros-network-api , ouroboros-network-framework diff --git a/cardano-api/internal/Cardano/Api/Block.hs b/cardano-api/internal/Cardano/Api/Block.hs index a93c4c83bd..645e4442bf 100644 --- a/cardano-api/internal/Cardano/Api/Block.hs +++ b/cardano-api/internal/Cardano/Api/Block.hs @@ -162,7 +162,8 @@ instance Show (Block era) where ) getBlockTxs :: forall era . Block era -> [Tx era] -getBlockTxs (ByronBlock Consensus.ByronBlock { Consensus.byronBlockRaw }) = +getBlockTxs = \case + ByronBlock Consensus.ByronBlock { Consensus.byronBlockRaw } -> case byronBlockRaw of Byron.ABOBBoundary{} -> [] -- no txs in EBBs Byron.ABOBBlock Byron.ABlock { @@ -171,9 +172,9 @@ getBlockTxs (ByronBlock Consensus.ByronBlock { Consensus.byronBlockRaw }) = Byron.bodyTxPayload = Byron.ATxPayload txs } } -> map ByronTx txs -getBlockTxs (ShelleyBlock era Consensus.ShelleyBlock{Consensus.shelleyBlockRaw}) = - withShelleyBasedEraConstraintForConsensus era $ - getShelleyBlockTxs era shelleyBlockRaw + ShelleyBlock sbe Consensus.ShelleyBlock{Consensus.shelleyBlockRaw} -> + shelleyBasedEraConstraints sbe $ + getShelleyBlockTxs sbe shelleyBlockRaw getShelleyBlockTxs :: forall era ledgerera blockheader. diff --git a/cardano-api/internal/Cardano/Api/Certificate.hs b/cardano-api/internal/Cardano/Api/Certificate.hs index a4aa950a15..2ff3fa6616 100644 --- a/cardano-api/internal/Cardano/Api/Certificate.hs +++ b/cardano-api/internal/Cardano/Api/Certificate.hs @@ -818,11 +818,12 @@ shelleyCertificateConstraints , Ledger.TxCert (ShelleyLedgerEra era) ~ Ledger.ShelleyTxCert (ShelleyLedgerEra era) ) => a) -> a -shelleyCertificateConstraints ShelleyToBabbageEraBabbage f = f -shelleyCertificateConstraints ShelleyToBabbageEraAlonzo f = f -shelleyCertificateConstraints ShelleyToBabbageEraMary f = f -shelleyCertificateConstraints ShelleyToBabbageEraAllegra f = f -shelleyCertificateConstraints ShelleyToBabbageEraShelley f = f +shelleyCertificateConstraints = \case + ShelleyToBabbageEraBabbage -> id + ShelleyToBabbageEraAlonzo -> id + ShelleyToBabbageEraMary -> id + ShelleyToBabbageEraAllegra -> id + ShelleyToBabbageEraShelley -> id conwayCertificateConstraints :: ConwayEraOnwards era @@ -831,5 +832,5 @@ conwayCertificateConstraints , Ledger.TxCert (ShelleyLedgerEra era) ~ Ledger.ConwayTxCert (ShelleyLedgerEra era) ) => a) -> a -conwayCertificateConstraints ConwayEraOnwardsConway f = f - +conwayCertificateConstraints = \case + ConwayEraOnwardsConway -> id diff --git a/cardano-api/internal/Cardano/Api/Eras/Constraints.hs b/cardano-api/internal/Cardano/Api/Eras/Constraints.hs index 33bca02f71..5440f8e1e7 100644 --- a/cardano-api/internal/Cardano/Api/Eras/Constraints.hs +++ b/cardano-api/internal/Cardano/Api/Eras/Constraints.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} @@ -7,42 +8,40 @@ {-# LANGUAGE TypeFamilyDependencies #-} {-# LANGUAGE TypeOperators #-} - --- | Cardano eras, sometimes we have to distinguish them. --- module Cardano.Api.Eras.Constraints - ( withShelleyBasedEraConstraintsForLedger - , cardanoEraConstraints + ( cardanoEraConstraints + , withShelleyBasedEraConstraintsForLedger , shelleyBasedEraConstraints ) where import Cardano.Api.Eras.Core +import Cardano.Api.Modes +import Cardano.Api.Query.Types +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) -withShelleyBasedEraConstraintsForLedger :: () - => ShelleyLedgerEra era ~ ledgerera - => ShelleyBasedEra era - -> ( () - => L.EraCrypto ledgerera ~ L.StandardCrypto - => L.EraTx ledgerera - => L.EraTxBody ledgerera - => L.Era ledgerera - => a - ) - -> a -withShelleyBasedEraConstraintsForLedger = \case - ShelleyBasedEraShelley -> id - ShelleyBasedEraAllegra -> id - ShelleyBasedEraMary -> id - ShelleyBasedEraAlonzo -> id - ShelleyBasedEraBabbage -> id - ShelleyBasedEraConway -> id +type CardanoEraConstraint era = + ( Typeable era + , IsCardanoEra era + ) -cardanoEraConstraints :: CardanoEra era -> (Typeable era => IsCardanoEra era => a) -> a +cardanoEraConstraints :: () + => CardanoEra era + -> (CardanoEraConstraint era => a) + -> a cardanoEraConstraints = \case ByronEra -> id ShelleyEra -> id @@ -52,18 +51,31 @@ cardanoEraConstraints = \case BabbageEra -> id ConwayEra -> id +type ShelleyBasedEraConstraints era ledgerera = + ( C.HashAlgorithm (L.HASH (L.EraCrypto ledgerera)) + , C.Signable (L.VRF (L.EraCrypto ledgerera)) L.Seed + , Consensus.PraosProtocolSupportsNode (ConsensusProtocol era) + , Consensus.ShelleyCompatible (ConsensusProtocol era) ledgerera + , L.ADDRHASH (Consensus.PraosProtocolSupportsNodeCrypto (ConsensusProtocol era)) ~ Blake2b.Blake2b_224 + , L.Crypto (L.EraCrypto ledgerera) + , L.Era ledgerera + , L.EraCrypto ledgerera ~ L.StandardCrypto + , L.EraPParams ledgerera + , L.EraTx ledgerera + , L.EraTxBody ledgerera + , L.HashAnnotated (L.TxBody ledgerera) L.EraIndependentTxBody L.StandardCrypto + , L.ShelleyEraTxBody ledgerera + , FromCBOR (Consensus.ChainDepState (ConsensusProtocol era)) + , FromCBOR (DebugLedgerState era) + , IsShelleyBasedEra era + , ToJSON (DebugLedgerState era) + , Typeable era + ) + shelleyBasedEraConstraints :: () + => ShelleyLedgerEra era ~ ledgerera => ShelleyBasedEra era - -> (() - => Typeable era - => IsShelleyBasedEra era - => L.EraCrypto (ShelleyLedgerEra era) ~ L.StandardCrypto - => L.Crypto (L.EraCrypto (ShelleyLedgerEra era)) - => L.EraPParams (ShelleyLedgerEra era) - => IsShelleyBasedEra era - => L.Era (ShelleyLedgerEra era) - => C.HashAlgorithm (L.HASH (L.EraCrypto (ShelleyLedgerEra era))) - => a) + -> (ShelleyBasedEraConstraints era ledgerera => a) -> a shelleyBasedEraConstraints = \case ShelleyBasedEraShelley -> id @@ -72,3 +84,11 @@ shelleyBasedEraConstraints = \case ShelleyBasedEraAlonzo -> id ShelleyBasedEraBabbage -> id ShelleyBasedEraConway -> id + +-- Deprecated: Use shelleyBasedEraConstraints instead. +withShelleyBasedEraConstraintsForLedger :: () + => ShelleyLedgerEra era ~ ledgerera + => ShelleyBasedEra era + -> (ShelleyBasedEraConstraints era ledgerera => a) + -> a +withShelleyBasedEraConstraintsForLedger = shelleyBasedEraConstraints diff --git a/cardano-api/internal/Cardano/Api/Eras/Core.hs b/cardano-api/internal/Cardano/Api/Eras/Core.hs index 9ae27747a3..56f59341a6 100644 --- a/cardano-api/internal/Cardano/Api/Eras/Core.hs +++ b/cardano-api/internal/Cardano/Api/Eras/Core.hs @@ -8,8 +8,6 @@ {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilyDependencies #-} -{-# LANGUAGE TypeOperators #-} - -- | Cardano eras, sometimes we have to distinguish them. -- diff --git a/cardano-api/internal/Cardano/Api/Feature/ConwayEraOnwards.hs b/cardano-api/internal/Cardano/Api/Feature/ConwayEraOnwards.hs index f7be9beb1f..5bf687c3e5 100644 --- a/cardano-api/internal/Cardano/Api/Feature/ConwayEraOnwards.hs +++ b/cardano-api/internal/Cardano/Api/Feature/ConwayEraOnwards.hs @@ -16,13 +16,24 @@ module Cardano.Api.Feature.ConwayEraOnwards ) where import Cardano.Api.Eras +import Cardano.Api.Modes import Cardano.Api.Query.Types import Cardano.Binary -import Cardano.Crypto.Hash.Class (HashAlgorithm) +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 qualified Cardano.Ledger.Conway.TxCert as L +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 +import Data.Typeable (Typeable) data ConwayEraOnwards era where ConwayEraOnwardsConway :: ConwayEraOnwards ConwayEra @@ -45,19 +56,34 @@ data AnyConwayEraOnwards where deriving instance Show AnyConwayEraOnwards -type ConwayEraOnwardsConstraints era = - ( FromCBOR (DebugLedgerState era) - , HashAlgorithm (L.HASH (L.EraCrypto (ShelleyLedgerEra era))) +type ConwayEraOnwardsConstraints era ledgerera = + ( C.HashAlgorithm (L.HASH (L.EraCrypto ledgerera)) + , C.Signable (L.VRF (L.EraCrypto ledgerera)) L.Seed + , Consensus.PraosProtocolSupportsNode (ConsensusProtocol era) + , Consensus.ShelleyCompatible (ConsensusProtocol era) ledgerera + , L.ADDRHASH (Consensus.PraosProtocolSupportsNodeCrypto (ConsensusProtocol era)) ~ Blake2b.Blake2b_224 + , L.ConwayEraTxBody ledgerera + , L.ConwayEraTxCert ledgerera + , L.Crypto (L.EraCrypto ledgerera) + , L.Era ledgerera + , L.EraCrypto ledgerera ~ L.StandardCrypto + , L.EraPParams ledgerera + , L.EraTx ledgerera + , L.EraTxBody ledgerera + , L.HashAnnotated (L.TxBody ledgerera) L.EraIndependentTxBody L.StandardCrypto + , L.ShelleyEraTxBody ledgerera + , L.TxCert ledgerera ~ L.ConwayTxCert ledgerera + , FromCBOR (Consensus.ChainDepState (ConsensusProtocol era)) + , FromCBOR (DebugLedgerState era) , IsShelleyBasedEra era - , L.ConwayEraTxBody (ShelleyLedgerEra era) - , L.Era (ShelleyLedgerEra era) - , L.EraCrypto (ShelleyLedgerEra era) ~ L.StandardCrypto , ToJSON (DebugLedgerState era) + , Typeable era ) -conwayEraOnwardsConstraints - :: ConwayEraOnwards era - -> (ConwayEraOnwardsConstraints era => a) +conwayEraOnwardsConstraints :: () + => ShelleyLedgerEra era ~ ledgerera + => ConwayEraOnwards era + -> (ConwayEraOnwardsConstraints era ledgerera => a) -> a conwayEraOnwardsConstraints = \case ConwayEraOnwardsConway -> id diff --git a/cardano-api/internal/Cardano/Api/Feature/ShelleyBasedEra.hs b/cardano-api/internal/Cardano/Api/Feature/ShelleyBasedEra.hs deleted file mode 100644 index b62399944c..0000000000 --- a/cardano-api/internal/Cardano/Api/Feature/ShelleyBasedEra.hs +++ /dev/null @@ -1,2 +0,0 @@ -module Cardano.Api.Features.ShelleyBasedEra - () where diff --git a/cardano-api/internal/Cardano/Api/Feature/ShelleyToBabbageEra.hs b/cardano-api/internal/Cardano/Api/Feature/ShelleyToBabbageEra.hs index 381c5deb61..83cd2dd1ee 100644 --- a/cardano-api/internal/Cardano/Api/Feature/ShelleyToBabbageEra.hs +++ b/cardano-api/internal/Cardano/Api/Feature/ShelleyToBabbageEra.hs @@ -16,13 +16,24 @@ module Cardano.Api.Feature.ShelleyToBabbageEra ) where import Cardano.Api.Eras +import Cardano.Api.Modes import Cardano.Api.Query.Types import Cardano.Binary -import Cardano.Crypto.Hash.Class (HashAlgorithm) +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 qualified Cardano.Ledger.Core as L +import qualified Cardano.Ledger.SafeHash as L +import qualified Cardano.Ledger.Shelley.TxCert 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 +import Data.Typeable (Typeable) data ShelleyToBabbageEra era where ShelleyToBabbageEraShelley :: ShelleyToBabbageEra ShelleyEra @@ -44,13 +55,27 @@ instance FeatureInEra ShelleyToBabbageEra where BabbageEra -> yes ShelleyToBabbageEraBabbage ConwayEra -> no -type ShelleyToBabbageEraConstraints era = - ( FromCBOR (DebugLedgerState era) - , HashAlgorithm (L.HASH (L.EraCrypto (ShelleyLedgerEra era))) +type ShelleyToBabbageEraConstraints era ledgerera = + ( C.HashAlgorithm (L.HASH (L.EraCrypto ledgerera)) + , C.Signable (L.VRF (L.EraCrypto ledgerera)) L.Seed + , Consensus.PraosProtocolSupportsNode (ConsensusProtocol era) + , Consensus.ShelleyCompatible (ConsensusProtocol era) ledgerera + , L.ADDRHASH (Consensus.PraosProtocolSupportsNodeCrypto (ConsensusProtocol era)) ~ Blake2b.Blake2b_224 + , L.Crypto (L.EraCrypto ledgerera) + , L.Era ledgerera + , L.EraCrypto ledgerera ~ L.StandardCrypto + , L.EraPParams ledgerera + , L.EraTx ledgerera + , L.EraTxBody ledgerera + , L.HashAnnotated (L.TxBody ledgerera) L.EraIndependentTxBody L.StandardCrypto + , L.ShelleyEraTxBody ledgerera + , L.ShelleyEraTxCert ledgerera + , L.TxCert ledgerera ~ L.ShelleyTxCert ledgerera + , FromCBOR (Consensus.ChainDepState (ConsensusProtocol era)) + , FromCBOR (DebugLedgerState era) , IsShelleyBasedEra era - , L.Era (ShelleyLedgerEra era) - , L.EraCrypto (ShelleyLedgerEra era) ~ L.StandardCrypto , ToJSON (DebugLedgerState era) + , Typeable era ) data AnyShelleyToBabbageEra where @@ -58,9 +83,10 @@ data AnyShelleyToBabbageEra where deriving instance Show AnyShelleyToBabbageEra -shelleyToBabbageEraConstraints - :: ShelleyToBabbageEra era - -> (ShelleyToBabbageEraConstraints era => a) +shelleyToBabbageEraConstraints :: () + => ShelleyLedgerEra era ~ ledgerera + => ShelleyToBabbageEra era + -> (ShelleyToBabbageEraConstraints era ledgerera => a) -> a shelleyToBabbageEraConstraints = \case ShelleyToBabbageEraShelley -> id diff --git a/cardano-api/internal/Cardano/Api/Modes.hs b/cardano-api/internal/Cardano/Api/Modes.hs index da7366e606..434d7d80f2 100644 --- a/cardano-api/internal/Cardano/Api/Modes.hs +++ b/cardano-api/internal/Cardano/Api/Modes.hs @@ -44,11 +44,9 @@ module Cardano.Api.Modes ( ConsensusBlockForEra, toConsensusEraIndex, fromConsensusEraIndex, - - withShelleyBasedEraConstraintForConsensus, ) where -import Cardano.Api.Eras +import Cardano.Api.Eras.Core import qualified Cardano.Chain.Slotting as Byron (EpochSlots (..)) import Cardano.Ledger.Crypto (StandardCrypto) @@ -60,7 +58,6 @@ import Ouroboros.Consensus.HardFork.Combinator as Consensus (EraIndex import qualified Ouroboros.Consensus.Protocol.Praos as Consensus import qualified Ouroboros.Consensus.Protocol.TPraos as Consensus import qualified Ouroboros.Consensus.Shelley.HFEras as Consensus -import qualified Ouroboros.Consensus.Shelley.Ledger as Consensus import qualified Ouroboros.Consensus.Shelley.ShelleyHFC as Consensus import Data.Aeson (FromJSON (parseJSON), ToJSON (toJSON), Value) @@ -429,17 +426,3 @@ fromConsensusEraIndex CardanoMode = fromShelleyEraIndex fromShelleyEraIndex (Consensus.EraIndex (S (S (S (S (S (S (Z (K ()))))))))) = AnyEraInMode ConwayEraInCardanoMode - -withShelleyBasedEraConstraintForConsensus - :: forall era ledgerera a. () - => ShelleyLedgerEra era ~ ledgerera - => ShelleyBasedEra era - -> (Consensus.ShelleyCompatible (ConsensusProtocol era) ledgerera => a) - -> a -withShelleyBasedEraConstraintForConsensus = \case - ShelleyBasedEraShelley -> id - ShelleyBasedEraAllegra -> id - ShelleyBasedEraMary -> id - ShelleyBasedEraAlonzo -> id - ShelleyBasedEraBabbage -> id - ShelleyBasedEraConway -> id diff --git a/cardano-api/internal/Cardano/Api/Query/Types.hs b/cardano-api/internal/Cardano/Api/Query/Types.hs index 7a36ff8ad5..1d6e68f44e 100644 --- a/cardano-api/internal/Cardano/Api/Query/Types.hs +++ b/cardano-api/internal/Cardano/Api/Query/Types.hs @@ -14,7 +14,7 @@ module Cardano.Api.Query.Types , toDebugLedgerStatePair ) where -import Cardano.Api.Eras +import Cardano.Api.Eras.Core import Cardano.Binary import Cardano.Ledger.Binary diff --git a/cardano-api/internal/Cardano/Api/Utils.hs b/cardano-api/internal/Cardano/Api/Utils.hs index 0783145518..36f26647e9 100644 --- a/cardano-api/internal/Cardano/Api/Utils.hs +++ b/cardano-api/internal/Cardano/Api/Utils.hs @@ -146,61 +146,37 @@ bounded t = eitherReader $ \s -> do when (i > fromIntegral (maxBound @a)) $ Left $ t <> " must not greater than " <> show (maxBound @a) pure (fromIntegral i) +-- Deprecated: Use shelleyBasedEraConstraints instead. obtainEraCryptoConstraints :: ShelleyBasedEra era -> ((EraCrypto (ShelleyLedgerEra era) ~ StandardCrypto) => a) -> a -obtainEraCryptoConstraints ShelleyBasedEraShelley f = f -obtainEraCryptoConstraints ShelleyBasedEraAllegra f = f -obtainEraCryptoConstraints ShelleyBasedEraMary f = f -obtainEraCryptoConstraints ShelleyBasedEraAlonzo f = f -obtainEraCryptoConstraints ShelleyBasedEraBabbage f = f -obtainEraCryptoConstraints ShelleyBasedEraConway f = f +obtainEraCryptoConstraints = shelleyBasedEraConstraints +-- Deprecated: Use shelleyBasedEraConstraints instead. obtainCryptoConstraints :: ShelleyBasedEra era -> ((Crypto (EraCrypto (ShelleyLedgerEra era))) => a) -> a -obtainCryptoConstraints ShelleyBasedEraShelley f = f -obtainCryptoConstraints ShelleyBasedEraAllegra f = f -obtainCryptoConstraints ShelleyBasedEraMary f = f -obtainCryptoConstraints ShelleyBasedEraAlonzo f = f -obtainCryptoConstraints ShelleyBasedEraBabbage f = f -obtainCryptoConstraints ShelleyBasedEraConway f = f - +obtainCryptoConstraints = shelleyBasedEraConstraints +-- Deprecated: Use shelleyBasedEraConstraints instead. obtainEraPParamsConstraint :: ShelleyBasedEra era -> (Ledger.EraPParams (ShelleyLedgerEra era) => a) -> a -obtainEraPParamsConstraint ShelleyBasedEraShelley f = f -obtainEraPParamsConstraint ShelleyBasedEraAllegra f = f -obtainEraPParamsConstraint ShelleyBasedEraMary f = f -obtainEraPParamsConstraint ShelleyBasedEraAlonzo f = f -obtainEraPParamsConstraint ShelleyBasedEraBabbage f = f -obtainEraPParamsConstraint ShelleyBasedEraConway f = f +obtainEraPParamsConstraint = shelleyBasedEraConstraints +-- Deprecated: Use shelleyBasedEraConstraints instead. obtainEraConstraints :: ShelleyLedgerEra era ~ ledgerera => ShelleyBasedEra era -> ( (IsShelleyBasedEra era, Ledger.Era ledgerera) => a) -> a -obtainEraConstraints ShelleyBasedEraShelley f = f -obtainEraConstraints ShelleyBasedEraAllegra f = f -obtainEraConstraints ShelleyBasedEraMary f = f -obtainEraConstraints ShelleyBasedEraAlonzo f = f -obtainEraConstraints ShelleyBasedEraBabbage f = f -obtainEraConstraints ShelleyBasedEraConway f = f - +obtainEraConstraints = shelleyBasedEraConstraints +-- Deprecated: Use shelleyBasedEraConstraints instead. obtainSafeToHashConstraint :: ShelleyBasedEra era -> (HashAlgorithm (Ledger.HASH (EraCrypto (ShelleyLedgerEra era))) => a) -> a -obtainSafeToHashConstraint ShelleyBasedEraShelley f = f -obtainSafeToHashConstraint ShelleyBasedEraAllegra f = f -obtainSafeToHashConstraint ShelleyBasedEraMary f = f -obtainSafeToHashConstraint ShelleyBasedEraAlonzo f = f -obtainSafeToHashConstraint ShelleyBasedEraBabbage f = f -obtainSafeToHashConstraint ShelleyBasedEraConway f = f - - +obtainSafeToHashConstraint = shelleyBasedEraConstraints