Merge pull request #5007 from IntersectMBO/aniketd/remove-conwaynewepochpredfailure

Remove ConwayNewEpochPredFailure

Author: lehins

eras/conway/impl/CHANGELOG.md

@@ -2,6 +2,7 @@
 
 ## 1.20.0.0
 
+- Remove `ConwayNewEpochPredFailure` and replace it with `Void`. #5007
 * Added to `PParams`: `ppCommitteeMaxTermLength`,`ppCommitteeMinSize`,`ppDRepActivity`,`ppDRepDeposit`,`ppDRepVotingThresholds`,`ppGovActionDeposit`,`ppGovActionLifetime`,`ppGovProtocolVersion`,`ppMinFeeRefScriptCostPerByte`,`ppPoolVotingThresholds`
 * Moved `ConwayEraPlutusTxInfo` class from `Context` module to `TxInfo`
 * Removed `Cardano.Ledger.Conway.Plutus.Context` module

eras/conway/impl/src/Cardano/Ledger/Conway/Rules/NewEpoch.hs

@@ -17,7 +17,6 @@
 
 module Cardano.Ledger.Conway.Rules.NewEpoch (
   ConwayNEWEPOCH,
-  ConwayNewEpochPredFailure (..),
   ConwayNewEpochEvent (..),
 ) where
 
@@ -54,28 +53,15 @@ import Cardano.Ledger.Slot (EpochNo (EpochNo))
 import Cardano.Ledger.State
 import qualified Cardano.Ledger.Val as Val
 import Control.DeepSeq (NFData)
+import Control.Exception (assert)
 import Control.State.Transition
 import Data.Default (Default (..))
 import qualified Data.Map.Strict as Map
 import Data.Set (Set)
+import Data.Void (Void)
 import GHC.Generics (Generic)
 import Lens.Micro ((%~), (&), (^.))
 
-newtype ConwayNewEpochPredFailure era
-  = CorruptRewardUpdate
-      RewardUpdate -- The reward update which violates an invariant
-  deriving (Generic)
-
-deriving instance Eq (ConwayNewEpochPredFailure era)
-
-deriving instance
-  ( Show (PredicateFailure (EraRule "EPOCH" era))
-  , Show (PredicateFailure (EraRule "RATIFY" era))
-  ) =>
-  Show (ConwayNewEpochPredFailure era)
-
-instance NFData (ConwayNewEpochPredFailure era)
-
 data ConwayNewEpochEvent era
   = DeltaRewardEvent !(Event (EraRule "RUPD" era))
   | RestrainedRewards
@@ -121,14 +107,16 @@ instance
   , GovState era ~ ConwayGovState era
   , Eq (PredicateFailure (EraRule "RATIFY" era))
   , Show (PredicateFailure (EraRule "RATIFY" era))
+  , Eq (PredicateFailure (ConwayNEWEPOCH era))
+  , Show (PredicateFailure (ConwayNEWEPOCH era))
   ) =>
   STS (ConwayNEWEPOCH era)
   where
   type State (ConwayNEWEPOCH era) = NewEpochState era
   type Signal (ConwayNEWEPOCH era) = EpochNo
   type Environment (ConwayNEWEPOCH era) = ()
   type BaseM (ConwayNEWEPOCH era) = ShelleyBase
-  type PredicateFailure (ConwayNEWEPOCH era) = ConwayNewEpochPredFailure era
+  type PredicateFailure (ConwayNEWEPOCH era) = Void
   type Event (ConwayNEWEPOCH era) = ConwayNewEpochEvent era
 
   initialRules =
@@ -162,6 +150,8 @@ newEpochTransition ::
   , GovState era ~ ConwayGovState era
   , Eq (PredicateFailure (EraRule "RATIFY" era))
   , Show (PredicateFailure (EraRule "RATIFY" era))
+  , Eq (PredicateFailure (ConwayNEWEPOCH era))
+  , Show (PredicateFailure (ConwayNEWEPOCH era))
   ) =>
   TransitionRule (ConwayNEWEPOCH era)
 newEpochTransition = do
@@ -216,7 +206,7 @@ updateRewards ::
   Rule (ConwayNEWEPOCH era) 'Transition (EpochState era)
 updateRewards es e ru'@(RewardUpdate dt dr rs_ df _) = do
   let totRs = sumRewards (es ^. prevPParamsEpochStateL . ppProtocolVersionL) rs_
