diff --git a/eras/conway/impl/CHANGELOG.md b/eras/conway/impl/CHANGELOG.md index f53c0bb89a8..d5d585bbc22 100644 --- a/eras/conway/impl/CHANGELOG.md +++ b/eras/conway/impl/CHANGELOG.md @@ -1,5 +1,9 @@ # Version history for `cardano-ledger-conway` +## 1.14.0 0 + +* Add `ucppPlutusV3CostModel` to `UpgradeConwayPParams` #4252 + ## 1.13.1.0 * Add `foldrVotingProcedures` diff --git a/eras/conway/impl/cardano-ledger-conway.cabal b/eras/conway/impl/cardano-ledger-conway.cabal index d053d1b04c3..128d5df05f9 100644 --- a/eras/conway/impl/cardano-ledger-conway.cabal +++ b/eras/conway/impl/cardano-ledger-conway.cabal @@ -1,6 +1,6 @@ cabal-version: 3.0 name: cardano-ledger-conway -version: 1.13.1.0 +version: 1.14.0.0 license: Apache-2.0 maintainer: operations@iohk.io author: IOHK @@ -90,7 +90,7 @@ library cardano-ledger-allegra ^>=1.4, cardano-ledger-alonzo ^>=1.7, cardano-ledger-babbage ^>=1.7, - cardano-ledger-core ^>=1.11, + cardano-ledger-core ^>=1.11.1, cardano-ledger-mary ^>=1.5, cardano-ledger-shelley ^>=1.10, cardano-slotting, @@ -126,6 +126,7 @@ library testlib Test.Cardano.Ledger.Conway.Imp.RatifySpec Test.Cardano.Ledger.Conway.Proposals Test.Cardano.Ledger.Conway.TreeDiff + Test.Cardano.Ledger.Conway.Genesis visibility: public hs-source-dirs: testlib @@ -183,7 +184,6 @@ test-suite tests build-depends: aeson, base, - cardano-data, cardano-ledger-core:testlib, cardano-ledger-allegra, cardano-ledger-alonzo:testlib, diff --git a/eras/conway/impl/src/Cardano/Ledger/Conway/Genesis.hs b/eras/conway/impl/src/Cardano/Ledger/Conway/Genesis.hs index 748c2799527..4a41d5c5ac1 100644 --- a/eras/conway/impl/src/Cardano/Ledger/Conway/Genesis.hs +++ b/eras/conway/impl/src/Cardano/Ledger/Conway/Genesis.hs @@ -39,7 +39,6 @@ import Data.Aeson ( (.:), (.:?), ) -import Data.Default.Class (Default (def)) import Data.Functor.Identity (Identity) import Data.ListMap (ListMap) import GHC.Generics (Generic) @@ -98,6 +97,3 @@ toConwayGenesisPairs cg@(ConwayGenesis _ _ _ _ _) = ++ ["delegs" .= cgDelegs | not (null cgDelegs)] ++ ["initialDReps" .= cgInitialDReps | not (null cgInitialDReps)] ++ toUpgradeConwayPParamsUpdatePairs cgUpgradePParams - -instance Crypto c => Default (ConwayGenesis c) where - def = ConwayGenesis def def def mempty mempty diff --git a/eras/conway/impl/src/Cardano/Ledger/Conway/PParams.hs b/eras/conway/impl/src/Cardano/Ledger/Conway/PParams.hs index 8c403758517..65d13b82748 100644 --- a/eras/conway/impl/src/Cardano/Ledger/Conway/PParams.hs +++ b/eras/conway/impl/src/Cardano/Ledger/Conway/PParams.hs @@ -100,14 +100,29 @@ import Cardano.Ledger.Coin (Coin (Coin)) import Cardano.Ledger.Conway.Era (ConwayEra) import Cardano.Ledger.Core (EraPParams (..)) import Cardano.Ledger.Crypto -import Cardano.Ledger.HKD (HKD, HKDFunctor (..), HKDNoUpdate, NoUpdate (..)) -import Cardano.Ledger.Plutus.CostModels (decodeValidAndUnknownCostModels) +import Cardano.Ledger.HKD ( + HKD, + HKDApplicative (hkdLiftA2), + HKDFunctor (..), + HKDNoUpdate, + NoUpdate (..), + ) +import Cardano.Ledger.Plutus.CostModels ( + CostModel, + decodeCostModelFailHard, + decodeValidAndUnknownCostModels, + encodeCostModel, + mkCostModel, + mkCostModels, + ) +import Cardano.Ledger.Plutus.Language (Language (PlutusV3)) import Cardano.Ledger.Val (Val (..)) import Control.DeepSeq (NFData (..), rwhnf) import Data.Aeson hiding (Encoding, Value, decode, encode) import qualified Data.Aeson as Aeson import Data.Default.Class (Default (def)) import Data.Functor.Identity (Identity) +import qualified Data.Map.Strict as Map import Data.Maybe.Strict (StrictMaybe (..), isSNothing) import Data.Proxy import Data.Set (Set) @@ -580,6 +595,7 @@ data UpgradeConwayPParams f = UpgradeConwayPParams , ucppDRepDeposit :: !(HKD f Coin) , ucppDRepActivity :: !(HKD f EpochInterval) , ucppMinFeeRefScriptCostPerByte :: !(HKD f NonNegativeInterval) + , ucppPlutusV3CostModel :: !(HKD f CostModel) } deriving (Generic) @@ -603,20 +619,6 @@ instance NoThunks (UpgradeConwayPParams StrictMaybe) instance NFData (UpgradeConwayPParams StrictMaybe) -instance Default (UpgradeConwayPParams Identity) where - def = - UpgradeConwayPParams - { ucppPoolVotingThresholds = def - , ucppDRepVotingThresholds = def - , ucppCommitteeMinSize = 0 - , ucppCommitteeMaxTermLength = EpochInterval 0 - , ucppGovActionLifetime = EpochInterval 0 - , ucppGovActionDeposit = Coin 0 - , ucppDRepDeposit = Coin 0 - , ucppDRepActivity = EpochInterval 0 - , ucppMinFeeRefScriptCostPerByte = minBound - } - instance Default (UpgradeConwayPParams StrictMaybe) where def = UpgradeConwayPParams @@ -629,6 +631,7 @@ instance Default (UpgradeConwayPParams StrictMaybe) where , ucppDRepDeposit = SNothing , ucppDRepActivity = SNothing , ucppMinFeeRefScriptCostPerByte = SNothing + , ucppPlutusV3CostModel = SNothing } instance EncCBOR (UpgradeConwayPParams Identity) where @@ -644,6 +647,7 @@ instance EncCBOR (UpgradeConwayPParams Identity) where !> To ucppDRepDeposit !> To ucppDRepActivity !> To ucppMinFeeRefScriptCostPerByte + !> E encodeCostModel ucppPlutusV3CostModel instance DecCBOR (UpgradeConwayPParams Identity) where decCBOR = @@ -658,6 +662,7 @@ instance DecCBOR (UpgradeConwayPParams Identity) where EraPParams (ConwayEra c) where type PParamsHKD f (ConwayEra c) = ConwayPParams f (ConwayEra c) @@ -1144,6 +1149,7 @@ upgradeConwayPParamsHKDPairs UpgradeConwayPParams {..} = , ("dRepDeposit", (toJSON @Coin) ucppDRepDeposit) , ("dRepActivity", (toJSON @EpochInterval) ucppDRepActivity) , ("minFeeRefScriptCostPerByte", (toJSON @NonNegativeInterval) ucppMinFeeRefScriptCostPerByte) + , ("plutusV3CostModel", (toJSON @CostModel) ucppPlutusV3CostModel) ] instance FromJSON (UpgradeConwayPParams Identity) where @@ -1159,10 +1165,15 @@ instance FromJSON (UpgradeConwayPParams Identity) where <*> o .: "dRepDeposit" <*> o .: "dRepActivity" <*> o .: "minFeeRefScriptCostPerByte" + <*> do + cm <- o .: "plutusV3CostModel" + case mkCostModel PlutusV3 cm of + Left e -> fail $ show e + Right cm' -> pure cm' upgradeConwayPParams :: forall f c. - HKDFunctor f => + HKDApplicative f => UpgradeConwayPParams f -> PParamsHKD f (BabbageEra c) -> ConwayPParams f (ConwayEra c) @@ -1183,7 +1194,17 @@ upgradeConwayPParams UpgradeConwayPParams {..} BabbagePParams {..} = , cppProtocolVersion = toNoUpdate @f @ProtVer bppProtocolVersion , cppMinPoolCost = THKD bppMinPoolCost , cppCoinsPerUTxOByte = THKD bppCoinsPerUTxOByte - , cppCostModels = THKD bppCostModels + , cppCostModels = + THKD $ + -- We add the PlutusV3 CostModel from ConwayGenesis to the ConwayPParams here + hkdLiftA2 @f + updateCostModels + bppCostModels + ( hkdMap + (Proxy @f) + (mkCostModels . Map.singleton PlutusV3) + ucppPlutusV3CostModel + ) , cppPrices = THKD bppPrices , cppMaxTxExUnits = THKD bppMaxTxExUnits , cppMaxBlockExUnits = THKD bppMaxBlockExUnits diff --git a/eras/conway/impl/test/Test/Cardano/Ledger/Conway/GenesisSpec.hs b/eras/conway/impl/test/Test/Cardano/Ledger/Conway/GenesisSpec.hs index dbc90df3234..d33e0b29cda 100644 --- a/eras/conway/impl/test/Test/Cardano/Ledger/Conway/GenesisSpec.hs +++ b/eras/conway/impl/test/Test/Cardano/Ledger/Conway/GenesisSpec.hs @@ -1,34 +1,15 @@ -{-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} -module Test.Cardano.Ledger.Conway.GenesisSpec (spec) where +module Test.Cardano.Ledger.Conway.GenesisSpec (spec, expectedConwayGenesis) where -import Cardano.Ledger.BaseTypes (textToUrl) -import Cardano.Ledger.CertState (DRep (..), DRepState (..)) -import Cardano.Ledger.Coin (Coin (..)) -import Cardano.Ledger.Conway -import Cardano.Ledger.Conway.Genesis (ConwayGenesis (..)) -import Cardano.Ledger.Conway.Governance (Anchor (..), Committee (..)) -import Cardano.Ledger.Conway.TxCert (Delegatee (..)) -import Cardano.Ledger.Core -import Cardano.Ledger.Credential -import Cardano.Ledger.Crypto (StandardCrypto) -import Cardano.Ledger.Keys -import Cardano.Ledger.Slot (EpochNo (..)) import Data.Aeson hiding (Encoding) -import Data.Default.Class (Default (def)) -import qualified Data.ListMap as ListMap -import Data.Map as Map -import Data.Maybe (fromJust) -import Data.Maybe.Strict (StrictMaybe (..)) -import Data.Ratio ((%)) import Paths_cardano_ledger_conway (getDataFileName) import Test.Cardano.Ledger.Common -import Test.Cardano.Ledger.Core.Utils (unsafeBoundRational) +import Test.Cardano.Ledger.Conway.Genesis (expectedConwayGenesis) import Test.Cardano.Slotting.Numeric () spec :: Spec @@ -36,106 +17,15 @@ spec = do describe "Genesis Golden Spec" $ do goldenConwayGenesisJSON +fileName :: String +fileName = "test/data/conway-genesis.json" + goldenConwayGenesisJSON :: Spec goldenConwayGenesisJSON = it "should deserialize to the default value" $ do - let fileName = "test/data/conway-genesis.json" - credMember = - KeyHashObj - (KeyHash "4e88cc2d27c364aaf90648a87dfb95f8ee103ba67fa1f12f5e86c42a") :: - Credential 'ColdCommitteeRole StandardCrypto - scriptMember = - ScriptHashObj - (ScriptHash "4e88cc2d27c364aaf90648a87dfb95f8ee103ba67fa1f12f5e86c42a") :: - Credential 'ColdCommitteeRole StandardCrypto - comm = - Committee - ( Map.fromList - [ - ( credMember - , EpochNo 1 - ) - , - ( scriptMember - , EpochNo 2 - ) - ] - ) - (unsafeBoundRational (1 % 2)) :: - Committee Conway file <- getDataFileName fileName dec <- eitherDecodeFileStrict' file cg <- case dec of Left err -> error ("Failed to deserialize JSON: " ++ err) Right x -> pure x - let - expectedCg = - def - { cgCommittee = comm - , cgInitialDReps = - ListMap.fromList - [ - ( KeyHashObj - (KeyHash "78301005df84ba67fa1f12f95f8ee10335bc5e86c42afbc593ab4cdd") - , DRepState - { drepExpiry = 1000 - , drepAnchor = SNothing - , drepDeposit = Coin 5000 - } - ) - , - ( ScriptHashObj - (ScriptHash "01305df84b078ac5e86c42afbc593ab4cdd67fa1f12f95f8ee10335b") - , DRepState - { drepExpiry = 300 - , drepAnchor = - SJust $ - Anchor - { anchorUrl = fromJust $ textToUrl 99 "example.com" - , anchorDataHash = def - } - , drepDeposit = Coin 6000 - } - ) - ] - , cgDelegs = - ListMap.fromList - [ - ( KeyHashObj - (KeyHash "35bc5e86c42afbc593ab4cdd78301005df84ba67fa1f12f95f8ee103") - , DelegVote DRepAlwaysNoConfidence - ) - , - ( KeyHashObj - (KeyHash "4e88cc2d27c364aaf90648a87dfb95f8ee103ba67fa1f12f5e86c42a") - , DelegVote DRepAlwaysAbstain - ) - , - ( KeyHashObj - (KeyHash "5df84bcdd7a5f8ee93aafbc500b435bc5e83067fa1f12f9110386c42") - , DelegStake $ KeyHash "0335bc5e86c42afbc578301005df84ba67fa1f12f95f8ee193ab4cdd" - ) - , - ( KeyHashObj - (KeyHash "8ee93a5df84bc42cdd7a5fafbc500b435bc5e83067fa1f12f9110386") - , DelegStakeVote - (KeyHash "086c42afbc578301005df84ba67fa1f12f95f8ee193ab4cdd335bc5e") - DRepAlwaysAbstain - ) - , - ( KeyHashObj - (KeyHash "df93ab435bc5eafbc500583067fa1f12f9110386c42cdd784ba5f8ee") - , DelegVote $ - DRepCredential - (ScriptHashObj (ScriptHash "01305df84b078ac5e86c42afbc593ab4cdd67fa1f12f95f8ee10335b")) - ) - , - ( ScriptHashObj - (ScriptHash "afbc5005df84ba5f8ee93ab435bc5e83067fa1f12f9c42cdd7110386") - , DelegVote $ - DRepCredential - (KeyHashObj (KeyHash "78301005df84ba67fa1f12f95f8ee10335bc5e86c42afbc593ab4cdd")) - ) - ] - } - cg `shouldBe` expectedCg + cg `shouldBe` expectedConwayGenesis diff --git a/eras/conway/impl/test/data/conway-genesis.json b/eras/conway/impl/test/data/conway-genesis.json index 031692a708c..b02d589c035 100644 --- a/eras/conway/impl/test/data/conway-genesis.json +++ b/eras/conway/impl/test/data/conway-genesis.json @@ -25,6 +25,7 @@ "dRepDeposit": 0, "dRepActivity": 0, "minFeeRefScriptCostPerByte": 0, + "plutusV3CostModel": [0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0], "constitution": { "anchor": { "url": "", diff --git a/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Arbitrary.hs b/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Arbitrary.hs index ce9679dba1d..7e03a5d827c 100644 --- a/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Arbitrary.hs +++ b/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Arbitrary.hs @@ -51,6 +51,7 @@ import Cardano.Ledger.Conway.TxCert import Cardano.Ledger.Conway.TxInfo (ConwayContextError) import Cardano.Ledger.Crypto (Crypto) import Cardano.Ledger.HKD (HKD, NoUpdate (..)) +import Cardano.Ledger.Plutus (Language (PlutusV3)) import Control.State.Transition.Extended (STS (Event)) import Data.Default.Class (def) import Data.Foldable (toList) @@ -67,6 +68,7 @@ import Test.Cardano.Data (genNonEmptyMap) import Test.Cardano.Data.Arbitrary () import Test.Cardano.Ledger.Alonzo.Arbitrary ( genValidAndUnknownCostModels, + genValidCostModel, unFlexibleCostModels, ) import Test.Cardano.Ledger.Babbage.Arbitrary () @@ -116,6 +118,7 @@ instance Arbitrary (UpgradeConwayPParams Identity) where <*> arbitrary <*> arbitrary <*> arbitrary + <*> genValidCostModel PlutusV3 instance Crypto c => Arbitrary (Delegatee c) where arbitrary = diff --git a/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Genesis.hs b/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Genesis.hs new file mode 100644 index 00000000000..0f59bd31354 --- /dev/null +++ b/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Genesis.hs @@ -0,0 +1,177 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Test.Cardano.Ledger.Conway.Genesis (expectedConwayGenesis, propConwayPParamsUpgrade, spec) where + +import Cardano.Ledger.Babbage (Babbage) +import Cardano.Ledger.BaseTypes (EpochInterval (..), textToUrl) +import Cardano.Ledger.CertState (DRep (..), DRepState (..)) +import Cardano.Ledger.Coin (Coin (..)) +import Cardano.Ledger.Conway +import Cardano.Ledger.Conway.Core (ppCostModelsL) +import Cardano.Ledger.Conway.Genesis (ConwayGenesis (..)) +import Cardano.Ledger.Conway.Governance (Anchor (..), Committee (..)) +import Cardano.Ledger.Conway.PParams +import Cardano.Ledger.Conway.TxCert (Delegatee (..)) +import Cardano.Ledger.Core +import Cardano.Ledger.Credential +import Cardano.Ledger.Crypto (StandardCrypto) +import Cardano.Ledger.Keys +import Cardano.Ledger.Plutus (Language (PlutusV3), costModelsValid, mkCostModel) +import Cardano.Ledger.Slot (EpochNo (..)) +import Data.Default.Class (Default (def)) +import Data.Functor.Identity (Identity) +import qualified Data.ListMap as ListMap +import Data.Map as Map +import Data.Maybe (fromJust) +import Data.Maybe.Strict (StrictMaybe (..)) +import Data.Ratio ((%)) +import Lens.Micro +import Test.Cardano.Ledger.Common +import Test.Cardano.Ledger.Conway.Arbitrary () +import Test.Cardano.Ledger.Core.Utils (unsafeBoundRational) + +credMember :: Credential 'ColdCommitteeRole StandardCrypto +credMember = + KeyHashObj + (KeyHash "4e88cc2d27c364aaf90648a87dfb95f8ee103ba67fa1f12f5e86c42a") + +scriptMember :: Credential 'ColdCommitteeRole StandardCrypto +scriptMember = + ScriptHashObj + (ScriptHash "4e88cc2d27c364aaf90648a87dfb95f8ee103ba67fa1f12f5e86c42a") + +comm :: Committee Conway +comm = + Committee + ( Map.fromList + [ + ( credMember + , EpochNo 1 + ) + , + ( scriptMember + , EpochNo 2 + ) + ] + ) + (unsafeBoundRational (1 % 2)) + +expectedConwayGenesis :: ConwayGenesis StandardCrypto +expectedConwayGenesis = + ConwayGenesis + { cgCommittee = comm + , cgInitialDReps = + ListMap.fromList + [ + ( KeyHashObj + (KeyHash "78301005df84ba67fa1f12f95f8ee10335bc5e86c42afbc593ab4cdd") + , DRepState + { drepExpiry = EpochNo 1000 + , drepAnchor = SNothing + , drepDeposit = Coin 5000 + } + ) + , + ( ScriptHashObj + (ScriptHash "01305df84b078ac5e86c42afbc593ab4cdd67fa1f12f95f8ee10335b") + , DRepState + { drepExpiry = EpochNo 300 + , drepAnchor = + SJust $ + Anchor + { anchorUrl = fromJust $ textToUrl 99 "example.com" + , anchorDataHash = def + } + , drepDeposit = Coin 6000 + } + ) + ] + , cgDelegs = + ListMap.fromList + [ + ( KeyHashObj + (KeyHash "35bc5e86c42afbc593ab4cdd78301005df84ba67fa1f12f95f8ee103") + , DelegVote DRepAlwaysNoConfidence + ) + , + ( KeyHashObj + (KeyHash "4e88cc2d27c364aaf90648a87dfb95f8ee103ba67fa1f12f5e86c42a") + , DelegVote DRepAlwaysAbstain + ) + , + ( KeyHashObj + (KeyHash "5df84bcdd7a5f8ee93aafbc500b435bc5e83067fa1f12f9110386c42") + , DelegStake $ KeyHash "0335bc5e86c42afbc578301005df84ba67fa1f12f95f8ee193ab4cdd" + ) + , + ( KeyHashObj + (KeyHash "8ee93a5df84bc42cdd7a5fafbc500b435bc5e83067fa1f12f9110386") + , DelegStakeVote + (KeyHash "086c42afbc578301005df84ba67fa1f12f95f8ee193ab4cdd335bc5e") + DRepAlwaysAbstain + ) + , + ( KeyHashObj + (KeyHash "df93ab435bc5eafbc500583067fa1f12f9110386c42cdd784ba5f8ee") + , DelegVote $ + DRepCredential + (ScriptHashObj (ScriptHash "01305df84b078ac5e86c42afbc593ab4cdd67fa1f12f95f8ee10335b")) + ) + , + ( ScriptHashObj + (ScriptHash "afbc5005df84ba5f8ee93ab435bc5e83067fa1f12f9c42cdd7110386") + , DelegVote $ + DRepCredential + (KeyHashObj (KeyHash "78301005df84ba67fa1f12f95f8ee10335bc5e86c42afbc593ab4cdd")) + ) + ] + , cgConstitution = def + , cgUpgradePParams = + UpgradeConwayPParams + { ucppPoolVotingThresholds = def + , ucppDRepVotingThresholds = def + , ucppCommitteeMinSize = 0 + , ucppCommitteeMaxTermLength = EpochInterval 0 + , ucppGovActionLifetime = EpochInterval 0 + , ucppGovActionDeposit = Coin 0 + , ucppDRepDeposit = Coin 0 + , ucppDRepActivity = EpochInterval 0 + , ucppMinFeeRefScriptCostPerByte = minBound + , ucppPlutusV3CostModel = + either + ( error + . const + ( "Impossible! Implementation of Default for ConwayGenesis. " + <> "mkCostModel PlutusV3 mempty cannot fail." + ) + ) + id + $ mkCostModel PlutusV3 + $ replicate 233 0 + } + } + +spec :: Spec +spec = + describe "ConwayGenesis" $ do + it "Upgrades" $ property $ propConwayPParamsUpgrade + +propConwayPParamsUpgrade :: UpgradeConwayPParams Identity -> PParams Babbage -> Property +propConwayPParamsUpgrade ppu pp = property $ do + let pp' = upgradePParams ppu pp :: PParams Conway + pp' ^. ppPoolVotingThresholdsL `shouldBe` ucppPoolVotingThresholds ppu + pp' ^. ppDRepVotingThresholdsL `shouldBe` ucppDRepVotingThresholds ppu + pp' ^. ppCommitteeMinSizeL `shouldBe` ucppCommitteeMinSize ppu + pp' ^. ppCommitteeMaxTermLengthL `shouldBe` ucppCommitteeMaxTermLength ppu + pp' ^. ppGovActionLifetimeL `shouldBe` ucppGovActionLifetime ppu + pp' ^. ppGovActionDepositL `shouldBe` ucppGovActionDeposit ppu + pp' ^. ppDRepDepositL `shouldBe` ucppDRepDeposit ppu + pp' ^. ppDRepActivityL `shouldBe` ucppDRepActivity ppu + pp' ^. ppMinFeeRefScriptCostPerByteL `shouldBe` ucppMinFeeRefScriptCostPerByte ppu + Map.lookup PlutusV3 (costModelsValid (pp' ^. ppCostModelsL)) + `shouldBe` Just (ucppPlutusV3CostModel ppu) diff --git a/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Imp.hs b/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Imp.hs index ab0799db167..0170ab6e52e 100644 --- a/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Imp.hs +++ b/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Imp.hs @@ -25,6 +25,7 @@ import Cardano.Ledger.Conway.TxInfo (ConwayContextError) import Cardano.Ledger.Shelley.Rules (Event, ShelleyUtxowPredFailure (..)) import Data.Typeable (Typeable) import Test.Cardano.Ledger.Common +import qualified Test.Cardano.Ledger.Conway.Genesis as Genesis import qualified Test.Cardano.Ledger.Conway.Imp.EnactSpec as Enact import qualified Test.Cardano.Ledger.Conway.Imp.EpochSpec as Epoch import qualified Test.Cardano.Ledger.Conway.Imp.GovCertSpec as GovCert @@ -64,3 +65,5 @@ spec = do Utxos.spec @era Ratify.spec @era GovCert.spec @era + describe "Conway Properties" $ do + Genesis.spec diff --git a/eras/conway/test-suite/cardano-ledger-conway-test.cabal b/eras/conway/test-suite/cardano-ledger-conway-test.cabal index e658f55a78e..decc3af81a8 100644 --- a/eras/conway/test-suite/cardano-ledger-conway-test.cabal +++ b/eras/conway/test-suite/cardano-ledger-conway-test.cabal @@ -36,14 +36,13 @@ library cardano-ledger-babbage >=1.3 && <1.8, cardano-ledger-babbage-test >=1.1.1, cardano-ledger-binary >=1.0, - cardano-ledger-conway:{cardano-ledger-conway, testlib} ^>=1.13, + cardano-ledger-conway:{cardano-ledger-conway, testlib} >=1.13 && <1.15, cardano-ledger-core:{cardano-ledger-core, testlib} >=1.11, cardano-ledger-allegra >=1.2, cardano-ledger-mary >=1.4, cardano-ledger-shelley-ma-test >=1.1, cardano-ledger-shelley-test >=1.1, cardano-ledger-shelley >=1.6, - cardano-slotting, cardano-strict-containers, containers, data-default-class, diff --git a/eras/conway/test-suite/src/Test/Cardano/Ledger/Conway/Examples/Consensus.hs b/eras/conway/test-suite/src/Test/Cardano/Ledger/Conway/Examples/Consensus.hs index 79e7717da35..26cd4af66a7 100644 --- a/eras/conway/test-suite/src/Test/Cardano/Ledger/Conway/Examples/Consensus.hs +++ b/eras/conway/test-suite/src/Test/Cardano/Ledger/Conway/Examples/Consensus.hs @@ -17,7 +17,7 @@ import Cardano.Ledger.Alonzo.TxAuxData ( ) import Cardano.Ledger.Alonzo.TxWits (Redeemers (..), TxDats (..)) import Cardano.Ledger.Babbage.TxBody (BabbageTxOut (..)) -import Cardano.Ledger.BaseTypes (StrictMaybe (..)) +import Cardano.Ledger.BaseTypes import Cardano.Ledger.Binary (mkSized) import Cardano.Ledger.Coin (Coin (..)) import Cardano.Ledger.Conway (Conway) @@ -29,10 +29,10 @@ import Cardano.Ledger.Conway.Scripts (ConwayPlutusPurpose (..)) import Cardano.Ledger.Conway.Translation () import Cardano.Ledger.Conway.Tx (AlonzoTx (..)) import Cardano.Ledger.Conway.TxBody (ConwayTxBody (..)) -import Cardano.Ledger.Conway.TxCert (ConwayTxCert (..)) +import Cardano.Ledger.Conway.TxCert import Cardano.Ledger.Conway.TxWits (AlonzoTxWits (..)) import Cardano.Ledger.Credential (Credential (KeyHashObj, ScriptHashObj)) -import Cardano.Ledger.Crypto (Crypto, StandardCrypto) +import Cardano.Ledger.Crypto (StandardCrypto) import Cardano.Ledger.Keys (asWitness) import Cardano.Ledger.Mary.Value (MaryValue (..)) import Cardano.Ledger.Plutus.Data ( @@ -45,7 +45,6 @@ import Cardano.Ledger.Plutus.Language (Language (..)) import Cardano.Ledger.SafeHash (hashAnnotated) import Cardano.Ledger.Shelley.API ( ApplyTxError (..), - Network (..), NewEpochState (..), ProposedPPUpdates (..), RewardAccount (..), @@ -53,7 +52,6 @@ import Cardano.Ledger.Shelley.API ( ) import Cardano.Ledger.Shelley.Tx (ShelleyTx (..)) import Cardano.Ledger.TxIn (mkTxInPartial) -import Cardano.Slotting.Slot (SlotNo (..)) import Control.State.Transition.Extended (Embed (..)) import Data.Default.Class (Default (def)) import qualified Data.Map.Strict as Map @@ -64,6 +62,7 @@ import qualified Data.Set as Set import Lens.Micro import qualified PlutusLedgerApi.Common as P import Test.Cardano.Ledger.Alonzo.Arbitrary (alwaysFails, alwaysSucceeds) +import Test.Cardano.Ledger.Conway.Genesis (expectedConwayGenesis) import Test.Cardano.Ledger.Core.KeyPair (mkAddr, mkWitnessesVKey) import Test.Cardano.Ledger.Core.Utils (mkDummySafeHash) import qualified Test.Cardano.Ledger.Mary.Examples.Consensus as MarySLE @@ -202,5 +201,5 @@ exampleConwayNewEpochState = emptyPParams (emptyPParams & ppCoinsPerUTxOByteL .~ CoinPerByte (Coin 1)) -exampleConwayGenesis :: Crypto c => ConwayGenesis c -exampleConwayGenesis = def +exampleConwayGenesis :: ConwayGenesis StandardCrypto +exampleConwayGenesis = expectedConwayGenesis diff --git a/libs/cardano-ledger-api/cardano-ledger-api.cabal b/libs/cardano-ledger-api/cardano-ledger-api.cabal index 67d955c5bb4..b44f331a6fb 100644 --- a/libs/cardano-ledger-api/cardano-ledger-api.cabal +++ b/libs/cardano-ledger-api/cardano-ledger-api.cabal @@ -58,7 +58,7 @@ library cardano-ledger-alonzo ^>=1.7, cardano-ledger-babbage ^>=1.7, cardano-ledger-binary ^>=1.3, - cardano-ledger-conway ^>=1.13, + cardano-ledger-conway >=1.13 && <1.15, cardano-ledger-core ^>=1.11, cardano-ledger-mary ^>=1.5, cardano-ledger-shelley ^>=1.10, diff --git a/libs/cardano-ledger-core/CHANGELOG.md b/libs/cardano-ledger-core/CHANGELOG.md index 1fd2a40b3d6..357da992949 100644 --- a/libs/cardano-ledger-core/CHANGELOG.md +++ b/libs/cardano-ledger-core/CHANGELOG.md @@ -6,6 +6,10 @@ * Add `byteStringToNum` * Add functions `rdRewardCoin`, `rdDepositCoin` in UMap.hs * Add function `mkCoinTxOut` in Core.hs +* Add typeclass `HKDApplicative` and make instances for the following: #4252 + * `HKD Identity` + * `HKD Maybe` + * `HKD StrictMaybe` ## 1.11.0.0 diff --git a/libs/cardano-ledger-core/src/Cardano/Ledger/Core/PParams.hs b/libs/cardano-ledger-core/src/Cardano/Ledger/Core/PParams.hs index 9519405595d..a4c39376323 100644 --- a/libs/cardano-ledger-core/src/Cardano/Ledger/Core/PParams.hs +++ b/libs/cardano-ledger-core/src/Cardano/Ledger/Core/PParams.hs @@ -90,7 +90,7 @@ import Cardano.Ledger.BaseTypes ( import Cardano.Ledger.Binary (DecCBOR, EncCBOR, FromCBOR, ToCBOR) import Cardano.Ledger.Coin (Coin (..)) import Cardano.Ledger.Core.Era (Era (..), PreviousEra, ProtVerAtMost) -import Cardano.Ledger.HKD (HKD, HKDFunctor (..), NoUpdate (..)) +import Cardano.Ledger.HKD (HKD, HKDApplicative, HKDFunctor (..), NoUpdate (..)) import Cardano.Ledger.Plutus.ToPlutusData (ToPlutusData (..)) import Control.DeepSeq (NFData) import Control.Monad.Identity (Identity) @@ -283,7 +283,7 @@ class -- | Upgrade PParams from previous era to the current one upgradePParamsHKD :: - (HKDFunctor f, EraPParams (PreviousEra era)) => + (HKDApplicative f, EraPParams (PreviousEra era)) => UpgradePParams f era -> PParamsHKD f (PreviousEra era) -> PParamsHKD f era diff --git a/libs/cardano-ledger-core/src/Cardano/Ledger/HKD.hs b/libs/cardano-ledger-core/src/Cardano/Ledger/HKD.hs index e8b68200570..1d8140c6e5b 100644 --- a/libs/cardano-ledger-core/src/Cardano/Ledger/HKD.hs +++ b/libs/cardano-ledger-core/src/Cardano/Ledger/HKD.hs @@ -14,9 +14,11 @@ module Cardano.Ledger.HKD ( HKDNoUpdate, HKDFunctor (..), NoUpdate (..), + HKDApplicative (..), ) where +import Control.Applicative (liftA2) import Control.DeepSeq (NFData) import Data.Functor.Identity (Identity) import Data.Maybe.Strict (StrictMaybe (..)) @@ -62,3 +64,19 @@ instance HKDFunctor StrictMaybe where hkdMap _ = fmap toNoUpdate _ = NoUpdate fromNoUpdate _ = SNothing + +class HKDFunctor f => HKDApplicative f where + hkdPure :: a -> HKD f a + hkdLiftA2 :: forall a b c. (a -> b -> c) -> HKD f a -> HKD f b -> HKD f c + +instance HKDApplicative Identity where + hkdPure = id + hkdLiftA2 g = g + +instance HKDApplicative Maybe where + hkdPure = pure + hkdLiftA2 = liftA2 + +instance HKDApplicative StrictMaybe where + hkdPure = pure + hkdLiftA2 = liftA2