Revert "Undid ImpredicativeTypes because of GHC8"

This reverts commit d99e0cd.

eras/shelley/impl/CHANGELOG.md

@@ -64,6 +64,7 @@
 
 ### `testlib`
 
+* Changed the return type of `iteExpectLedgerRuleConformance`
 * Add `runSTS`
 * Add `iteExpectLedgerRuleConformance` to `ImpTestEnv` for additionally checking conformance with ImpTests. #4748
   * Add lens `iteExpectLedgerRuleConformanceL`.

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

@@ -1,10 +1,12 @@
 {-# LANGUAGE AllowAmbiguousTypes #-}
+{-# LANGUAGE CPP #-}
 {-# LANGUAGE DataKinds #-}
 {-# LANGUAGE DefaultSignatures #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE GADTs #-}
 {-# LANGUAGE ImplicitParams #-}
+{-# LANGUAGE ImpredicativeTypes #-}
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE NamedFieldPuns #-}
@@ -22,6 +24,7 @@
 
 module Test.Cardano.Ledger.Shelley.ImpTest (
   ImpTestM,
+  BaseImpM,
   LedgerSpec,
   SomeSTSEvent (..),
   ImpTestState,
@@ -283,6 +286,20 @@ import UnliftIO (evaluateDeep)
 
 type ImpTestM era = ImpM (LedgerSpec era)
 
+-- TODO remove this once we get rid of the CPP directives
+{- FOURMOLU_DISABLE -}
+type BaseImpM a = -- TODO get rid of the CPP once we have deprecated GHC8
+#if __GLASGOW_HASKELL__ < 906
+  Expectation
+#else
+  forall t. ImpM t a
+  -- ^ Note the use of higher ranked types here. This prevents the hook from
+  -- accessing the state while still permitting the use of more general
+  -- functions that return some `ImpM t a` and that don't constrain the
+  -- state in any way (e.g. `logString`, `shouldBe` are still fine to use).
+#endif
+{- FOURMOLU_ENABLE -}
+
 data LedgerSpec era
 
 instance ShelleyEraImp era => ImpSpec (LedgerSpec era) where
@@ -622,7 +639,7 @@ modifyImpInitExpectLedgerRuleConformance ::
     LedgerEnv era ->
     LedgerState era ->
     Tx era ->
-    Expectation
+    BaseImpM ()
   ) ->
   SpecWith (ImpInit (LedgerSpec era)) ->
   SpecWith (ImpInit (LedgerSpec era))
@@ -775,11 +792,7 @@ data ImpTestEnv era = ImpTestEnv
       LedgerEnv era ->
       LedgerState era ->
       Tx era ->
-      Expectation
-  -- ^ Note the use of higher ranked types here. This prevents the hook from
-  -- accessing the state while still permitting the use of more general
-  -- functions that return some `ImpM t a` and that don't constrain the
-  -- state in any way (e.g. `logString`, `shouldBe` are still fine to use).
+      BaseImpM ()
   , iteCborRoundTripFailures :: !Bool
   -- ^ Expect failures in CBOR round trip serialization tests for predicate failures
   }
@@ -798,7 +811,7 @@ iteExpectLedgerRuleConformanceL ::
       LedgerEnv era ->
       LedgerState era ->
       Tx era ->
-      Expectation
+      BaseImpM ()
     )
 iteExpectLedgerRuleConformanceL = lens iteExpectLedgerRuleConformance (\x y -> x {iteExpectLedgerRuleConformance = y})
 
@@ -1046,6 +1059,8 @@ submitTx_ = void . submitTx
 submitTx :: (HasCallStack, ShelleyEraImp era) => Tx era -> ImpTestM era (Tx era)
 submitTx tx = trySubmitTx tx >>= expectRightDeepExpr . first fst
 
+-- TODO remove this once we get rid of the CPP directives
+{- FOURMOLU_DISABLE -}
 trySubmitTx ::
   forall era.
   ( ShelleyEraImp era
@@ -1065,7 +1080,12 @@ trySubmitTx tx = do
 
   -- Check for conformance
   asks iteExpectLedgerRuleConformance
+  -- TODO get rid of the CPP once we have deprecated GHC8
+#if __GLASGOW_HASKELL__ < 906
     >>= (\f -> liftIO $ f globals res lEnv (st ^. nesEsL . esLStateL) txFixed)
+#else
+    >>= (\f -> f globals res lEnv (st ^. nesEsL . esLStateL) txFixed)
+#endif
 
   case res of
     Left predFailures -> do
@@ -1098,6 +1118,7 @@ trySubmitTx tx = do
             | otherwise = error "Root not found in UTxO"
       impRootTxInL .= newRoot
       pure $ Right txFixed
+{- FOURMOLU_ENABLE -}
 
 -- | Submit a transaction that is expected to be rejected with the given predicate failures.
 -- The inputs and outputs are automatically balanced.

libs/cardano-ledger-conformance/test/Test/Cardano/Ledger/Conformance/Imp.hs

@@ -1,12 +1,15 @@
 {-# LANGUAGE AllowAmbiguousTypes #-}
+{-# LANGUAGE CPP #-}
 {-# LANGUAGE DataKinds #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE ImportQualifiedPost #-}
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TypeApplications #-}
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE TypeOperators #-}
+{-# OPTIONS_GHC -Wno-redundant-constraints #-}
 
 module Test.Cardano.Ledger.Conformance.Imp (spec) where
 
@@ -34,6 +37,8 @@ import Test.Cardano.Ledger.Conway.ImpTest
 import Test.Cardano.Ledger.Imp.Common hiding (Args)
 import UnliftIO (evaluateDeep)
 
+-- TODO remove this once we get rid of the CPP directives
+{- FOURMOLU_DISABLE -}
 testImpConformance ::
   forall era.
   ( ConwayEraImp era
@@ -50,6 +55,7 @@ testImpConformance ::
   , ExecEnvironment ConwayFn "LEDGER" era ~ LedgerEnv era
   , Tx era ~ AlonzoTx era
   , SpecTranslate ConwayTxBodyTransContext (TxBody era)
+  , ToExpr (SpecRep (PredicateFailure (EraRule "LEDGER" era)))
   ) =>
   Globals ->
   Either
@@ -58,8 +64,8 @@ testImpConformance ::
   ExecEnvironment ConwayFn "LEDGER" era ->
   ExecState ConwayFn "LEDGER" era ->
   ExecSignal ConwayFn "LEDGER" era ->
-  Expectation
-testImpConformance _ impRuleResult env state signal = do
+  BaseImpM ()
+testImpConformance _globals impRuleResult env state signal = do
   let ctx =
         ConwayLedgerExecContext
           { clecPolicyHash =
@@ -97,8 +103,33 @@ testImpConformance _ impRuleResult env state signal = do
           (toTestRep . inject @_ @(ExecState ConwayFn "LEDGER" era) . fst)
           impRuleResult
 
-  when (impResponse /= agdaResponse) $ do
+#if __GLASGOW_HASKELL__ >= 906
+  logString "implEnv"
+  logToExpr env
+  logString "implState"
+  logToExpr state
+  logString "implSignal"
+  logToExpr signal
+  logString "specEnv"
+  logToExpr specEnv
+  logString "specState"
+  logToExpr specState
+  logString "specSignal"
+  logToExpr specSignal
+  logString "Extra info:"
+  logDoc $
+    extraInfo @ConwayFn @"LEDGER" @era
+      _globals
+      ctx
+      env
+      state
+      signal
+      (first showOpaqueErrorString impRuleResult)
+  logDoc $ diffConformance impResponse agdaResponse
+#endif
+  when (impResponse /= agdaResponse) $
     assertFailure "Conformance failure"
+{- FOURMOLU_ENABLE -}
 
 spec :: Spec
 spec =