From d0a554ef14dc75fc7d6d142520f79c84de3ff33a Mon Sep 17 00:00:00 2001 From: John Ky Date: Mon, 24 Jul 2023 20:33:38 +1000 Subject: [PATCH 1/4] Move ShelleyToBabbageEra and ConwayEraOnwards to their own module --- cardano-api/cardano-api.cabal | 2 + .../internal/Cardano/Api/Certificate.hs | 43 +------------------ .../Cardano/Api/Feature/ConwayEraOnwards.hs | 30 +++++++++++++ .../Api/Feature/ShelleyToBabbageEra.hs | 34 +++++++++++++++ cardano-api/src/Cardano/Api.hs | 10 +++-- 5 files changed, 74 insertions(+), 45 deletions(-) create mode 100644 cardano-api/internal/Cardano/Api/Feature/ConwayEraOnwards.hs create mode 100644 cardano-api/internal/Cardano/Api/Feature/ShelleyToBabbageEra.hs diff --git a/cardano-api/cardano-api.cabal b/cardano-api/cardano-api.cabal index 01d2e58312..64efb21bb8 100644 --- a/cardano-api/cardano-api.cabal +++ b/cardano-api/cardano-api.cabal @@ -59,6 +59,8 @@ library internal Cardano.Api.Eras Cardano.Api.Error Cardano.Api.Feature + Cardano.Api.Feature.ConwayEraOnwards + Cardano.Api.Feature.ShelleyToBabbageEra Cardano.Api.Fees Cardano.Api.Genesis Cardano.Api.GenesisParameters diff --git a/cardano-api/internal/Cardano/Api/Certificate.hs b/cardano-api/internal/Cardano/Api/Certificate.hs index 1f70045ea0..a4aa950a15 100644 --- a/cardano-api/internal/Cardano/Api/Certificate.hs +++ b/cardano-api/internal/Cardano/Api/Certificate.hs @@ -66,10 +66,6 @@ module Cardano.Api.Certificate ( -- * Data family instances AsType(..), - -- * GADTs for Conway/Shelley differences - ShelleyToBabbageEra(..), - ConwayEraOnwards(..), - -- * Internal functions filterUnRegCreds, selectStakeCredential, @@ -79,7 +75,8 @@ import Cardano.Api.Address import Cardano.Api.DRepMetadata import Cardano.Api.EraCast import Cardano.Api.Eras -import Cardano.Api.Feature +import Cardano.Api.Feature.ConwayEraOnwards +import Cardano.Api.Feature.ShelleyToBabbageEra import Cardano.Api.Governance.Actions.VotingProcedure import Cardano.Api.HasTypeProxy import Cardano.Api.Keys.Praos @@ -316,42 +313,6 @@ data DRepMetadataReference = -- Constructor functions -- -data ConwayEraOnwards era where - ConwayEraOnwardsConway :: ConwayEraOnwards ConwayEra - -deriving instance Show (ConwayEraOnwards era) -deriving instance Eq (ConwayEraOnwards era) - -instance FeatureInEra ConwayEraOnwards where - featureInEra no yes = \case - ByronEra -> no - ShelleyEra -> no - AllegraEra -> no - MaryEra -> no - AlonzoEra -> no - BabbageEra -> no - ConwayEra -> yes ConwayEraOnwardsConway - -data ShelleyToBabbageEra era where - ShelleyToBabbageEraShelley :: ShelleyToBabbageEra ShelleyEra - ShelleyToBabbageEraAllegra :: ShelleyToBabbageEra AllegraEra - ShelleyToBabbageEraMary :: ShelleyToBabbageEra MaryEra - ShelleyToBabbageEraAlonzo :: ShelleyToBabbageEra AlonzoEra - ShelleyToBabbageEraBabbage :: ShelleyToBabbageEra BabbageEra - -deriving instance Show (ShelleyToBabbageEra era) -deriving instance Eq (ShelleyToBabbageEra era) - -instance FeatureInEra ShelleyToBabbageEra where - featureInEra no yes = \case - ByronEra -> no - ShelleyEra -> yes ShelleyToBabbageEraShelley - AllegraEra -> yes ShelleyToBabbageEraAllegra - MaryEra -> yes ShelleyToBabbageEraMary - AlonzoEra -> yes ShelleyToBabbageEraAlonzo - BabbageEra -> yes ShelleyToBabbageEraBabbage - ConwayEra -> no - data StakeAddressRequirements era where StakeAddrRegistrationConway :: ConwayEraOnwards era diff --git a/cardano-api/internal/Cardano/Api/Feature/ConwayEraOnwards.hs b/cardano-api/internal/Cardano/Api/Feature/ConwayEraOnwards.hs new file mode 100644 index 0000000000..e0ebecfdf0 --- /dev/null +++ b/cardano-api/internal/Cardano/Api/Feature/ConwayEraOnwards.hs @@ -0,0 +1,30 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeFamilies #-} + +module Cardano.Api.Feature.ConwayEraOnwards + ( ConwayEraOnwards(..) + ) where + +import Cardano.Api.Eras +import Cardano.Api.Feature + +data ConwayEraOnwards era where + ConwayEraOnwardsConway :: ConwayEraOnwards ConwayEra + +deriving instance Show (ConwayEraOnwards era) +deriving instance Eq (ConwayEraOnwards era) + +instance FeatureInEra ConwayEraOnwards where + featureInEra no yes = \case + ByronEra -> no + ShelleyEra -> no + AllegraEra -> no + MaryEra -> no + AlonzoEra -> no + BabbageEra -> no + ConwayEra -> yes ConwayEraOnwardsConway diff --git a/cardano-api/internal/Cardano/Api/Feature/ShelleyToBabbageEra.hs b/cardano-api/internal/Cardano/Api/Feature/ShelleyToBabbageEra.hs new file mode 100644 index 0000000000..b83e6a722e --- /dev/null +++ b/cardano-api/internal/Cardano/Api/Feature/ShelleyToBabbageEra.hs @@ -0,0 +1,34 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeFamilies #-} + +module Cardano.Api.Feature.ShelleyToBabbageEra + ( ShelleyToBabbageEra(..) + ) where + +import Cardano.Api.Eras +import Cardano.Api.Feature + +data ShelleyToBabbageEra era where + ShelleyToBabbageEraShelley :: ShelleyToBabbageEra ShelleyEra + ShelleyToBabbageEraAllegra :: ShelleyToBabbageEra AllegraEra + ShelleyToBabbageEraMary :: ShelleyToBabbageEra MaryEra + ShelleyToBabbageEraAlonzo :: ShelleyToBabbageEra AlonzoEra + ShelleyToBabbageEraBabbage :: ShelleyToBabbageEra BabbageEra + +deriving instance Show (ShelleyToBabbageEra era) +deriving instance Eq (ShelleyToBabbageEra era) + +instance FeatureInEra ShelleyToBabbageEra where + featureInEra no yes = \case + ByronEra -> no + ShelleyEra -> yes ShelleyToBabbageEraShelley + AllegraEra -> yes ShelleyToBabbageEraAllegra + MaryEra -> yes ShelleyToBabbageEraMary + AlonzoEra -> yes ShelleyToBabbageEraAlonzo + BabbageEra -> yes ShelleyToBabbageEraBabbage + ConwayEra -> no diff --git a/cardano-api/src/Cardano/Api.hs b/cardano-api/src/Cardano/Api.hs index 9389e8e804..a85a141d90 100644 --- a/cardano-api/src/Cardano/Api.hs +++ b/cardano-api/src/Cardano/Api.hs @@ -268,6 +268,10 @@ module Cardano.Api ( BuildTx, ViewTx, + -- ** Era-based transaction body features + ShelleyToBabbageEra(..), + ConwayEraOnwards(..), + -- ** Era-dependent transaction body features CollateralSupportedInEra(..), MultiAssetSupportedInEra(..), @@ -903,10 +907,6 @@ module Cardano.Api ( queryUtxo, determineEraExpr, - -- ** Conway related - ShelleyToBabbageEra(..), - ConwayEraOnwards(..), - -- ** DReps DRepKey, DRepMetadata, @@ -939,6 +939,8 @@ import Cardano.Api.EraCast import Cardano.Api.Eras import Cardano.Api.Error import Cardano.Api.Feature +import Cardano.Api.Feature.ConwayEraOnwards +import Cardano.Api.Feature.ShelleyToBabbageEra import Cardano.Api.Fees import Cardano.Api.Genesis import Cardano.Api.GenesisParameters From 128dad5c3ea07892ebc92d5c849a3136695bc241 Mon Sep 17 00:00:00 2001 From: John Ky Date: Mon, 24 Jul 2023 22:08:01 +1000 Subject: [PATCH 2/4] Move FeatureInEra to Cardano.Api.Eras module --- cardano-api/gen/Test/Gen/Cardano/Api/Typed.hs | 1 - cardano-api/internal/Cardano/Api/Eras.hs | 40 +++++++++++++++++++ cardano-api/internal/Cardano/Api/Feature.hs | 34 ---------------- .../Cardano/Api/Feature/ConwayEraOnwards.hs | 1 - .../Api/Feature/ShelleyToBabbageEra.hs | 1 - .../Cardano/Api/ProtocolParameters.hs | 1 - cardano-api/src/Cardano/Api.hs | 15 ++++--- 7 files changed, 50 insertions(+), 43 deletions(-) diff --git a/cardano-api/gen/Test/Gen/Cardano/Api/Typed.hs b/cardano-api/gen/Test/Gen/Cardano/Api/Typed.hs index 19cb5f8046..27a232bc1f 100644 --- a/cardano-api/gen/Test/Gen/Cardano/Api/Typed.hs +++ b/cardano-api/gen/Test/Gen/Cardano/Api/Typed.hs @@ -122,7 +122,6 @@ import Cardano.Api hiding (txIns) import qualified Cardano.Api as Api import Cardano.Api.Byron (KeyWitness (ByronKeyWitness), WitnessNetworkIdOrByronAddress (..)) -import Cardano.Api.Feature import Cardano.Api.Script (scriptInEraToRefScript) import Cardano.Api.Shelley (GovernancePoll (..), GovernancePollAnswer (..), Hash (..), KESPeriod (KESPeriod), diff --git a/cardano-api/internal/Cardano/Api/Eras.hs b/cardano-api/internal/Cardano/Api/Eras.hs index 6087da48ee..334257e850 100644 --- a/cardano-api/internal/Cardano/Api/Eras.hs +++ b/cardano-api/internal/Cardano/Api/Eras.hs @@ -30,6 +30,11 @@ module Cardano.Api.Eras , InAnyCardanoEra(..) , CardanoLedgerEra + -- * FeatureInEra + , FeatureInEra(..) + , maybeFeatureInEra + , featureInShelleyBasedEra + -- * Deprecated aliases , Byron , Shelley @@ -71,10 +76,14 @@ import Ouroboros.Consensus.Shelley.Eras as Consensus (StandardAllegra, 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 @@ -124,6 +133,37 @@ 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 -- diff --git a/cardano-api/internal/Cardano/Api/Feature.hs b/cardano-api/internal/Cardano/Api/Feature.hs index e0d5114e5d..969eb7b992 100644 --- a/cardano-api/internal/Cardano/Api/Feature.hs +++ b/cardano-api/internal/Cardano/Api/Feature.hs @@ -6,8 +6,6 @@ module Cardano.Api.Feature ( FeatureValue (..) - , FeatureInEra(..) - , featureInShelleyBasedEra , valueOrDefault , asFeatureValue , asFeatureValueInShelleyBasedEra @@ -16,38 +14,6 @@ module Cardano.Api.Feature import Cardano.Api.Eras -import Data.Kind - --- | A class 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 - -instance FeatureInEra ShelleyBasedEra where - featureInEra no yes = \case - ByronEra -> no - ShelleyEra -> yes ShelleyBasedEraShelley - AllegraEra -> yes ShelleyBasedEraAllegra - MaryEra -> yes ShelleyBasedEraMary - AlonzoEra -> yes ShelleyBasedEraAlonzo - BabbageEra -> yes ShelleyBasedEraBabbage - ConwayEra -> yes ShelleyBasedEraConway - --- | 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 - -- | A value of type @'FeatureValue' feature era a@ is either: data FeatureValue feature era a where -- | A value is available for this feature in this era diff --git a/cardano-api/internal/Cardano/Api/Feature/ConwayEraOnwards.hs b/cardano-api/internal/Cardano/Api/Feature/ConwayEraOnwards.hs index e0ebecfdf0..f90012578d 100644 --- a/cardano-api/internal/Cardano/Api/Feature/ConwayEraOnwards.hs +++ b/cardano-api/internal/Cardano/Api/Feature/ConwayEraOnwards.hs @@ -11,7 +11,6 @@ module Cardano.Api.Feature.ConwayEraOnwards ) where import Cardano.Api.Eras -import Cardano.Api.Feature data ConwayEraOnwards era where ConwayEraOnwardsConway :: ConwayEraOnwards ConwayEra diff --git a/cardano-api/internal/Cardano/Api/Feature/ShelleyToBabbageEra.hs b/cardano-api/internal/Cardano/Api/Feature/ShelleyToBabbageEra.hs index b83e6a722e..5ef4f97ea3 100644 --- a/cardano-api/internal/Cardano/Api/Feature/ShelleyToBabbageEra.hs +++ b/cardano-api/internal/Cardano/Api/Feature/ShelleyToBabbageEra.hs @@ -11,7 +11,6 @@ module Cardano.Api.Feature.ShelleyToBabbageEra ) where import Cardano.Api.Eras -import Cardano.Api.Feature data ShelleyToBabbageEra era where ShelleyToBabbageEraShelley :: ShelleyToBabbageEra ShelleyEra diff --git a/cardano-api/internal/Cardano/Api/ProtocolParameters.hs b/cardano-api/internal/Cardano/Api/ProtocolParameters.hs index 530793866f..fbc264c69f 100644 --- a/cardano-api/internal/Cardano/Api/ProtocolParameters.hs +++ b/cardano-api/internal/Cardano/Api/ProtocolParameters.hs @@ -82,7 +82,6 @@ module Cardano.Api.ProtocolParameters ( import Cardano.Api.Address import Cardano.Api.Eras import Cardano.Api.Error -import Cardano.Api.Feature import Cardano.Api.Hash import Cardano.Api.HasTypeProxy import Cardano.Api.Json (toRationalJSON) diff --git a/cardano-api/src/Cardano/Api.hs b/cardano-api/src/Cardano/Api.hs index a85a141d90..a300bc1242 100644 --- a/cardano-api/src/Cardano/Api.hs +++ b/cardano-api/src/Cardano/Api.hs @@ -26,6 +26,16 @@ module Cardano.Api ( cardanoEraConstraints, InAnyCardanoEra(..), + -- * Feature support + FeatureInEra(..), + FeatureValue(..), + maybeFeatureInEra, + featureInShelleyBasedEra, + + -- * Features + ShelleyToBabbageEra(..), + ConwayEraOnwards(..), + -- ** Shelley-based eras ShelleyBasedEra(..), IsShelleyBasedEra(..), @@ -268,10 +278,6 @@ module Cardano.Api ( BuildTx, ViewTx, - -- ** Era-based transaction body features - ShelleyToBabbageEra(..), - ConwayEraOnwards(..), - -- ** Era-dependent transaction body features CollateralSupportedInEra(..), MultiAssetSupportedInEra(..), @@ -291,7 +297,6 @@ module Cardano.Api ( TxTotalAndReturnCollateralSupportedInEra(..), TxVotesSupportedInEra(..), TxGovernanceActionSupportedInEra(..), - FeatureInEra(..), -- ** Feature availability functions collateralSupportedInEra, From 24e6df125aa10dc739c271b921a681875dac6170 Mon Sep 17 00:00:00 2001 From: John Ky Date: Fri, 21 Jul 2023 22:18:17 +1000 Subject: [PATCH 3/4] Improved feature ergonomics --- cardano-api/gen/Test/Gen/Cardano/Api/Typed.hs | 26 ++++++--- cardano-api/internal/Cardano/Api/Feature.hs | 56 +++++++------------ cardano-api/src/Cardano/Api.hs | 4 +- 3 files changed, 41 insertions(+), 45 deletions(-) diff --git a/cardano-api/gen/Test/Gen/Cardano/Api/Typed.hs b/cardano-api/gen/Test/Gen/Cardano/Api/Typed.hs index 27a232bc1f..a0dd7978ba 100644 --- a/cardano-api/gen/Test/Gen/Cardano/Api/Typed.hs +++ b/cardano-api/gen/Test/Gen/Cardano/Api/Typed.hs @@ -7,8 +7,11 @@ {-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeApplications #-} +{-# OPTIONS_GHC -Wno-deprecations #-} + module Test.Gen.Cardano.Api.Typed - ( genFeatureValueInEra + ( genFeaturedInEra + , genMaybeFeaturedInEra , genAddressByron , genAddressInEra @@ -731,16 +734,25 @@ genTxBody era = do Left err -> fail (displayError err) Right txBody -> pure txBody --- | Generate a 'FeatureValue' for the given 'CardanoEra' with the provided generator. -genFeatureValueInEra :: () +-- | Generate a 'Featured' for the given 'CardanoEra' with the provided generator. +genFeaturedInEra :: () + => Alternative f + => feature era + -> f a + -> f (Featured feature era a) +genFeaturedInEra witness gen = + Featured witness <$> gen + +-- | Generate a 'Featured' for the given 'CardanoEra' with the provided generator. +genMaybeFeaturedInEra :: () => FeatureInEra feature => Alternative f => f a -> CardanoEra era - -> f (FeatureValue feature era a) -genFeatureValueInEra gen = - featureInEra (pure NoFeatureValue) $ \witness -> - pure NoFeatureValue <|> fmap (FeatureValue witness) gen + -> f (Maybe (Featured feature era a)) +genMaybeFeaturedInEra gen = + featureInEra (pure Nothing) $ \witness -> + pure Nothing <|> fmap Just (genFeaturedInEra witness gen) genTxScriptValidity :: CardanoEra era -> Gen (TxScriptValidity era) genTxScriptValidity era = case txScriptValiditySupportedInCardanoEra era of diff --git a/cardano-api/internal/Cardano/Api/Feature.hs b/cardano-api/internal/Cardano/Api/Feature.hs index 969eb7b992..85094928e1 100644 --- a/cardano-api/internal/Cardano/Api/Feature.hs +++ b/cardano-api/internal/Cardano/Api/Feature.hs @@ -1,64 +1,46 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE KindSignatures #-} -{-# LANGUAGE LambdaCase #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} +{-# OPTIONS_GHC -Wno-deprecations #-} + module Cardano.Api.Feature - ( FeatureValue (..) - , valueOrDefault - , asFeatureValue - , asFeatureValueInShelleyBasedEra - , isFeatureValue + ( Featured (..) + , asFeaturedInEra + , asFeaturedInShelleyBasedEra ) where import Cardano.Api.Eras --- | A value of type @'FeatureValue' feature era a@ is either: -data FeatureValue feature era a where - -- | A value is available for this feature in this era - FeatureValue +-- | A value only if the feature is supported in this era +data Featured feature era a where + Featured :: feature era -- ^ The witness that the feature is supported in this era -> a -- ^ The value to use - -> FeatureValue feature era a - - -- | No value is available for this feature in this era - NoFeatureValue - :: FeatureValue feature era a - -deriving instance (Eq a, Eq (feature era)) => Eq (FeatureValue feature era a) -deriving instance (Show a, Show (feature era)) => Show (FeatureValue feature era a) + -> Featured feature era a --- | Determine if a value is defined. --- --- If the value is not defined, it could be because the feature is not supported or --- because the feature is supported but the value is not available. -isFeatureValue :: FeatureValue feature era a -> Bool -isFeatureValue = \case - NoFeatureValue -> False - FeatureValue _ _ -> True +deriving instance (Eq a, Eq (feature era)) => Eq (Featured feature era a) +deriving instance (Show a, Show (feature era)) => Show (Featured feature era a) --- | Get the value if it is defined, otherwise return the default value. -valueOrDefault :: a -> FeatureValue feature era a -> a -valueOrDefault defaultValue = \case - NoFeatureValue -> defaultValue - FeatureValue _ a -> a +instance Functor (Featured feature era) where + fmap f (Featured feature a) = Featured feature (f a) -- | Attempt to construct a 'FeatureValue' from a value and era. -- If the feature is not supported in the era, then 'NoFeatureValue' is returned. -asFeatureValue :: () +asFeaturedInEra :: () => FeatureInEra feature => a -> CardanoEra era - -> FeatureValue feature era a -asFeatureValue value = featureInEra NoFeatureValue (`FeatureValue` value) + -> Maybe (Featured feature era a) +asFeaturedInEra value = featureInEra Nothing (Just . flip Featured value) -- | Attempt to construct a 'FeatureValue' from a value and a shelley-based-era. -asFeatureValueInShelleyBasedEra :: () +asFeaturedInShelleyBasedEra :: () => FeatureInEra feature => a -> ShelleyBasedEra era - -> FeatureValue feature era a -asFeatureValueInShelleyBasedEra value = asFeatureValue value . shelleyBasedToCardanoEra + -> Maybe (Featured feature era a) +asFeaturedInShelleyBasedEra value = asFeaturedInEra value . shelleyBasedToCardanoEra diff --git a/cardano-api/src/Cardano/Api.hs b/cardano-api/src/Cardano/Api.hs index a300bc1242..91fbd1f810 100644 --- a/cardano-api/src/Cardano/Api.hs +++ b/cardano-api/src/Cardano/Api.hs @@ -28,9 +28,11 @@ module Cardano.Api ( -- * Feature support FeatureInEra(..), - FeatureValue(..), maybeFeatureInEra, featureInShelleyBasedEra, + Featured(..), + asFeaturedInEra, + asFeaturedInShelleyBasedEra, -- * Features ShelleyToBabbageEra(..), From 3ef0c97ff83ccd2639d90594bab25abe869cb6ea Mon Sep 17 00:00:00 2001 From: John Ky Date: Tue, 25 Jul 2023 19:55:47 +1000 Subject: [PATCH 4/4] New shelleyToBabbageEraToCardanoEra and cardanoEraOnwardsToCardanoEra functions --- .../Cardano/Api/Feature/ConwayEraOnwards.hs | 27 +++++++++++++++ .../Api/Feature/ShelleyToBabbageEra.hs | 34 +++++++++++++++++++ cardano-api/src/Cardano/Api.hs | 6 ++++ 3 files changed, 67 insertions(+) diff --git a/cardano-api/internal/Cardano/Api/Feature/ConwayEraOnwards.hs b/cardano-api/internal/Cardano/Api/Feature/ConwayEraOnwards.hs index f90012578d..78ba97b439 100644 --- a/cardano-api/internal/Cardano/Api/Feature/ConwayEraOnwards.hs +++ b/cardano-api/internal/Cardano/Api/Feature/ConwayEraOnwards.hs @@ -5,13 +5,20 @@ {-# LANGUAGE RankNTypes #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} module Cardano.Api.Feature.ConwayEraOnwards ( ConwayEraOnwards(..) + , conwayEraOnwardsConstraints + , conwayEraOnwardsToCardanoEra + , conwayEraOnwardsToShelleyBasedEra ) where import Cardano.Api.Eras +import Cardano.Crypto.Hash.Class (HashAlgorithm) +import qualified Cardano.Ledger.Api as L + data ConwayEraOnwards era where ConwayEraOnwardsConway :: ConwayEraOnwards ConwayEra @@ -27,3 +34,23 @@ instance FeatureInEra ConwayEraOnwards where AlonzoEra -> no BabbageEra -> no ConwayEra -> yes ConwayEraOnwardsConway + +type ConwayEraOnwardsConstraints era = + ( L.EraCrypto (ShelleyLedgerEra era) ~ L.StandardCrypto + , HashAlgorithm (L.HASH (L.EraCrypto (ShelleyLedgerEra era))) + , L.ConwayEraTxBody (ShelleyLedgerEra era) + ) + +conwayEraOnwardsConstraints + :: ConwayEraOnwards era + -> (ConwayEraOnwardsConstraints era => a) + -> a +conwayEraOnwardsConstraints = \case + ConwayEraOnwardsConway -> id + +conwayEraOnwardsToCardanoEra :: ConwayEraOnwards era -> CardanoEra era +conwayEraOnwardsToCardanoEra = shelleyBasedToCardanoEra . conwayEraOnwardsToShelleyBasedEra + +conwayEraOnwardsToShelleyBasedEra :: ConwayEraOnwards era -> ShelleyBasedEra era +conwayEraOnwardsToShelleyBasedEra = \case + ConwayEraOnwardsConway -> ShelleyBasedEraConway diff --git a/cardano-api/internal/Cardano/Api/Feature/ShelleyToBabbageEra.hs b/cardano-api/internal/Cardano/Api/Feature/ShelleyToBabbageEra.hs index 5ef4f97ea3..91244dbc3e 100644 --- a/cardano-api/internal/Cardano/Api/Feature/ShelleyToBabbageEra.hs +++ b/cardano-api/internal/Cardano/Api/Feature/ShelleyToBabbageEra.hs @@ -5,13 +5,20 @@ {-# LANGUAGE RankNTypes #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} module Cardano.Api.Feature.ShelleyToBabbageEra ( ShelleyToBabbageEra(..) + , shelleyToBabbageEraConstraints + , shelleyToBabbageEraToCardanoEra + , shelleyToBabbageEraToShelleyBasedEra ) where import Cardano.Api.Eras +import Cardano.Crypto.Hash.Class (HashAlgorithm) +import qualified Cardano.Ledger.Api as L + data ShelleyToBabbageEra era where ShelleyToBabbageEraShelley :: ShelleyToBabbageEra ShelleyEra ShelleyToBabbageEraAllegra :: ShelleyToBabbageEra AllegraEra @@ -31,3 +38,30 @@ instance FeatureInEra ShelleyToBabbageEra where AlonzoEra -> yes ShelleyToBabbageEraAlonzo BabbageEra -> yes ShelleyToBabbageEraBabbage ConwayEra -> no + +type ShelleyToBabbageEraConstraints era = + ( L.EraCrypto (ShelleyLedgerEra era) ~ L.StandardCrypto + , HashAlgorithm (L.HASH (L.EraCrypto (ShelleyLedgerEra era))) + ) + +shelleyToBabbageEraConstraints + :: ShelleyToBabbageEra era + -> (ShelleyToBabbageEraConstraints era => a) + -> a +shelleyToBabbageEraConstraints = \case + ShelleyToBabbageEraShelley -> id + ShelleyToBabbageEraAllegra -> id + ShelleyToBabbageEraMary -> id + ShelleyToBabbageEraAlonzo -> id + ShelleyToBabbageEraBabbage -> id + +shelleyToBabbageEraToCardanoEra :: ShelleyToBabbageEra era -> CardanoEra era +shelleyToBabbageEraToCardanoEra = shelleyBasedToCardanoEra . shelleyToBabbageEraToShelleyBasedEra + +shelleyToBabbageEraToShelleyBasedEra :: ShelleyToBabbageEra era -> ShelleyBasedEra era +shelleyToBabbageEraToShelleyBasedEra = \case + ShelleyToBabbageEraShelley -> ShelleyBasedEraShelley + ShelleyToBabbageEraAllegra -> ShelleyBasedEraAllegra + ShelleyToBabbageEraMary -> ShelleyBasedEraMary + ShelleyToBabbageEraAlonzo -> ShelleyBasedEraAlonzo + ShelleyToBabbageEraBabbage -> ShelleyBasedEraBabbage diff --git a/cardano-api/src/Cardano/Api.hs b/cardano-api/src/Cardano/Api.hs index 91fbd1f810..926ead6a26 100644 --- a/cardano-api/src/Cardano/Api.hs +++ b/cardano-api/src/Cardano/Api.hs @@ -36,7 +36,13 @@ module Cardano.Api ( -- * Features ShelleyToBabbageEra(..), + shelleyToBabbageEraConstraints, + shelleyToBabbageEraToCardanoEra, + shelleyToBabbageEraToShelleyBasedEra, ConwayEraOnwards(..), + conwayEraOnwardsConstraints, + conwayEraOnwardsToCardanoEra, + conwayEraOnwardsToShelleyBasedEra, -- ** Shelley-based eras ShelleyBasedEra(..),