From 4fba42ef52d28e996ab65ca8efb50159b6f0423f Mon Sep 17 00:00:00 2001
From: Ben Gamari <ben@smart-cactus.org>
Date: Sat, 11 Mar 2023 11:51:04 -0500
Subject: [PATCH] compiler: Default and warn ExceptionContext constraints
---
compiler/GHC/Builtin/Names.hs | 19 ++++++
compiler/GHC/Core/Predicate.hs | 23 +++++++
compiler/GHC/Driver/Flags.hs | 2 +
compiler/GHC/Driver/Session.hs | 1 +
compiler/GHC/Tc/Errors/Ppr.hs | 15 +++++
compiler/GHC/Tc/Errors/Types.hs | 8 +++
compiler/GHC/Tc/Solver.hs | 65 +++++++++++++------
compiler/GHC/Types/Error/Codes.hs | 1 +
docs/users_guide/using-warnings.rst | 17 +++++
.../src/GHC/Internal/Exception/Context.hs | 3 +
.../WarnDefaultedExceptionContext.hs | 9 +++
.../WarnDefaultedExceptionContext.stderr | 6 ++
.../tests/typecheck/should_compile/all.T | 1 +
.../should_run/DefaultExceptionContext.hs | 20 ++++++
testsuite/tests/typecheck/should_run/all.T | 1 +
15 files changed, 171 insertions(+), 20 deletions(-)
create mode 100644 testsuite/tests/typecheck/should_compile/WarnDefaultedExceptionContext.hs
create mode 100644 testsuite/tests/typecheck/should_compile/WarnDefaultedExceptionContext.stderr
create mode 100644 testsuite/tests/typecheck/should_run/DefaultExceptionContext.hs
diff --git a/compiler/GHC/Builtin/Names.hs b/compiler/GHC/Builtin/Names.hs
index 54ceb0ae16e3..363b3024fc0c 100644
--- a/compiler/GHC/Builtin/Names.hs
+++ b/compiler/GHC/Builtin/Names.hs
@@ -456,6 +456,10 @@ basicKnownKeyNames
-- Overloaded record fields
hasFieldClassName,
+ -- ExceptionContext
+ exceptionContextTyConName,
+ emptyExceptionContextName,
+
-- Call Stacks
callStackTyConName,
emptyCallStackName, pushCallStackName,
@@ -577,6 +581,7 @@ gHC_INTERNAL_BASE, gHC_INTERNAL_ENUM,
gHC_INTERNAL_SHOW, gHC_INTERNAL_READ, gHC_INTERNAL_NUM, gHC_INTERNAL_MAYBE,
gHC_INTERNAL_LIST, gHC_INTERNAL_TUPLE, gHC_INTERNAL_DATA_EITHER,
gHC_INTERNAL_DATA_FOLDABLE, gHC_INTERNAL_DATA_TRAVERSABLE,
+ gHC_INTERNAL_EXCEPTION_CONTEXT,
gHC_INTERNAL_CONC, gHC_INTERNAL_IO, gHC_INTERNAL_IO_Exception,
gHC_INTERNAL_ST, gHC_INTERNAL_IX, gHC_INTERNAL_STABLE, gHC_INTERNAL_PTR, gHC_INTERNAL_ERR, gHC_INTERNAL_REAL,
gHC_INTERNAL_FLOAT, gHC_INTERNAL_TOP_HANDLER, gHC_INTERNAL_SYSTEM_IO, gHC_INTERNAL_DYNAMIC,
@@ -628,6 +633,7 @@ gHC_INTERNAL_RANDOM = mkGhcInternalModule (fsLit "GHC.Internal.S
gHC_INTERNAL_EXTS = mkGhcInternalModule (fsLit "GHC.Internal.Exts")
gHC_INTERNAL_IS_LIST = mkGhcInternalModule (fsLit "GHC.Internal.IsList")
gHC_INTERNAL_CONTROL_EXCEPTION_BASE = mkGhcInternalModule (fsLit "GHC.Internal.Control.Exception.Base")
+gHC_INTERNAL_EXCEPTION_CONTEXT = mkGhcInternalModule (fsLit "GHC.Internal.Exception.Context")
gHC_INTERNAL_GENERICS = mkGhcInternalModule (fsLit "GHC.Internal.Generics")
gHC_INTERNAL_TYPEERROR = mkGhcInternalModule (fsLit "GHC.Internal.TypeError")
gHC_INTERNAL_TYPELITS = mkGhcInternalModule (fsLit "GHC.Internal.TypeLits")
@@ -1615,6 +1621,13 @@ hasFieldClassName :: Name
hasFieldClassName
= clsQual gHC_INTERNAL_RECORDS (fsLit "HasField") hasFieldClassNameKey
+-- ExceptionContext
+exceptionContextTyConName, emptyExceptionContextName :: Name
+exceptionContextTyConName =
+ tcQual gHC_INTERNAL_EXCEPTION_CONTEXT (fsLit "ExceptionContext") exceptionContextTyConKey
+emptyExceptionContextName
+ = varQual gHC_INTERNAL_EXCEPTION_CONTEXT (fsLit "emptyExceptionContext") emptyExceptionContextKey
+
-- Source Locations
callStackTyConName, emptyCallStackName, pushCallStackName,
srcLocDataConName :: Name
@@ -2094,6 +2107,9 @@ constPtrTyConKey = mkPreludeTyConUnique 417
jsvalTyConKey = mkPreludeTyConUnique 418
+exceptionContextTyConKey :: Unique
+exceptionContextTyConKey = mkPreludeTyConUnique 420
+
{-
************************************************************************
* *
@@ -2544,6 +2560,9 @@ fromStaticPtrClassOpKey = mkPreludeMiscIdUnique 560
makeStaticKey :: Unique
makeStaticKey = mkPreludeMiscIdUnique 561
+emptyExceptionContextKey :: Unique
+emptyExceptionContextKey = mkPreludeMiscIdUnique 562
+
-- Unsafe coercion proofs
unsafeEqualityProofIdKey, unsafeCoercePrimIdKey :: Unique
unsafeEqualityProofIdKey = mkPreludeMiscIdUnique 570
diff --git a/compiler/GHC/Core/Predicate.hs b/compiler/GHC/Core/Predicate.hs
index be9195b27b2f..12767b9956ac 100644
--- a/compiler/GHC/Core/Predicate.hs
+++ b/compiler/GHC/Core/Predicate.hs
@@ -27,6 +27,7 @@ module GHC.Core.Predicate (
-- Implicit parameters
isIPLikePred, mentionsIP, isIPTyCon, isIPClass,
isCallStackTy, isCallStackPred, isCallStackPredTy,
+ isExceptionContextPred,
isIPPred_maybe,
-- Evidence variables
@@ -277,6 +278,28 @@ isIPPred_maybe cls tys
| otherwise
= Nothing
+-- --------------------- ExceptionContext predicates --------------------------
+
+-- | Is a 'PredType' an @ExceptionContext@ implicit parameter?
+--
+-- If so, return the name of the parameter.
+isExceptionContextPred :: Class -> [Type] -> Maybe FastString
+isExceptionContextPred cls tys
+ | [ty1, ty2] <- tys
+ , isIPClass cls
+ , isExceptionContextTy ty2
+ = isStrLitTy ty1
+ | otherwise
+ = Nothing
+
+-- | Is a type a 'CallStack'?
+isExceptionContextTy :: Type -> Bool
+isExceptionContextTy ty
+ | Just tc <- tyConAppTyCon_maybe ty
+ = tc `hasKey` exceptionContextTyConKey
+ | otherwise
+ = False
+
-- --------------------- CallStack predicates ---------------------------------
isCallStackPredTy :: Type -> Bool
diff --git a/compiler/GHC/Driver/Flags.hs b/compiler/GHC/Driver/Flags.hs
index 070a09394473..39c8fb330cff 100644
--- a/compiler/GHC/Driver/Flags.hs
+++ b/compiler/GHC/Driver/Flags.hs
@@ -706,6 +706,7 @@ data WarningFlag =
| Opt_WarnInconsistentFlags -- Since 9.8
| Opt_WarnDataKindsTC -- Since 9.10
| Opt_WarnDeprecatedTypeAbstractions -- Since 9.10
+ | Opt_WarnDefaultedExceptionContext -- Since 9.10
deriving (Eq, Ord, Show, Enum, Bounded)
-- | Return the names of a WarningFlag
@@ -821,6 +822,7 @@ warnFlagNames wflag = case wflag of
Opt_WarnInconsistentFlags -> "inconsistent-flags" :| []
Opt_WarnDataKindsTC -> "data-kinds-tc" :| []
Opt_WarnDeprecatedTypeAbstractions -> "deprecated-type-abstractions" :| []
+ Opt_WarnDefaultedExceptionContext -> "defaulted-exception-context" :| []
-- -----------------------------------------------------------------------------
-- Standard sets of warning options
diff --git a/compiler/GHC/Driver/Session.hs b/compiler/GHC/Driver/Session.hs
index 228918452543..b8eaf91f37b7 100644
--- a/compiler/GHC/Driver/Session.hs
+++ b/compiler/GHC/Driver/Session.hs
@@ -2301,6 +2301,7 @@ wWarningFlagsDeps = [minBound..maxBound] >>= \x -> case x of
Opt_WarnIncompleteRecordSelectors -> warnSpec x
Opt_WarnDataKindsTC -> warnSpec x
Opt_WarnDeprecatedTypeAbstractions -> warnSpec x
+ Opt_WarnDefaultedExceptionContext -> warnSpec x
warningGroupsDeps :: [(Deprecation, FlagSpec WarningGroup)]
warningGroupsDeps = map mk warningGroups
diff --git a/compiler/GHC/Tc/Errors/Ppr.hs b/compiler/GHC/Tc/Errors/Ppr.hs
index 01b7f6b4af73..ef4fe07f8818 100644
--- a/compiler/GHC/Tc/Errors/Ppr.hs
+++ b/compiler/GHC/Tc/Errors/Ppr.hs
@@ -1806,6 +1806,17 @@ instance Diagnostic TcRnMessage where
TcRnNonCanonicalDefinition reason inst_ty
-> mkSimpleDecorated $
pprNonCanonicalDefinition inst_ty reason
+ TcRnDefaultedExceptionContext ct_loc ->
+ mkSimpleDecorated $ vcat [ header, warning, proposal ]
+ where
+ header, warning, proposal :: SDoc
+ header
+ = vcat [ text "Solving for an implicit ExceptionContext constraint"
+ , nest 2 $ pprCtOrigin (ctLocOrigin ct_loc) <> text "." ]
+ warning
+ = vcat [ text "Future versions of GHC will turn this warning into an error." ]
+ proposal
+ = vcat [ text "See GHC Proposal #330." ]
TcRnImplicitImportOfPrelude
-> mkSimpleDecorated $
text "Module" <+> quotes (text "Prelude") <+> text "implicitly imported."
@@ -2503,6 +2514,8 @@ instance Diagnostic TcRnMessage where
-> WarningWithFlag Opt_WarnNonCanonicalMonoidInstances
TcRnNonCanonicalDefinition (NonCanonicalMonad _) _
-> WarningWithFlag Opt_WarnNonCanonicalMonadInstances
+ TcRnDefaultedExceptionContext{}
+ -> WarningWithFlag Opt_WarnDefaultedExceptionContext
TcRnImplicitImportOfPrelude {}
-> WarningWithFlag Opt_WarnImplicitPrelude
TcRnMissingMain {}
@@ -3169,6 +3182,8 @@ instance Diagnostic TcRnMessage where
-> noHints
TcRnNonCanonicalDefinition reason _
-> suggestNonCanonicalDefinition reason
+ TcRnDefaultedExceptionContext _
+ -> noHints
TcRnImplicitImportOfPrelude {}
-> noHints
TcRnMissingMain {}
diff --git a/compiler/GHC/Tc/Errors/Types.hs b/compiler/GHC/Tc/Errors/Types.hs
index ec2e4aa3e2a5..d313a844f591 100644
--- a/compiler/GHC/Tc/Errors/Types.hs
+++ b/compiler/GHC/Tc/Errors/Types.hs
@@ -4263,6 +4263,14 @@ data TcRnMessage where
-}
TcRnNamespacedFixitySigWithoutFlag :: FixitySig GhcPs -> TcRnMessage
+ {-| TcRnDefaultedExceptionContext is a warning that is triggered when the
+ backward-compatibility logic solving for implicit ExceptionContext
+ constraints fires.
+
+ Test cases: DefaultExceptionContext
+ -}
+ TcRnDefaultedExceptionContext :: CtLoc -> TcRnMessage
+
deriving Generic
----
diff --git a/compiler/GHC/Tc/Solver.hs b/compiler/GHC/Tc/Solver.hs
index 947cdf88ca7d..f29451b0259d 100644
--- a/compiler/GHC/Tc/Solver.hs
+++ b/compiler/GHC/Tc/Solver.hs
@@ -68,6 +68,7 @@ import GHC.Core.Unify ( tcMatchTyKis )
import GHC.Unit.Module ( getModule )
import GHC.Utils.Misc
import GHC.Utils.Panic
+import GHC.Types.TyThing ( MonadThings(lookupId) )
import GHC.Types.Var
import GHC.Types.Var.Env
import GHC.Types.Var.Set
@@ -83,7 +84,7 @@ import Data.Foldable ( toList, traverse_ )
import Data.List ( partition )
import Data.List.NonEmpty ( NonEmpty(..), nonEmpty )
import qualified Data.List.NonEmpty as NE
-import GHC.Data.Maybe ( mapMaybe )
+import GHC.Data.Maybe ( mapMaybe, runMaybeT, MaybeT )
{-
*********************************************************************************
@@ -548,10 +549,7 @@ simplifyTopWanteds wanteds
try_callstack_defaulting :: WantedConstraints -> TcS WantedConstraints
try_callstack_defaulting wc
- | isEmptyWC wc
- = return wc
- | otherwise
- = defaultCallStacks wc
+ = defaultConstraints [defaultCallStack, defaultExceptionContext] wc
-- | If an implication contains a Given of the form @Unsatisfiable msg@, use
-- it to solve all Wanteds within the implication.
@@ -696,19 +694,56 @@ This allows us to indirectly box constraints with different representations
(such as primitive equality constraints).
-}
+-- | A 'TcS' action which can may default a 'Ct'.
+type CtDefaultingStrategy = Ct -> MaybeT TcS ()
+
+-- | Default @ExceptionContext@ constraints to @emptyExceptionContext@.
+defaultExceptionContext :: CtDefaultingStrategy
+defaultExceptionContext ct
+ = do { ClassPred cls tys <- pure $ classifyPredType (ctPred ct)
+ ; Just {} <- pure $ isExceptionContextPred cls tys
+ ; emptyEC <- Var <$> lift (lookupId emptyExceptionContextName)
+ ; let ev = ctEvidence ct
+ ; let ev_tm = mkEvCast emptyEC (wrapIP (ctEvPred ev))
+ ; lift $ warnTcS $ TcRnDefaultedExceptionContext (ctLoc ct)
+ ; lift $ setEvBindIfWanted ev False ev_tm
+ }
+
-- | Default any remaining @CallStack@ constraints to empty @CallStack@s.
-defaultCallStacks :: WantedConstraints -> TcS WantedConstraints
-- See Note [Overview of implicit CallStacks] in GHC.Tc.Types.Evidence
-defaultCallStacks wanteds
+defaultCallStack :: CtDefaultingStrategy
+defaultCallStack ct
+ = do { ClassPred cls tys <- pure $ classifyPredType (ctPred ct)
+ ; Just {} <- pure $ isCallStackPred cls tys
+ ; lift $ solveCallStack (ctEvidence ct) EvCsEmpty
+ }
+
+defaultConstraints :: [CtDefaultingStrategy]
+ -> WantedConstraints
+ -> TcS WantedConstraints
+-- See Note [Overview of implicit CallStacks] in GHC.Tc.Types.Evidence
+defaultConstraints defaulting_strategies wanteds
+ | isEmptyWC wanteds = return wanteds
+ | otherwise
= do simples <- handle_simples (wc_simple wanteds)
mb_implics <- mapBagM handle_implic (wc_impl wanteds)
return (wanteds { wc_simple = simples
, wc_impl = catBagMaybes mb_implics })
where
-
+ handle_simples :: Bag Ct -> TcS (Bag Ct)
handle_simples simples
- = catBagMaybes <$> mapBagM defaultCallStack simples
+ = catBagMaybes <$> mapBagM handle_simple simples
+ where
+ handle_simple :: Ct -> TcS (Maybe Ct)
+ handle_simple ct = go defaulting_strategies
+ where
+ go [] = return (Just ct)
+ go (f:fs) = do
+ mb <- runMaybeT (f ct)
+ case mb of
+ Just () -> return Nothing
+ Nothing -> go fs
handle_implic :: Implication -> TcS (Maybe Implication)
-- The Maybe is because solving the CallStack constraint
@@ -720,19 +755,9 @@ defaultCallStacks wanteds
= do { wanteds <- setEvBindsTcS (ic_binds implic) $
-- defaultCallStack sets a binding, so
-- we must set the correct binding group
- defaultCallStacks (ic_wanted implic)
+ defaultConstraints defaulting_strategies (ic_wanted implic)
; setImplicationStatus (implic { ic_wanted = wanteds }) }
- defaultCallStack ct
- | ClassPred cls tys <- classifyPredType (ctPred ct)
- , Just {} <- isCallStackPred cls tys
- = do { solveCallStack (ctEvidence ct) EvCsEmpty
- ; return Nothing }
-
- defaultCallStack ct
- = return (Just ct)
-
-
{- Note [When to do type-class defaulting]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
In GHC 7.6 and 7.8.2, we did type-class defaulting only if insolubleWC
diff --git a/compiler/GHC/Types/Error/Codes.hs b/compiler/GHC/Types/Error/Codes.hs
index 751bab158c1c..f45cf0fdfb81 100644
--- a/compiler/GHC/Types/Error/Codes.hs
+++ b/compiler/GHC/Types/Error/Codes.hs
@@ -588,6 +588,7 @@ type family GhcDiagnosticCode c = n | n -> c where
GhcDiagnosticCode "TcRnBindingNameConflict" = 10498
GhcDiagnosticCode "NonCanonicalMonoid" = 50928
GhcDiagnosticCode "NonCanonicalMonad" = 22705
+ GhcDiagnosticCode "TcRnDefaultedExceptionContext" = 46235
GhcDiagnosticCode "TcRnImplicitImportOfPrelude" = 20540
GhcDiagnosticCode "TcRnMissingMain" = 67120
GhcDiagnosticCode "TcRnGhciUnliftedBind" = 17999
diff --git a/docs/users_guide/using-warnings.rst b/docs/users_guide/using-warnings.rst
index 6713c8f7b971..ce0db740e8c3 100644
--- a/docs/users_guide/using-warnings.rst
+++ b/docs/users_guide/using-warnings.rst
@@ -2594,6 +2594,23 @@ of ``-W(no-)*``.
removed. Users can enable the :extension:`DataKinds` extension to avoid
issues (thus silencing the warning).
+.. ghc-flag:: -Wdefaulted-exception-context
+ :shortdesc: warn when an :base-ref:`Control.Exception.Context.ExceptionContext`
+ implicit parameter is defaulted to
+ :base-ref:`Control.Exception.Context.emptyExceptionContext`.
+ :type: dynamic
+ :reverse: -Wnop-defaulted-exception-context
+
+ :since: 9.10.1
+
+ Introduced in GHC 9.10.1 with the introduction of an implicit
+ :base-ref:`Control.Exception.Context.ExceptionContext`` context to
+ :base-ref:`Control.Exception.SomeException`. To preserve compatibility
+ with earlier compilers, this constraints is implicitly defaulted to
+ :base-ref:`Control.Exception.Context.emptyExceptionContext` when no other
+ evidence is available. As this behavior may result in dropped exception context
+ this warning is provided to give notice when defaulting occurs.
+
If you're feeling really paranoid, the :ghc-flag:`-dcore-lint` option is a good choice.
It turns on heavyweight intra-pass sanity-checking within GHC. (It checks GHC's
sanity, not yours.)
diff --git a/libraries/ghc-internal/src/GHC/Internal/Exception/Context.hs b/libraries/ghc-internal/src/GHC/Internal/Exception/Context.hs
index 7a3a64c04f45..2ae71102c673 100644
--- a/libraries/ghc-internal/src/GHC/Internal/Exception/Context.hs
+++ b/libraries/ghc-internal/src/GHC/Internal/Exception/Context.hs
@@ -46,6 +46,9 @@ import GHC.Internal.Data.Type.Equality ( (:~~:)(HRefl) )
--
-- 'ExceptionContext's can be merged via concatenation using the 'Semigroup'
-- instance or 'mergeExceptionContext'.
+--
+-- Note that GHC will automatically solve implicit constraints of type 'ExceptionContext'
+-- with 'emptyExceptionContext'.
data ExceptionContext = ExceptionContext [SomeExceptionAnnotation]
instance Semigroup ExceptionContext where
diff --git a/testsuite/tests/typecheck/should_compile/WarnDefaultedExceptionContext.hs b/testsuite/tests/typecheck/should_compile/WarnDefaultedExceptionContext.hs
new file mode 100644
index 000000000000..09a01af6acf7
--- /dev/null
+++ b/testsuite/tests/typecheck/should_compile/WarnDefaultedExceptionContext.hs
@@ -0,0 +1,9 @@
+module WarnDefaultedExceptionContext where
+
+import Control.Exception.Context
+import Control.Exception
+
+-- The implicit ExceptionContext constraint here should be defaulted with a warning
+exc :: SomeException
+exc = SomeException (userError "uh oh")
+
diff --git a/testsuite/tests/typecheck/should_compile/WarnDefaultedExceptionContext.stderr b/testsuite/tests/typecheck/should_compile/WarnDefaultedExceptionContext.stderr
new file mode 100644
index 000000000000..a868edc21462
--- /dev/null
+++ b/testsuite/tests/typecheck/should_compile/WarnDefaultedExceptionContext.stderr
@@ -0,0 +1,6 @@
+
+WarnDefaultedExceptionContext.hs:1:1: warning: [GHC-46235] [-Wdefaulted-exception-context]
+ Solving for an implicit ExceptionContext constraint
+ arising from a use of ‘SomeException’.
+ Future versions of GHC will turn this warning into an error.
+ See GHC Proposal #330.
diff --git a/testsuite/tests/typecheck/should_compile/all.T b/testsuite/tests/typecheck/should_compile/all.T
index a2f4b3ea7521..0d3ff57dbeca 100644
--- a/testsuite/tests/typecheck/should_compile/all.T
+++ b/testsuite/tests/typecheck/should_compile/all.T
@@ -911,3 +911,4 @@ test('T22788', normal, compile, [''])
test('T21206', normal, compile, [''])
test('T17594a', req_th, compile, [''])
test('T17594f', normal, compile, [''])
+test('WarnDefaultedExceptionContext', normal, compile, ['-Wdefaulted-exception-context'])
diff --git a/testsuite/tests/typecheck/should_run/DefaultExceptionContext.hs b/testsuite/tests/typecheck/should_run/DefaultExceptionContext.hs
new file mode 100644
index 000000000000..42e3357dd4d5
--- /dev/null
+++ b/testsuite/tests/typecheck/should_run/DefaultExceptionContext.hs
@@ -0,0 +1,20 @@
+module Main where
+
+import Control.Exception.Context
+import Control.Exception
+
+data TestError = TestError
+ deriving (Show)
+
+instance Exception TestError
+
+-- The implicit ExceptionContext constraint here should be defaulted
+exc :: SomeException
+exc = SomeException TestError
+
+main :: IO ()
+main = do
+ case getAllExceptionAnnotations (someExceptionContext exc) of
+ [] -> return ()
+ _ -> fail "unexpected ExceptionContext"
+
diff --git a/testsuite/tests/typecheck/should_run/all.T b/testsuite/tests/typecheck/should_run/all.T
index 4e189e0adb8e..f27df87c541e 100755
--- a/testsuite/tests/typecheck/should_run/all.T
+++ b/testsuite/tests/typecheck/should_run/all.T
@@ -178,3 +178,4 @@ test('T18324', normal, compile_and_run, [''])
test('T15598', normal, compile_and_run, [''])
test('T22086', normal, compile_and_run, [''])
test('T24411', normal, compile_and_run, [''])
+test('DefaultExceptionContext', normal, compile_and_run, [''])
--
GitLab