Sketch round trip test for cost model adding

IntersectMBO · Nov 2, 2023 · 4a81c6c · 4a81c6c
1 parent 09acbfd
commit 4a81c6c
Show file tree

Hide file tree

Showing 3 changed files with 181 additions and 3 deletions.
diff --git 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
@@ -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,14 +24,14 @@ 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)
 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
@@ -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}