Merge pull request #4748 from IntersectMBO/aniketd/tx-imptest-conform…

…ance

Add Conformance.Imp: imptests with conformance

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

@@ -6,7 +6,7 @@
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE TypeOperators #-}
 
-module Test.Cardano.Ledger.Conway.Imp (spec) where
+module Test.Cardano.Ledger.Conway.Imp (spec, conwaySpec) where
 
 import Cardano.Ledger.Alonzo.Plutus.Context (EraPlutusContext (..))
 import Cardano.Ledger.Alonzo.Rules (
@@ -54,18 +54,23 @@ import qualified Test.Cardano.Ledger.Conway.Imp.LedgerSpec as Ledger
 import qualified Test.Cardano.Ledger.Conway.Imp.RatifySpec as Ratify
 import qualified Test.Cardano.Ledger.Conway.Imp.UtxoSpec as Utxo
 import qualified Test.Cardano.Ledger.Conway.Imp.UtxosSpec as Utxos
-import Test.Cardano.Ledger.Conway.ImpTest (ConwayEraImp, LedgerSpec, modifyImpInitProtVer)
+import Test.Cardano.Ledger.Conway.ImpTest (
+  ConwayEraImp,
+  LedgerSpec,
+  modifyImpInitProtVer,
+ )
 import Test.Cardano.Ledger.Imp.Common
+import Test.Cardano.Ledger.Shelley.ImpTest (ImpInit)
 
 spec ::
   forall era.
   ( Arbitrary (TxAuxData era)
   , ConwayEraImp era
   , EraSegWits era
-  , InjectRuleFailure "LEDGER" ConwayGovPredFailure era
-  , InjectRuleFailure "LEDGER" ConwayCertsPredFailure era
   , Inject (BabbageContextError era) (ContextError era)
   , Inject (ConwayContextError era) (ContextError era)
+  , InjectRuleFailure "LEDGER" ConwayGovPredFailure era
+  , InjectRuleFailure "LEDGER" ConwayCertsPredFailure era
   , InjectRuleFailure "LEDGER" BabbageUtxoPredFailure era
   , InjectRuleFailure "LEDGER" BabbageUtxowPredFailure era
   , InjectRuleFailure "LEDGER" AlonzoUtxoPredFailure era
@@ -77,38 +82,75 @@ spec ::
   , InjectRuleFailure "LEDGER" ConwayGovCertPredFailure era
   , InjectRuleFailure "LEDGER" ConwayLedgerPredFailure era
   , InjectRuleFailure "BBODY" ConwayBbodyPredFailure era
-  , NFData (Event (EraRule "ENACT" era))
-  , ToExpr (Event (EraRule "ENACT" era))
-  , Eq (Event (EraRule "ENACT" era))
-  , Typeable (Event (EraRule "ENACT" era))
   , 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
   , BaseM (EraRule "LEDGERS" era) ~ ShelleyBase
   , Environment (EraRule "LEDGERS" era) ~ ShelleyLedgersEnv era
   , Signal (EraRule "LEDGERS" era) ~ Seq (Tx era)
   , STS (EraRule "LEDGERS" era)
   , ApplyTx era
-  , Event (EraRule "HARDFORK" era) ~ ConwayHardForkEvent era
+  , NFData (Event (EraRule "ENACT" era))
+  , ToExpr (Event (EraRule "ENACT" era))
+  , Eq (Event (EraRule "ENACT" era))
+  , Typeable (Event (EraRule "ENACT" era))
   ) =>
   Spec
 spec = do
   BabbageImp.spec @era
   withImpInit @(LedgerSpec era) $
     forM_ (eraProtVersions @era) $ \protVer ->
       describe ("ConwayImpSpec - " <> show protVer) $
-        modifyImpInitProtVer protVer $ do
-          describe "BBODY" Bbody.spec
-          describe "CERTS" Certs.spec
-          describe "DELEG" Deleg.spec
-          describe "ENACT" Enact.spec
-          describe "EPOCH" Epoch.spec
-          describe "GOV" Gov.spec
-          describe "GOVCERT" GovCert.spec
-          describe "LEDGER" Ledger.spec
-          describe "RATIFY" Ratify.spec
-          describe "UTXO" Utxo.spec
-          describe "UTXOS" Utxos.spec
+        modifyImpInitProtVer protVer $
+          conwaySpec @era
+
+conwaySpec ::
+  forall era.
+  ( ConwayEraImp era
+  , EraSegWits era
+  , Inject (BabbageContextError era) (ContextError era)
+  , Inject (ConwayContextError era) (ContextError era)
+  , InjectRuleFailure "LEDGER" ConwayGovPredFailure era
+  , InjectRuleFailure "LEDGER" ConwayCertsPredFailure era
+  , InjectRuleFailure "LEDGER" BabbageUtxoPredFailure era
+  , InjectRuleFailure "LEDGER" AlonzoUtxosPredFailure era
+  , InjectRuleFailure "LEDGER" AlonzoUtxowPredFailure era
+  , InjectRuleFailure "LEDGER" ShelleyUtxowPredFailure era
+  , InjectRuleFailure "LEDGER" ConwayDelegPredFailure era
+  , InjectRuleFailure "LEDGER" ConwayGovCertPredFailure era
+  , InjectRuleFailure "LEDGER" ConwayLedgerPredFailure era
+  , InjectRuleFailure "BBODY" ConwayBbodyPredFailure era
+  , 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
+  , BaseM (EraRule "LEDGERS" era) ~ ShelleyBase
+  , Environment (EraRule "LEDGERS" era) ~ ShelleyLedgersEnv era
+  , Signal (EraRule "LEDGERS" era) ~ Seq (Tx era)
+  , STS (EraRule "LEDGERS" era)
+  , ApplyTx era
+  , NFData (Event (EraRule "ENACT" era))
+  , ToExpr (Event (EraRule "ENACT" era))
+  , Eq (Event (EraRule "ENACT" era))
+  , Typeable (Event (EraRule "ENACT" era))
+  ) =>
+  SpecWith (ImpInit (LedgerSpec era))
+conwaySpec = do
+  describe "BBODY" Bbody.spec
+  describe "CERTS" Certs.spec
+  describe "DELEG" Deleg.spec
+  describe "ENACT" Enact.spec
+  describe "EPOCH" Epoch.spec
+  describe "GOV" Gov.spec
+  describe "GOVCERT" GovCert.spec
+  describe "LEDGER" Ledger.spec
+  describe "RATIFY" Ratify.spec
+  describe "UTXO" Utxo.spec
+  describe "UTXOS" Utxos.spec

eras/shelley/impl/CHANGELOG.md

@@ -2,6 +2,13 @@
 
 ## 1.15.0.0
 
+* Add lenses for `LedgerEnv`. #4748
+  * `ledgerSlotNoL`
+  * `ledgerEpochNoL`
+  * `ledgerIxL`
+  * `ledgerPpL`
+  * `ledgerAccountL`
+  * `ledgerMempoolL`
 * Change `PoolEnv` to take `EpochNo` instead of `SlotNo`
 * Add `EpochNo` to `DelplEnv`
 * Add `Maybe EpochNo` to `LedgerEnv`
@@ -39,6 +46,9 @@
 
 ### `testlib`
 
+* Add `iteExpectLedgerRuleConformance` to `ImpTestEnv` for additionally checking conformance with ImpTests. #4748
+  * Add lens `iteExpectLedgerRuleConformanceL`.
+  * Add `modifyImpInitExpectLedgerRuleConformance`.
 * Added `tryLookupReward`
 * Switch to using `ImpSpec` package
 * Remove: `runImpTestM`, `runImpTestM_`, `evalImpTestM`, `execImpTestM`, `runImpTestGenM`, `runImpTestGenM_`, `evalImpTestGenM`, `execImpTestGenM`, `withImpState` and `withImpStateModified`.

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

@@ -19,6 +19,12 @@
 module Cardano.Ledger.Shelley.Rules.Ledger (
   ShelleyLEDGER,
   LedgerEnv (..),
+  ledgerSlotNoL,
+  ledgerEpochNoL,
+  ledgerIxL,
+  ledgerPpL,
+  ledgerAccountL,
+  ledgerMempoolL,
   ShelleyLedgerPredFailure (..),
   ShelleyLedgerEvent (..),
   Event,
@@ -119,6 +125,24 @@ data ShelleyLedgerPredFailure era
   | DelegsFailure (PredicateFailure (EraRule "DELEGS" era)) -- Subtransition Failures
   deriving (Generic)
 
+ledgerSlotNoL :: Lens' (LedgerEnv era) SlotNo
+ledgerSlotNoL = lens ledgerSlotNo $ \x y -> x {ledgerSlotNo = y}
+
+ledgerEpochNoL :: Lens' (LedgerEnv era) (Maybe EpochNo)
+ledgerEpochNoL = lens ledgerEpochNo $ \x y -> x {ledgerEpochNo = y}
+
+ledgerIxL :: Lens' (LedgerEnv era) TxIx
+ledgerIxL = lens ledgerIx $ \x y -> x {ledgerIx = y}
+
+ledgerPpL :: Lens' (LedgerEnv era) (PParams era)
+ledgerPpL = lens ledgerPp $ \x y -> x {ledgerPp = y}
+
+ledgerAccountL :: Lens' (LedgerEnv era) AccountState
+ledgerAccountL = lens ledgerAccount $ \x y -> x {ledgerAccount = y}
+
+ledgerMempoolL :: Lens' (LedgerEnv era) Bool
+ledgerMempoolL = lens ledgerMempool $ \x y -> x {ledgerMempool = y}
+
 type instance EraRuleFailure "LEDGER" (ShelleyEra c) = ShelleyLedgerPredFailure (ShelleyEra c)
 
 instance InjectRuleFailure "LEDGER" ShelleyLedgerPredFailure (ShelleyEra c)

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

@@ -1,12 +1,10 @@
 {-# LANGUAGE AllowAmbiguousTypes #-}
 {-# LANGUAGE DataKinds #-}
 {-# LANGUAGE DefaultSignatures #-}
-{-# LANGUAGE DeriveFunctor #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE FunctionalDependencies #-}
 {-# LANGUAGE GADTs #-}
-{-# LANGUAGE GeneralizedNewtypeDeriving #-}
 {-# LANGUAGE ImplicitParams #-}
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE NamedFieldPuns #-}
@@ -15,7 +13,6 @@
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE PatternSynonyms #-}
 {-# LANGUAGE RankNTypes #-}
-{-# LANGUAGE RecordWildCards #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TypeApplications #-}
 {-# LANGUAGE TypeFamilyDependencies #-}
@@ -100,6 +97,7 @@ module Test.Cardano.Ledger.Shelley.ImpTest (
   impEraStartEpochNo,
   impSetSeed,
   modifyImpInitProtVer,
+  modifyImpInitExpectLedgerRuleConformance,
 
   -- * Logging
   Doc,
@@ -286,7 +284,7 @@ import Test.Cardano.Ledger.Shelley.TreeDiff (Expr (..))
 import Test.Cardano.Slotting.Numeric ()
 import Test.ImpSpec
 import Type.Reflection (Typeable, typeOf)
-import UnliftIO.Exception (evaluateDeep)
+import UnliftIO (evaluateDeep)
 
 type ImpTestM era = ImpM (LedgerSpec era)
 
@@ -304,6 +302,7 @@ instance ShelleyEraImp era => ImpSpec (LedgerSpec era) where
             ImpTestEnv
               { iteFixup = fixupTx
               , iteCborRoundTripFailures = True
+              , iteExpectLedgerRuleConformance = \_ _ _ _ -> pure ()
               }
         , impInitState = initState
         }
@@ -631,6 +630,27 @@ modifyImpInitProtVer ver =
               .~ ProtVer ver 0
       }
 
+modifyImpInitExpectLedgerRuleConformance ::
+  forall era.
+  ShelleyEraImp era =>
+  ( Either
+      (NonEmpty (PredicateFailure (EraRule "LEDGER" era)))
+      (State (EraRule "LEDGER" era), [Event (EraRule "LEDGER" era)]) ->
+    LedgerEnv era ->
+    LedgerState era ->
+    Tx era ->
+    Expectation
+  ) ->
+  SpecWith (ImpInit (LedgerSpec era)) ->
+  SpecWith (ImpInit (LedgerSpec era))
+modifyImpInitExpectLedgerRuleConformance f =
+  modifyImpInit $ \impInit ->
+    impInit
+      { impInitEnv =
+          impInitEnv impInit
+            & iteExpectLedgerRuleConformanceL .~ f
+      }
+
 impLedgerEnv :: EraGov era => NewEpochState era -> ImpTestM era (LedgerEnv era)
 impLedgerEnv nes = do
   slotNo <- gets impLastTick
@@ -771,13 +791,34 @@ impWitsVKeyNeeded txBody = do
 
 data ImpTestEnv era = ImpTestEnv
   { iteFixup :: Tx era -> ImpTestM era (Tx era)
+  , iteExpectLedgerRuleConformance ::
+      Either
+        (NonEmpty (PredicateFailure (EraRule "LEDGER" era)))
+        (State (EraRule "LEDGER" era), [Event (EraRule "LEDGER" era)]) ->
+      LedgerEnv era ->
+      LedgerState era ->
+      Tx era ->
+      Expectation
   , iteCborRoundTripFailures :: !Bool
   -- ^ Expect failures in CBOR round trip serialization tests for predicate failures
   }
 
 iteFixupL :: Lens' (ImpTestEnv era) (Tx era -> ImpTestM era (Tx era))
 iteFixupL = lens iteFixup (\x y -> x {iteFixup = y})
 
+iteExpectLedgerRuleConformanceL ::
+  Lens'
+    (ImpTestEnv era)
+    ( Either
+        (NonEmpty (PredicateFailure (EraRule "LEDGER" era)))
+        (State (EraRule "LEDGER" era), [Event (EraRule "LEDGER" era)]) ->
+      LedgerEnv era ->
+      LedgerState era ->
+      Tx era ->
+      Expectation
+    )
+iteExpectLedgerRuleConformanceL = lens iteExpectLedgerRuleConformance (\x y -> x {iteExpectLedgerRuleConformance = y})
+
 iteCborRoundTripFailuresL :: Lens' (ImpTestEnv era) Bool
 iteCborRoundTripFailuresL = lens iteCborRoundTripFailures (\x y -> x {iteCborRoundTripFailures = y})
 
@@ -1036,6 +1077,11 @@ trySubmitTx tx = do
   ImpTestState {impRootTxIn} <- get
   res <- tryRunImpRule @"LEDGER" lEnv (st ^. nesEsL . esLStateL) txFixed
   roundTripCheck <- asks iteCborRoundTripFailures
+
+  -- Check for conformance
+  asks iteExpectLedgerRuleConformance
+    >>= (\f -> liftIO $ f res lEnv (st ^. nesEsL . esLStateL) txFixed)
+
   case res of
     Left predFailures -> do
       -- Verify that produced predicate failures are ready for the node-to-client protocol

libs/cardano-ledger-conformance/cardano-ledger-conformance.cabal

@@ -22,13 +22,13 @@ library
     exposed-modules:
         Test.Cardano.Ledger.Conformance
         Test.Cardano.Ledger.Conformance.ExecSpecRule.Core
+        Test.Cardano.Ledger.Conformance.SpecTranslate.Core
         Test.Cardano.Ledger.Conformance.ExecSpecRule.Conway
         Test.Cardano.Ledger.Conformance.ExecSpecRule.Conway.Base
         Test.Cardano.Ledger.Conformance.SpecTranslate.Conway
 
     hs-source-dirs:   src
     other-modules:
-        Test.Cardano.Ledger.Conformance.SpecTranslate.Core
         Test.Cardano.Ledger.Conformance.SpecTranslate.Conway.Base
         Test.Cardano.Ledger.Conformance.SpecTranslate.Conway.Deleg
         Test.Cardano.Ledger.Conformance.SpecTranslate.Conway.Pool
@@ -106,6 +106,7 @@ test-suite tests
         Test.Cardano.Ledger.Conformance.Spec.Conway
         Test.Cardano.Ledger.Conformance.ExecSpecRule.MiniTrace
         Test.Cardano.Ledger.Conformance.Imp.Ratify
+        Test.Cardano.Ledger.Conformance.Imp
 
     default-language: Haskell2010
     ghc-options:
@@ -126,4 +127,7 @@ test-suite tests
         cardano-ledger-alonzo,
         cardano-ledger-conway:{cardano-ledger-conway, testlib},
         cardano-ledger-test,
-        microlens
+        cardano-ledger-executable-spec,
+        microlens,
+        unliftio,
+        text

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

@@ -1,6 +1,7 @@
 module Test.Cardano.Ledger.Conformance.ExecSpecRule.Conway (
   module X,
   ConwayRatifyExecContext (..),
+  ConwayLedgerExecContext (..),
 ) where
 
 import Test.Cardano.Ledger.Conformance.ExecSpecRule.Conway.Base as X (
@@ -16,7 +17,9 @@ import Test.Cardano.Ledger.Conformance.ExecSpecRule.Conway.Certs as X (nameCerts
 import Test.Cardano.Ledger.Conformance.ExecSpecRule.Conway.Deleg as X (nameDelegCert)
 import Test.Cardano.Ledger.Conformance.ExecSpecRule.Conway.Gov as X ()
 import Test.Cardano.Ledger.Conformance.ExecSpecRule.Conway.GovCert as X (nameGovCert)
-import Test.Cardano.Ledger.Conformance.ExecSpecRule.Conway.Ledger as X ()
+import Test.Cardano.Ledger.Conformance.ExecSpecRule.Conway.Ledger as X (
+  ConwayLedgerExecContext (..),
+ )
 import Test.Cardano.Ledger.Conformance.ExecSpecRule.Conway.Ledgers as X ()
 import Test.Cardano.Ledger.Conformance.ExecSpecRule.Conway.Pool as X (namePoolCert)
 import Test.Cardano.Ledger.Conformance.ExecSpecRule.Conway.Utxo as X ()

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

@@ -13,7 +13,7 @@
 {-# LANGUAGE UndecidableInstances #-}
 {-# OPTIONS_GHC -Wno-orphans #-}
 
-module Test.Cardano.Ledger.Conformance.ExecSpecRule.Conway.Ledger () where
+module Test.Cardano.Ledger.Conformance.ExecSpecRule.Conway.Ledger (ConwayLedgerExecContext (..)) where
 
 import Data.Bifunctor (Bifunctor (..))
 import Data.Functor.Identity (Identity)

libs/cardano-ledger-conformance/src/Test/Cardano/Ledger/Conformance/ExecSpecRule/Core.hs

@@ -21,6 +21,8 @@ module Test.Cardano.Ledger.Conformance.ExecSpecRule.Core (
   checkConformance,
   defaultTestConformance,
   translateWithContext,
+  ForAllExecSpecRep,
+  ForAllExecTypes,
 ) where
 
 import Cardano.Ledger.BaseTypes (Inject (..), ShelleyBase)
@@ -279,7 +281,7 @@ checkConformance ctx env st sig implResTest agdaResTest = do
         dumpCbor path env "conformance_dump_env"
         dumpCbor path st "conformance_dump_st"
         dumpCbor path sig "conformance_dump_sig"
-        logDoc $ "Dumped a CBOR files to " <> ansiExpr path
+        logDoc $ "Dumped the CBOR files to " <> ansiExpr path
       Nothing ->
         logDoc $
           "Run the test again with "