compiler: Default and warn ExceptionContext constraints

3 files changed, 78 insertions, 34 deletions

diff --git a/compiler/GHC/Tc/Errors/Ppr.hs b/compiler/GHC/Tc/Errors/Ppr.hs
index 269063ae65..d58d5bae2d 100644
--- a/compiler/GHC/Tc/Errors/Ppr.hs
+++ b/compiler/GHC/Tc/Errors/Ppr.hs
@@ -1862,6 +1862,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." ]
 
   diagnosticReason = \case
     TcRnUnknownMessage m
@@ -2491,7 +2502,8 @@ instance Diagnostic TcRnMessage where
       -> WarningWithFlag Opt_WarnNonCanonicalMonoidInstances
     TcRnNonCanonicalDefinition (NonCanonicalMonad _) _
       -> WarningWithFlag Opt_WarnNonCanonicalMonadInstances
-
+    TcRnDefaultedExceptionContext{}
+      -> WarningWithoutFlag --WarningWithFlag TODO
 
   diagnosticHints = \case
     TcRnUnknownMessage m
@@ -3155,6 +3167,8 @@ instance Diagnostic TcRnMessage where
       -> noHints
     TcRnNonCanonicalDefinition reason _
       -> suggestNonCanonicalDefinition reason
+    TcRnDefaultedExceptionContext _
+      -> noHints
 
   diagnosticCode :: TcRnMessage -> Maybe DiagnosticCode
   diagnosticCode = constructorCode
diff --git a/compiler/GHC/Tc/Errors/Types.hs b/compiler/GHC/Tc/Errors/Types.hs
index 68c5ca2869..7b1e68490b 100644
--- a/compiler/GHC/Tc/Errors/Types.hs
+++ b/compiler/GHC/Tc/Errors/Types.hs
@@ -4053,6 +4053,14 @@ data TcRnMessage where
                              -> !(LHsSigType GhcRn) -- ^ The instance type
                              -> 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 eaa62e44ea..dc2924c1aa 100644
--- a/compiler/GHC/Tc/Solver.hs
+++ b/compiler/GHC/Tc/Solver.hs
@@ -33,7 +33,6 @@ import GHC.Data.Bag
 import GHC.Core.Class
 import GHC.Core
 import GHC.Core.DataCon
-import GHC.Core.InstEnv ( Coherence(IsCoherent) )
 import GHC.Core.Make
 import GHC.Driver.Session
 import GHC.Data.FastString
@@ -56,6 +55,7 @@ import GHC.Tc.Solver.InertSet
 import GHC.Tc.Solver.Monad  as TcS
 import GHC.Tc.Types.Constraint
 import GHC.Tc.Instance.FunDeps
+import GHC.Core.InstEnv ( Coherence(..) )
 import GHC.Core.Predicate
 import GHC.Tc.Types.Origin
 import GHC.Tc.Utils.TcType
@@ -67,6 +67,7 @@ import GHC.Core.Unify    ( tcMatchTyKi )
 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.Set
 import GHC.Types.Basic
@@ -80,7 +81,7 @@ import Control.Monad.Trans.State.Strict ( StateT(runStateT), put )
 import Data.Foldable      ( toList )
 import Data.List          ( partition )
 import Data.List.NonEmpty ( NonEmpty(..) )
-import GHC.Data.Maybe     ( mapMaybe )
+import GHC.Data.Maybe     ( mapMaybe, runMaybeT, MaybeT )
 
 {-
 *********************************************************************************
@@ -545,10 +546,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.
@@ -693,41 +691,65 @@ This allows us to indirectly box constraints with different representations
 (such as primitive equality constraints).
 -}
 
+defaultExceptionContext :: Ct -> MaybeT TcS ()
+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 IsCoherent 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 :: Ct -> MaybeT TcS ()
+defaultCallStack ct
+  = do { ClassPred cls tys <- pure $ classifyPredType (ctPred ct)
+       ; Just {} <- pure $ isCallStackPred cls tys
+       ; lift $ solveCallStack (ctEvidence ct) EvCsEmpty
+       }
+
+defaultConstraints :: [Ct -> MaybeT TcS ()]
+                   -> 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 simples
-    = catBagMaybes <$> mapBagM defaultCallStack simples
-
-  handle_implic :: Implication -> TcS (Maybe Implication)
-  -- The Maybe is because solving the CallStack constraint
-  -- may well allow us to discard the implication entirely
-  handle_implic implic
-    | isSolvedStatus (ic_status implic)
-    = return (Just implic)
-    | otherwise
-    = do { wanteds <- setEvBindsTcS (ic_binds implic) $
-                      -- defaultCallStack sets a binding, so
-                      -- we must set the correct binding group
-                      defaultCallStacks (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)
+    handle_simples :: Bag Ct -> TcS (Bag Ct)
+    handle_simples 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
+    -- may well allow us to discard the implication entirely
+    handle_implic implic
+      | isSolvedStatus (ic_status implic)
+      = return (Just implic)
+      | otherwise
+      = do { wanteds <- setEvBindsTcS (ic_binds implic) $
+                        -- defaultCallStack sets a binding, so
+                        -- we must set the correct binding group
+                        defaultConstraints defaulting_strategies (ic_wanted implic)
+           ; setImplicationStatus (implic { ic_wanted = wanteds }) }
 
 
 {- Note [When to do type-class defaulting]