From 52f174bc77f591a5753840c2c40283954b564af8 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Joosep=20J=C3=A4=C3=A4ger?= Date: Wed, 11 Dec 2024 12:58:48 +0200 Subject: [PATCH] Revert "Undid ImpredicativeTypes because of GHC8" This reverts commit d99e0cd2d31e78e4acb222a4d36511f2c7a5c926. --- .../Test/Cardano/Ledger/Shelley/ImpTest.hs | 35 +++++++++++++++---- .../Test/Cardano/Ledger/Conformance/Imp.hs | 30 ++++++++++++++-- 2 files changed, 55 insertions(+), 10 deletions(-) diff --git a/eras/shelley/impl/testlib/Test/Cardano/Ledger/Shelley/ImpTest.hs b/eras/shelley/impl/testlib/Test/Cardano/Ledger/Shelley/ImpTest.hs index 9e3c186435a..a53fa2f26cc 100644 --- a/eras/shelley/impl/testlib/Test/Cardano/Ledger/Shelley/ImpTest.hs +++ b/eras/shelley/impl/testlib/Test/Cardano/Ledger/Shelley/ImpTest.hs @@ -1,4 +1,5 @@ {-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DefaultSignatures #-} {-# LANGUAGE FlexibleContexts #-} @@ -6,6 +7,7 @@ {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE ImplicitParams #-} +{-# LANGUAGE ImpredicativeTypes #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE NumericUnderscores #-} @@ -22,6 +24,7 @@ module Test.Cardano.Ledger.Shelley.ImpTest ( ImpTestM, + BaseImpM, LedgerSpec, SomeSTSEvent (..), ImpTestState, @@ -289,6 +292,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 @@ -640,7 +657,7 @@ modifyImpInitExpectLedgerRuleConformance :: LedgerEnv era -> LedgerState era -> Tx era -> - Expectation + BaseImpM () ) -> SpecWith (ImpInit (LedgerSpec era)) -> SpecWith (ImpInit (LedgerSpec era)) @@ -800,11 +817,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 } @@ -823,7 +836,7 @@ iteExpectLedgerRuleConformanceL :: LedgerEnv era -> LedgerState era -> Tx era -> - Expectation + BaseImpM () ) iteExpectLedgerRuleConformanceL = lens iteExpectLedgerRuleConformance (\x y -> x {iteExpectLedgerRuleConformance = y}) @@ -1071,6 +1084,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 @@ -1090,7 +1105,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 @@ -1123,6 +1143,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. diff --git a/libs/cardano-ledger-conformance/test/Test/Cardano/Ledger/Conformance/Imp.hs b/libs/cardano-ledger-conformance/test/Test/Cardano/Ledger/Conformance/Imp.hs index 0db1fe163d0..fbad16eff44 100644 --- a/libs/cardano-ledger-conformance/test/Test/Cardano/Ledger/Conformance/Imp.hs +++ b/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 @@ -53,6 +58,7 @@ testImpConformance :: , ExecEnvironment ConwayFn "LEDGER" era ~ LedgerEnv era , Tx era ~ AlonzoTx era , SpecTranslate (ConwayTxBodyTransContext (EraCrypto era)) (TxBody era) + , ToExpr (SpecRep (PredicateFailure (EraRule "LEDGER" era))) ) => Globals -> Either @@ -61,8 +67,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 = @@ -100,8 +106,26 @@ 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 impRuleResult + logDoc $ diffConformance impResponse agdaResponse +#endif + when (impResponse /= agdaResponse) $ assertFailure "Conformance failure" +{- FOURMOLU_ENABLE -} spec :: Spec spec =