From d5da0c7eb351a3f6cf647aba178331c906c4e64a Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Joosep=20J=C3=A4=C3=A4ger?= Date: Tue, 7 Jan 2025 12:13:44 +0200 Subject: [PATCH] Added `NonZero` Co-authored-by: Alexey Kuleshevich --- .../src/Cardano/Ledger/Alonzo/Rules/Utxo.hs | 5 +- .../src/Cardano/Ledger/Conway/Governance.hs | 9 +- .../src/Cardano/Ledger/Conway/Rules/Ratify.hs | 18 +- .../impl/src/Cardano/Ledger/Conway/Tx.hs | 5 +- eras/shelley/impl/CHANGELOG.md | 7 + .../src/Cardano/Ledger/Shelley/API/Wallet.hs | 10 +- .../src/Cardano/Ledger/Shelley/Genesis.hs | 11 +- .../Shelley/LedgerState/PulsingReward.hs | 22 ++- .../src/Cardano/Ledger/Shelley/PoolRank.hs | 30 ++- .../src/Cardano/Ledger/Shelley/Rewards.hs | 22 ++- .../Cardano/Ledger/Shelley/StabilityWindow.hs | 8 +- .../Test/Cardano/Ledger/Shelley/ImpTest.hs | 2 +- .../Ledger/Shelley/Examples/Consensus.hs | 2 +- .../Ledger/Shelley/Generator/Update.hs | 2 + .../Test/Cardano/Ledger/Shelley/Rewards.hs | 12 +- .../Shelley/Serialisation/Golden/Genesis.hs | 4 +- .../Conformance/SpecTranslate/Conway/Base.hs | 2 +- libs/cardano-ledger-core/CHANGELOG.md | 10 + .../cardano-ledger-core.cabal | 1 + .../src/Cardano/Ledger/BaseTypes.hs | 8 +- .../src/Cardano/Ledger/BaseTypes/NonZero.hs | 173 ++++++++++++++++++ .../src/Cardano/Ledger/Coin.hs | 32 +++- .../src/Cardano/Ledger/EpochBoundary.hs | 45 +++-- .../src/Cardano/Ledger/Plutus/ToPlutusData.hs | 13 +- .../Test/Cardano/Ledger/Core/Arbitrary.hs | 5 + .../testlib/Test/Cardano/Ledger/Core/Utils.hs | 4 +- .../testlib/Test/Cardano/Ledger/TreeDiff.hs | 3 + .../Constrained/Conway/Instances/Basic.hs | 2 +- .../Constrained/Conway/Instances/Ledger.hs | 2 +- .../Test/Cardano/Ledger/Constrained/Vars.hs | 7 +- .../src/Cardano/Protocol/TPraos/BHeader.hs | 8 +- .../src/Constrained/Base.hs | 2 +- 32 files changed, 393 insertions(+), 93 deletions(-) create mode 100644 libs/cardano-ledger-core/src/Cardano/Ledger/BaseTypes/NonZero.hs diff --git a/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/Rules/Utxo.hs b/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/Rules/Utxo.hs index 6e2066e2e47..b1637abdcf8 100644 --- a/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/Rules/Utxo.hs +++ b/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/Rules/Utxo.hs @@ -63,8 +63,10 @@ import Cardano.Ledger.BaseTypes ( ShelleyBase, StrictMaybe (..), epochInfo, + knownNonZero, networkId, systemStart, + (%.), ) import Cardano.Ledger.Binary (DecCBOR (..), EncCBOR (..), serialize) import Cardano.Ledger.Binary.Coders ( @@ -104,7 +106,6 @@ import Data.Coerce (coerce) import Data.Either (isRight) import Data.Foldable as F (foldl', sequenceA_, toList) import qualified Data.Map.Strict as Map -import Data.Ratio ((%)) import Data.Set (Set) import qualified Data.Set as Set import GHC.Generics (Generic) @@ -331,7 +332,7 @@ validateInsufficientCollateral pp txBody bal = failureUnless (Val.scale (100 :: Int) bal >= Val.scale collPerc (toDeltaCoin txfee)) $ InsufficientCollateral bal $ rationalToCoinViaCeiling $ - (fromIntegral collPerc * unCoin txfee) % 100 + (fromIntegral collPerc * unCoin txfee) %. knownNonZero @100 where txfee = txBody ^. feeTxBodyL -- Coin supplied to pay fees collPerc = pp ^. ppCollateralPercentageL diff --git a/eras/conway/impl/src/Cardano/Ledger/Conway/Governance.hs b/eras/conway/impl/src/Cardano/Ledger/Conway/Governance.hs index fde48e10610..605c804ba47 100644 --- a/eras/conway/impl/src/Cardano/Ledger/Conway/Governance.hs +++ b/eras/conway/impl/src/Cardano/Ledger/Conway/Governance.hs @@ -181,6 +181,10 @@ import Cardano.Ledger.BaseTypes ( EpochNo (..), Globals (..), StrictMaybe (..), + knownNonZero, + mulNonZero, + toIntegerNonZero, + (%.), ) import Cardano.Ledger.Binary ( DecCBOR (..), @@ -251,7 +255,6 @@ import qualified Data.Foldable as F (foldl') import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map import qualified Data.Set as Set -import Data.Word (Word64) import GHC.Generics (Generic) import Lens.Micro import Lens.Micro.Extras (view) @@ -491,14 +494,14 @@ setFreshDRepPulsingState epochNo stakePoolDistr epochState = do k = securityParameter globals -- On mainnet set to 2160 umap = dsUnified dState umapSize = Map.size $ umElems umap - pulseSize = max 1 (umapSize `div` (fromIntegral :: Word64 -> Int) (4 * k)) + pulseSize = max 1 (fromIntegral umapSize %. (knownNonZero @4 `mulNonZero` toIntegerNonZero k)) govState' = predictFuturePParams $ govState & cgsDRepPulsingStateL .~ DRPulsing ( DRepPulser - { dpPulseSize = pulseSize + { dpPulseSize = floor pulseSize , dpUMap = dsUnified dState , dpIndex = 0 -- used as the index of the remaining UMap , dpStakeDistr = stakeDistr -- used as part of the snapshot diff --git a/eras/conway/impl/src/Cardano/Ledger/Conway/Rules/Ratify.hs b/eras/conway/impl/src/Cardano/Ledger/Conway/Rules/Ratify.hs index 00952d77ab8..e12176df35b 100644 --- a/eras/conway/impl/src/Cardano/Ledger/Conway/Rules/Ratify.hs +++ b/eras/conway/impl/src/Cardano/Ledger/Conway/Rules/Ratify.hs @@ -33,6 +33,7 @@ import Cardano.Ledger.BaseTypes ( ShelleyBase, StrictMaybe (..), addEpochInterval, + (%?), ) import Cardano.Ledger.CertState (CommitteeAuthorization (..), CommitteeState (csCommitteeCreds)) import Cardano.Ledger.Coin (Coin (..), CompactForm (..)) @@ -81,7 +82,6 @@ import Control.State.Transition.Extended ( import Data.Foldable (Foldable (..)) import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map -import Data.Ratio ((%)) import qualified Data.Sequence as Seq import qualified Data.Sequence.Strict as SSeq import qualified Data.Set as Set @@ -140,9 +140,8 @@ committeeAcceptedRatio :: CommitteeState era -> EpochNo -> Rational -committeeAcceptedRatio members votes committeeState currentEpoch - | totalExcludingAbstain == 0 = 0 - | otherwise = yesVotes % totalExcludingAbstain +committeeAcceptedRatio members votes committeeState currentEpoch = + yesVotes %? totalExcludingAbstain where accumVotes :: (Integer, Integer) -> @@ -200,10 +199,8 @@ spoAcceptedRatio { gasStakePoolVotes , gasProposalProcedure = ProposalProcedure {pProcGovAction} } - pv - | totalActiveStake == 0 = 0 -- guard against the degenerate case when active stake is zero. - | totalActiveStake == abstainStake = 0 -- guard against the degenerate case when all abstain. - | otherwise = toInteger yesStake % toInteger (totalActiveStake - abstainStake) + pv = + toInteger yesStake %? toInteger (totalActiveStake - abstainStake) where accumStake (!yes, !abstain) poolId distr = let CompactCoin stake = individualTotalPoolStake distr @@ -253,9 +250,8 @@ dRepAcceptedRatio :: Map (Credential 'DRepRole) Vote -> GovAction era -> Rational -dRepAcceptedRatio RatifyEnv {reDRepDistr, reDRepState, reCurrentEpoch} gasDRepVotes govAction - | totalExcludingAbstainStake == 0 = 0 - | otherwise = toInteger yesStake % toInteger totalExcludingAbstainStake +dRepAcceptedRatio RatifyEnv {reDRepDistr, reDRepState, reCurrentEpoch} gasDRepVotes govAction = + toInteger yesStake %? toInteger totalExcludingAbstainStake where accumStake (!yes, !tot) drep (CompactCoin stake) = case drep of diff --git a/eras/conway/impl/src/Cardano/Ledger/Conway/Tx.hs b/eras/conway/impl/src/Cardano/Ledger/Conway/Tx.hs index 867af32f0b7..0d55dd188a2 100644 --- a/eras/conway/impl/src/Cardano/Ledger/Conway/Tx.hs +++ b/eras/conway/impl/src/Cardano/Ledger/Conway/Tx.hs @@ -42,7 +42,6 @@ import Cardano.Ledger.Conway.TxBody () import Cardano.Ledger.Conway.TxWits () import Cardano.Ledger.Core import Cardano.Ledger.Val (Val (..)) -import Data.Ratio ((%)) import GHC.Stack import Lens.Micro ((^.)) @@ -125,10 +124,10 @@ tierRefScriptFee multiplier sizeIncrement where go !acc !curTierPrice !n | n < sizeIncrement = - Coin $ floor (acc + (toInteger n % 1) * curTierPrice) + Coin $ floor (acc + toRational n * curTierPrice) | otherwise = go (acc + sizeIncrementRational * curTierPrice) (multiplier * curTierPrice) (n - sizeIncrement) - sizeIncrementRational = toInteger sizeIncrement % 1 + sizeIncrementRational = toRational sizeIncrement instance AlonzoEraTx ConwayEra where isValidTxL = isValidAlonzoTxL diff --git a/eras/shelley/impl/CHANGELOG.md b/eras/shelley/impl/CHANGELOG.md index 3dbdae62704..52d3bfc02ff 100644 --- a/eras/shelley/impl/CHANGELOG.md +++ b/eras/shelley/impl/CHANGELOG.md @@ -2,6 +2,13 @@ ## 1.16.0.0 +* Changed the type of `sgSecurityParam` to `NonZero Word64` +* Following functions now expect a `NonZero Word64` security parameter: + * `startStep` + * `createRUpd` + * `desirability` + * `getTopRankedPools` + * `getTopRankedPoolsVMap` * Remove `Era era` constraint from `sizeShelleyTxF` and `wireSizeShelleyTxF` * Add `MemPack` instance `ShelleyTxOut` * Deprecate `hashShelleyTxAuxData` diff --git a/eras/shelley/impl/src/Cardano/Ledger/Shelley/API/Wallet.hs b/eras/shelley/impl/src/Cardano/Ledger/Shelley/API/Wallet.hs index ce2db376e91..0efbfb86399 100644 --- a/eras/shelley/impl/src/Cardano/Ledger/Shelley/API/Wallet.hs +++ b/eras/shelley/impl/src/Cardano/Ledger/Shelley/API/Wallet.hs @@ -44,6 +44,7 @@ import Cardano.Ledger.BaseTypes ( NonNegativeInterval, UnitInterval, epochInfoPure, + (%?), ) import Cardano.Ledger.Binary ( DecCBOR (..), @@ -110,7 +111,6 @@ import Data.Default (Default (def)) import Data.Foldable (foldMap') import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map -import Data.Ratio ((%)) import Data.Set (Set) import qualified Data.Set as Set import qualified Data.VMap as VMap @@ -197,7 +197,7 @@ poolsByTotalStakeFraction globals ss = where snap = currentSnapshot ss Coin totalStake = getTotalStake globals ss - stakeRatio = unCoin (fromCompact totalActiveStake) % totalStake + stakeRatio = unCoin (fromCompact totalActiveStake) %? totalStake PoolDistr poolsByActiveStake totalActiveStake = calculatePoolDistr snap poolsByTotalStake = Map.map toTotalStakeFrac poolsByActiveStake toTotalStakeFrac :: @@ -231,8 +231,8 @@ getNonMyopicMemberRewards globals ss = Map.fromSet (\cred -> Map.map (mkNMMRewards $ memShare cred) poolData) where maxSupply = Coin . fromIntegral $ maxLovelaceSupply globals - Coin totalStake = circulation es maxSupply - toShare (Coin x) = StakeShare (x % totalStake) + totalStakeCoin@(Coin totalStake) = circulation es maxSupply + toShare (Coin x) = StakeShare $ x %? totalStake memShare (Right cred) = toShare $ maybe mempty fromCompact $ VMap.lookup cred (EB.unStake stake) memShare (Left coin) = toShare coin @@ -255,7 +255,7 @@ getNonMyopicMemberRewards globals ss = topPools = getTopRankedPoolsVMap rPot - (Coin totalStake) + totalStakeCoin pp poolParams (fmap percentile' ls) diff --git a/eras/shelley/impl/src/Cardano/Ledger/Shelley/Genesis.hs b/eras/shelley/impl/src/Cardano/Ledger/Shelley/Genesis.hs index 0c5dd115a29..888fafc437a 100644 --- a/eras/shelley/impl/src/Cardano/Ledger/Shelley/Genesis.hs +++ b/eras/shelley/impl/src/Cardano/Ledger/Shelley/Genesis.hs @@ -52,6 +52,7 @@ import Cardano.Ledger.BaseTypes ( EpochSize (..), Globals (..), Network, + NonZero (..), Nonce (..), PositiveUnitInterval, mkActiveSlotCoeff, @@ -211,7 +212,7 @@ data ShelleyGenesis = ShelleyGenesis , sgNetworkMagic :: !Word32 , sgNetworkId :: !Network , sgActiveSlotsCoeff :: !PositiveUnitInterval - , sgSecurityParam :: !Word64 + , sgSecurityParam :: !(NonZero Word64) , sgEpochLength :: !EpochSize , sgSlotsPerKESPeriod :: !Word64 , sgMaxKESEvolutions :: !Word64 @@ -634,14 +635,14 @@ validateGenesis let activeSlotsCoeff = unboundRational sgActiveSlotsCoeff minLength = EpochSize . ceiling $ - fromIntegral @_ @Double (3 * sgSecurityParam) + fromIntegral @_ @Double (3 * unNonZero sgSecurityParam) / fromRational activeSlotsCoeff in if minLength > sgEpochLength then Just $ EpochNotLongEnough sgEpochLength - sgSecurityParam + (unNonZero sgSecurityParam) activeSlotsCoeff minLength else Nothing @@ -680,6 +681,6 @@ mkShelleyGlobals genesis epochInfoAc = systemStart = SystemStart $ sgSystemStart genesis k = sgSecurityParam genesis stabilityWindow = - computeStabilityWindow k (sgActiveSlotCoeff genesis) + computeStabilityWindow (unNonZero k) (sgActiveSlotCoeff genesis) randomnessStabilisationWindow = - computeRandomnessStabilisationWindow k (sgActiveSlotCoeff genesis) + computeRandomnessStabilisationWindow (unNonZero k) (sgActiveSlotCoeff genesis) diff --git a/eras/shelley/impl/src/Cardano/Ledger/Shelley/LedgerState/PulsingReward.hs b/eras/shelley/impl/src/Cardano/Ledger/Shelley/LedgerState/PulsingReward.hs index 96798b8aa9e..4e1e27711d2 100644 --- a/eras/shelley/impl/src/Cardano/Ledger/Shelley/LedgerState/PulsingReward.hs +++ b/eras/shelley/impl/src/Cardano/Ledger/Shelley/LedgerState/PulsingReward.hs @@ -6,6 +6,7 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} module Cardano.Ledger.Shelley.LedgerState.PulsingReward ( startStep, @@ -24,8 +25,13 @@ import Cardano.Ledger.BaseTypes ( ActiveSlotCoeff, BlocksMade (..), BoundedRational (..), + NonZero, ShelleyBase, activeSlotVal, + knownNonZero, + mulNonZero, + toIntegerNonZero, + (%.), ) import Cardano.Ledger.CertState ( CertState (..), @@ -102,13 +108,12 @@ startStep :: EpochState era -> Coin -> ActiveSlotCoeff -> - Word64 -> + NonZero Word64 -> PulsingRewUpdate startStep slotsPerEpoch b@(BlocksMade b') es@(EpochState acnt ls ss nm) maxSupply asc secparam = let SnapShot stake delegs poolParams = ssStakeGo ss - numStakeCreds, k :: Rational numStakeCreds = fromIntegral (VMap.size $ unStake stake) - k = fromIntegral secparam + k = toIntegerNonZero secparam -- We expect approximately 10k-many blocks to be produced each epoch. -- The reward calculation begins (4k/f)-many slots into the epoch, -- and we guarantee that it ends (2k/f)-many slots before the end @@ -120,7 +125,7 @@ startStep slotsPerEpoch b@(BlocksMade b') es@(EpochState acnt ls ss nm) maxSuppl -- stake credential rewards we should calculate each block. -- If it does not finish in this amount of time, the calculation is -- forced to completion. - pulseSize = max 1 (ceiling (numStakeCreds / (4 * k))) + pulseSize = max 1 (ceiling (numStakeCreds %. (knownNonZero @4 `mulNonZero` k))) -- We now compute the amount of total rewards that can potentially be given -- out this epoch, and the adjustments to the reserves and the treasury. Coin reserves = asReserves acnt @@ -140,8 +145,11 @@ startStep slotsPerEpoch b@(BlocksMade b') es@(EpochState acnt ls ss nm) maxSuppl -- it would be nice to not have to compute expectedBlocks every epoch blocksMade = fromIntegral $ Map.foldr (+) 0 b' :: Integer eta - | unboundRational (pr ^. ppDG) >= 0.8 = 1 - | otherwise = blocksMade % expectedBlocks + | d >= 0.8 = 1 + | otherwise = + -- We use unsafe division here, because any sane configuration + -- should never have expectedBlocks anywhere close to zero + blocksMade % expectedBlocks Coin rPot = ssFee ss <> deltaR1 deltaT1 = floor $ unboundRational (pr ^. ppTauL) * fromIntegral rPot _R = Coin $ rPot - deltaT1 @@ -306,7 +314,7 @@ createRUpd :: EpochState era -> Coin -> ActiveSlotCoeff -> - Word64 -> + NonZero Word64 -> ShelleyBase RewardUpdate createRUpd slotsPerEpoch blocksmade epstate maxSupply asc secparam = do let step1 = startStep slotsPerEpoch blocksmade epstate maxSupply asc secparam diff --git a/eras/shelley/impl/src/Cardano/Ledger/Shelley/PoolRank.hs b/eras/shelley/impl/src/Cardano/Ledger/Shelley/PoolRank.hs index 29434123ac6..3ae7fc24a60 100644 --- a/eras/shelley/impl/src/Cardano/Ledger/Shelley/PoolRank.hs +++ b/eras/shelley/impl/src/Cardano/Ledger/Shelley/PoolRank.hs @@ -7,6 +7,7 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} module Cardano.Ledger.Shelley.PoolRank ( @@ -31,8 +32,14 @@ import Cardano.Ledger.BaseTypes ( ActiveSlotCoeff, BoundedRational (..), NonNegativeInterval, + NonZero (..), UnitInterval, activeSlotVal, + knownNonZero, + knownNonZeroBounded, + nonZeroOr, + toIntegerNonZero, + (%.), ) import Cardano.Ledger.Binary ( DecCBOR (decCBOR), @@ -266,26 +273,27 @@ toNonMyopicPair nm@(NonMyopic _ _) = -- corresponding to f^~ in section 5.6.1 of -- "Design Specification for Delegation and Incentives in Cardano" desirability :: - (NonNegativeInterval, Word16) -> + NonNegativeInterval -> + NonZero Word16 -> Coin -> PoolParams -> PerformanceEstimate -> Coin -> Double -desirability (a0, nOpt) r pool (PerformanceEstimate p) (Coin totalStake) = +desirability a0 nOpt r pool (PerformanceEstimate p) totalStake = if fTilde <= cost then 0 else (fTilde - cost) * (1 - margin) where + -- This division is safe, because 1 <= fTildeDenom <= 2 fTilde = fTildeNumer / fTildeDenom fTildeNumer = p * fromRational (coinToRational r * (z0 + min s z0 * unboundRational a0)) - fTildeDenom = fromRational $ 1 + unboundRational a0 + fTildeDenom = fromRational (1 + unboundRational a0) cost = (fromRational . coinToRational . ppCost) pool margin = (fromRational . unboundRational . ppMargin) pool - tot = max 1 (fromIntegral totalStake) Coin pledge = ppPledge pool - s = fromIntegral pledge % tot - z0 = 1 % max 1 (fromIntegral nOpt) + s = toInteger pledge % max 1 (unCoin totalStake) + z0 = 1 %. toIntegerNonZero nOpt -- | Computes the top ranked stake pools -- corresponding to section 5.6.1 of @@ -328,7 +336,13 @@ getTopRankedPoolsInternal rPot totalStake pp pdata = where rankings = [ ( hk - , desirability (pp ^. ppA0L, pp ^. ppNOptL) rPot pool ap totalStake + , desirability + (pp ^. ppA0L) + ((pp ^. ppNOptL) `nonZeroOr` knownNonZeroBounded @1) + rPot + pool + ap + totalStake ) | (hk, (pool, ap)) <- pdata ] @@ -350,7 +364,7 @@ nonMyopicStake :: Set (KeyHash 'StakePool) -> StakeShare nonMyopicStake pp (StakeShare s) (StakeShare sigma) (StakeShare t) kh topPools = - let z0 = 1 % max 1 (fromIntegral (pp ^. ppNOptL)) + let z0 = 1 %. (toInteger (pp ^. ppNOptL) `nonZeroOr` knownNonZero @1) in if kh `Set.member` topPools then StakeShare (max (sigma + t) z0) else StakeShare (s + t) diff --git a/eras/shelley/impl/src/Cardano/Ledger/Shelley/Rewards.hs b/eras/shelley/impl/src/Cardano/Ledger/Shelley/Rewards.hs index adb2ef59e88..508e0a59c1a 100644 --- a/eras/shelley/impl/src/Cardano/Ledger/Shelley/Rewards.hs +++ b/eras/shelley/impl/src/Cardano/Ledger/Shelley/Rewards.hs @@ -31,6 +31,8 @@ import Cardano.Ledger.BaseTypes ( BoundedRational (..), ProtVer, UnitInterval, + nonZeroOr, + (%?), ) import Cardano.Ledger.Binary ( DecCBOR (..), @@ -56,7 +58,6 @@ import Control.Monad (guard) import Data.Foldable (fold, foldMap') import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map -import Data.Ratio ((%)) import Data.Set (Set) import qualified Data.Set as Set import qualified Data.VMap as VMap @@ -275,7 +276,7 @@ rewardOnePoolMember :: Maybe Coin rewardOnePoolMember pp - (Coin totalStake) + totalStake addrsRew rewardInfo hk @@ -288,7 +289,8 @@ rewardOnePoolMember pool = poolPs rewardInfo sigma = poolRelativeStake rewardInfo poolR = poolPot rewardInfo - r = memberRew poolR pool (StakeShare (c % totalStake)) sigma + stakeShare = StakeShare $ c %? unCoin totalStake + r = memberRew poolR pool stakeShare sigma -- | Calculate single stake pool specific values for the reward computation. -- @@ -319,8 +321,8 @@ mkPoolRewardInfo stake delegs stakePerPool - (Coin totalStake) - (Coin activeStake) + totalStake + activeStake pool = case Map.lookup (ppId pool) (unBlocksMade blocks) of -- This pool made no blocks this epoch. For the purposes of stake pool -- ranking only, we return the relative stake of this pool so that we @@ -330,8 +332,8 @@ mkPoolRewardInfo -- intermediate values needed for the individual reward calculations. Just blocksN -> let Coin pledge = ppPledge pool - pledgeRelative = pledge % totalStake - sigmaA = if activeStake == 0 then 0 else pstakeTot % activeStake + pledgeRelative = pledge %? unCoin totalStake + sigmaA = pstakeTot %? unCoin activeStake Coin maxP = if pledge <= ostake then maxPool' pp_a0 pp_nOpt r sigma pledgeRelative @@ -342,7 +344,7 @@ mkPoolRewardInfo leaderRew poolR pool - (StakeShare $ if totalStake == 0 then 0 else ostake % totalStake) + (StakeShare $ ostake %? unCoin totalStake) (StakeShare sigma) rewardInfo = PoolRewardInfo @@ -356,11 +358,11 @@ mkPoolRewardInfo where pp_d = pp ^. ppDG pp_a0 = pp ^. ppA0L - pp_nOpt = pp ^. ppNOptL + pp_nOpt = (pp ^. ppNOptL) `nonZeroOr` error "nOpt is zero" Coin pstakeTot = Map.findWithDefault mempty (ppId pool) stakePerPool accOwnerStake c o = maybe c (c <>) $ do hk <- VMap.lookup (KeyHashObj o) delegs guard (hk == ppId pool) fromCompact <$> VMap.lookup (KeyHashObj o) (unStake stake) Coin ostake = Set.foldl' accOwnerStake mempty (ppOwners pool) - sigma = if totalStake == 0 then 0 else fromIntegral pstakeTot % fromIntegral totalStake + sigma = fromIntegral pstakeTot %? unCoin totalStake diff --git a/eras/shelley/impl/src/Cardano/Ledger/Shelley/StabilityWindow.hs b/eras/shelley/impl/src/Cardano/Ledger/Shelley/StabilityWindow.hs index e5cee15cec5..f7dd80de4c5 100644 --- a/eras/shelley/impl/src/Cardano/Ledger/Shelley/StabilityWindow.hs +++ b/eras/shelley/impl/src/Cardano/Ledger/Shelley/StabilityWindow.hs @@ -17,9 +17,9 @@ computeStabilityWindow :: ActiveSlotCoeff -> Word64 computeStabilityWindow k asc = - ceiling $ (3 * fromIntegral k) / f + ceiling $ (3 * fromIntegral k) /. f where - f = unboundRational . activeSlotVal $ asc + f = positiveUnitIntervalNonZeroRational . activeSlotVal $ asc -- | Calculate the randomness stabilisation window from the security param and -- the active slot coefficient. @@ -31,6 +31,6 @@ computeRandomnessStabilisationWindow :: ActiveSlotCoeff -> Word64 computeRandomnessStabilisationWindow k asc = - ceiling $ (4 * fromIntegral k) / f + ceiling $ (4 * fromIntegral k) /. f where - f = unboundRational . activeSlotVal $ asc + f = positiveUnitIntervalNonZeroRational . activeSlotVal $ asc diff --git a/eras/shelley/impl/testlib/Test/Cardano/Ledger/Shelley/ImpTest.hs b/eras/shelley/impl/testlib/Test/Cardano/Ledger/Shelley/ImpTest.hs index 5dc01d04b3c..4451f84b6cf 100644 --- a/eras/shelley/impl/testlib/Test/Cardano/Ledger/Shelley/ImpTest.hs +++ b/eras/shelley/impl/testlib/Test/Cardano/Ledger/Shelley/ImpTest.hs @@ -694,7 +694,7 @@ instance , sgNetworkMagic = 123456 -- Mainnet value: 764824073 , sgNetworkId = Testnet , sgActiveSlotsCoeff = 20 %! 100 -- Mainnet value: 5 %! 100 - , sgSecurityParam = 108 -- Mainnet value: 2160 + , sgSecurityParam = knownNonZeroBounded @108 -- Mainnet value: 2160 , sgEpochLength = 4320 -- Mainnet value: 432000 , sgSlotsPerKESPeriod = 129600 , sgMaxKESEvolutions = 62 diff --git a/eras/shelley/test-suite/src/Test/Cardano/Ledger/Shelley/Examples/Consensus.hs b/eras/shelley/test-suite/src/Test/Cardano/Ledger/Shelley/Examples/Consensus.hs index 08933064bcf..b4f97f87089 100644 --- a/eras/shelley/test-suite/src/Test/Cardano/Ledger/Shelley/Examples/Consensus.hs +++ b/eras/shelley/test-suite/src/Test/Cardano/Ledger/Shelley/Examples/Consensus.hs @@ -353,7 +353,7 @@ exampleNewEpochState value ppp pp = epochState (Coin 1000) (activeSlotCoeff testGlobals) - 10 + (knownNonZeroBounded @10) exampleLedgerChainDepState :: Word64 -> ChainDepState exampleLedgerChainDepState seed = diff --git a/eras/shelley/test-suite/src/Test/Cardano/Ledger/Shelley/Generator/Update.hs b/eras/shelley/test-suite/src/Test/Cardano/Ledger/Shelley/Generator/Update.hs index 98be2d7e8db..06688411257 100644 --- a/eras/shelley/test-suite/src/Test/Cardano/Ledger/Shelley/Generator/Update.hs +++ b/eras/shelley/test-suite/src/Test/Cardano/Ledger/Shelley/Generator/Update.hs @@ -24,6 +24,7 @@ import Cardano.Ledger.BaseTypes ( BoundedRational, EpochInterval (..), NonNegativeInterval, + NonZero, Nonce (NeutralNonce), ProtVer (..), StrictMaybe (..), @@ -34,6 +35,7 @@ import Cardano.Ledger.BaseTypes ( mkVersion, mkVersion64, succVersion, + unsafeNonZero, ) import Cardano.Ledger.Coin (Coin (..)) import Cardano.Ledger.Core diff --git a/eras/shelley/test-suite/src/Test/Cardano/Ledger/Shelley/Rewards.hs b/eras/shelley/test-suite/src/Test/Cardano/Ledger/Shelley/Rewards.hs index 50e3bb3e0c7..a7e62b28318 100644 --- a/eras/shelley/test-suite/src/Test/Cardano/Ledger/Shelley/Rewards.hs +++ b/eras/shelley/test-suite/src/Test/Cardano/Ledger/Shelley/Rewards.hs @@ -44,9 +44,15 @@ import Cardano.Ledger.BaseTypes ( activeSlotVal, epochInfoPure, mkActiveSlotCoeff, + (%?), ) import Cardano.Ledger.Binary (encCBOR, hashWithEncoder, natVersion, shelleyProtVer) -import Cardano.Ledger.Coin (Coin (..), DeltaCoin (..), rationalToCoinViaFloor, toDeltaCoin) +import Cardano.Ledger.Coin ( + Coin (..), + DeltaCoin (..), + rationalToCoinViaFloor, + toDeltaCoin, + ) import Cardano.Ledger.Compactible import Cardano.Ledger.Credential (Credential (..)) import Cardano.Ledger.EpochBoundary ( @@ -485,8 +491,8 @@ rewardOld ] results = do (hk, pparams) <- VMap.toAscList poolParams - let sigma = if totalStake == 0 then 0 else fromIntegral pstake % fromIntegral totalStake - sigmaA = if activeStake == 0 then 0 else fromIntegral pstake % fromIntegral activeStake + let sigma = fromIntegral pstake %? fromIntegral totalStake + sigmaA = fromIntegral pstake %? fromIntegral activeStake blocksProduced = Map.lookup hk b actgr = poolStake hk delegs stake Coin pstake = sumAllStake actgr diff --git a/eras/shelley/test-suite/test/Test/Cardano/Ledger/Shelley/Serialisation/Golden/Genesis.hs b/eras/shelley/test-suite/test/Test/Cardano/Ledger/Shelley/Serialisation/Golden/Genesis.hs index 5fa4f2fd32d..3df8a221cdb 100644 --- a/eras/shelley/test-suite/test/Test/Cardano/Ledger/Shelley/Serialisation/Golden/Genesis.hs +++ b/eras/shelley/test-suite/test/Test/Cardano/Ledger/Shelley/Serialisation/Golden/Genesis.hs @@ -14,7 +14,7 @@ module Test.Cardano.Ledger.Shelley.Serialisation.Golden.Genesis ( ) where -import Cardano.Ledger.BaseTypes (textToDns, textToUrl) +import Cardano.Ledger.BaseTypes (knownNonZeroBounded, textToDns, textToUrl) import Cardano.Ledger.Binary (Tokens (..)) import qualified Cardano.Ledger.Binary.Plain as Plain import Cardano.Ledger.Core (emptyPParams, ppDL, ppMaxBBSizeL, ppMaxBHSizeL) @@ -195,7 +195,7 @@ exampleShelleyGenesis = , sgNetworkMagic = 4036000900 , sgNetworkId = L.Testnet , sgActiveSlotsCoeff = unsafeBoundRational 0.259 - , sgSecurityParam = 120842 + , sgSecurityParam = knownNonZeroBounded @120842 , sgEpochLength = EpochSize 1215 , sgSlotsPerKESPeriod = 8541 , sgMaxKESEvolutions = 28899 diff --git a/libs/cardano-ledger-conformance/src/Test/Cardano/Ledger/Conformance/SpecTranslate/Conway/Base.hs b/libs/cardano-ledger-conformance/src/Test/Cardano/Ledger/Conformance/SpecTranslate/Conway/Base.hs index 410b1862c25..72cb1d705f2 100644 --- a/libs/cardano-ledger-conformance/src/Test/Cardano/Ledger/Conformance/SpecTranslate/Conway/Base.hs +++ b/libs/cardano-ledger-conformance/src/Test/Cardano/Ledger/Conformance/SpecTranslate/Conway/Base.hs @@ -833,7 +833,7 @@ instance SpecTranslate ctx (ConwayPParams StrictMaybe era) where ppuKeyDeposit <- toSpecRep cppKeyDeposit ppuPoolDeposit <- toSpecRep cppPoolDeposit ppuEmax <- toSpecRep cppEMax - ppuNopt <- toSpecRep (fmap toInteger . strictMaybeToMaybe . unTHKD $ cppNOpt) + ppuNopt <- toSpecRep (fmap toInteger . strictMaybeToMaybe $ unTHKD cppNOpt) let ppuPv = Nothing ppuMinUTxOValue = Nothing -- minUTxOValue has been deprecated and is not supported in Conway diff --git a/libs/cardano-ledger-core/CHANGELOG.md b/libs/cardano-ledger-core/CHANGELOG.md index cae6e98e0f0..801869e0c4f 100644 --- a/libs/cardano-ledger-core/CHANGELOG.md +++ b/libs/cardano-ledger-core/CHANGELOG.md @@ -2,6 +2,15 @@ ## 1.17.0.0 +* Added `ToPlutusData` instance for `NonZero` +* `maxpool'` now expects `nOpt` to be a `NonZero Word16` +* Add `HasZero` instance for `Coin` together with lifted conversion functions: + * `toCompactCoinNonZero` + * `fromCompactCoinNonZero` + * `unCoinNonZero` + * `toCoinNonZero` + * `compactCoinNonZero` +* Add `Cardano.Ledger.BaseTypes.NonZero` * Remove `era` type parameter from `MemoBytes` type * Remove `Era era` constraint from: * `Memo` pattern @@ -83,6 +92,7 @@ ### `testlib` +* Added `Arbitrary` and `ToExpr` instances for `NonZero` * Deprecate `genBadPtr`, `genAddrBadPtr` and `genCompactAddrBadPtr` * Remove crypto parametrization from types: `KeyPair` and `KeyPairs` diff --git a/libs/cardano-ledger-core/cardano-ledger-core.cabal b/libs/cardano-ledger-core/cardano-ledger-core.cabal index 4af07250ca9..409051d5200 100644 --- a/libs/cardano-ledger-core/cardano-ledger-core.cabal +++ b/libs/cardano-ledger-core/cardano-ledger-core.cabal @@ -30,6 +30,7 @@ library Cardano.Ledger.AuxiliaryData Cardano.Ledger.BHeaderView Cardano.Ledger.BaseTypes + Cardano.Ledger.BaseTypes.NonZero Cardano.Ledger.Block Cardano.Ledger.CertState Cardano.Ledger.Coin diff --git a/libs/cardano-ledger-core/src/Cardano/Ledger/BaseTypes.hs b/libs/cardano-ledger-core/src/Cardano/Ledger/BaseTypes.hs index 65d0ffdfc0a..13a92ab8a3a 100644 --- a/libs/cardano-ledger-core/src/Cardano/Ledger/BaseTypes.hs +++ b/libs/cardano-ledger-core/src/Cardano/Ledger/BaseTypes.hs @@ -20,6 +20,7 @@ module Cardano.Ledger.BaseTypes ( module Slotting, + module NonZero, ProtVer (..), module Cardano.Ledger.Binary.Version, FixedPoint, @@ -82,12 +83,14 @@ module Cardano.Ledger.BaseTypes ( -- * Injection Inject (..), + positiveUnitIntervalNonZeroRational, ) where import Cardano.Crypto.Hash import Cardano.Crypto.Util (SignableRepresentation (..)) import qualified Cardano.Crypto.VRF as VRF +import Cardano.Ledger.BaseTypes.NonZero as NonZero import Cardano.Ledger.Binary ( CBORGroup (..), DecCBOR (decCBOR), @@ -678,7 +681,7 @@ data Globals = Globals , randomnessStabilisationWindow :: !Word64 -- ^ Number of slots before the end of the epoch at which we stop updating -- the candidate nonce for the next epoch. - , securityParameter :: !Word64 + , securityParameter :: !(NonZero Word64) -- ^ Maximum number of blocks we are allowed to roll back , maxKESEvo :: !Word64 -- ^ Maximum number of KES iterations @@ -927,3 +930,6 @@ instance Inject a a where -- | Helper function for a common pattern of creating objects kindObject :: Text -> [Pair] -> Value kindObject name obj = object $ ("kind" .= name) : obj + +positiveUnitIntervalNonZeroRational :: PositiveUnitInterval -> NonZero Rational +positiveUnitIntervalNonZeroRational = unsafeNonZero . unboundRational diff --git a/libs/cardano-ledger-core/src/Cardano/Ledger/BaseTypes/NonZero.hs b/libs/cardano-ledger-core/src/Cardano/Ledger/BaseTypes/NonZero.hs new file mode 100644 index 00000000000..c55b43a42e0 --- /dev/null +++ b/libs/cardano-ledger-core/src/Cardano/Ledger/BaseTypes/NonZero.hs @@ -0,0 +1,173 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# OPTIONS_GHC -Wno-redundant-constraints #-} + +module Cardano.Ledger.BaseTypes.NonZero ( + KnownBounds (..), + HasZero (..), + WithinBounds, + NonZero, + unNonZero, + nonZero, + knownNonZero, + knownNonZeroBounded, + (%.), + bindNonZero, + mapNonZero, + unsafeNonZero, + toIntegerNonZero, + (/.), + nonZeroOr, + recipNonZero, + negateNonZero, + mulNonZero, + mulNonZeroNat, + toRatioNonZero, + (%?), +) where + +import Cardano.Ledger.Binary (DecCBOR (..), EncCBOR) +import Control.DeepSeq (NFData) +import Data.Aeson (FromJSON (..), ToJSON) +import Data.Maybe (fromMaybe) +import Data.Proxy (Proxy (..)) +import Data.Ratio (Ratio, numerator, (%)) +import Data.Typeable (Typeable) +import Data.Word (Word16, Word32, Word64, Word8) +import GHC.TypeLits +import NoThunks.Class (NoThunks) +#if __GLASGOW_HASKELL__ < 900 +import Numeric.Natural (Natural) +#endif + +class KnownBounds a where + type MinBound a :: Nat + type MaxBound a :: Nat + +instance KnownBounds Word8 where + type MinBound Word8 = 0 + type MaxBound Word8 = 0xFF + +instance KnownBounds Word16 where + type MinBound Word16 = 0 + type MaxBound Word16 = 0xFFFF + +instance KnownBounds Word32 where + type MinBound Word32 = 0 + type MaxBound Word32 = 0xFFFFFFFF + +instance KnownBounds Word64 where + type MinBound Word64 = 0 + type MaxBound Word64 = 0xFFFFFFFFFFFFFFFF + +type WithinBounds n a = (MinBound a <= n, n <= MaxBound a) + +newtype NonZero a = NonZero {unNonZero :: a} + deriving (Eq, Ord, Show, NoThunks, NFData) + deriving newtype (EncCBOR, ToJSON) + +class HasZero a where + isZero :: a -> Bool + default isZero :: (Eq a, Num a) => a -> Bool + isZero = (== 0) + +instance HasZero Word8 + +instance HasZero Word16 + +instance HasZero Word32 + +instance HasZero Word64 + +instance HasZero Integer + +instance HasZero Int + +instance HasZero Natural + +instance HasZero a => HasZero (Ratio a) where + isZero = isZero . numerator + +instance (Typeable a, DecCBOR a, HasZero a) => DecCBOR (NonZero a) where + decCBOR = decCBOR >>= nonZeroM + +instance (FromJSON a, HasZero a) => FromJSON (NonZero a) where + parseJSON v = parseJSON v >>= nonZeroM + +knownNonZero :: + forall (n :: Nat). + (KnownNat n, 1 <= n) => + NonZero Integer +knownNonZero = NonZero (natVal $ Proxy @n) + +knownNonZeroBounded :: + forall (n :: Nat) a. + (KnownNat n, 1 <= n, WithinBounds n a, Num a) => + NonZero a +knownNonZeroBounded = NonZero (fromInteger . natVal $ Proxy @n) + +nonZero :: HasZero a => a -> Maybe (NonZero a) +nonZero = nonZeroM + +nonZeroM :: (HasZero a, MonadFail m) => a -> m (NonZero a) +nonZeroM x + | isZero x = fail "Encountered zero while trying to construct a NonZero value" + | otherwise = pure $ NonZero x + +nonZeroOr :: HasZero a => a -> NonZero a -> NonZero a +nonZeroOr x d = fromMaybe d $ nonZero x + +mapNonZero :: (Eq b, HasZero b) => (a -> b) -> NonZero a -> Maybe (NonZero b) +mapNonZero f (NonZero x) = nonZero $ f x + +bindNonZero :: (a -> NonZero b) -> NonZero a -> NonZero b +bindNonZero f (NonZero x) = f x + +unsafeNonZero :: a -> NonZero a +unsafeNonZero = NonZero + +infixl 7 %. +(%.) :: Integral a => a -> NonZero a -> Ratio a +x %. y = x % unNonZero y + +infixl 7 %? +(%?) :: Integral a => a -> a -> Ratio a +x %? y + | y == 0 = 0 + | otherwise = x % y + +toIntegerNonZero :: Integral a => NonZero a -> NonZero Integer +toIntegerNonZero (NonZero x) = NonZero $ toInteger x + +infixl 7 /. +(/.) :: Fractional a => a -> NonZero a -> a +x /. y = x / unNonZero y + +-- Common safe functions + +toRatioNonZero :: Integral a => NonZero a -> NonZero (Ratio a) +toRatioNonZero (NonZero x) = NonZero $ x % 1 + +recipNonZero :: Integral a => NonZero (Ratio a) -> NonZero (Ratio a) +recipNonZero (NonZero x) = NonZero $ recip x + +negateNonZero :: NonZero Integer -> NonZero Integer +negateNonZero (NonZero x) = NonZero $ negate x + +mulNonZero :: (Integral a, Integral b) => NonZero a -> NonZero b -> NonZero Integer +mulNonZero (NonZero x) (NonZero y) = NonZero $ toInteger x * toInteger y + +mulNonZeroNat :: forall n a. (KnownNat n, 1 <= n, Integral a) => NonZero a -> NonZero Integer +mulNonZeroNat (NonZero x) = NonZero (toInteger x * natVal (Proxy @n)) diff --git a/libs/cardano-ledger-core/src/Cardano/Ledger/Coin.hs b/libs/cardano-ledger-core/src/Cardano/Ledger/Coin.hs index ea33cdae2b4..1755887a470 100644 --- a/libs/cardano-ledger-core/src/Cardano/Ledger/Coin.hs +++ b/libs/cardano-ledger-core/src/Cardano/Ledger/Coin.hs @@ -24,11 +24,23 @@ module Cardano.Ledger.Coin ( integerToWord64, decodePositiveCoin, compactCoinOrError, + -- NonZero helpers + toCompactCoinNonZero, + unCoinNonZero, + toCoinNonZero, + fromCompactCoinNonZero, + compactCoinNonZero, ) where import Cardano.HeapWords (HeapWords) -import Cardano.Ledger.BaseTypes (Inject (..)) +import Cardano.Ledger.BaseTypes ( + HasZero (..), + Inject (..), + NonZero, + unNonZero, + unsafeNonZero, + ) import Cardano.Ledger.Binary ( DecCBOR (..), Decoder, @@ -190,3 +202,21 @@ instance UniformRange Coin where instance UniformRange (CompactForm Coin) where uniformRM (CompactCoin l, CompactCoin h) g = CompactCoin <$> uniformRM (l, h) g + +instance HasZero Coin where + isZero = (== Coin 0) + +toCompactCoinNonZero :: NonZero Coin -> Maybe (NonZero (CompactForm Coin)) +toCompactCoinNonZero = fmap unsafeNonZero . toCompact . unNonZero + +fromCompactCoinNonZero :: NonZero (CompactForm Coin) -> NonZero Coin +fromCompactCoinNonZero = unsafeNonZero . fromCompact . unNonZero + +unCoinNonZero :: NonZero Coin -> NonZero Integer +unCoinNonZero = unsafeNonZero . unCoin . unNonZero + +toCoinNonZero :: Integral a => NonZero a -> NonZero Coin +toCoinNonZero = unsafeNonZero . Coin . toInteger . unNonZero + +compactCoinNonZero :: NonZero Word64 -> NonZero (CompactForm Coin) +compactCoinNonZero = unsafeNonZero . CompactCoin . unNonZero diff --git a/libs/cardano-ledger-core/src/Cardano/Ledger/EpochBoundary.hs b/libs/cardano-ledger-core/src/Cardano/Ledger/EpochBoundary.hs index 5c88d10f180..18c9fb20add 100644 --- a/libs/cardano-ledger-core/src/Cardano/Ledger/EpochBoundary.hs +++ b/libs/cardano-ledger-core/src/Cardano/Ledger/EpochBoundary.hs @@ -10,7 +10,7 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} @@ -46,7 +46,18 @@ module Cardano.Ledger.EpochBoundary ( ) where -import Cardano.Ledger.BaseTypes (BoundedRational (..), NonNegativeInterval) +import Cardano.Ledger.BaseTypes ( + BoundedRational (..), + NonNegativeInterval, + NonZero (..), + knownNonZeroBounded, + nonZeroOr, + recipNonZero, + toIntegerNonZero, + toRatioNonZero, + (%.), + (/.), + ) import Cardano.Ledger.Binary ( DecCBOR (decCBOR), DecShareCBOR (..), @@ -62,7 +73,10 @@ import Cardano.Ledger.Coin ( Coin (..), CompactForm (..), coinToRational, + compactCoinNonZero, + fromCompactCoinNonZero, rationalToCoinViaFloor, + unCoinNonZero, ) import Cardano.Ledger.Compactible import Cardano.Ledger.Core @@ -76,7 +90,6 @@ import Data.Aeson (KeyValue, ToJSON (..), object, pairs, (.=)) import Data.Default (Default, def) import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map -import Data.Ratio ((%)) import Data.VMap as VMap import Data.Word (Word16) import GHC.Generics (Generic) @@ -127,20 +140,24 @@ sumStakePerPool delegs (Stake stake) = VMap.foldlWithKey accum Map.empty stake -- | Calculate maximal pool reward maxPool' :: NonNegativeInterval -> - Word16 -> + NonZero Word16 -> Coin -> Rational -> Rational -> Coin maxPool' a0 nOpt r sigma pR = rationalToCoinViaFloor $ factor1 * factor2 where - z0 = 1 % fromIntegral nOpt + nonZeroZ0 = recipNonZero . toRatioNonZero $ toIntegerNonZero nOpt + z0 = unNonZero nonZeroZ0 sigma' = min sigma z0 p' = min pR z0 - factor1 = coinToRational r / (1 + unboundRational a0) + factor1 = + -- This division is safe, because a0 is non-negative and we're adding one + -- to it + coinToRational r / (1 + unboundRational a0) factor2 = sigma' + p' * unboundRational a0 * factor3 - factor3 = (sigma' - p' * factor4) / z0 - factor4 = (z0 - sigma') / z0 + factor3 = (sigma' - p' * factor4) /. nonZeroZ0 + factor4 = (z0 - sigma') /. nonZeroZ0 -- | Version of `maxPool'` that extracts `ppA0L` and `ppNOptL` from a `PParams` maxPool :: @@ -153,7 +170,7 @@ maxPool :: maxPool pp r sigma pR = maxPool' a0 nOpt r sigma pR where a0 = pp ^. ppA0L - nOpt = pp ^. ppNOptL + nOpt = (pp ^. ppNOptL) `nonZeroOr` knownNonZeroBounded @1 -- | Snapshot of the stake distribution. data SnapShot = SnapShot @@ -281,23 +298,23 @@ calculatePoolDistr = calculatePoolDistr' (const True) calculatePoolDistr' :: (KeyHash 'StakePool -> Bool) -> SnapShot -> PoolDistr calculatePoolDistr' includeHash (SnapShot stake delegs poolParams) = - let total = sumAllStakeCompact stake + let CompactCoin total = sumAllStakeCompact stake -- total could be zero (in particular when shrinking) - nonZeroTotalCompact = if total == mempty then CompactCoin 1 else total - nonZeroTotalInteger = unCoin $ fromCompact nonZeroTotalCompact + nonZeroTotalCompact = compactCoinNonZero $ total `nonZeroOr` knownNonZeroBounded @1 + nonZeroTotalInteger = unCoinNonZero $ fromCompactCoinNonZero nonZeroTotalCompact poolStakeMap = calculatePoolStake includeHash delegs stake in PoolDistr ( Map.intersectionWith ( \word64 poolparam -> IndividualPoolStake - (toInteger word64 % nonZeroTotalInteger) + (toInteger word64 %. nonZeroTotalInteger) (CompactCoin word64) (ppVrf poolparam) ) poolStakeMap (VMap.toMap poolParams) ) - nonZeroTotalCompact + (unNonZero nonZeroTotalCompact) -- ====================================================== -- Lenses diff --git a/libs/cardano-ledger-core/src/Cardano/Ledger/Plutus/ToPlutusData.hs b/libs/cardano-ledger-core/src/Cardano/Ledger/Plutus/ToPlutusData.hs index 943f13212f9..61e60880009 100644 --- a/libs/cardano-ledger-core/src/Cardano/Ledger/Plutus/ToPlutusData.hs +++ b/libs/cardano-ledger-core/src/Cardano/Ledger/Plutus/ToPlutusData.hs @@ -9,9 +9,13 @@ module Cardano.Ledger.Plutus.ToPlutusData where import Cardano.Ledger.BaseTypes ( BoundedRational (boundRational, unboundRational), EpochInterval (..), + HasZero, NonNegativeInterval, + NonZero (..), ProtVer (..), UnitInterval, + nonZero, + (%.), ) import Cardano.Ledger.Binary.Version (Version, getVersion, mkVersion) import Cardano.Ledger.Coin (Coin (..)) @@ -23,7 +27,6 @@ import Cardano.Ledger.Plutus.CostModels ( import Cardano.Ledger.Plutus.ExUnits (ExUnits (..), Prices (..)) import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map -import Data.Ratio ((%)) import Data.Word import GHC.Real (Ratio ((:%))) import Numeric.Natural (Natural) @@ -67,14 +70,14 @@ instance ToPlutusData UnitInterval where toPlutusData x = List [I num, I denom] where (num :% denom) = unboundRational x - fromPlutusData (List [I num, I denom]) = boundRational (num % denom) + fromPlutusData (List [I num, I denom]) = boundRational . (num %.) =<< nonZero denom fromPlutusData _ = Nothing instance ToPlutusData NonNegativeInterval where toPlutusData x = List [I num, I denom] where (num :% denom) = unboundRational x - fromPlutusData (List [I num, I denom]) = boundRational (num % denom) + fromPlutusData (List [I num, I denom]) = boundRational . (num %.) =<< nonZero denom fromPlutusData _ = Nothing instance ToPlutusData CostModels where @@ -128,3 +131,7 @@ instance ToPlutusData Word where toPlutusData w = I (toInteger @Word w) fromPlutusData (I n) | n >= 0 && n <= toInteger (maxBound @Word) = Just $ fromInteger @Word n fromPlutusData _ = Nothing + +instance (ToPlutusData a, HasZero a) => ToPlutusData (NonZero a) where + toPlutusData = toPlutusData . unNonZero + fromPlutusData x = nonZero =<< fromPlutusData x diff --git a/libs/cardano-ledger-core/testlib/Test/Cardano/Ledger/Core/Arbitrary.hs b/libs/cardano-ledger-core/testlib/Test/Cardano/Ledger/Core/Arbitrary.hs index 2e320a3ca3c..0da03786fc3 100644 --- a/libs/cardano-ledger-core/testlib/Test/Cardano/Ledger/Core/Arbitrary.hs +++ b/libs/cardano-ledger-core/testlib/Test/Cardano/Ledger/Core/Arbitrary.hs @@ -54,6 +54,7 @@ import Cardano.Ledger.BaseTypes ( CertIx (..), DnsName, EpochInterval (..), + HasZero, Mismatch (..), Network (..), NonNegativeInterval, @@ -73,6 +74,7 @@ import Cardano.Ledger.BaseTypes ( textToDns, textToUrl, ) +import qualified Cardano.Ledger.BaseTypes as NZ import Cardano.Ledger.Binary (EncCBOR, Sized, mkSized) import Cardano.Ledger.CertState ( Anchor (..), @@ -548,6 +550,9 @@ instance Arbitrary DRep where , pure DRepAlwaysNoConfidence ] +instance (Arbitrary a, HasZero a) => Arbitrary (NZ.NonZero a) where + arbitrary = arbitrary `suchThatMap` NZ.nonZero + -- | Used for testing UMap operations genValidTuples :: Gen diff --git a/libs/cardano-ledger-core/testlib/Test/Cardano/Ledger/Core/Utils.hs b/libs/cardano-ledger-core/testlib/Test/Cardano/Ledger/Core/Utils.hs index b57bd0794dd..fabbc8c289b 100644 --- a/libs/cardano-ledger-core/testlib/Test/Cardano/Ledger/Core/Utils.hs +++ b/libs/cardano-ledger-core/testlib/Test/Cardano/Ledger/Core/Utils.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE DataKinds #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} @@ -13,6 +14,7 @@ import Cardano.Ledger.BaseTypes ( EpochSize (..), Globals (..), Network (..), + knownNonZeroBounded, mkActiveSlotCoeff, ) import Cardano.Ledger.Core @@ -32,7 +34,7 @@ testGlobals = , slotsPerKESPeriod = 20 , stabilityWindow = 33 , randomnessStabilisationWindow = 33 - , securityParameter = 10 + , securityParameter = knownNonZeroBounded @10 , maxKESEvo = 10 , quorum = 5 , maxLovelaceSupply = 45 * 1000 * 1000 * 1000 * 1000 * 1000 diff --git a/libs/cardano-ledger-core/testlib/Test/Cardano/Ledger/TreeDiff.hs b/libs/cardano-ledger-core/testlib/Test/Cardano/Ledger/TreeDiff.hs index a2cfc9146d6..b7c6b45b93a 100644 --- a/libs/cardano-ledger-core/testlib/Test/Cardano/Ledger/TreeDiff.hs +++ b/libs/cardano-ledger-core/testlib/Test/Cardano/Ledger/TreeDiff.hs @@ -256,3 +256,6 @@ deriving instance (Era era, ToExpr (Script era)) => ToExpr (ScriptsProvided era) instance ToExpr (TxOut era) => ToExpr (UTxO era) instance ToExpr TxOutSource + +instance ToExpr a => ToExpr (NonZero a) where + toExpr x = App "NonZero" [toExpr $ unNonZero x] diff --git a/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Constrained/Conway/Instances/Basic.hs b/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Constrained/Conway/Instances/Basic.hs index 60276d02319..99b7d30c156 100644 --- a/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Constrained/Conway/Instances/Basic.hs +++ b/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Constrained/Conway/Instances/Basic.hs @@ -66,7 +66,7 @@ import Test.Cardano.Ledger.Allegra.Arbitrary () import Test.Cardano.Ledger.Alonzo.Arbitrary () import Test.Cardano.Ledger.Generic.PrettyCore (PrettyA (..)) import Test.Cardano.Ledger.Generic.Proof (Reflect (..)) -import Test.QuickCheck hiding (Args, Fun, forAll) +import Test.QuickCheck hiding (Args, Fun, NonZero, forAll) -- ============================================================================ -- Making Intervals based on Ratios, These can fail, so be careful using them. diff --git a/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Constrained/Conway/Instances/Ledger.hs b/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Constrained/Conway/Instances/Ledger.hs index adaa8e261b9..570d6bb8382 100644 --- a/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Constrained/Conway/Instances/Ledger.hs +++ b/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Constrained/Conway/Instances/Ledger.hs @@ -174,7 +174,7 @@ import Test.Cardano.Ledger.Core.Utils import Test.Cardano.Ledger.Shelley.Utils import Test.Cardano.Ledger.TreeDiff (ToExpr) import Test.Cardano.Slotting.Numeric () -import Test.QuickCheck hiding (Args, Fun, forAll) +import Test.QuickCheck hiding (Args, Fun, NonZero, forAll) -- ========================================================== diff --git a/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Constrained/Vars.hs b/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Constrained/Vars.hs index 4256735ae6e..49ddc405287 100644 --- a/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Constrained/Vars.hs +++ b/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Constrained/Vars.hs @@ -25,6 +25,10 @@ import Cardano.Ledger.BaseTypes ( SlotNo (..), StrictMaybe (..), UnitInterval, + knownNonZero, + mulNonZero, + toIntegerNonZero, + (%.), ) import qualified Cardano.Ledger.BaseTypes as Base (EpochInterval (..), Globals (..)) import Cardano.Ledger.CertState ( @@ -109,7 +113,6 @@ import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map import Data.Maybe.Strict (maybeToStrictMaybe, strictMaybeToMaybe) import qualified Data.OMap.Strict as OMap -import Data.Ratio ((%)) import qualified Data.Sequence.Strict as SS import Data.Set (Set) import qualified Data.VMap as VMap @@ -1847,7 +1850,7 @@ initPulser proof utx credDRepMap poold credDRepStateMap epoch commstate enactsta pp = def & ppProtocolVersionL .~ protocolVersion proof IStake stakeDistr _ = updateStakeDistribution pp mempty mempty (utx ^. utxoFL proof) in DRepPulser - (max 1 (ceiling (toInteger umapSize % (8 * toInteger k)))) + (max 1 (ceiling (toInteger umapSize %. (knownNonZero @8 `mulNonZero` toIntegerNonZero k)))) umap 0 stakeDistr diff --git a/libs/cardano-protocol-tpraos/src/Cardano/Protocol/TPraos/BHeader.hs b/libs/cardano-protocol-tpraos/src/Cardano/Protocol/TPraos/BHeader.hs index faf5f80f1bd..c344d51d2fe 100644 --- a/libs/cardano-protocol-tpraos/src/Cardano/Protocol/TPraos/BHeader.hs +++ b/libs/cardano-protocol-tpraos/src/Cardano/Protocol/TPraos/BHeader.hs @@ -10,6 +10,7 @@ {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeApplications #-} module Cardano.Protocol.TPraos.BHeader ( HashHeader (..), @@ -53,6 +54,7 @@ import Cardano.Ledger.BaseTypes ( mkNonceFromNumber, mkNonceFromOutputVRF, ) +import Cardano.Ledger.BaseTypes.NonZero (nonZero, (%.)) import Cardano.Ledger.Binary ( Annotator (..), Case (..), @@ -98,7 +100,6 @@ import qualified Data.ByteString as BS import qualified Data.ByteString.Builder as BS import qualified Data.ByteString.Builder.Extra as BS import qualified Data.ByteString.Lazy as BSL -import Data.Ratio ((%)) import Data.Typeable import Data.Word (Word32, Word64) import GHC.Generics (Generic) @@ -409,7 +410,10 @@ checkLeaderNatValue bn σ f = where c, recip_q, x :: FixedPoint c = activeSlotLog f - recip_q = fromRational (toInteger certNatMax % toInteger (certNatMax - certNat)) + recip_q = + case nonZero . toInteger $ certNatMax - certNat of + Just d -> fromRational (toInteger certNatMax %. d) + Nothing -> fromIntegral @Natural @FixedPoint certNatMax x = -fromRational σ * c certNatMax = bvMaxValue bn certNat = bvValue bn diff --git a/libs/constrained-generators/src/Constrained/Base.hs b/libs/constrained-generators/src/Constrained/Base.hs index c62f5db5743..07efb94d0bb 100644 --- a/libs/constrained-generators/src/Constrained/Base.hs +++ b/libs/constrained-generators/src/Constrained/Base.hs @@ -5104,7 +5104,7 @@ instance BaseUniverse fn => Functions (IntFn fn) fn where | HOLE :? Value i :> Nil <- ctx = case spec of TypeSpec ts cant -> - subtractSpec @fn i ts <> notMemberSpec (catMaybes $ map (safeSubtract @fn i) cant) + subtractSpec @fn i ts <> notMemberSpec (mapMaybe (safeSubtract @fn i) cant) MemberSpec es -> memberSpecList (nub $ mapMaybe (safeSubtract @fn i) (NE.toList es))