Support gov/pparams/v0 namespace

Author: qnikst

libs/cardano-ledger-canonical-state/cardano-ledger-canonical-state.cabal

@@ -41,6 +41,7 @@ library
     Cardano.Ledger.CanonicalState.Namespace.Blocks.V0
     Cardano.Ledger.CanonicalState.Namespace.GovCommittee.V0
     Cardano.Ledger.CanonicalState.Namespace.GovConstitution.V0
+    Cardano.Ledger.CanonicalState.Namespace.GovPParams.V0
     Cardano.Ledger.CanonicalState.Namespace.UTxO.V0
 
   hs-source-dirs: src
@@ -51,6 +52,7 @@ library
     cardano-crypto-class,
     cardano-ledger-binary,
     cardano-ledger-core,
+    cardano-slotting,
     cborg,
     containers,
     mempack-scls,
@@ -67,7 +69,9 @@ library conway
   hs-source-dirs: conway
   build-depends:
     base,
+    cardano-ledger-alonzo,
     cardano-ledger-canonical-state,
+    cardano-ledger-core,
     cardano-ledger-conway,
     scls-core,
 
@@ -105,6 +109,7 @@ test-suite tests
 
   build-depends:
     base,
+    cardano-ledger-core,
     cardano-ledger-canonical-state:{cardano-ledger-canonical-state, conway, testlib},
     cardano-ledger-conway,
     cardano-ledger-core:testlib,

libs/cardano-ledger-canonical-state/conway/Cardano/Ledger/CanonicalState/Conway.hs

@@ -9,13 +9,22 @@ module Cardano.Ledger.CanonicalState.Conway (
   mkCanonicalConstitution,
 ) where
 
+import Cardano.Ledger.Alonzo.PParams (OrdExUnits(..))
+import Cardano.Ledger.BaseTypes (ProtVer)
+import Cardano.Ledger.CanonicalState.BasicTypes (CanonicalCoin (..), fromCanonicalExUnits, mkCanonicalExUnits)
 import Cardano.Ledger.CanonicalState.Namespace
 import Cardano.Ledger.CanonicalState.Namespace.GovCommittee.V0 ()
 import Cardano.Ledger.CanonicalState.Namespace.GovConstitution.V0
+import Cardano.Ledger.CanonicalState.Namespace.GovCommittee.V0 ()
+import Cardano.Ledger.CanonicalState.Namespace.GovPParams.V0
 import Cardano.Ledger.CanonicalState.Namespace.UTxO.V0
+import Cardano.Ledger.Coin (CoinPerByte (..))
 import Cardano.Ledger.Conway (ConwayEra)
 import Cardano.Ledger.Conway.Governance (Constitution (..))
+import Cardano.Ledger.Conway.PParams (ConwayPParams (..), DRepVotingThresholds (..), PoolVotingThresholds (..), THKD (..))
+import Cardano.Ledger.Core (PParams (..))
 import Cardano.SCLS.NamespaceCodec
+import Data.Function ((&))
 
 type instance NamespaceEra "blocks/v0" = ConwayEra
 
@@ -25,9 +34,94 @@ type instance NamespaceEra "utxo/v0" = ConwayEra
 
 type instance NamespaceEra "gov/constitution/v0" = ConwayEra
 
+type instance NamespaceEra "gov/pparams/v0" = ConwayEra
+
+type instance NamespaceEra "utxo/v0" = ConwayEra
+
 instance KnownNamespace "utxo/v0" where
   type NamespaceKey "utxo/v0" = UtxoIn
   type NamespaceEntry "utxo/v0" = UtxoOut ConwayEra
 
 mkCanonicalConstitution :: Constitution era -> CanonicalConstitution
 mkCanonicalConstitution Constitution {..} = CanonicalConstitution {..}
