Skip to content

Commit

Permalink
Use whole cost models in the roundtrip test
Browse files Browse the repository at this point in the history
  • Loading branch information
@carlhammann
carlhammann committed Nov 21, 2023
1 parent ce36dc9 commit b8cd44a
Show file tree
Hide file tree
Showing 2 changed files with 8 additions and 133 deletions.
4 changes: 1 addition & 3 deletions cardano-cli/cardano-cli.cabal
View file
Original file line number Diff line number Diff line change
Expand Up @@ -298,8 +298,7 @@ test-suite cardano-cli-test
, base16-bytestring
, bech32 >= 1.1.0
, bytestring
, cardano-api:{cardano-api, internal}
, cardano-api-gen ^>= 8.2.0.0
, cardano-api:{cardano-api, gen, internal}
, cardano-cli
, cardano-cli:cardano-cli-test-lib
, cardano-ledger-alonzo
Expand All @@ -308,7 +307,6 @@ test-suite cardano-cli-test
, filepath
, hedgehog
, hedgehog-extras ^>= 0.4.7.0
, hedgehog-quickcheck
, tasty
, tasty-hedgehog
, text
Expand Down
137 changes: 7 additions & 130 deletions cardano-cli/test/cardano-cli-test/Test/Cli/AddCostModels.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -9,172 +9,49 @@ import Cardano.Api.ProtocolParameters
import Cardano.CLI.EraBased.Run.Governance.Actions
import qualified Cardano.Ledger.Alonzo.Scripts as Alonzo

import qualified Data.Map as Map

import Test.Gen.Cardano.Api.ProtocolParameters
import Test.Gen.Cardano.Api.Typed

import Hedgehog
import qualified Hedgehog.Gen as Gen
import Hedgehog.Gen.QuickCheck (arbitrary)

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 arbitrary
<*> genStrictMaybe arbitrary
<*> genStrictMaybe arbitrary
<*> genStrictMaybe arbitrary
<*> genStrictMaybe arbitrary
<*> genStrictMaybe arbitrary
<*> genStrictMaybe arbitrary
<*> genStrictMaybe arbitrary
<*> genStrictMaybe arbitrary
<*> genStrictMaybe arbitrary
<*> genStrictMaybe arbitrary
<*> genStrictMaybe arbitrary
<*> genStrictMaybe arbitrary

genDeprecatedAfterMaryPParams :: MonadGen m => m (DeprecatedAfterMaryPParams era)
genDeprecatedAfterMaryPParams = DeprecatedAfterMaryPParams <$> genStrictMaybe arbitrary

genDeprecatedAfterBabbagePParams :: MonadGen m => m (DeprecatedAfterBabbagePParams era)
genDeprecatedAfterBabbagePParams = DeprecatedAfterBabbagePParams <$> genStrictMaybe arbitrary

genShelleyToAlonzoPParams :: MonadGen m => m (ShelleyToAlonzoPParams era)
genShelleyToAlonzoPParams =
ShelleyToAlonzoPParams
<$> genStrictMaybe arbitrary
<*> genStrictMaybe arbitrary

genAlonzoOnwardsPParams :: MonadGen m => m (AlonzoOnwardsPParams era)
genAlonzoOnwardsPParams =
AlonzoOnwardsPParams
SNothing -- No cost models here!
<$> genStrictMaybe arbitrary
<*> genStrictMaybe arbitrary
<*> genStrictMaybe arbitrary
<*> genStrictMaybe arbitrary
<*> genStrictMaybe arbitrary
<*> genStrictMaybe arbitrary

genIntroducedInBabbagePParams :: MonadGen m => m (IntroducedInBabbagePParams era)
genIntroducedInBabbagePParams = IntroducedInBabbagePParams <$> genStrictMaybe arbitrary

genIntroducedInConwayPParams :: MonadGen m => m (IntroducedInConwayPParams era)
genIntroducedInConwayPParams =
IntroducedInConwayPParams
<$> genStrictMaybe arbitrary
<*> genStrictMaybe arbitrary
<*> genStrictMaybe arbitrary
<*> genStrictMaybe arbitrary
<*> genStrictMaybe arbitrary
<*> genStrictMaybe arbitrary
<*> genStrictMaybe arbitrary
<*> genStrictMaybe arbitrary

genShelleyEraBasedProtocolParametersUpdate :: MonadGen m => m (EraBasedProtocolParametersUpdate ShelleyEra)
genShelleyEraBasedProtocolParametersUpdate =
ShelleyEraBasedProtocolParametersUpdate
<$> genCommonProtocolParametersUpdate
<*> genDeprecatedAfterMaryPParams
<*> genDeprecatedAfterBabbagePParams
<*> genShelleyToAlonzoPParams

genAllegraEraBasedProtocolParametersUpdate :: MonadGen m => m (EraBasedProtocolParametersUpdate AllegraEra)
genAllegraEraBasedProtocolParametersUpdate =
AllegraEraBasedProtocolParametersUpdate
<$> genCommonProtocolParametersUpdate
<*> genDeprecatedAfterMaryPParams
<*> genShelleyToAlonzoPParams
<*> genDeprecatedAfterBabbagePParams

