From 65ef348db5b1000df82264dfe74a2443425556d7 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. --- eras/shelley/impl/CHANGELOG.md | 1 + .../Test/Cardano/Ledger/Shelley/ImpTest.hs | 35 ++++++++++++++---- .../Test/Cardano/Ledger/Conformance/Imp.hs | 37 +++++++++++++++++-- 3 files changed, 63 insertions(+), 10 deletions(-) diff --git a/eras/shelley/impl/CHANGELOG.md b/eras/shelley/impl/CHANGELOG.md index 63adc566992..6ae7ba7436b 100644 --- a/eras/shelley/impl/CHANGELOG.md +++ b/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`. 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 39485cccec6..656e8c7dcc1 100644 --- a/eras/shelley/impl/testlib/Test/Cardano/Ledger/Shelley/ImpTest.hs +++ b/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. 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 5b48175f9af..c099e372146 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 @@ -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 =