-
Notifications
You must be signed in to change notification settings - Fork 23
New issue
Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.
By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.
Already on GitHub? Sign in to your account
Generate fields only if they make sense for the given era #40
Changes from all commits
4d2ee8f
df3e51d
19e9c1d
e728649
954c294
44d6e78
cc83938
File filter
Filter by extension
Conversations
Jump to
Diff view
Diff view
There are no files selected for viewing
Original file line number | Diff line number | Diff line change |
---|---|---|
|
@@ -7,7 +7,9 @@ | |
{-# LANGUAGE TypeApplications #-} | ||
|
||
module Test.Gen.Cardano.Api.Typed | ||
( genAddressByron | ||
( genFeatureValueInEra | ||
|
||
, genAddressByron | ||
, genAddressInEra | ||
, genAddressShelley | ||
, genCertificate | ||
|
@@ -119,11 +121,12 @@ 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), | ||
OperationalCertificateIssueCounter (OperationalCertificateIssueCounter), | ||
PlutusScript (PlutusScriptSerialised), ProtocolParameters (ProtocolParameters), | ||
PlutusScript (PlutusScriptSerialised), ProtocolParameters (..), | ||
ReferenceScript (..), ReferenceTxInsScriptsInlineDatumsSupportedInEra (..), | ||
StakeCredential (StakeCredentialByKey), StakePoolKey, | ||
refInsScriptsAndInlineDatsSupportedInEra) | ||
|
@@ -137,7 +140,7 @@ import qualified Cardano.Ledger.Alonzo.Scripts as Alonzo | |
import Cardano.Ledger.SafeHash (unsafeMakeSafeHash) | ||
import qualified Cardano.Ledger.Shelley.TxBody as Ledger (EraIndependentTxBody) | ||
|
||
import Control.Applicative (optional) | ||
import Control.Applicative (Alternative (..), optional) | ||
import Data.ByteString (ByteString) | ||
import qualified Data.ByteString as BS | ||
import qualified Data.ByteString.Short as SBS | ||
|
@@ -160,6 +163,7 @@ import qualified Hedgehog.Gen as Gen | |
import qualified Hedgehog.Range as Range | ||
|
||
{- HLINT ignore "Reduce duplication" -} | ||
{- HLINT ignore "Use let" -} | ||
|
||
genAddressByron :: Gen (Address ByronAddr) | ||
genAddressByron = makeByronAddress <$> genNetworkId | ||
|
@@ -634,7 +638,7 @@ genTxBodyContent era = do | |
txMetadata <- genTxMetadataInEra era | ||
txAuxScripts <- genTxAuxScripts era | ||
let txExtraKeyWits = TxExtraKeyWitnessesNone --TODO: Alonzo era: Generate witness key hashes | ||
txProtocolParams <- BuildTxWith <$> Gen.maybe genValidProtocolParameters | ||
txProtocolParams <- BuildTxWith <$> Gen.maybe (genValidProtocolParameters era) | ||
txWithdrawals <- genTxWithdrawals era | ||
txCertificates <- genTxCertificates era | ||
txUpdateProposal <- genTxUpdateProposal era | ||
|
@@ -703,6 +707,17 @@ genTxBody era = do | |
Left err -> fail (displayError err) | ||
Right txBody -> pure txBody | ||
|
||
-- | Generate a 'FeatureValue' for the given 'CardanoEra' with the provided generator. | ||
genFeatureValueInEra :: () | ||
=> 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 | ||
|
||
genTxScriptValidity :: CardanoEra era -> Gen (TxScriptValidity era) | ||
genTxScriptValidity era = case txScriptValiditySupportedInCardanoEra era of | ||
Nothing -> pure TxScriptValidityNone | ||
|
@@ -831,41 +846,42 @@ genPraosNonce = makePraosNonce <$> Gen.bytes (Range.linear 0 32) | |
genMaybePraosNonce :: Gen (Maybe PraosNonce) | ||
genMaybePraosNonce = Gen.maybe genPraosNonce | ||
|
||
genProtocolParameters :: Gen ProtocolParameters | ||
genProtocolParameters = | ||
ProtocolParameters | ||
<$> ((,) <$> genNat <*> genNat) | ||
<*> Gen.maybe genRational | ||
<*> genMaybePraosNonce | ||
<*> genNat | ||
<*> genNat | ||
<*> genNat | ||
<*> genLovelace | ||
<*> genLovelace | ||
<*> Gen.maybe genLovelace | ||
<*> genLovelace | ||
<*> genLovelace | ||
<*> genLovelace | ||
<*> genEpochNo | ||
<*> genNat | ||
<*> genRationalInt64 | ||
<*> genRational | ||
<*> genRational | ||
<*> Gen.maybe genLovelace | ||
<*> return mempty | ||
--TODO: Babbage figure out how to deal with | ||
-- asymmetric cost model JSON instances | ||
<*> Gen.maybe genExecutionUnitPrices | ||
<*> Gen.maybe genExecutionUnits | ||
<*> Gen.maybe genExecutionUnits | ||
<*> Gen.maybe genNat | ||
<*> Gen.maybe genNat | ||
<*> Gen.maybe genNat | ||
<*> Gen.maybe genLovelace | ||
genProtocolParameters :: CardanoEra era -> Gen ProtocolParameters | ||
genProtocolParameters era = do | ||
protocolParamProtocolVersion <- (,) <$> genNat <*> genNat | ||
protocolParamDecentralization <- Gen.maybe genRational | ||
protocolParamExtraPraosEntropy <- genMaybePraosNonce | ||
protocolParamMaxBlockHeaderSize <- genNat | ||
protocolParamMaxBlockBodySize <- genNat | ||
protocolParamMaxTxSize <- genNat | ||
protocolParamTxFeeFixed <- genLovelace | ||
protocolParamTxFeePerByte <- genLovelace | ||
protocolParamMinUTxOValue <- Gen.maybe genLovelace | ||
protocolParamStakeAddressDeposit <- genLovelace | ||
protocolParamStakePoolDeposit <- genLovelace | ||
protocolParamMinPoolCost <- genLovelace | ||
protocolParamPoolRetireMaxEpoch <- genEpochNo | ||
protocolParamStakePoolTargetNum <- genNat | ||
protocolParamPoolPledgeInfluence <- genRationalInt64 | ||
protocolParamMonetaryExpansion <- genRational | ||
protocolParamTreasuryCut <- genRational | ||
protocolParamUTxOCostPerWord <- featureInEra @ProtocolUTxOCostPerWordFeature (pure Nothing) (const (Just <$> genLovelace)) era | ||
protocolParamCostModels <- pure mempty | ||
--TODO: Babbage figure out how to deal with | ||
-- asymmetric cost model JSON instances | ||
protocolParamPrices <- Gen.maybe genExecutionUnitPrices | ||
protocolParamMaxTxExUnits <- Gen.maybe genExecutionUnits | ||
protocolParamMaxBlockExUnits <- Gen.maybe genExecutionUnits | ||
protocolParamMaxValueSize <- Gen.maybe genNat | ||
protocolParamCollateralPercent <- Gen.maybe genNat | ||
protocolParamMaxCollateralInputs <- Gen.maybe genNat | ||
protocolParamUTxOCostPerByte <- featureInEra @ProtocolUTxOCostPerByteFeature (pure Nothing) (const (Just <$> genLovelace)) era | ||
|
||
pure ProtocolParameters {..} | ||
|
||
-- | Generate valid protocol parameters which pass validations in Cardano.Api.ProtocolParameters | ||
genValidProtocolParameters :: Gen ProtocolParameters | ||
genValidProtocolParameters = | ||
genValidProtocolParameters :: CardanoEra era -> Gen ProtocolParameters | ||
genValidProtocolParameters era = | ||
ProtocolParameters | ||
<$> ((,) <$> genNat <*> genNat) | ||
<*> Gen.maybe genRational | ||
|
@@ -885,7 +901,7 @@ genValidProtocolParameters = | |
<*> genRational | ||
<*> genRational | ||
-- 'Just' is required by checks in Cardano.Api.ProtocolParameters | ||
<*> fmap Just genLovelace | ||
<*> featureInEra @ProtocolUTxOCostPerWordFeature (pure Nothing) (const (Just <$> genLovelace)) era | ||
<*> return mempty | ||
--TODO: Babbage figure out how to deal with | ||
-- asymmetric cost model JSON instances | ||
|
@@ -896,10 +912,10 @@ genValidProtocolParameters = | |
<*> fmap Just genNat | ||
<*> fmap Just genNat | ||
<*> fmap Just genNat | ||
<*> fmap Just genLovelace | ||
<*> featureInEra @ProtocolUTxOCostPerByteFeature (pure Nothing) (const (Just <$> genLovelace)) era | ||
|
||
genProtocolParametersUpdate :: Gen ProtocolParametersUpdate | ||
genProtocolParametersUpdate = do | ||
genProtocolParametersUpdate :: CardanoEra era -> Gen ProtocolParametersUpdate | ||
genProtocolParametersUpdate era = do | ||
protocolUpdateProtocolVersion <- Gen.maybe ((,) <$> genNat <*> genNat) | ||
protocolUpdateDecentralization <- Gen.maybe genRational | ||
protocolUpdateExtraPraosEntropy <- Gen.maybe genMaybePraosNonce | ||
|
@@ -917,7 +933,7 @@ genProtocolParametersUpdate = do | |
protocolUpdatePoolPledgeInfluence <- Gen.maybe genRationalInt64 | ||
protocolUpdateMonetaryExpansion <- Gen.maybe genRational | ||
protocolUpdateTreasuryCut <- Gen.maybe genRational | ||
protocolUpdateUTxOCostPerWord <- Gen.maybe genLovelace | ||
protocolUpdateUTxOCostPerWord <- featureInEra @ProtocolUTxOCostPerWordFeature (pure Nothing) (const (Just <$> genLovelace)) era | ||
There was a problem hiding this comment. Choose a reason for hiding this commentThe reason will be displayed to describe this comment to others. Learn more. The main part of the PR is implemented here and similar. We only generate values for fields if they make sense for the given era. Note, this code is not yet type-safe because the type of The intent is to eventually define these fields like this:
This would make the code type-safe because the code that checks the relevant feature for the field would not compile if they are accidentally mismatched. Unfortunately this is not implemented here because doing so requires |
||
let protocolUpdateCostModels = mempty -- genCostModels | ||
--TODO: Babbage figure out how to deal with | ||
-- asymmetric cost model JSON instances | ||
|
@@ -927,16 +943,19 @@ genProtocolParametersUpdate = do | |
protocolUpdateMaxValueSize <- Gen.maybe genNat | ||
protocolUpdateCollateralPercent <- Gen.maybe genNat | ||
protocolUpdateMaxCollateralInputs <- Gen.maybe genNat | ||
protocolUpdateUTxOCostPerByte <- Gen.maybe genLovelace | ||
protocolUpdateUTxOCostPerByte <- featureInEra @ProtocolUTxOCostPerByteFeature (pure Nothing) (const (Just <$> genLovelace)) era | ||
|
||
pure ProtocolParametersUpdate{..} | ||
|
||
|
||
genUpdateProposal :: CardanoEra era -> Gen UpdateProposal | ||
genUpdateProposal _era = -- TODO Make era specific | ||
genUpdateProposal era = | ||
UpdateProposal | ||
<$> Gen.map (Range.constant 1 3) | ||
((,) <$> genVerificationKeyHash AsGenesisKey | ||
<*> genProtocolParametersUpdate) | ||
( (,) | ||
<$> genVerificationKeyHash AsGenesisKey | ||
<*> genProtocolParametersUpdate era | ||
) | ||
<*> genEpochNo | ||
|
||
genCostModel :: Gen Alonzo.CostModel | ||
|
Original file line number | Diff line number | Diff line change |
---|---|---|
@@ -0,0 +1,88 @@ | ||
{-# LANGUAGE GADTs #-} | ||
{-# LANGUAGE KindSignatures #-} | ||
{-# LANGUAGE LambdaCase #-} | ||
{-# LANGUAGE ScopedTypeVariables #-} | ||
{-# LANGUAGE StandaloneDeriving #-} | ||
|
||
module Cardano.Api.Feature | ||
( FeatureValue (..) | ||
, FeatureInEra(..) | ||
, featureInShelleyBasedEra | ||
, valueOrDefault | ||
, asFeatureValue | ||
, asFeatureValueInShelleyBasedEra | ||
, isFeatureValue | ||
) 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 | ||
|
||
-- | 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 | ||
:: 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) | ||
|
||
-- | 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 | ||
|
||
-- | 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 | ||
|
||
-- | Attempt to construct a 'FeatureValue' from a value and era. | ||
-- If the feature is not supported in the era, then 'NoFeatureValue' is returned. | ||
asFeatureValue :: () | ||
=> FeatureInEra feature | ||
=> a | ||
-> CardanoEra era | ||
-> FeatureValue feature era a | ||
asFeatureValue value = featureInEra NoFeatureValue (`FeatureValue` value) | ||
|
||
-- | Attempt to construct a 'FeatureValue' from a value and a shelley-based-era. | ||
asFeatureValueInShelleyBasedEra :: () | ||
=> FeatureInEra feature | ||
=> a | ||
-> ShelleyBasedEra era | ||
-> FeatureValue feature era a | ||
asFeatureValueInShelleyBasedEra value = asFeatureValue value . shelleyBasedToCardanoEra |
Original file line number | Diff line number | Diff line change |
---|---|---|
|
@@ -8,6 +8,7 @@ | |
{-# LANGUAGE NamedFieldPuns #-} | ||
{-# LANGUAGE RecordWildCards #-} | ||
{-# LANGUAGE ScopedTypeVariables #-} | ||
{-# LANGUAGE StandaloneDeriving #-} | ||
{-# LANGUAGE TypeFamilies #-} | ||
|
||
{- HLINT ignore "Redundant ==" -} | ||
|
@@ -70,11 +71,17 @@ module Cardano.Api.ProtocolParameters ( | |
|
||
-- * Data family instances | ||
AsType(..), | ||
|
||
-- ** Era-dependent protocol features | ||
ProtocolUTxOCostPerByteFeature(..), | ||
ProtocolUTxOCostPerWordFeature(..), | ||
|
||
) where | ||
|
||
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) | ||
|
@@ -667,6 +674,52 @@ instance FromCBOR ProtocolParametersUpdate where | |
<*> fromCBOR | ||
<*> fromCBOR | ||
|
||
-- ---------------------------------------------------------------------------- | ||
-- Features | ||
-- | ||
|
||
-- | A representation of whether the era supports the 'UTxO Cost Per Byte' | ||
-- protocol parameter. | ||
-- | ||
-- The Babbage and subsequent eras support such a protocol parameter. | ||
-- | ||
data ProtocolUTxOCostPerByteFeature era where | ||
ProtocolUTxOCostPerByteInBabbageEra :: ProtocolUTxOCostPerByteFeature BabbageEra | ||
ProtocolUTxOCostPerByteInConwayEra :: ProtocolUTxOCostPerByteFeature ConwayEra | ||
|
||
deriving instance Eq (ProtocolUTxOCostPerByteFeature era) | ||
deriving instance Show (ProtocolUTxOCostPerByteFeature era) | ||
|
||
instance FeatureInEra ProtocolUTxOCostPerByteFeature where | ||
featureInEra no yes = \case | ||
ByronEra -> no | ||
ShelleyEra -> no | ||
AllegraEra -> no | ||
MaryEra -> no | ||
AlonzoEra -> no | ||
BabbageEra -> yes ProtocolUTxOCostPerByteInBabbageEra | ||
ConwayEra -> yes ProtocolUTxOCostPerByteInConwayEra | ||
|
||
-- | A representation of whether the era supports the 'UTxO Cost Per Word' | ||
-- protocol parameter. | ||
-- | ||
-- The Babbage and subsequent eras support such a protocol parameter. | ||
-- | ||
data ProtocolUTxOCostPerWordFeature era where | ||
ProtocolUpdateUTxOCostPerWordInAlonzoEra :: ProtocolUTxOCostPerWordFeature AlonzoEra | ||
There was a problem hiding this comment. Choose a reason for hiding this commentThe reason will be displayed to describe this comment to others. Learn more. This is how to define a "feature". This is exactly the way we currently define features except the naming convention for them is "SupportedInEra". This PR proposes to use the word |
||
|
||
deriving instance Eq (ProtocolUTxOCostPerWordFeature era) | ||
deriving instance Show (ProtocolUTxOCostPerWordFeature era) | ||
|
||
instance FeatureInEra ProtocolUTxOCostPerWordFeature where | ||
featureInEra no yes = \case | ||
ByronEra -> no | ||
ShelleyEra -> no | ||
AllegraEra -> no | ||
MaryEra -> no | ||
AlonzoEra -> yes ProtocolUpdateUTxOCostPerWordInAlonzoEra | ||
BabbageEra -> no | ||
ConwayEra -> no | ||
There was a problem hiding this comment. Choose a reason for hiding this commentThe reason will be displayed to describe this comment to others. Learn more. Every feature defines a
|
||
|
||
-- ---------------------------------------------------------------------------- | ||
-- Praos nonce | ||
|
There was a problem hiding this comment.
Choose a reason for hiding this comment
The reason will be displayed to describe this comment to others. Learn more.
This function is not yet used because the relevant fields are not yet using the
FeatureValue
type, but it will be once that change is made (possibly in a future PR).The advantage of having a
genFeatureValueInEra
is that using it is less error prone than exist practise which is to define per-feature generators manually. It is very easy to accidentally not returnNoFeatureValue
in the case where the feature is supported in the given era in implementation of those manually written functions and that bug currently exists in the code.