summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--compiler/GHC/Tc/Errors/Ppr.hs16
-rw-r--r--compiler/GHC/Tc/Errors/Types.hs8
-rw-r--r--compiler/GHC/Tc/Solver.hs3
-rw-r--r--compiler/GHC/Types/Error/Codes.hs1
4 files changed, 27 insertions, 1 deletions
diff --git a/compiler/GHC/Tc/Errors/Ppr.hs b/compiler/GHC/Tc/Errors/Ppr.hs
index 946b028e00..e70cd31db6 100644
--- a/compiler/GHC/Tc/Errors/Ppr.hs
+++ b/compiler/GHC/Tc/Errors/Ppr.hs
@@ -1238,6 +1238,18 @@ instance Diagnostic TcRnMessage where
= vcat [ text "Starting from GHC 9.10, this warning will turn into an error." ]
user_manual =
vcat [ text "See the user manual, ยง Undecidable instances and loopy superclasses." ]
+ 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." ]
+
diagnosticReason = \case
TcRnUnknownMessage m
@@ -1646,6 +1658,8 @@ instance Diagnostic TcRnMessage where
-> ErrorWithoutFlag
TcRnLoopySuperclassSolve{}
-> WarningWithFlag Opt_WarnLoopySuperclassSolve
+ TcRnDefaultedExceptionContext{}
+ -> WarningWithoutFlag --WarningWithFlag TODO
diagnosticHints = \case
TcRnUnknownMessage m
@@ -2064,6 +2078,8 @@ instance Diagnostic TcRnMessage where
cls_or_qc = case ctLocOrigin wtd_loc of
ScOrigin c_or_q _ -> c_or_q
_ -> IsClsInst -- shouldn't happen
+ TcRnDefaultedExceptionContext _
+ -> noHints
diagnosticCode = constructorCode
diff --git a/compiler/GHC/Tc/Errors/Types.hs b/compiler/GHC/Tc/Errors/Types.hs
index f52dfe58c6..941bcdef8e 100644
--- a/compiler/GHC/Tc/Errors/Types.hs
+++ b/compiler/GHC/Tc/Errors/Types.hs
@@ -2793,6 +2793,14 @@ data TcRnMessage where
-> PredType -- ^ Wanted 'PredType'
-> TcRnMessage
+ {-| TcRnDefaultedExceptionContext is a warning that is triggered when the
+ backward-compatibility logic solving for implicit ExceptionContext
+ constraints fires.
+
+ Test cases: TODO
+ -}
+ TcRnDefaultedExceptionContext :: CtLoc -> TcRnMessage
+
deriving Generic
-- | Things forbidden in @type data@ declarations.
diff --git a/compiler/GHC/Tc/Solver.hs b/compiler/GHC/Tc/Solver.hs
index 847ddb6887..a35fc71928 100644
--- a/compiler/GHC/Tc/Solver.hs
+++ b/compiler/GHC/Tc/Solver.hs
@@ -542,10 +542,11 @@ simplifyTopWanteds wanteds
defaultExceptionContext :: Ct -> MaybeT TcS ()
defaultExceptionContext ct
= do { ClassPred cls tys <- pure $ classifyPredType (ctPred ct)
- ; Just {} <- pure $ isCallStackPred cls tys
+ ; 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 ev_tm
}
diff --git a/compiler/GHC/Types/Error/Codes.hs b/compiler/GHC/Types/Error/Codes.hs
index 0072f91030..23766a6e87 100644
--- a/compiler/GHC/Types/Error/Codes.hs
+++ b/compiler/GHC/Types/Error/Codes.hs
@@ -502,6 +502,7 @@ type family GhcDiagnosticCode c = n | n -> c where
GhcDiagnosticCode "TcRnBadFamInstDecl" = 06206
GhcDiagnosticCode "TcRnNotOpenFamily" = 06207
GhcDiagnosticCode "TcRnLoopySuperclassSolve" = 36038
+ GhcDiagnosticCode "TcRnDefaultedExceptionContext" = 46235
-- IllegalNewtypeReason
GhcDiagnosticCode "DoesNotHaveSingleField" = 23517