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/gen/Test/Gen/Cardano/Api/Typed.hs b/cardano-api/gen/Test/Gen/Cardano/Api/Typed.hs index 19cb5f8046..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 @@ -122,7 +125,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), @@ -732,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/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/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..85094928e1 100644 --- a/cardano-api/internal/Cardano/Api/Feature.hs +++ b/cardano-api/internal/Cardano/Api/Feature.hs @@ -1,98 +1,46 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE KindSignatures #-} -{-# LANGUAGE LambdaCase #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} +{-# OPTIONS_GHC -Wno-deprecations #-} + module Cardano.Api.Feature - ( FeatureValue (..) - , FeatureInEra(..) - , featureInShelleyBasedEra - , valueOrDefault - , asFeatureValue - , asFeatureValueInShelleyBasedEra - , isFeatureValue + ( Featured (..) + , asFeaturedInEra + , asFeaturedInShelleyBasedEra ) where 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 - 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/internal/Cardano/Api/Feature/ConwayEraOnwards.hs b/cardano-api/internal/Cardano/Api/Feature/ConwayEraOnwards.hs new file mode 100644 index 0000000000..78ba97b439 --- /dev/null +++ b/cardano-api/internal/Cardano/Api/Feature/ConwayEraOnwards.hs @@ -0,0 +1,56 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# 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 + +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 + +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 new file mode 100644 index 0000000000..91244dbc3e --- /dev/null +++ b/cardano-api/internal/Cardano/Api/Feature/ShelleyToBabbageEra.hs @@ -0,0 +1,67 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# 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 + 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 + +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/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 9389e8e804..926ead6a26 100644 --- a/cardano-api/src/Cardano/Api.hs +++ b/cardano-api/src/Cardano/Api.hs @@ -26,6 +26,24 @@ module Cardano.Api ( cardanoEraConstraints, InAnyCardanoEra(..), + -- * Feature support + FeatureInEra(..), + maybeFeatureInEra, + featureInShelleyBasedEra, + Featured(..), + asFeaturedInEra, + asFeaturedInShelleyBasedEra, + + -- * Features + ShelleyToBabbageEra(..), + shelleyToBabbageEraConstraints, + shelleyToBabbageEraToCardanoEra, + shelleyToBabbageEraToShelleyBasedEra, + ConwayEraOnwards(..), + conwayEraOnwardsConstraints, + conwayEraOnwardsToCardanoEra, + conwayEraOnwardsToShelleyBasedEra, + -- ** Shelley-based eras ShelleyBasedEra(..), IsShelleyBasedEra(..), @@ -287,7 +305,6 @@ module Cardano.Api ( TxTotalAndReturnCollateralSupportedInEra(..), TxVotesSupportedInEra(..), TxGovernanceActionSupportedInEra(..), - FeatureInEra(..), -- ** Feature availability functions collateralSupportedInEra, @@ -903,10 +920,6 @@ module Cardano.Api ( queryUtxo, determineEraExpr, - -- ** Conway related - ShelleyToBabbageEra(..), - ConwayEraOnwards(..), - -- ** DReps DRepKey, DRepMetadata, @@ -939,6 +952,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