Fixed ImpTest committee expiry

Author: Soupstraw

eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Imp/EnactSpec.hs

@@ -315,9 +315,6 @@ noConfidenceSpec =
         & ppPoolVotingThresholdsL . pvtCommitteeNoConfidenceL .~ 1 %! 2
         & ppCommitteeMaxTermLengthL .~ EpochInterval 200
     let
-      getCommittee =
-        getsNES $
-          nesEsL . esLStateL . lsUTxOStateL . utxosGovStateL . committeeGovStateL
       assertNoCommittee :: HasCallStack => ImpTestM era ()
       assertNoCommittee =
         do

eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Imp/RatifySpec.hs

@@ -1,5 +1,6 @@
 {-# LANGUAGE DataKinds #-}
 {-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE NumericUnderscores #-}
 {-# LANGUAGE OverloadedLists #-}
 {-# LANGUAGE RankNTypes #-}
@@ -529,15 +530,24 @@ spoVotesForHardForkInitiation =
       modifyPParams $ ppPoolVotingThresholdsL . pvtHardForkInitiationL .~ 1 %! 2
       protVer <- getProtVer
       gai <- submitGovAction $ HardForkInitiation SNothing (majorFollow protVer)
-      submitYesVoteCCs_ hotCCs gai
+      impAnn "Submit CC yes vote" $ submitYesVoteCCs_ hotCCs gai
+      logString $ "Committee: " <> showExpr hotCCs
+      GovActionState {gasCommitteeVotes} <- getGovActionState gai
+      logString $ "CC Votes: " <> showExpr gasCommitteeVotes
+      minSize <- getsPParams ppCommitteeMinSizeL
+      committee <- getCommittee
+      logString $ "Min committee size: " <> show minSize
+      logString $ "Committee: " <> showExpr committee
+      logString . show =<< getsNES nesELL
+      impAnn "Accepted by committee" $ isCommitteeAccepted gai `shouldReturn` True
       -- 1 % 4 stake yes; 3 % 4 stake no; yes / stake - abstain < 1 % 2
-      submitYesVote_ (StakePoolVoter spoK1) gai
+      impAnn "Submit SPO1 yes vote" $ submitYesVote_ (StakePoolVoter spoK1) gai
       passNEpochs 2
       logRatificationChecks gai
       isSpoAccepted gai `shouldReturn` False
       getLastEnactedHardForkInitiation `shouldReturn` SNothing
       -- 1 % 2 stake yes; 1 % 2 stake no; yes / stake - abstain = 1 % 2
-      submitYesVote_ (StakePoolVoter spoK2) gai
+      impAnn "Submit SPO2 yes vote" $ submitYesVote_ (StakePoolVoter spoK2) gai
       isSpoAccepted gai `shouldReturn` True
       passNEpochs 2
       getLastEnactedHardForkInitiation `shouldReturn` SJust (GovPurposeId gai)

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

@@ -132,6 +132,7 @@ module Test.Cardano.Ledger.Conway.ImpTest (
   SubmitFailureExpectation (..),
   FailBoth (..),
   delegateSPORewardAddressToDRep_,
+  getCommittee,
 ) where
 
 import Cardano.Ledger.Address (RewardAccount (..))
@@ -1798,3 +1799,6 @@ instance InjectRuleFailure "DELEG" ShelleyDelegPredFailure ConwayEra where
   injectFailure (Shelley.StakeKeyNotRegisteredDELEG c) = StakeKeyNotRegisteredDELEG c
   injectFailure (Shelley.StakeKeyNonZeroAccountBalanceDELEG c) = StakeKeyHasNonZeroRewardAccountBalanceDELEG c
   injectFailure _ = error "Cannot inject ShelleyDelegPredFailure into ConwayEra"
+
+getCommittee :: ConwayEraGov era => ImpTestM era (StrictMaybe (Committee era))
+getCommittee = getsNES $ nesEsL . epochStateGovStateL . committeeGovStateL

eras/dijkstra/cardano-ledger-dijkstra.cabal

@@ -123,6 +123,7 @@ library testlib
     cardano-ledger-core:{cardano-ledger-core, testlib},
     cardano-ledger-dijkstra,
     cardano-ledger-shelley,
+    microlens,
 
 test-suite tests
   type: exitcode-stdio-1.0

eras/dijkstra/src/Cardano/Ledger/Dijkstra/Genesis.hs

@@ -4,7 +4,7 @@
 module Cardano.Ledger.Dijkstra.Genesis () where
 
 import Cardano.Ledger.Dijkstra.Era (DijkstraEra)
-import Cardano.Ledger.Genesis (EraGenesis (..))
+import Cardano.Ledger.Genesis (EraGenesis (..), NoGenesis)
 
 instance EraGenesis DijkstraEra where
-  type Genesis DijkstraEra = ()
+  type Genesis DijkstraEra = NoGenesis DijkstraEra

eras/dijkstra/src/Cardano/Ledger/Dijkstra/Translation.hs

@@ -52,6 +52,7 @@ import Cardano.Ledger.Dijkstra.Tx ()
 import Cardano.Ledger.Dijkstra.TxAuxData ()
 import Cardano.Ledger.Dijkstra.TxBody (upgradeGovAction, upgradeProposals)
 import Cardano.Ledger.Dijkstra.TxWits ()
+import Cardano.Ledger.Genesis (NoGenesis)
 import qualified Cardano.Ledger.Shelley.API as API
 import Cardano.Ledger.Shelley.LedgerState (
   DState (..),
@@ -69,7 +70,7 @@ import Data.Default (Default (..))
 import qualified Data.Map.Strict as Map
 import Lens.Micro ((&), (.~), (^.))
 
-type instance TranslationContext DijkstraEra = ()
+type instance TranslationContext DijkstraEra = NoGenesis DijkstraEra
 
 newtype Tx era = Tx (Core.Tx era)
 

eras/dijkstra/testlib/Test/Cardano/Ledger/Dijkstra/ImpTest.hs

@@ -1,10 +1,13 @@
 {-# LANGUAGE DataKinds #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE TypeApplications #-}
 {-# LANGUAGE TypeFamilies #-}
 {-# OPTIONS_GHC -Wno-orphans #-}
 
 module Test.Cardano.Ledger.Dijkstra.ImpTest () where
 
+import Cardano.Ledger.BaseTypes (EpochInterval (..), addEpochInterval)
+import Cardano.Ledger.Conway.Governance (ConwayEraGov (..), committeeMembersL)
 import Cardano.Ledger.Conway.Rules (
   ConwayCertPredFailure (..),
   ConwayCertsPredFailure (..),
@@ -13,14 +16,25 @@ import Cardano.Ledger.Conway.Rules (
  )
 import Cardano.Ledger.Dijkstra (DijkstraEra)
 import Cardano.Ledger.Dijkstra.Core
+import Cardano.Ledger.Genesis (NoGenesis (..))
 import Cardano.Ledger.Plutus (SLanguage (..))
+import Cardano.Ledger.Shelley.LedgerState (epochStateGovStateL, nesEsL)
 import Cardano.Ledger.Shelley.Rules (ShelleyDelegPredFailure)
 import qualified Cardano.Ledger.Shelley.Rules as Shelley
+import Lens.Micro ((%~), (&))
 import Test.Cardano.Ledger.Conway.ImpTest
 import Test.Cardano.Ledger.Dijkstra.Era ()
 
 instance ShelleyEraImp DijkstraEra where
-  initGenesis = pure ()
+  initGenesis = pure NoGenesis
+
+  initNewEpochState = defaultInitNewEpochState $ \nes ->
+    nes
+      & nesEsL . epochStateGovStateL . committeeGovStateL %~ fmap updateCommitteeExpiry
+    where
+      updateCommitteeExpiry =
+        committeeMembersL
+          %~ fmap (const $ addEpochInterval (impEraStartEpochNo @DijkstraEra) (EpochInterval 15))
 
   impSatisfyNativeScript = impAllegraSatisfyNativeScript