Made MEMPOOL call LEDGER

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

@@ -55,7 +55,6 @@ import Cardano.Ledger.Conway.Era (
   ConwayEra,
   ConwayGOV,
   ConwayLEDGER,
-  ConwayMEMPOOL,
   ConwayUTXOW,
  )
 import Cardano.Ledger.Conway.Governance (
@@ -81,7 +80,6 @@ import Cardano.Ledger.Conway.Rules.Gov (
   GovSignal (..),
  )
 import Cardano.Ledger.Conway.Rules.GovCert (ConwayGovCertPredFailure)
-import Cardano.Ledger.Conway.Rules.Mempool (ConwayMempoolEvent (..), ConwayMempoolPredFailure (..))
 import Cardano.Ledger.Conway.Rules.Utxo (ConwayUtxoPredFailure)
 import Cardano.Ledger.Conway.Rules.Utxos (ConwayUtxosPredFailure)
 import Cardano.Ledger.Conway.Rules.Utxow (ConwayUtxowPredFailure)
@@ -114,7 +112,7 @@ import Cardano.Ledger.State (EraUTxO (..))
 import Cardano.Ledger.UMap (UView (..))
 import qualified Cardano.Ledger.UMap as UMap
 import Control.DeepSeq (NFData)
-import Control.Monad (unless, void, when)
+import Control.Monad (unless)
 import Control.State.Transition.Extended (
   Embed (..),
   STS (..),
@@ -210,9 +208,6 @@ instance InjectRuleFailure "LEDGER" ConwayGovCertPredFailure ConwayEra where
 instance InjectRuleFailure "LEDGER" ConwayGovPredFailure ConwayEra where
   injectFailure = ConwayGovFailure
 
-instance InjectRuleFailure "LEDGER" ConwayMempoolPredFailure ConwayEra where
-  injectFailure (ConwayMempoolPredFailure t) = ConwayMempoolFailure t
-
 deriving instance
   ( Era era
   , Eq (PredicateFailure (EraRule "UTXOW" era))
@@ -286,22 +281,19 @@ data ConwayLedgerEvent era
   = UtxowEvent (Event (EraRule "UTXOW" era))
   | CertsEvent (Event (EraRule "CERTS" era))
   | GovEvent (Event (EraRule "GOV" era))
-  | MempoolEvent (Event (EraRule "MEMPOOL" era))
   deriving (Generic)
 
 deriving instance
   ( Eq (Event (EraRule "CERTS" era))
   , Eq (Event (EraRule "UTXOW" era))
   , Eq (Event (EraRule "GOV" era))
-  , Eq (Event (EraRule "MEMPOOL" era))
   ) =>
   Eq (ConwayLedgerEvent era)
 
 instance
   ( NFData (Event (EraRule "CERTS" era))
   , NFData (Event (EraRule "UTXOW" era))
   , NFData (Event (EraRule "GOV" era))
-  , NFData (Event (EraRule "MEMPOOL" era))
   ) =>
   NFData (ConwayLedgerEvent era)
 
@@ -313,19 +305,15 @@ instance
   , Embed (EraRule "UTXOW" era) (ConwayLEDGER era)
   , Embed (EraRule "GOV" era) (ConwayLEDGER era)
   , Embed (EraRule "CERTS" era) (ConwayLEDGER era)
-  , Embed (EraRule "MEMPOOL" era) (ConwayLEDGER era)
   , State (EraRule "UTXOW" era) ~ UTxOState era
   , State (EraRule "CERTS" era) ~ CertState era
   , State (EraRule "GOV" era) ~ Proposals era
-  , State (EraRule "MEMPOOL" era) ~ LedgerState era
   , Environment (EraRule "UTXOW" era) ~ UtxoEnv era
   , Environment (EraRule "CERTS" era) ~ CertsEnv era
   , Environment (EraRule "GOV" era) ~ GovEnv era
-  , Environment (EraRule "MEMPOOL" era) ~ LedgerEnv era
   , Signal (EraRule "UTXOW" era) ~ Tx era
   , Signal (EraRule "CERTS" era) ~ Seq (TxCert era)
   , Signal (EraRule "GOV" era) ~ GovSignal era
-  , Signal (EraRule "MEMPOOL" era) ~ Tx era
   ) =>
   STS (ConwayLEDGER era)
   where
@@ -358,36 +346,27 @@ ledgerTransition ::
   , Embed (EraRule "UTXOW" era) (someLEDGER era)
   , Embed (EraRule "GOV" era) (someLEDGER era)
   , Embed (EraRule "CERTS" era) (someLEDGER era)
-  , Embed (EraRule "MEMPOOL" era) (someLEDGER era)
   , State (EraRule "UTXOW" era) ~ UTxOState era
   , State (EraRule "CERTS" era) ~ CertState era
   , State (EraRule "GOV" era) ~ Proposals era
-  , State (EraRule "MEMPOOL" era) ~ LedgerState era
   , Environment (EraRule "UTXOW" era) ~ UtxoEnv era
   , Environment (EraRule "GOV" era) ~ GovEnv era
   , Environment (EraRule "CERTS" era) ~ CertsEnv era
-  , Environment (EraRule "MEMPOOL" era) ~ LedgerEnv era
   , Signal (EraRule "UTXOW" era) ~ Tx era
   , Signal (EraRule "CERTS" era) ~ Seq (TxCert era)
   , Signal (EraRule "GOV" era) ~ GovSignal era
-  , Signal (EraRule "MEMPOOL" era) ~ Tx era
   , BaseM (someLEDGER era) ~ ShelleyBase
   , STS (someLEDGER era)
   ) =>
   TransitionRule (someLEDGER era)
 ledgerTransition = do
   TRC
-    ( le@(LedgerEnv slot mbCurEpochNo _txIx pp account mempool)
-      , ls@(LedgerState utxoState certState)
+    ( LedgerEnv slot mbCurEpochNo _txIx pp account _mempool
+      , LedgerState utxoState certState
       , tx
       ) <-
     judgmentContext
 
-  when mempool $
-    void $
-      trans @(EraRule "MEMPOOL" era) $
-        TRC (le, ls, tx)
-
   curEpochNo <- maybe (liftSTS $ epochFromSlot slot) pure mbCurEpochNo
 
   (utxoState', certStateAfterCERTS) <-
@@ -531,7 +510,6 @@ instance
   ( Embed (EraRule "UTXOW" era) (ConwayLEDGER era)
   , Embed (EraRule "CERTS" era) (ConwayLEDGER era)
   , Embed (EraRule "GOV" era) (ConwayLEDGER era)
-  , Embed (EraRule "MEMPOOL" era) (ConwayLEDGER era)
   , ConwayEraGov era
   , AlonzoEraTx era
   , ConwayEraTxBody era
@@ -540,15 +518,12 @@ instance
   , Environment (EraRule "UTXOW" era) ~ UtxoEnv era
   , Environment (EraRule "CERTS" era) ~ CertsEnv era
   , Environment (EraRule "GOV" era) ~ GovEnv era
-  , Environment (EraRule "MEMPOOL" era) ~ LedgerEnv era
   , Signal (EraRule "UTXOW" era) ~ Tx era
   , Signal (EraRule "CERTS" era) ~ Seq (TxCert era)
   , Signal (EraRule "GOV" era) ~ GovSignal era
-  , Signal (EraRule "MEMPOOL" era) ~ Tx era
   , State (EraRule "UTXOW" era) ~ UTxOState era
   , State (EraRule "CERTS" era) ~ CertState era
   , State (EraRule "GOV" era) ~ Proposals era
-  , State (EraRule "MEMPOOL" era) ~ LedgerState era
   , EraRule "GOV" era ~ ConwayGOV era
   , PredicateFailure (EraRule "LEDGER" era) ~ ConwayLedgerPredFailure era
   , Event (EraRule "LEDGER" era) ~ ConwayLedgerEvent era
@@ -585,16 +560,3 @@ instance
   where
   wrapFailed = ConwayCertsFailure . CertFailure . DelegFailure
   wrapEvent = CertsEvent . CertEvent . DelegEvent
-
-instance
-  ( EraTx era
-  , ConwayEraGov era
-  , ConwayEraTxBody era
-  , EraRule "MEMPOOL" era ~ ConwayMEMPOOL era
-  , PredicateFailure (EraRule "MEMPOOL" era) ~ ConwayMempoolPredFailure era
-  , Event (EraRule "MEMPOOL" era) ~ ConwayMempoolEvent era
-  ) =>
-  Embed (ConwayMEMPOOL era) (ConwayLEDGER era)
-  where
-  wrapFailed (ConwayMempoolPredFailure t) = ConwayMempoolFailure t
-  wrapEvent = MempoolEvent

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

@@ -4,6 +4,7 @@
 {-# LANGUAGE DerivingStrategies #-}
 {-# LANGUAGE EmptyDataDeriving #-}
 {-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE OverloadedStrings #-}
@@ -16,23 +17,24 @@
 
 module Cardano.Ledger.Conway.Rules.Mempool (
   ConwayMEMPOOL,
-  ConwayMempoolEvent (..),
-  ConwayMempoolPredFailure (..),
 ) where
 
 import Cardano.Ledger.BaseTypes (ShelleyBase)
-import Cardano.Ledger.Binary (DecCBOR (..), EncCBOR (..), FromCBOR, ToCBOR)
 import Cardano.Ledger.Conway.Core
-import Cardano.Ledger.Conway.Era (ConwayEra, ConwayMEMPOOL)
+import Cardano.Ledger.Conway.Era (ConwayLEDGER, ConwayMEMPOOL)
 import Cardano.Ledger.Conway.Governance (
   ConwayEraGov,
+  ConwayGovState,
+  Proposals,
   Voter (..),
   authorizedElectedHotCommitteeCredentials,
   unVotingProcedures,
  )
+import Cardano.Ledger.Conway.Rules.Certs (CertsEnv)
+import Cardano.Ledger.Conway.Rules.Gov (GovEnv, GovSignal)
+import Cardano.Ledger.Conway.Rules.Ledger (ConwayLedgerEvent, ConwayLedgerPredFailure (..))
 import Cardano.Ledger.Shelley.LedgerState
-import Cardano.Ledger.Shelley.Rules (LedgerEnv (..))
-import Control.DeepSeq (NFData)
+import Cardano.Ledger.Shelley.Rules (LedgerEnv (..), UtxoEnv)
 import Control.State.Transition (
   BaseM,
   Environment,
@@ -45,51 +47,58 @@ import Control.State.Transition (
   TransitionRule,
   failOnNonEmpty,
   judgmentContext,
-  tellEvent,
   transitionRules,
  )
+import Control.State.Transition.Extended (Embed (..), trans)
 import qualified Data.List.NonEmpty as NE
 import qualified Data.Map.Strict as Map
+import Data.Sequence (Seq)
 import qualified Data.Set as Set
-import Data.Text as T (Text, pack)
-import GHC.Generics (Generic)
+import Data.Text as T (pack)
 import Lens.Micro ((^.))
-import NoThunks.Class (NoThunks)
-
-newtype ConwayMempoolPredFailure era = ConwayMempoolPredFailure Text
-  deriving (Eq, Show, Generic)
-  deriving newtype (NoThunks, NFData, ToCBOR, FromCBOR, EncCBOR, DecCBOR)
-
-type instance EraRuleFailure "MEMPOOL" ConwayEra = ConwayMempoolPredFailure ConwayEra
-instance InjectRuleFailure "MEMPOOL" ConwayMempoolPredFailure ConwayEra
-
-newtype ConwayMempoolEvent era = ConwayMempoolEvent Text
-  deriving (Generic, Eq)
-  deriving newtype (NFData)
-
-type instance EraRuleEvent "MEMPOOL" ConwayEra = ConwayMempoolEvent ConwayEra
 
 instance
-  (EraTx era, ConwayEraTxBody era, ConwayEraGov era) =>
+  ( EraTx era
+  , ConwayEraTxBody era
+  , ConwayEraGov era
+  , Embed (EraRule "LEDGER" era) (ConwayMEMPOOL era)
+  , State (EraRule "LEDGER" era) ~ LedgerState era
+  , Eq (PredicateFailure (EraRule "CERTS" era))
+  , Eq (PredicateFailure (EraRule "GOV" era))
+  , Eq (PredicateFailure (EraRule "UTXOW" era))
+  , Show (PredicateFailure (EraRule "CERTS" era))
+  , Show (PredicateFailure (EraRule "GOV" era))
+  , Show (PredicateFailure (EraRule "UTXOW" era))
+  , Environment (EraRule "LEDGER" era) ~ LedgerEnv era
+  , Tx era ~ Signal (EraRule "LEDGER" era)
+  ) =>
   STS (ConwayMEMPOOL era)
   where
   type State (ConwayMEMPOOL era) = LedgerState era
   type Signal (ConwayMEMPOOL era) = Tx era
   type Environment (ConwayMEMPOOL era) = LedgerEnv era
   type BaseM (ConwayMEMPOOL era) = ShelleyBase
-  type PredicateFailure (ConwayMEMPOOL era) = ConwayMempoolPredFailure era
-  type Event (ConwayMEMPOOL era) = ConwayMempoolEvent era
+  type PredicateFailure (ConwayMEMPOOL era) = ConwayLedgerPredFailure era
+  type Event (ConwayMEMPOOL era) = ConwayLedgerEvent era
 
   transitionRules = [mempoolTransition @era]
 
 mempoolTransition ::
-  (EraTx era, ConwayEraTxBody era, ConwayEraGov era) => TransitionRule (ConwayMEMPOOL era)
+  forall era.
+  ( EraTx era
+  , ConwayEraTxBody era
+  , ConwayEraGov era
+  , Embed (EraRule "LEDGER" era) (ConwayMEMPOOL era)
+  , State (EraRule "LEDGER" era) ~ LedgerState era
+  , Environment (EraRule "LEDGER" era) ~ LedgerEnv era
+  , Tx era ~ Signal (EraRule "LEDGER" era)
+  ) =>
+  TransitionRule (ConwayMEMPOOL era)
 mempoolTransition = do
-  TRC (_ledgerEnv, ledgerState, tx) <-
+  TRC trc@(_ledgerEnv, ledgerState, tx) <-
     judgmentContext
   -- This rule only gets invoked on transactions within the mempool.
   -- Add checks here that sanitize undesired transactions.
-  tellEvent . ConwayMempoolEvent . ("Mempool rule for tx " <>) . T.pack . show $ txIdTx tx
   let
     authorizedElectedHotCreds = authorizedElectedHotCommitteeCredentials ledgerState
     collectUnelectedCommitteeVotes !unelectedHotCreds voter _ =
@@ -104,5 +113,31 @@ mempoolTransition = do
     addPrefix =
       ("Unelected committee members are not allowed to cast votes: " <>)
   failOnNonEmpty unelectedCommitteeVoters $
-    ConwayMempoolPredFailure . addPrefix . T.pack . show . NE.toList
-  pure ledgerState
+    ConwayMempoolFailure . addPrefix . T.pack . show . NE.toList
+  trans @(EraRule "LEDGER" era) $ TRC trc
+
+instance
+  ( AlonzoEraTx era
+  , ConwayEraTxBody era
+  , ConwayEraGov era
+  , BaseM (EraRule "CERTS" era) ~ ShelleyBase
+  , BaseM (EraRule "GOV" era) ~ ShelleyBase
+  , BaseM (EraRule "UTXOW" era) ~ ShelleyBase
+  , Embed (EraRule "CERTS" era) (ConwayLEDGER era)
+  , Embed (EraRule "GOV" era) (ConwayLEDGER era)
+  , Embed (EraRule "UTXOW" era) (ConwayLEDGER era)
+  , Environment (EraRule "CERTS" era) ~ CertsEnv era
+  , Environment (EraRule "GOV" era) ~ GovEnv era
+  , Environment (EraRule "UTXOW" era) ~ UtxoEnv era
+  , State (EraRule "CERTS" era) ~ CertState era
+  , State (EraRule "GOV" era) ~ Proposals era
+  , State (EraRule "UTXOW" era) ~ UTxOState era
+  , GovState era ~ ConwayGovState era
+  , Signal (EraRule "CERTS" era) ~ Seq (TxCert era)
+  , Signal (EraRule "GOV" era) ~ GovSignal era
+  , Signal (EraRule "UTXOW" era) ~ Tx era
+  ) =>
+  Embed (ConwayLEDGER era) (ConwayMEMPOOL era)
+  where
+  wrapFailed = id
+  wrapEvent = id

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

@@ -226,9 +226,6 @@ instance
   where
   arbitrary = genericArbitraryU
 
-instance Arbitrary (ConwayMempoolPredFailure era) where
-  arbitrary = genericArbitraryU
-
 instance
   ( EraTxOut era
   , Arbitrary (Value era)

eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Binary/RoundTrip.hs

@@ -84,7 +84,6 @@ instance RuleListEra ConwayEra where
        , "GOV"
        , "LEDGER"
        , "LEDGERS"
-       , "MEMPOOL"
        , "POOL"
        , "UTXO"
        , "UTXOS"

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

@@ -28,7 +28,6 @@ import Cardano.Ledger.Conway.Rules (
   ConwayHardForkEvent,
   ConwayLedgerEvent,
   ConwayLedgerPredFailure,
-  ConwayMempoolEvent,
   ConwayNewEpochEvent,
  )
 import Cardano.Ledger.Conway.TxInfo (ConwayContextError)
@@ -85,7 +84,6 @@ spec ::
   , InjectRuleEvent "TICK" ConwayEpochEvent era
   , Event (EraRule "EPOCH" era) ~ ConwayEpochEvent era
   , Event (EraRule "NEWEPOCH" era) ~ ConwayNewEpochEvent era
-  , Event (EraRule "MEMPOOL" era) ~ ConwayMempoolEvent era
   , Event (EraRule "LEDGERS" era) ~ ShelleyLedgersEvent era
   , Event (EraRule "LEDGER" era) ~ ConwayLedgerEvent era
   , Event (EraRule "HARDFORK" era) ~ ConwayHardForkEvent era
@@ -127,7 +125,6 @@ conwaySpec ::
   , InjectRuleEvent "TICK" ConwayEpochEvent era
   , Event (EraRule "EPOCH" era) ~ ConwayEpochEvent era
   , Event (EraRule "NEWEPOCH" era) ~ ConwayNewEpochEvent era
-  , Event (EraRule "MEMPOOL" era) ~ ConwayMempoolEvent era
   , Event (EraRule "LEDGERS" era) ~ ShelleyLedgersEvent era
   , Event (EraRule "LEDGER" era) ~ ConwayLedgerEvent era
   , Event (EraRule "HARDFORK" era) ~ ConwayHardForkEvent era

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

@@ -16,7 +16,6 @@ import Cardano.Ledger.Conway.Governance
 import Cardano.Ledger.Conway.Rules (
   ConwayLedgerEvent (..),
   ConwayLedgerPredFailure (..),
-  ConwayMempoolEvent (..),
   maxRefScriptSizePerTx,
  )
 import Cardano.Ledger.Credential (Credential (..))
@@ -44,7 +43,6 @@ spec ::
   forall era.
   ( ConwayEraImp era
   , InjectRuleFailure "LEDGER" ConwayLedgerPredFailure era
-  , Event (EraRule "MEMPOOL" era) ~ ConwayMempoolEvent era
   , BaseM (EraRule "LEDGERS" era) ~ ShelleyBase
   , Environment (EraRule "LEDGERS" era) ~ ShelleyLedgersEnv era
   , Signal (EraRule "LEDGERS" era) ~ Seq.Seq (Tx era)
@@ -235,7 +233,7 @@ spec = do
           (LedgersEnv slotNo epochNo pp account)
           ls
           (Seq.singleton tx)
-      let mempoolEvents = [ev | LedgerEvent ev@(MempoolEvent (ConwayMempoolEvent _)) <- evs]
+      let mempoolEvents = [ev | LedgerEvent ev <- evs]
       mempoolEvents `shouldBeExpr` []
 
     it "Mempool events should be emitted via `applyTx` with `mkMempoolEnv`" $ do
@@ -256,7 +254,7 @@ spec = do
         Left e ->
           assertFailure $ "Unexpected failure while applyingTx: " <> show tx <> ": " <> show e
         Right (_, evs) ->
-          length [ev | ev@(MempoolEvent (ConwayMempoolEvent _)) <- evs] `shouldBe` 1
+          length [ev | ev <- evs] `shouldBe` 1
 
     it "Unelected Committee voting" $ whenPostBootstrap $ do
       globals <- use impGlobalsL

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

@@ -290,5 +290,3 @@ instance
   , ToExpr (Tx era)
   ) =>
   ToExpr (CertsEnv era)
-
-instance ToExpr (ConwayMempoolEvent era)