Merge pull request #352 from input-output-hk/ch/gen-erabased-protocol…

…-parameters-updates Add generators for `EraBasedProtocolParametersUpdate`
IntersectMBO · Nov 6, 2023 · c7ba006 · c7ba006
2 parents 95dbeb7 + a95ebd9
commit c7ba006
Show file tree

Hide file tree

Showing 3 changed files with 125 additions and 21 deletions.
diff --git a/cardano-api/cardano-api.cabal b/cardano-api/cardano-api.cabal
@@ -264,7 +264,7 @@ library gen
                       , cardano-binary >= 1.6 && < 1.8
                       , cardano-crypto-class ^>= 2.1.2
                       , cardano-crypto-test ^>= 1.5
-                      , cardano-ledger-alonzo:{cardano-ledger-alonzo, testlib} >= 1.5.0
+                      , cardano-ledger-alonzo:{cardano-ledger-alonzo} >= 1.5.0
                       , cardano-ledger-byron-test >= 1.5
                       , cardano-ledger-core:{cardano-ledger-core, testlib} >= 1.8.0
                       , cardano-ledger-shelley >= 1.7.0

diff --git a/cardano-api/gen/Test/Gen/Cardano/Api/ProtocolParameters.hs b/cardano-api/gen/Test/Gen/Cardano/Api/ProtocolParameters.hs
@@ -0,0 +1,118 @@
+module Test.Gen.Cardano.Api.ProtocolParameters where
+
+import           Cardano.Api
+import           Cardano.Api.Ledger
+import           Cardano.Api.ProtocolParameters
+
+import           Test.Gen.Cardano.Api.Typed (genCostModels)
+
+import           Test.Cardano.Ledger.Alonzo.Arbitrary ()
+import           Test.Cardano.Ledger.Conway.Arbitrary ()
+
+import           Hedgehog (MonadGen)
+import qualified Hedgehog.Gen as Gen
+import qualified Hedgehog.Gen.QuickCheck as Q
+
+genStrictMaybe :: MonadGen m => m a -> m (StrictMaybe a)
+genStrictMaybe gen =
+  Gen.sized $ \n ->
+    Gen.frequency [
+      (2, pure SNothing),
+      (1 + fromIntegral n, SJust<$> gen)
+    ]
+
+genCommonProtocolParametersUpdate :: MonadGen m => m CommonProtocolParametersUpdate
+genCommonProtocolParametersUpdate =
+  CommonProtocolParametersUpdate
+    <$> genStrictMaybe Q.arbitrary
+    <*> genStrictMaybe Q.arbitrary
+    <*> genStrictMaybe Q.arbitrary
+    <*> genStrictMaybe Q.arbitrary
+    <*> genStrictMaybe Q.arbitrary
+    <*> genStrictMaybe Q.arbitrary
+    <*> genStrictMaybe Q.arbitrary
+    <*> genStrictMaybe Q.arbitrary
+    <*> genStrictMaybe Q.arbitrary
+    <*> genStrictMaybe Q.arbitrary
+    <*> genStrictMaybe Q.arbitrary
+    <*> genStrictMaybe Q.arbitrary
+    <*> genStrictMaybe Q.arbitrary
+    <*> genStrictMaybe Q.arbitrary
+
+genDeprecatedAfterMaryPParams :: MonadGen m => m (DeprecatedAfterMaryPParams era)
+genDeprecatedAfterMaryPParams = DeprecatedAfterMaryPParams <$> genStrictMaybe Q.arbitrary
+
+genShelleyToAlonzoPParams :: MonadGen m => m (ShelleyToAlonzoPParams era)
+genShelleyToAlonzoPParams =
+  ShelleyToAlonzoPParams
+    <$> genStrictMaybe Q.arbitrary
+    <*> genStrictMaybe Q.arbitrary
+
+genAlonzoOnwardsPParams :: MonadGen m => m (AlonzoOnwardsPParams era)
+genAlonzoOnwardsPParams =
+  AlonzoOnwardsPParams
+    <$> genStrictMaybe genCostModels
+    <*> genStrictMaybe Q.arbitrary
+    <*> genStrictMaybe Q.arbitrary
+    <*> genStrictMaybe Q.arbitrary
+    <*> genStrictMaybe Q.arbitrary
+    <*> genStrictMaybe Q.arbitrary
+    <*> genStrictMaybe Q.arbitrary
+
+genIntroducedInBabbagePParams :: MonadGen m => m (IntroducedInBabbagePParams era)
+genIntroducedInBabbagePParams = IntroducedInBabbagePParams <$> genStrictMaybe Q.arbitrary
+
+genIntroducedInConwayPParams :: MonadGen m => m (IntroducedInConwayPParams era)
+genIntroducedInConwayPParams =
+  IntroducedInConwayPParams
+    <$> genStrictMaybe Q.arbitrary
+    <*> genStrictMaybe Q.arbitrary
+    <*> genStrictMaybe Q.arbitrary
+    <*> genStrictMaybe Q.arbitrary
+    <*> genStrictMaybe Q.arbitrary
+    <*> genStrictMaybe Q.arbitrary
+    <*> genStrictMaybe Q.arbitrary
+    <*> genStrictMaybe Q.arbitrary
+
+genShelleyEraBasedProtocolParametersUpdate :: MonadGen m => m (EraBasedProtocolParametersUpdate ShelleyEra)
+genShelleyEraBasedProtocolParametersUpdate =
+  ShelleyEraBasedProtocolParametersUpdate
+     <$> genCommonProtocolParametersUpdate
+     <*> genDeprecatedAfterMaryPParams
+     <*> genShelleyToAlonzoPParams
+
+genAllegraEraBasedProtocolParametersUpdate :: MonadGen m => m (EraBasedProtocolParametersUpdate AllegraEra)
+genAllegraEraBasedProtocolParametersUpdate =
+  AllegraEraBasedProtocolParametersUpdate
+     <$> genCommonProtocolParametersUpdate
+     <*> genDeprecatedAfterMaryPParams
+     <*> genShelleyToAlonzoPParams
+
+genMaryEraBasedProtocolParametersUpdate :: MonadGen m => m (EraBasedProtocolParametersUpdate MaryEra)
+genMaryEraBasedProtocolParametersUpdate =
+  MaryEraBasedProtocolParametersUpdate
+     <$> genCommonProtocolParametersUpdate
+     <*> genDeprecatedAfterMaryPParams
+     <*> genShelleyToAlonzoPParams
+
+genAlonzoEraBasedProtocolParametersUpdate :: MonadGen m => m (EraBasedProtocolParametersUpdate AlonzoEra)
+genAlonzoEraBasedProtocolParametersUpdate =
+  AlonzoEraBasedProtocolParametersUpdate
+     <$> genCommonProtocolParametersUpdate
+     <*> genShelleyToAlonzoPParams
+     <*> genAlonzoOnwardsPParams
+
+genBabbageEraBasedProtocolParametersUpdate :: MonadGen m => m (EraBasedProtocolParametersUpdate BabbageEra)
+genBabbageEraBasedProtocolParametersUpdate =
+  BabbageEraBasedProtocolParametersUpdate
+     <$> genCommonProtocolParametersUpdate
+     <*> genAlonzoOnwardsPParams
+     <*> genIntroducedInBabbagePParams
+
+genConwayEraBasedProtocolParametersUpdate :: MonadGen m => m (EraBasedProtocolParametersUpdate ConwayEra)
+genConwayEraBasedProtocolParametersUpdate =
+  ConwayEraBasedProtocolParametersUpdate
+     <$> genCommonProtocolParametersUpdate
+     <*> genAlonzoOnwardsPParams
+     <*> genIntroducedInBabbagePParams
+     <*> genIntroducedInConwayPParams
diff --git a/cardano-api/gen/Test/Gen/Cardano/Api/Typed.hs b/cardano-api/gen/Test/Gen/Cardano/Api/Typed.hs
@@ -20,6 +20,7 @@ module Test.Gen.Cardano.Api.Typed
   , genAddressShelley
   , genCertificate
   , genCostModel
