compiler: Default and warn ExceptionContext constraints

6 files changed, 123 insertions, 36 deletions

diff --git a/compiler/GHC/Builtin/Names.hs b/compiler/GHC/Builtin/Names.hs
index d72e911541..d8c7519b7e 100644
--- a/compiler/GHC/Builtin/Names.hs
+++ b/compiler/GHC/Builtin/Names.hs
@@ -452,6 +452,10 @@ basicKnownKeyNames
         -- Overloaded record fields
         hasFieldClassName,
 
+        -- ExceptionContext
+        exceptionContextTyConName,
+        emptyExceptionContextName,
+
         -- Call Stacks
         callStackTyConName,
         emptyCallStackName, pushCallStackName,
@@ -561,7 +565,8 @@ gHC_PRIM, gHC_PRIM_PANIC,
     tYPEABLE, tYPEABLE_INTERNAL, gENERICS,
     rEAD_PREC, lEX, gHC_INT, gHC_WORD, mONAD, mONAD_FIX, mONAD_ZIP, mONAD_FAIL,
     aRROW, gHC_DESUGAR, rANDOM, gHC_EXTS, gHC_IS_LIST,
-    cONTROL_EXCEPTION_BASE, gHC_TYPEERROR, gHC_TYPELITS, gHC_TYPELITS_INTERNAL,
+    cONTROL_EXCEPTION_BASE, gHC_EXCEPTION_CONTEXT,
+    gHC_TYPEERROR, gHC_TYPELITS, gHC_TYPELITS_INTERNAL,
     gHC_TYPENATS, gHC_TYPENATS_INTERNAL,
     dATA_COERCE, dEBUG_TRACE, uNSAFE_COERCE, fOREIGN_C_CONSTPTR :: Module
 
@@ -623,6 +628,7 @@ rANDOM          = mkBaseModule (fsLit "System.Random")
 gHC_EXTS        = mkBaseModule (fsLit "GHC.Exts")
 gHC_IS_LIST     = mkBaseModule (fsLit "GHC.IsList")
 cONTROL_EXCEPTION_BASE = mkBaseModule (fsLit "Control.Exception.Base")
+gHC_EXCEPTION_CONTEXT = mkBaseModule (fsLit "GHC.Exception.Context")
 gHC_GENERICS    = mkBaseModule (fsLit "GHC.Generics")
 gHC_TYPEERROR   = mkBaseModule (fsLit "GHC.TypeError")
 gHC_TYPELITS    = mkBaseModule (fsLit "GHC.TypeLits")
@@ -1632,6 +1638,13 @@ hasFieldClassName :: Name
 hasFieldClassName
  = clsQual gHC_RECORDS (fsLit "HasField") hasFieldClassNameKey
 
+-- ExceptionContext
+exceptionContextTyConName, emptyExceptionContextName :: Name
+exceptionContextTyConName =
+    tcQual gHC_EXCEPTION_CONTEXT (fsLit "ExceptionContext") exceptionContextTyConKey
+emptyExceptionContextName
+  = varQual gHC_EXCEPTION_CONTEXT (fsLit "emptyExceptionContext") emptyExceptionContextKey
+
 -- Source Locations
 callStackTyConName, emptyCallStackName, pushCallStackName,
   srcLocDataConName :: Name
@@ -2103,6 +2116,9 @@ typeCharToNatTyFamNameKey = mkPreludeTyConUnique 415
 typeNatToCharTyFamNameKey = mkPreludeTyConUnique 416
 constPtrTyConKey = mkPreludeTyConUnique 417
 
+exceptionContextTyConKey :: Unique
+exceptionContextTyConKey = mkPreludeTyConUnique 420
+
 {-
 ************************************************************************
 *                                                                      *
@@ -2553,6 +2569,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 c8d280259a..499f0c5fa8 100644
--- a/compiler/GHC/Core/Predicate.hs
+++ b/compiler/GHC/Core/Predicate.hs
@@ -26,7 +26,8 @@ module GHC.Core.Predicate (
 
   -- Implicit parameters
   isIPLikePred, hasIPSuperClasses, isIPTyCon, isIPClass,
-  isCallStackTy, isCallStackPred, isCallStackPredTy,
+  isCallStackPred, isCallStackPredTy,
+  isExceptionContextPred,
   isIPPred_maybe,
 
   -- Evidence variables
@@ -292,6 +293,28 @@ has_ip_super_classes rec_clss cls tys
 initIPRecTc :: RecTcChecker
 initIPRecTc = setRecTcMaxBound 1 initRecTc
 
+-- --------------------- 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/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]
diff --git a/compiler/GHC/Types/Error/Codes.hs b/compiler/GHC/Types/Error/Codes.hs
index 5025ff022f..d465422e95 100644
--- a/compiler/GHC/Types/Error/Codes.hs
+++ b/compiler/GHC/Types/Error/Codes.hs
@@ -600,6 +600,7 @@ type family GhcDiagnosticCode c = n | n -> c where
   GhcDiagnosticCode "TcRnBindingNameConflict"                       = 10498
   GhcDiagnosticCode "NonCanonicalMonoid"                            = 50928
   GhcDiagnosticCode "NonCanonicalMonad"                             = 22705
+  GhcDiagnosticCode "TcRnDefaultedExceptionContext"                 = 46235
 
   -- PatSynInvalidRhsReason
   GhcDiagnosticCode "PatSynNotInvertible"                           = 69317