Optimize MonadWriter ImpTestM instance by using a Seq instead of a list

Also abstract the interface for obtaining events from ImpTestM actions

Author: neilmayhew

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

@@ -23,7 +23,6 @@ import Cardano.Ledger.Shelley.LedgerState
 import Cardano.Ledger.Shelley.Rules (Event, ShelleyTickEvent (..))
 import Cardano.Ledger.Val (zero, (<->))
 import Control.Monad (forM)
-import Control.Monad.Writer (listen)
 import Data.Default (def)
 import Data.Foldable as F (foldl', traverse_)
 import Data.List.NonEmpty (NonEmpty (..))
@@ -214,18 +213,18 @@ hardForkInitiationSpec =
     submitYesVote_ (DRepVoter dRep1) govActionId
     submitYesVote_ (StakePoolVoter stakePoolId1) govActionId
     passNEpochs 2
-      & listen
-      >>= expectHardForkEvents . snd <*> pure []
+      & impEventsFrom
+      >>= expectHardForkEvents <*> pure []
     getProtVer `shouldReturn` curProtVer
     submitYesVote_ (DRepVoter dRep2) govActionId
     passNEpochs 2
-      & listen
-      >>= expectHardForkEvents . snd <*> pure []
+      & impEventsFrom
+      >>= expectHardForkEvents <*> pure []
     getProtVer `shouldReturn` curProtVer
     submitYesVote_ (StakePoolVoter stakePoolId2) govActionId
     passNEpochs 2
-      & listen
-      >>= expectHardForkEvents . snd
+      & impEventsFrom
+      >>= expectHardForkEvents
         <*> pure
           [ SomeSTSEvent @era @"TICK" . injectEvent $ ConwayHardForkEvent nextProtVer
           ]
@@ -255,13 +254,13 @@ hardForkInitiationNoDRepsSpec =
     submitYesVoteCCs_ committeeMembers' govActionId
     submitYesVote_ (StakePoolVoter stakePoolId1) govActionId
     passNEpochs 2
-      & listen
-      >>= expectHardForkEvents . snd <*> pure []
+      & impEventsFrom
+      >>= expectHardForkEvents <*> pure []
     getProtVer `shouldReturn` curProtVer
     submitYesVote_ (StakePoolVoter stakePoolId2) govActionId
     passNEpochs 2
-      & listen
-      >>= expectHardForkEvents . snd
+      & impEventsFrom
+      >>= expectHardForkEvents
         <*> pure
           [ SomeSTSEvent @era @"TICK" . injectEvent $ ConwayHardForkEvent nextProtVer
           ]

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

@@ -25,7 +25,6 @@ import Cardano.Ledger.Conway.State
 import Cardano.Ledger.Shelley.LedgerState
 import Cardano.Ledger.Shelley.Rules (Event, ShelleyTickEvent (..))
 import Cardano.Ledger.Val
-import Control.Monad.Writer (listen)
 import Data.Default (Default (..))
 import qualified Data.List.NonEmpty as NE
 import qualified Data.Map.Strict as Map
@@ -528,7 +527,7 @@ eventsSpec = describe "Events" $ do
           | Just (TickNewEpochEvent (EpochEvent (GovInfoEvent {})) :: ShelleyTickEvent era) <- cast ev = True
         isGovInfoEvent _ = False
         passEpochWithNoDroppedActions = do
-          (_, evs) <- listen passEpoch
+          evs <- impEventsFrom passEpoch
           filter isGovInfoEvent evs
             `shouldBeExpr` [ SomeSTSEvent @era @"TICK" . injectEvent $
                                GovInfoEvent mempty mempty mempty mempty
@@ -545,7 +544,7 @@ eventsSpec = describe "Events" $ do
           & bodyTxL . certsTxBodyL
             .~ SSeq.singleton (UnRegDepositTxCert rewardCred keyDeposit)
       passEpochWithNoDroppedActions
-      (_, evs) <- listen passEpoch
+      evs <- impEventsFrom passEpoch
       checkProposedParameterA
       let
         filteredEvs = filter isGovInfoEvent evs

eras/shelley/impl/CHANGELOG.md

@@ -49,6 +49,8 @@
 
 ### `testlib`
 
+* Add `impEventsFrom`
+* Change type of `ImpTestState.impEvents` field from `[]` to `Seq`
 * Renamed `impLastTick` to `impCurSlotNo` and `impLastTickG` to `impCurSlotNoG`
 * Add CDDL certificate definitions: `account_registration_cert`, `account_unregistration_cert`, `delegation_to_stake_pool_cert`
 * Add CDDL pool certificate definitions via `mkPoolRules`: `pool_registration_cert`, `pool_retirement_cert`

eras/shelley/impl/testlib/Test/Cardano/Ledger/Shelley/ImpTest.hs

@@ -147,6 +147,7 @@ module Test.Cardano.Ledger.Shelley.ImpTest (
   withNoFixup,
   withPostFixup,
   withPreFixup,
+  impEventsFrom,
   impNESL,
   impGlobalsL,
   impCurSlotNoG,
@@ -262,6 +263,8 @@ import Data.Map.Strict (Map)
 import qualified Data.Map.Strict as Map
 import Data.Maybe (catMaybes, isNothing, mapMaybe)
 import Data.Ratio (denominator, numerator, (%))
+import Data.Sequence (Seq)
+import qualified Data.Sequence as Seq
 import Data.Sequence.Strict (StrictSeq (..))
 import qualified Data.Sequence.Strict as SSeq
 import qualified Data.Set as Set
@@ -346,7 +349,7 @@ data ImpTestState era = ImpTestState
   , impNativeScripts :: !(Map ScriptHash (NativeScript era))
   , impCurSlotNo :: !SlotNo
   , impGlobals :: !Globals
-  , impEvents :: [SomeSTSEvent era]
+  , impEvents :: Seq (SomeSTSEvent era)
   }
 
 -- | This is a preliminary state that is used to prepare the actual `ImpTestState`
@@ -409,7 +412,7 @@ impNativeScriptsG ::
   SimpleGetter (ImpTestState era) (Map ScriptHash (NativeScript era))
 impNativeScriptsG = impNativeScriptsL
 
-impEventsL :: Lens' (ImpTestState era) [SomeSTSEvent era]
+impEventsL :: Lens' (ImpTestState era) (Seq (SomeSTSEvent era))
 impEventsL = lens impEvents (\x y -> x {impEvents = y})
 
 class
@@ -897,7 +900,7 @@ itePostEpochBoundaryHookL ::
     )
 itePostEpochBoundaryHookL = lens itePostEpochBoundaryHook (\x y -> x {itePostEpochBoundaryHook = y})
 
-instance MonadWriter [SomeSTSEvent era] (ImpTestM era) where
+instance MonadWriter (Seq (SomeSTSEvent era)) (ImpTestM era) where
   writer (x, evs) = (impEventsL %= (<> evs)) $> x
   listen act = do
     oldEvs <- use impEventsL
@@ -910,6 +913,11 @@ instance MonadWriter [SomeSTSEvent era] (ImpTestM era) where
     ((a, f), evs) <- listen act
     writer (a, f evs)
 
+impEventsFrom ::
+  ImpTestM era () ->
+  ImpTestM era [SomeSTSEvent era]
+impEventsFrom = fmap (toList . snd) . listen
+
 runShelleyBase :: ShelleyBase a -> ImpTestM era a
 runShelleyBase act = do
   globals <- use impGlobalsL
@@ -1208,7 +1216,7 @@ trySubmitTx tx = do
           rootIndex
             | outsSize > 0 = outsSize - 1
             | otherwise = error ("Expected at least 1 output after submitting tx: " <> show txId)
-      tell $ fmap (SomeSTSEvent @era @"LEDGER") events
+      tell . Seq.fromList $ SomeSTSEvent @era @"LEDGER" <$> events
       modify $ impNESL . nesEsL . esLStateL .~ st'
       UTxO utxo <- getUTxO
       -- This TxIn is in the utxo, and thus can be the new root, only if the transaction
@@ -1328,7 +1336,7 @@ runImpRule env st sig = do
           unlines $
             ("Failed to run " <> ruleName <> ":") : map show (toList fs)
       Right res -> evaluateDeep res
-  tell $ fmap (SomeSTSEvent @era @rule) ev
+  tell . Seq.fromList $ SomeSTSEvent @era @rule <$> ev
   pure res
 
 -- | Runs the TICK rule once