+
+instance MkCanonicalPParams (PParams ConwayEra) where
+  mkCanonicalPParams (PParams ConwayPParams {..}) =
+    CanonicalPParams
+      { ccppA0 = unTHKD cppA0
+      , ccppTxFeePerByte = CanonicalCoin $ unCoinPerByte $ unTHKD cppTxFeePerByte
+      , ccppTxFeeFixed = CanonicalCoin $ unTHKD cppTxFeeFixed
+      , ccppMaxBBSize = unTHKD cppMaxBBSize
+      , ccppMaxTxSize = unTHKD cppMaxTxSize
+      , ccppMaxBHSize = unTHKD cppMaxBHSize
+      , ccppKeyDeposit = CanonicalCoin $ unTHKD cppKeyDeposit
+      , ccppPoolDeposit = CanonicalCoin $ unTHKD cppPoolDeposit
+      , ccppEMax = unTHKD cppEMax
+      , ccppNOpt = unTHKD cppNOpt
+      , ccppRho = unTHKD cppRho
+      , ccppTau = unTHKD cppTau
+      , ccppMinPoolCost = CanonicalCoin $ unTHKD cppMinPoolCost
+      , ccppCoinsPerUTxOByte = CanonicalCoin $ unCoinPerByte $ unTHKD cppCoinsPerUTxOByte
+      , ccppCostModels = mkCanonicalCostModels $ unTHKD cppCostModels
+      , ccppPrices = mkCanonicalPrices $ unTHKD cppPrices
+      , ccppMaxTxExUnits = unTHKD cppMaxTxExUnits & unOrdExUnits & mkCanonicalExUnits
+      , ccppMaxBlockExUnits = unTHKD cppMaxBlockExUnits & unOrdExUnits & mkCanonicalExUnits
+      , ccppMaxValSize = unTHKD cppMaxValSize
+      , ccppCollateralPercentage = unTHKD cppCollateralPercentage
+      , ccppMaxCollateralInputs = unTHKD cppMaxCollateralInputs
+      , ccppPoolVotingThresholds = mkCanonicalPoolVotingThresholds $ unTHKD cppPoolVotingThresholds
+      , ccppDRepVotingThresholds = mkCanonicalDRepVotingThresholds $ unTHKD cppDRepVotingThresholds
+      , ccppCommitteeMinSize = unTHKD cppCommitteeMinSize
+      , ccppCommitteeMaxTermLength = unTHKD cppCommitteeMaxTermLength
+      , ccppGovActionLifetime = unTHKD cppGovActionLifetime
+      , ccppGovActionDeposit = CanonicalCoin $ unTHKD cppGovActionDeposit
+      , ccppDRepDeposit = CanonicalCoin $ unTHKD cppDRepDeposit
+      , ccppDRepActivity = unTHKD cppDRepActivity
+      , ccppMinFeeRefScriptCostPerByte = unTHKD cppMinFeeRefScriptCostPerByte
+      }
+
+instance FromCanonicalPParams (PParams ConwayEra)  where
+  type FromCanonicalPParamsExtra (PParams ConwayEra) = ProtVer
+  fromCanonicalPParams protocolVersion CanonicalPParams {..} =
+    PParams
+      ConwayPParams
+        { cppA0 = THKD ccppA0
+        , cppTxFeePerByte = THKD (CoinPerByte $ unCoin ccppTxFeePerByte)
+        , cppTxFeeFixed = THKD (unCoin ccppTxFeeFixed)
+        , cppMaxBBSize = THKD ccppMaxBBSize
+        , cppMaxTxSize = THKD ccppMaxTxSize
+        , cppMaxBHSize = THKD ccppMaxBHSize
+        , cppKeyDeposit = THKD (unCoin ccppKeyDeposit)
+        , cppPoolDeposit = THKD (unCoin ccppPoolDeposit)
+        , cppEMax = THKD ccppEMax
+        , cppNOpt = THKD ccppNOpt
+        , cppRho = THKD ccppRho
+        , cppTau = THKD ccppTau
+        , cppProtocolVersion = protocolVersion
+        , cppMinPoolCost = THKD (unCoin ccppMinPoolCost)
+        , cppCoinsPerUTxOByte = THKD (CoinPerByte $ unCoin ccppCoinsPerUTxOByte)
+        , cppCostModels = THKD (fromCanonicalCostModels ccppCostModels)
+        , cppPrices = THKD (fromCanonicalPrices ccppPrices)
+        , cppMaxTxExUnits = THKD (ccppMaxTxExUnits & fromCanonicalExUnits & OrdExUnits)
+        , cppMaxBlockExUnits = THKD (ccppMaxBlockExUnits & fromCanonicalExUnits & OrdExUnits)
+        , cppMaxValSize = THKD ccppMaxValSize
+        , cppCollateralPercentage = THKD ccppCollateralPercentage
+        , cppMaxCollateralInputs = THKD ccppMaxCollateralInputs
+        , cppPoolVotingThresholds = THKD (fromCanonicalPoolVotingThresholds ccppPoolVotingThresholds)
+        , cppDRepVotingThresholds = THKD (fromCanonicalDRepVotingThresholds ccppDRepVotingThresholds)
+        , cppCommitteeMinSize = THKD ccppCommitteeMinSize
+        , cppCommitteeMaxTermLength = THKD ccppCommitteeMaxTermLength
+        , cppGovActionLifetime = THKD ccppGovActionLifetime
+        , cppGovActionDeposit = THKD (unCoin ccppGovActionDeposit)
+        , cppDRepDeposit = THKD (unCoin ccppDRepDeposit)
+        , cppDRepActivity = THKD ccppDRepActivity
+        , cppMinFeeRefScriptCostPerByte = THKD ccppMinFeeRefScriptCostPerByte
+        }
+
+instance IsCanonicalDRepVotingThresholds DRepVotingThresholds where
+  mkCanonicalDRepVotingThresholds DRepVotingThresholds {..} = CanonicalDRepVotingThresholds {..}
+  fromCanonicalDRepVotingThresholds CanonicalDRepVotingThresholds {..} = DRepVotingThresholds {..}
+
+instance IsCanonicalPoolVotingThresholds PoolVotingThresholds where
+  fromCanonicalPoolVotingThresholds CanonicalPoolVotingThresholds {..} = PoolVotingThresholds {..}
+  mkCanonicalPoolVotingThresholds PoolVotingThresholds {..} = CanonicalPoolVotingThresholds {..}