+  , genCostModels
   , genMaybePraosNonce
   , genPraosNonce
   , genValidProtocolParameters
@@ -137,7 +138,6 @@ import qualified Cardano.Binary as CBOR
 import qualified Cardano.Crypto.Hash as Crypto
 import qualified Cardano.Crypto.Hash.Class as CRYPTO
 import qualified Cardano.Crypto.Seed as Crypto
-import           Cardano.Ledger.Alonzo.Language (Language (..))
 import qualified Cardano.Ledger.Alonzo.Scripts as Alonzo
 import qualified Cardano.Ledger.Core as Ledger
 import           Cardano.Ledger.SafeHash (unsafeMakeSafeHash)
@@ -148,7 +148,6 @@ import qualified Data.ByteString as BS
 import qualified Data.ByteString.Short as SBS
 import           Data.Coerce
 import           Data.Int (Int64)
-import           Data.Map.Strict (Map)
 import           Data.Maybe
 import           Data.Ratio (Ratio, (%))
 import           Data.String
@@ -160,11 +159,10 @@ import           Test.Gen.Cardano.Api.Metadata (genTxMetadata)
 
 import           Test.Cardano.Chain.UTxO.Gen (genVKWitness)
 import           Test.Cardano.Crypto.Gen (genProtocolMagicId)
-import           Test.Cardano.Ledger.Alonzo.Arbitrary (genValidCostModel)
 import           Test.Cardano.Ledger.Conway.Arbitrary ()
 import           Test.Cardano.Ledger.Core.Arbitrary ()
 
-import           Hedgehog (Gen, Range)
+import           Hedgehog (Gen, MonadGen, Range)
 import qualified Hedgehog.Gen as Gen
 import qualified Hedgehog.Gen.QuickCheck as Q
 import qualified Hedgehog.Range as Range
@@ -954,23 +952,11 @@ genUpdateProposal era =
         )
     <*> genEpochNo
 
-genCostModel :: Gen Alonzo.CostModel
-genCostModel = do
-  lang <- genPlutusLanguage
-  cm <- Q.quickcheck (genValidCostModel lang)
-  pure cm
+genCostModel :: MonadGen m => m Alonzo.CostModel
+genCostModel = Q.arbitrary
 
-genPlutusLanguage :: Gen Language
-genPlutusLanguage = Gen.element [PlutusV1, PlutusV2, PlutusV3]
-
-_genCostModels :: Gen (Map AnyPlutusScriptVersion CostModel)
-_genCostModels =
-    Gen.map (Range.linear 0 (length plutusScriptVersions))
-            ((,) <$> Gen.element plutusScriptVersions
-                 <*> (Api.fromAlonzoCostModel <$> genCostModel))
-  where
-    plutusScriptVersions :: [AnyPlutusScriptVersion]
-    plutusScriptVersions = [minBound..maxBound]
+genCostModels :: MonadGen m => m Alonzo.CostModels
+genCostModels = Q.arbitrary
 
 genExecutionUnits :: Gen ExecutionUnits
 genExecutionUnits = ExecutionUnits <$> Gen.integral (Range.constant 0 1000)