From 09b817e7e2fc6faf0fe247f29daf1fda1ac96524 Mon Sep 17 00:00:00 2001 From: Aniket Deshpande Date: Wed, 10 Apr 2024 20:34:06 +0530 Subject: [PATCH] Add PlutusV3 CostModel to UpgradeConwayPParams Use `updateCostModels` to add them to Conway PParams during tranlation/upgrade from Babbage --- eras/conway/impl/CHANGELOG.md | 11 +- eras/conway/impl/cardano-ledger-conway.cabal | 6 +- .../impl/src/Cardano/Ledger/Conway/Genesis.hs | 4 - .../impl/src/Cardano/Ledger/Conway/PParams.hs | 53 +++--- .../Test/Cardano/Ledger/Conway/GenesisSpec.hs | 151 ++++-------------- .../conway/impl/test/data/conway-genesis.json | 1 + .../Test/Cardano/Ledger/Conway/Arbitrary.hs | 3 + .../Test/Cardano/Ledger/Conway/Genesis.hs | 142 ++++++++++++++++ .../cardano-ledger-conway-test.cabal | 3 +- .../Ledger/Conway/Examples/Consensus.hs | 13 +- .../cardano-ledger-api.cabal | 2 +- libs/cardano-ledger-core/CHANGELOG.md | 4 + .../src/Cardano/Ledger/Core/PParams.hs | 4 +- .../src/Cardano/Ledger/HKD.hs | 22 ++- 14 files changed, 262 insertions(+), 157 deletions(-) create mode 100644 eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Genesis.hs diff --git a/eras/conway/impl/CHANGELOG.md b/eras/conway/impl/CHANGELOG.md index f53c0bb89a8..b25c15f1245 100644 --- a/eras/conway/impl/CHANGELOG.md +++ b/eras/conway/impl/CHANGELOG.md @@ -1,8 +1,17 @@ # Version history for `cardano-ledger-conway` +## 1.14.0 0 + +* Add `ucppPlutusV3CostModel` to `UpgradeConwayPParams`. #4252 + * Remove the `Default` instance for `ConwayGenesis`. +* Add `foldrVotingProcedures`. + +### `testlib` + +* Updated `exampleConwayGenesis` to `conway-genesis.json`. #4252 + ## 1.13.1.0 -* Add `foldrVotingProcedures` * Fix typo in `ToJSON` instance of `ConwayGovState` ### `testlib` diff --git a/eras/conway/impl/cardano-ledger-conway.cabal b/eras/conway/impl/cardano-ledger-conway.cabal index eb23806cd56..7b5af8965b8 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.8, cardano-ledger-babbage ^>=1.8, - 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..a020d4e327d 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,11 @@ instance FromJSON (UpgradeConwayPParams Identity) where <*> o .: "dRepDeposit" <*> o .: "dRepActivity" <*> o .: "minFeeRefScriptCostPerByte" + <*> (either (fail . show) pure . mkCostModel PlutusV3 =<< o .: "plutusV3CostModel") upgradeConwayPParams :: forall f c. - HKDFunctor f => + HKDApplicative f => UpgradeConwayPParams f -> PParamsHKD f (BabbageEra c) -> ConwayPParams f (ConwayEra c) @@ -1183,7 +1190,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..6bd21746b10 100644 --- a/eras/conway/impl/test/Test/Cardano/Ledger/Conway/GenesisSpec.hs +++ b/eras/conway/impl/test/Test/Cardano/Ledger/Conway/GenesisSpec.hs @@ -1,141 +1,56 @@ -{-# 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 Cardano.Ledger.Babbage (Babbage) +import Cardano.Ledger.Conway (Conway) +import Cardano.Ledger.Conway.Core +import Cardano.Ledger.Conway.PParams +import Cardano.Ledger.Plutus.CostModels (costModelsValid) +import Cardano.Ledger.Plutus.Language (Language (PlutusV3)) 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 Data.Functor.Identity (Identity) +import qualified Data.Map.Strict as Map +import Lens.Micro 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 spec = do - describe "Genesis Golden Spec" $ do - goldenConwayGenesisJSON + describe "ConwayGenesis" $ do + describe "Golden Spec" goldenConwayGenesisJSON + prop "Upgrades" propConwayPParamsUpgrade + +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 + +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/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..119116a4ff8 --- /dev/null +++ b/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Genesis.hs @@ -0,0 +1,142 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Test.Cardano.Ledger.Conway.Genesis (expectedConwayGenesis) where + +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.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.Slot (EpochNo (..)) +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 Test.Cardano.Ledger.Conway.Arbitrary () +import Test.Cardano.Ledger.Core.Utils (unsafeBoundRational) +import Test.Cardano.Ledger.Plutus (zeroTestingCostModelV3) + +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 = zeroTestingCostModelV3 + } + } diff --git a/eras/conway/test-suite/cardano-ledger-conway-test.cabal b/eras/conway/test-suite/cardano-ledger-conway-test.cabal index 97d9d80911e..6ba0d263d75 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.9, 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 7891b2b38f8..d163bfdedfb 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.8, cardano-ledger-babbage ^>=1.8, 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 795dc2df10e..23cce60a3fd 100644 --- a/libs/cardano-ledger-core/CHANGELOG.md +++ b/libs/cardano-ledger-core/CHANGELOG.md @@ -7,6 +7,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..182f0e29eaa 100644 --- a/libs/cardano-ledger-core/src/Cardano/Ledger/HKD.hs +++ b/libs/cardano-ledger-core/src/Cardano/Ledger/HKD.hs @@ -1,4 +1,5 @@ {-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} @@ -14,9 +15,12 @@ module Cardano.Ledger.HKD ( HKDNoUpdate, HKDFunctor (..), NoUpdate (..), + HKDApplicative (..), ) where - +#if __GLASGOW_HASKELL__ < 906 +import Control.Applicative (liftA2) +#endif import Control.DeepSeq (NFData) import Data.Functor.Identity (Identity) import Data.Maybe.Strict (StrictMaybe (..)) @@ -62,3 +66,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