-  Val.isZero (dt <> dr <> toDeltaCoin totRs <> df) ?! CorruptRewardUpdate ru'
+   in assert (Val.isZero (dt <> dr <> toDeltaCoin totRs <> df)) (pure ())
   let !(!es', filtered) = applyRUpdFiltered ru' es
   tellEvent $ RestrainedRewards e (frShelleyIgnored filtered) (frUnregistered filtered)
   -- This event (which is only generated once per epoch) must be generated even if the
@@ -226,8 +216,8 @@ updateRewards es e ru'@(RewardUpdate dt dr rs_ df _) = do
 
 instance
   ( STS (ConwayNEWEPOCH era)
-  , PredicateFailure (EraRule "NEWEPOCH" era) ~ ConwayNewEpochPredFailure era
   , Event (EraRule "NEWEPOCH" era) ~ ConwayNewEpochEvent era
+  , PredicateFailure (EraRule "NEWEPOCH" era) ~ PredicateFailure (ConwayNEWEPOCH era)
   ) =>
   Embed (ConwayNEWEPOCH era) (ShelleyTICK era)
   where

eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/TreeDiff.hs

@@ -281,8 +281,6 @@ instance ToExpr (PParamsHKD StrictMaybe era) => ToExpr (RatifySignal era)
 
 instance ToExpr (PParamsHKD StrictMaybe era) => ToExpr (EnactSignal era)
 
-instance ToExpr (ConwayNewEpochPredFailure era)
-
 instance
   ( ToExpr (PParamsHKD Identity era)
   , ToExpr (PParamsHKD StrictMaybe era)

eras/shelley/impl/CHANGELOG.md

@@ -2,6 +2,7 @@
 
 ## 1.17.0.0
 
+- Remove `CorruptRewardUpdate` predicate failure and replace that check with an assertion. #5007
 * Added to `PParams`: `shelleyPParams`, `ppA0`,`ppD`,`ppEMax`,`ppExtraEntropy`,`ppMaxBBSize`,`ppKeyDeposit`,`ppMinFeeA`,`ppMinFeeB`,`ppMinPoolCost` `ppMaxBHSize`,`ppMaxTxSize`,`ppNOpt`,`ppProtocolVersion`,`ppPoolDeposit`,`ppRho`,`ppTau`
 * Removed from `PParams`: `shelleyCommonPParamsHKDPairs`,`shelleyCommonPParamsHKDPairsV6`,`shelleyCommonPParamsHKDPairsV8`
 * Replace export from `Cardano.Ledger.Shelley.UTxO` of deprecated `balance` and `coinBalance` with `sumUTxO` and `sumCoinUTxO` respectively

eras/shelley/impl/src/Cardano/Ledger/Shelley/Rules/NewEpoch.hs

@@ -42,6 +42,7 @@ import Cardano.Ledger.Slot (EpochNo (..))
 import Cardano.Ledger.State
 import qualified Cardano.Ledger.Val as Val
 import Control.DeepSeq (NFData)
+import Control.Exception (assert)
 import Control.State.Transition
 import Data.Default (Default, def)
 import qualified Data.Map.Strict as Map
@@ -52,8 +53,6 @@ import NoThunks.Class (NoThunks (..))
 
 data ShelleyNewEpochPredFailure era
   = EpochFailure (PredicateFailure (EraRule "EPOCH" era)) -- Subtransition Failures
-  | CorruptRewardUpdate
-      RewardUpdate -- The reward update which violates an invariant
   | MirFailure (PredicateFailure (EraRule "MIR" era)) -- Subtransition Failures
   deriving (Generic)
 
@@ -265,7 +264,7 @@ updateRewards ::
   Rule (ShelleyNEWEPOCH era) 'Transition (EpochState era)
 updateRewards es e ru'@(RewardUpdate dt dr rs_ df _) = do
   let totRs = sumRewards (es ^. prevPParamsEpochStateL . ppProtocolVersionL) rs_
-  Val.isZero (dt <> (dr <> toDeltaCoin totRs <> df)) ?! CorruptRewardUpdate ru'
+   in assert (Val.isZero (dt <> (dr <> toDeltaCoin totRs <> df))) (pure ())
   let !(!es', filtered) = applyRUpdFiltered ru' es
   tellEvent $ RestrainedRewards e (frShelleyIgnored filtered) (frUnregistered filtered)
   -- This event (which is only generated once per epoch) must be generated even if the

eras/shelley/test-suite/test/Test/Cardano/Ledger/Shelley/RulesTests.hs

@@ -9,35 +9,19 @@
 module Test.Cardano.Ledger.Shelley.RulesTests (
   chainExamples,
   multisigExamples,
-  testTickF,
 ) where
 
-import Cardano.Ledger.BaseTypes (Network (..), StrictMaybe (..))
+import Cardano.Ledger.BaseTypes (Network (..))
 import Cardano.Ledger.Coin (Coin (..))
 import Cardano.Ledger.Core (hashScript)
 import Cardano.Ledger.Credential (pattern ScriptHashObj)
 import Cardano.Ledger.Keys (asWitness, hashKey)
 import Cardano.Ledger.Shelley (ShelleyEra)
-import Cardano.Ledger.Shelley.API (ShelleyTICK, ShelleyTICKF)
-import Cardano.Ledger.Shelley.LedgerState (
-  EpochState (..),
-  LedgerState (..),
-  NewEpochState (..),
-  UTxOState (..),
-  totalObligation,
-  utxosGovStateL,
- )
-import Cardano.Ledger.Shelley.RewardUpdate (PulsingRewUpdate (..), RewardUpdate (..))
 import Cardano.Ledger.Shelley.Rules (ShelleyUtxowPredFailure (..))
 import Cardano.Ledger.Shelley.TxBody (RewardAccount (..), Withdrawals (..))
-import Cardano.Ledger.Slot (EpochNo (..))
-import Cardano.Protocol.TPraos.API (GetLedgerView (..))
-import Control.State.Transition.Extended (TRC (..))
 import Data.Either (isRight)
 import qualified Data.Map.Strict as Map
-import Data.Maybe (fromMaybe)
 import qualified Data.Set as Set
-import Lens.Micro ((^.))
 import Test.Cardano.Ledger.Core.KeyPair (vKey)
 import Test.Cardano.Ledger.Shelley.Examples (testCHAINExample)
 import qualified Test.Cardano.Ledger.Shelley.Examples.Cast as Cast
@@ -62,10 +46,8 @@ import Test.Cardano.Ledger.Shelley.MultiSigExamples (
  )
 import Test.Cardano.Ledger.Shelley.Serialisation.EraIndepGenerators ()
 import Test.Cardano.Ledger.Shelley.Serialisation.Generators ()
-import Test.Cardano.Ledger.Shelley.Utils
 import Test.Tasty (TestTree, testGroup)
 import Test.Tasty.HUnit (Assertion, assertBool, testCase, (@?=))
-import Test.Tasty.QuickCheck (Property, discard, testProperty, (===))
 
 chainExamples :: TestTree
 chainExamples =
@@ -488,54 +470,3 @@ testRwdAliceSignsAlone''' =
         (Coin 0)
         [asWitness Cast.alicePay, asWitness Cast.bobPay]
     wits = Set.singleton $ hashScript @ShelleyEra bobOnly
-
--- | The reward aggregation bug described in the Shelley ledger spec in
--- section 17.4 (in the Errata) resulted in needing to use 'aggregatedRewards' to change
--- the behavior of how rewards are collected starting at protocol version 3.
--- Instead of collecting a `Coin` for each stake credential, we collect 'Set Reward'.
--- In major protocol version 2, it is impossible for this set to be empty, but sadly this
--- property is not enforced in the types. For this reason, the property test
--- 'propTickfPerservesLedgerView' removes these empty sets from an otherwise arbitrary
--- 'NewEpochState'.
-filterEmptyRewards :: NewEpochState ShelleyEra -> NewEpochState ShelleyEra
-filterEmptyRewards (NewEpochState el bprev bcur es ru pd stash) =
-  NewEpochState el bprev bcur es ru' pd stash
-  where
-    removeEmptyRewards = Map.filter $ not . Set.null
-    ru' = case ru of
-      SNothing -> SNothing
-      SJust (Pulsing _ _) -> SNothing
-      SJust (Complete rewardUpdate) ->
-        SJust . Complete $ rewardUpdate {rs = removeEmptyRewards (rs rewardUpdate)}
-
-setDepositsToObligation :: NewEpochState ShelleyEra -> NewEpochState ShelleyEra
-setDepositsToObligation nes = nes {nesEs = es {esLState = ls {lsUTxOState = utxoState}}}
-  where
-    es = nesEs nes
-    ls = esLState es
-    utxoState =
-      (lsUTxOState ls)
-        { utxosDeposited =
-            totalObligation
-              (lsCertState ls)
-              (utxoState ^. utxosGovStateL)
-        }
-
--- | This property test checks the correctness of the TICKF transation.
--- TICKF is used by the consensus layer to get a ledger view in a computationally
--- cheaper way than using the TICK rule.
--- Therefore TICKF and TICK need to compute the same ledger view.
-propTickfPerservesLedgerView :: NewEpochState ShelleyEra -> Property
-propTickfPerservesLedgerView nes =
-  let (EpochNo e) = nesEL nes
-      slot = slotFromEpoch (EpochNo $ e + 1)
-      nes' = setDepositsToObligation (filterEmptyRewards nes)
-      tickNes = runShelleyBase $ applySTSTest @(ShelleyTICK ShelleyEra) (TRC ((), nes', slot))
-      tickFNes = runShelleyBase $ applySTSTest @(ShelleyTICKF ShelleyEra) (TRC ((), nes', slot))
-   in fromMaybe discard $ do
-        Right tickNes' <- pure tickNes
-        Right tickFNes' <- pure tickFNes
-        pure $ currentLedgerView tickNes' === currentLedgerView tickFNes'
-
-testTickF :: TestTree
-testTickF = testProperty "TICKF properties" propTickfPerservesLedgerView

eras/shelley/test-suite/test/Tests.hs

@@ -16,7 +16,6 @@ import qualified Test.Cardano.Ledger.Shelley.Rules.Deposits as Deposits (tests)
 import qualified Test.Cardano.Ledger.Shelley.RulesTests as RulesTests (
   chainExamples,
   multisigExamples,
-  testTickF,
  )
 import qualified Test.Cardano.Ledger.Shelley.SafeHash as SafeHash (safeHashTest)
 import qualified Test.Cardano.Ledger.Shelley.Serialisation as Serialisation
@@ -52,7 +51,6 @@ defaultTests =
     , Serialisation.tests
     , RulesTests.chainExamples
     , RulesTests.multisigExamples
-    , RulesTests.testTickF
     , UnitTests.unitTests
     , SafeHash.safeHashTest
     ]

libs/cardano-ledger-conformance/src/Test/Cardano/Ledger/Conformance/SpecTranslate/Conway/Cert.hs

@@ -223,7 +223,3 @@ instance
       <$> toSpecRep nesEL
       <*> toSpecRep nesEs
       <*> toSpecRep nesRu
-
-instance SpecTranslate ctx (ConwayNewEpochPredFailure era) where
-  type SpecRep (ConwayNewEpochPredFailure era) = OpaqueErrorString
-  toSpecRep = pure . showOpaqueErrorString

libs/cardano-ledger-test/src/Test/Cardano/Ledger/Generic/PrettyCore.hs

@@ -134,7 +134,6 @@ import Cardano.Ledger.Conway.Rules (
   ConwayGovCertPredFailure (..),
   ConwayGovPredFailure (..),
   ConwayLedgerPredFailure (..),
-  ConwayNewEpochPredFailure,
   ConwayUtxosPredFailure,
   EnactSignal (..),
   GovEnv (..),
@@ -1265,7 +1264,7 @@ ppNEWEPOCH Allegra x = ppShelleyNewEpochPredicateFailure x
 ppNEWEPOCH Mary x = ppShelleyNewEpochPredicateFailure x
 ppNEWEPOCH Alonzo x = ppShelleyNewEpochPredicateFailure x
 ppNEWEPOCH Babbage x = ppShelleyNewEpochPredicateFailure x
-ppNEWEPOCH Conway x = ppConwayNewEpochPredFailure x
+ppNEWEPOCH Conway x = absurd x
 
 ppEPOCH :: Proof era -> PredicateFailure (EraRule "EPOCH" era) -> PDoc
 ppEPOCH Shelley x = ppShelleyEpochPredFailure x
@@ -1702,21 +1701,12 @@ instance Reflect era => PrettyA (ShelleyTickPredFailure era) where
 ppShelleyNewEpochPredicateFailure ::
   forall era. Reflect era => ShelleyNewEpochPredFailure era -> PDoc
 ppShelleyNewEpochPredicateFailure (EpochFailure x) = ppEPOCH @era reify x
-ppShelleyNewEpochPredicateFailure (CorruptRewardUpdate x) =
-  ppSexp "CorruptRewardUpdate" [ppRewardUpdate x]
 ppShelleyNewEpochPredicateFailure (MirFailure _) =
   error "In the Conway era, there is no (EraRule MIR) type instance."
 
 instance Reflect era => PrettyA (ShelleyNewEpochPredFailure era) where
   prettyA = ppShelleyNewEpochPredicateFailure
 
-ppConwayNewEpochPredFailure :: ConwayNewEpochPredFailure era -> PDoc
-ppConwayNewEpochPredFailure (ConwayRules.CorruptRewardUpdate x) =
-  ppSexp "CorruptRewardUpdate" [ppRewardUpdate x]
-
-instance PrettyA (ConwayNewEpochPredFailure era) where
-  prettyA = ppConwayNewEpochPredFailure
-
 -- ===============
 
 ppShelleyEpochPredFailure :: forall era. ShelleyEpochPredFailure era -> PDoc