genMaryEraBasedProtocolParametersUpdate :: MonadGen m => m (EraBasedProtocolParametersUpdate MaryEra)
genMaryEraBasedProtocolParametersUpdate =
MaryEraBasedProtocolParametersUpdate
<$> genCommonProtocolParametersUpdate
<*> genDeprecatedAfterMaryPParams
<*> genShelleyToAlonzoPParams
<*> genDeprecatedAfterBabbagePParams

genAlonzoEraBasedProtocolParametersUpdate :: MonadGen m => m (EraBasedProtocolParametersUpdate AlonzoEra)
genAlonzoEraBasedProtocolParametersUpdate =
AlonzoEraBasedProtocolParametersUpdate
<$> genCommonProtocolParametersUpdate
<*> genShelleyToAlonzoPParams
<*> genAlonzoOnwardsPParams
<*> genDeprecatedAfterBabbagePParams

genBabbageEraBasedProtocolParametersUpdate :: MonadGen m => m (EraBasedProtocolParametersUpdate BabbageEra)
genBabbageEraBasedProtocolParametersUpdate =
BabbageEraBasedProtocolParametersUpdate
<$> genCommonProtocolParametersUpdate
<*> genAlonzoOnwardsPParams
<*> genDeprecatedAfterBabbagePParams
<*> genIntroducedInBabbagePParams

genConwayEraBasedProtocolParametersUpdate :: MonadGen m => m (EraBasedProtocolParametersUpdate ConwayEra)
genConwayEraBasedProtocolParametersUpdate =
ConwayEraBasedProtocolParametersUpdate
<$> genCommonProtocolParametersUpdate
<*> genAlonzoOnwardsPParams
<*> genIntroducedInBabbagePParams
<*> genIntroducedInConwayPParams

hprop_roundtrip_Alonzo_addCostModelsToEraBasedProtocolParametersUpdate :: Property
hprop_roundtrip_Alonzo_addCostModelsToEraBasedProtocolParametersUpdate =
property $ do
ppu <- forAll genAlonzoEraBasedProtocolParametersUpdate
cmdl <- forAll genCostModel
let lang = Alonzo.getCostModelLanguage cmdl
cmdl <- forAll genCostModels
tripping
(singletonCostModels lang cmdl)
cmdl
(flip (addCostModelsToEraBasedProtocolParametersUpdate AlonzoEraOnwardsAlonzo) ppu)
getCostModels
where
getCostModels :: EraBasedProtocolParametersUpdate era -> Maybe Alonzo.CostModels
getCostModels (AlonzoEraBasedProtocolParametersUpdate _ _ AlonzoOnwardsPParams {alCostModels = SJust cmdls} _) = Just cmdls
getCostModels _ = Nothing

singletonCostModels lang cmdl = Alonzo.emptyCostModels { Alonzo.costModelsValid = Map.singleton lang cmdl}

hprop_roundtrip_Babbage_addCostModelsToEraBasedProtocolParametersUpdate :: Property
hprop_roundtrip_Babbage_addCostModelsToEraBasedProtocolParametersUpdate =
property $ do
ppu <- forAll genBabbageEraBasedProtocolParametersUpdate
cmdl <- forAll genCostModel
let lang = Alonzo.getCostModelLanguage cmdl
cmdl <- forAll genCostModels
tripping
(singletonCostModels lang cmdl)
cmdl
(flip (addCostModelsToEraBasedProtocolParametersUpdate AlonzoEraOnwardsBabbage) ppu)
getCostModels
where
getCostModels :: EraBasedProtocolParametersUpdate era -> Maybe Alonzo.CostModels
getCostModels (BabbageEraBasedProtocolParametersUpdate _ AlonzoOnwardsPParams {alCostModels = SJust cmdls} _ _) = Just cmdls
getCostModels _ = Nothing

singletonCostModels lang cmdl = Alonzo.emptyCostModels { Alonzo.costModelsValid = Map.singleton lang cmdl}

hprop_roundtrip_Conway_addCostModelsToEraBasedProtocolParametersUpdate :: Property
hprop_roundtrip_Conway_addCostModelsToEraBasedProtocolParametersUpdate =
property $ do
ppu <- forAll genConwayEraBasedProtocolParametersUpdate
cmdl <- forAll genCostModel
let lang = Alonzo.getCostModelLanguage cmdl
cmdl <- forAll genCostModels
tripping
(singletonCostModels lang cmdl)
cmdl
(flip (addCostModelsToEraBasedProtocolParametersUpdate AlonzoEraOnwardsConway) ppu)
getCostModels
where
getCostModels :: EraBasedProtocolParametersUpdate era -> Maybe Alonzo.CostModels
getCostModels (ConwayEraBasedProtocolParametersUpdate _ AlonzoOnwardsPParams {alCostModels = SJust cmdls} _ _) = Just cmdls
getCostModels _ = Nothing

singletonCostModels lang cmdl = Alonzo.emptyCostModels { Alonzo.costModelsValid = Map.singleton lang cmdl}

0 comments on commit b8cd44a

Please sign in to comment.