From 4a81c6c1e6c56a8d0a0f109038ec3a80b5ea44e1 Mon Sep 17 00:00:00 2001 From: Carl Hammann Date: Thu, 2 Nov 2023 15:41:06 +0100 Subject: [PATCH] Sketch round trip test for cost model adding --- cardano-cli/cardano-cli.cabal | 6 +- .../CLI/EraBased/Run/Governance/Actions.hs | 5 +- .../Test/Cli/AddCostModels.hs | 173 ++++++++++++++++++ 3 files changed, 181 insertions(+), 3 deletions(-) create mode 100644 cardano-cli/test/cardano-cli-test/Test/Cli/AddCostModels.hs diff --git a/cardano-cli/cardano-cli.cabal b/cardano-cli/cardano-cli.cabal index 91155427e4..051c978f10 100644 --- a/cardano-cli/cardano-cli.cabal +++ b/cardano-cli/cardano-cli.cabal @@ -297,11 +297,14 @@ test-suite cardano-cli-test , cardano-api-gen ^>= 8.2.0.0 , cardano-cli , cardano-cli:cardano-cli-test-lib + , cardano-ledger-alonzo + , cardano-ledger-core , cardano-slotting , containers , filepath , hedgehog , hedgehog-extras ^>= 0.4.7.0 + , hedgehog-quickcheck , parsec , tasty , tasty-hedgehog @@ -311,7 +314,8 @@ test-suite cardano-cli-test build-tool-depends: tasty-discover:tasty-discover - other-modules: Test.Cli.CliIntermediateFormat + other-modules: Test.Cli.AddCostModels + Test.Cli.CliIntermediateFormat Test.Cli.FilePermissions Test.Cli.ITN Test.Cli.JSON diff --git a/cardano-cli/src/Cardano/CLI/EraBased/Run/Governance/Actions.hs b/cardano-cli/src/Cardano/CLI/EraBased/Run/Governance/Actions.hs index 67d8022be7..1779246890 100644 --- a/cardano-cli/src/Cardano/CLI/EraBased/Run/Governance/Actions.hs +++ b/cardano-cli/src/Cardano/CLI/EraBased/Run/Governance/Actions.hs @@ -9,10 +9,11 @@ module Cardano.CLI.EraBased.Run.Governance.Actions ( runGovernanceActionCmds , GovernanceActionsError(..) + , addCostModelsToEraBasedProtocolParametersUpdate ) where import Cardano.Api -import Cardano.Api.Ledger (coerceKeyRole, StrictMaybe (..)) +import Cardano.Api.Ledger (StrictMaybe (..), coerceKeyRole) import qualified Cardano.Api.Ledger as Ledger import Cardano.Api.Shelley @@ -23,6 +24,7 @@ import Cardano.CLI.Read import Cardano.CLI.Types.Common import Cardano.CLI.Types.Errors.GovernanceActionsError import Cardano.CLI.Types.Key +import qualified Cardano.Ledger.Alonzo.Scripts as Alonzo import Control.Monad import Control.Monad.Except (ExceptT) @@ -30,7 +32,6 @@ import Control.Monad.Trans (MonadTrans (..)) import Control.Monad.Trans.Except.Extra import Data.Function import qualified Data.Map.Strict as Map -import qualified Cardano.Ledger.Alonzo.Scripts as Alonzo runGovernanceActionCmds :: () => GovernanceActionCmds era diff --git a/cardano-cli/test/cardano-cli-test/Test/Cli/AddCostModels.hs b/cardano-cli/test/cardano-cli-test/Test/Cli/AddCostModels.hs new file mode 100644 index 0000000000..0794d912dd --- /dev/null +++ b/cardano-cli/test/cardano-cli-test/Test/Cli/AddCostModels.hs @@ -0,0 +1,173 @@ +{-# LANGUAGE GADTs #-} + +module Test.Cli.AddCostModels where + +import Cardano.Api +import Cardano.Api.Ledger (StrictMaybe (..)) +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.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 + <*> genStrictMaybe arbitrary + +genDeprecatedAfterMaryPParams :: MonadGen m => m (DeprecatedAfterMaryPParams era) +genDeprecatedAfterMaryPParams = DeprecatedAfterMaryPParams <$> 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 + <*> 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 + +hprop_roundtrip_Alonzo_addCostModelsToEraBasedProtocolParametersUpdate :: Property +hprop_roundtrip_Alonzo_addCostModelsToEraBasedProtocolParametersUpdate = + property $ do + ppu <- forAll genAlonzoEraBasedProtocolParametersUpdate + cmdl <- forAll genCostModel + let lang = Alonzo.getCostModelLanguage cmdl + tripping + (singletonCostModels lang 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 + tripping + (singletonCostModels lang cmdl) + (flip (addCostModelsToEraBasedProtocolParametersUpdate AlonzoEraOnwardsBabbage) 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_Conway_addCostModelsToEraBasedProtocolParametersUpdate :: Property +hprop_roundtrip_Conway_addCostModelsToEraBasedProtocolParametersUpdate = + property $ do + ppu <- forAll genConwayEraBasedProtocolParametersUpdate + cmdl <- forAll genCostModel + let lang = Alonzo.getCostModelLanguage cmdl + tripping + (singletonCostModels lang cmdl) + (flip (addCostModelsToEraBasedProtocolParametersUpdate AlonzoEraOnwardsConway) 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}