From b5571f1aae3975a7a44e80b060d87bbea34390b9 Mon Sep 17 00:00:00 2001
From: Ben Gamari <ben@smart-cactus.org>
Date: Sat, 11 Mar 2023 18:14:41 -0500
Subject: warning

---
 compiler/GHC/Tc/Errors/Ppr.hs     | 16 ++++++++++++++++
 compiler/GHC/Tc/Errors/Types.hs   |  8 ++++++++
 compiler/GHC/Tc/Solver.hs         |  3 ++-
 compiler/GHC/Types/Error/Codes.hs |  1 +
 4 files changed, 27 insertions(+), 1 deletion(-)

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
-- 
cgit v1.2.1