libs/cardano-ledger-canonical-state/src/Cardano/Ledger/CanonicalState/BasicTypes.hs

@@ -13,16 +13,20 @@
 {-# LANGUAGE TypeApplications #-}
 {-# LANGUAGE TypeOperators #-}
 {-# LANGUAGE UndecidableInstances #-}
+{-# LANGUAGE ViewPatterns #-}
 {-# OPTIONS_GHC -Wno-orphans #-}
 
 module Cardano.Ledger.CanonicalState.BasicTypes (
   OnChain (..),
   DecodeOnChain (..),
   CanonicalCoin (..),
+  CanonicalExUnits (..),
+  mkCanonicalExUnits,
+  fromCanonicalExUnits,
 ) where
 
 import qualified Cardano.Crypto.Hash as Hash
-import Cardano.Ledger.BaseTypes (Anchor (..), SlotNo (..), StrictMaybe (..))
+import Cardano.Ledger.BaseTypes (Anchor (..), SlotNo (..), StrictMaybe (..), UnitInterval, NonNegativeInterval, EpochInterval)
 import Cardano.Ledger.CanonicalState.LedgerCBOR
 import Cardano.Ledger.CanonicalState.Namespace (Era, NamespaceEra)
 import Cardano.Ledger.Coin (Coin (..), CompactForm (CompactCoin))
@@ -36,6 +40,7 @@ import Cardano.SCLS.CBOR.Canonical.Decoder (
   peekTokenType,
  )
 import Cardano.SCLS.CBOR.Canonical.Encoder (ToCanonicalCBOR (..))
+import Cardano.Ledger.Plutus.ExUnits (ExUnits (..), ExUnits' (..))
 import Cardano.SCLS.Versioned
 import qualified Codec.CBOR.Decoding as D
 import qualified Data.ByteString as BS (ByteString)
@@ -162,3 +167,53 @@ instance (Era era, NamespaceEra v ~ era, Typeable kr) => FromCanonicalCBOR v (Cr
       0 -> fmap ScriptHashObj <$> fromCanonicalCBOR @v
       1 -> fmap KeyHashObj <$> fromCanonicalCBOR @v
       _ -> fail "Invalid Credential tag"
+
+deriving via
+  LedgerCBOR v UnitInterval
+  instance
+    (Era era, NamespaceEra v ~ era) => ToCanonicalCBOR v UnitInterval
+
+deriving via
+  LedgerCBOR v UnitInterval
+  instance
+    (Era era, NamespaceEra v ~ era) => FromCanonicalCBOR v UnitInterval
+
+deriving via
+  LedgerCBOR v NonNegativeInterval
+  instance
+    (Era era, NamespaceEra v ~ era) => ToCanonicalCBOR v NonNegativeInterval
+
+deriving via
+  LedgerCBOR v NonNegativeInterval
+  instance
+    (Era era, NamespaceEra v ~ era) => FromCanonicalCBOR v NonNegativeInterval
+
+deriving via
+  LedgerCBOR v EpochInterval
+  instance
+    (Era era, NamespaceEra v ~ era) => ToCanonicalCBOR v EpochInterval
+
+deriving via
+  LedgerCBOR v EpochInterval
+  instance
+    (Era era, NamespaceEra v ~ era) => FromCanonicalCBOR v EpochInterval
+
+data CanonicalExUnits = CanonicalExUnits
+  { exUnitsMem' :: !Natural
+  , exUnitsSteps' :: !Natural
+  }
+  deriving (Eq, Show, Generic)
+
+instance ToCanonicalCBOR v CanonicalExUnits where
+  toCanonicalCBOR v CanonicalExUnits {..} = toCanonicalCBOR v (exUnitsMem', exUnitsSteps')
+
+instance FromCanonicalCBOR v CanonicalExUnits where
+  fromCanonicalCBOR = do
+    Versioned (exUnitsMem', exUnitsSteps') <- fromCanonicalCBOR @v
+    return $ Versioned CanonicalExUnits {..}
+
+mkCanonicalExUnits :: ExUnits -> CanonicalExUnits
+mkCanonicalExUnits (unWrapExUnits -> ExUnits' {..}) = CanonicalExUnits {..}
+
+fromCanonicalExUnits :: CanonicalExUnits -> ExUnits
+fromCanonicalExUnits CanonicalExUnits {..} = WrapExUnits ExUnits' {..}