Suppress -Winaccessible-code in derived code

Summary:
It's rather unfortunate that derived code can produce inaccessible
code warnings (as demonstrated in #8128, #8740, and #15398), since
the programmer has no control over the generated code. This patch
aims to suppress `-Winaccessible-code` in all derived code. It
accomplishes this by doing the following:

* Generalize the `ic_env :: TcLclEnv` field of `Implication` to
  be of type `Env TcGblEnc TcLclEnv` instead. This way, it also
  captures `DynFlags`, which record the flag state at the time
  the `Implication` was created.
* When typechecking derived code, turn off `-Winaccessible-code`.
  This way, any insoluble given `Implication`s that are created when
  typechecking this derived code will remember that
  `-Winaccessible-code` was disabled.
* During error reporting, consult the `DynFlags` of an
  `Implication` before making the decision to report an inaccessible
  code warning.

Test Plan: make test TEST="T8128 T8740 T15398"

Reviewers: simonpj, bgamari

Reviewed By: simonpj

Subscribers: monoidal, rwbarton, thomie, carter

GHC Trac Issues: #8128, #8740, #15398

Differential Revision: https://phabricator.haskell.org/D4993

10 files changed, 209 insertions, 138 deletions

diff --git a/compiler/typecheck/TcErrors.hs b/compiler/typecheck/TcErrors.hs
index 95dc152767..9a45d7ada0 100644
--- a/compiler/typecheck/TcErrors.hs
+++ b/compiler/typecheck/TcErrors.hs
@@ -387,7 +387,7 @@ reportImplic ctxt implic@(Implic { ic_skols = tvs, ic_telescope = m_telescope
                                  , ic_given = given
                                  , ic_wanted = wanted, ic_binds = evb
                                  , ic_status = status, ic_info = info
-                                 , ic_env = tcl_env, ic_tclvl = tc_lvl })
+                                 , ic_tclvl = tc_lvl })
   | BracketSkol <- info
   , not insoluble
   = return ()        -- For Template Haskell brackets report only
@@ -402,6 +402,7 @@ reportImplic ctxt implic@(Implic { ic_skols = tvs, ic_telescope = m_telescope
          warnRedundantConstraints ctxt' tcl_env info' dead_givens
        ; when bad_telescope $ reportBadTelescope ctxt tcl_env m_telescope tvs }
   where
+    tcl_env      = implicLclEnv implic
     insoluble    = isInsolubleStatus status
     (env1, tvs') = mapAccumL tidyTyCoVarBndr (cec_tidy ctxt) tvs
     info'        = tidySkolemInfo env1 info
@@ -622,6 +623,9 @@ reportWanteds ctxt tc_lvl (WC { wc_simple = simples, wc_impl = implics })
     find_gadt_match (implic : implics)
       | PatSkol {} <- ic_info implic
       , not (ic_no_eqs implic)
+      , wopt Opt_WarnInaccessibleCode (implicDynFlags implic)
+          -- Don't bother doing this if -Winaccessible-code isn't enabled.
+          -- See Note [Avoid -Winaccessible-code when deriving] in TcInstDcls.
       = Just implic
       | otherwise
       = find_gadt_match implics
@@ -698,7 +702,7 @@ mkGivenErrorReporter :: Implication -> Reporter
 mkGivenErrorReporter implic ctxt cts
   = do { (ctxt, binds_msg, ct) <- relevantBindings True ctxt ct
        ; dflags <- getDynFlags
-       ; let ct' = setCtLoc ct (setCtLocEnv (ctLoc ct) (ic_env implic))
+       ; let ct' = setCtLoc ct (setCtLocEnv (ctLoc ct) (implicLclEnv implic))
                    -- For given constraints we overwrite the env (and hence src-loc)
                   -- with one from the implication.  See Note [Inaccessible code]
 
@@ -1233,9 +1237,9 @@ givenConstraintsMsg :: ReportErrCtxt -> SDoc
 givenConstraintsMsg ctxt =
     let constraints :: [(Type, RealSrcSpan)]
         constraints =
-          do { Implic{ ic_given = given, ic_env = env } <- cec_encl ctxt
+          do { implic@Implic{ ic_given = given } <- cec_encl ctxt
              ; constraint <- given
-             ; return (varType constraint, tcl_loc env) }
+             ; return (varType constraint, tcl_loc (implicLclEnv implic)) }
 
         pprConstraint (constraint, loc) =
           ppr constraint <+> nest 2 (parens (text "from" <+> ppr loc))
@@ -1679,7 +1683,7 @@ mkTyVarEqErr' dflags ctxt report ct oriented tv1 co1 ty2
 
   -- Check for skolem escape
   | (implic:_) <- cec_encl ctxt   -- Get the innermost context
-  , Implic { ic_env = env, ic_skols = skols, ic_info = skol_info } <- implic
+  , Implic { ic_skols = skols, ic_info = skol_info } <- implic
   , let esc_skols = filter (`elemVarSet` (tyCoVarsOfType ty2)) skols
   , not (null esc_skols)
   = do { let msg = important $ misMatchMsg ct oriented ty1 ty2
@@ -1697,7 +1701,8 @@ mkTyVarEqErr' dflags ctxt report ct oriented tv1 co1 ty2
                                            what <+> text "variables are")
                                <+> text "bound by"
                              , nest 2 $ ppr skol_info
-                             , nest 2 $ text "at" <+> ppr (tcl_loc env) ] ]
+                             , nest 2 $ text "at" <+>
+                               ppr (tcl_loc (implicLclEnv implic)) ] ]
        ; mkErrorMsgFromCt ctxt ct (mconcat [msg, tv_extra, report]) }
 
   -- Nastiest case: attempt to unify an untouchable variable
@@ -1706,8 +1711,7 @@ mkTyVarEqErr' dflags ctxt report ct oriented tv1 co1 ty2
   -- meta tyvar or a SigTv, else it'd have been unified
   -- See Note [Error messages for untouchables]
   | (implic:_) <- cec_encl ctxt   -- Get the innermost context
-  , Implic { ic_env = env, ic_given = given
-           , ic_tclvl = lvl, ic_info = skol_info } <- implic
+  , Implic { ic_given = given, ic_tclvl = lvl, ic_info = skol_info } <- implic
   = ASSERT2( not (isTouchableMetaTyVar lvl tv1)
            , ppr tv1 $$ ppr lvl )  -- See Note [Error messages for untouchables]
     do { let msg = important $ misMatchMsg ct oriented ty1 ty2
@@ -1716,7 +1720,8 @@ mkTyVarEqErr' dflags ctxt report ct oriented tv1 co1 ty2
                   sep [ quotes (ppr tv1) <+> text "is untouchable"
                       , nest 2 $ text "inside the constraints:" <+> pprEvVarTheta given
                       , nest 2 $ text "bound by" <+> ppr skol_info
-                      , nest 2 $ text "at" <+> ppr (tcl_loc env) ]
+                      , nest 2 $ text "at" <+>
+                        ppr (tcl_loc (implicLclEnv implic)) ]
              tv_extra = important $ extraTyVarEqInfo ctxt tv1 ty2
              add_sig  = important $ suggestAddSig ctxt ty1 ty2
        ; mkErrorMsgFromCt ctxt ct $ mconcat
@@ -1819,11 +1824,10 @@ pp_givens givens
          (g:gs) ->      ppr_given (text "from the context:") g
                  : map (ppr_given (text "or from:")) gs
     where
-       ppr_given herald (Implic { ic_given = gs, ic_info = skol_info
-                                , ic_env = env })
+       ppr_given herald implic@(Implic { ic_given = gs, ic_info = skol_info })
            = hang (herald <+> pprEvVarTheta gs)
                 2 (sep [ text "bound by" <+> ppr skol_info
-                       , text "at" <+> ppr (tcl_loc env) ])
+                       , text "at" <+> ppr (tcl_loc (implicLclEnv implic)) ])
 
 extraTyVarEqInfo :: ReportErrCtxt -> TcTyVar -> TcType -> SDoc
 -- Add on extra info about skolem constants
@@ -2501,12 +2505,13 @@ mk_dict_err ctxt@(CEC {cec_encl = implics}) (ct, (matches, unifiers, unsafe_over
 
     matching_givens = mapMaybe matchable useful_givens
 
-    matchable (Implic { ic_given = evvars, ic_info = skol_info, ic_env = env })
+    matchable implic@(Implic { ic_given = evvars, ic_info = skol_info })
       = case ev_vars_matching of
              [] -> Nothing
              _  -> Just $ hang (pprTheta ev_vars_matching)
                             2 (sep [ text "bound by" <+> ppr skol_info
-                                   , text "at" <+> ppr (tcl_loc env) ])
+                                   , text "at" <+>
+                                     ppr (tcl_loc (implicLclEnv implic)) ])
         where ev_vars_matching = filter ev_var_matches (map evVarPred evvars)
               ev_var_matches ty = case getClassPredTys_maybe ty of
                  Just (clas', tys')
diff --git a/compiler/typecheck/TcInstDcls.hs b/compiler/typecheck/TcInstDcls.hs
index cee92caca8..c00841902f 100644
--- a/compiler/typecheck/TcInstDcls.hs
+++ b/compiler/typecheck/TcInstDcls.hs
@@ -813,15 +813,14 @@ tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = ibinds })
                             , sc_binds   `unionBags` meth_binds
                             , sc_implics `unionBags` meth_implics ) }
 
-       ; env <- getLclEnv
+       ; imp <- newImplication
        ; emitImplication $
-         newImplication { ic_tclvl  = tclvl
-                        , ic_skols  = inst_tyvars
-                        , ic_given  = dfun_ev_vars
-                        , ic_wanted = mkImplicWC sc_meth_implics
-                        , ic_binds  = dfun_ev_binds_var
-                        , ic_env    = env
-                        , ic_info   = InstSkol }
+         imp { ic_tclvl  = tclvl
+             , ic_skols  = inst_tyvars
+             , ic_given  = dfun_ev_vars
+             , ic_wanted = mkImplicWC sc_meth_implics
+             , ic_binds  = dfun_ev_binds_var
+             , ic_info   = InstSkol }
 
        -- Create the result bindings
        ; self_dict <- newDict clas inst_tys
@@ -1035,14 +1034,13 @@ checkInstConstraints thing_inside
                                     thing_inside
 
        ; ev_binds_var <- newTcEvBinds
-       ; env <- getLclEnv
-       ; let implic = newImplication { ic_tclvl  = tclvl
-                                     , ic_wanted = wanted
-                                     , ic_binds  = ev_binds_var
-                                     , ic_env    = env
-                                     , ic_info   = InstSkol }
+       ; implic <- newImplication
+       ; let implic' = implic { ic_tclvl  = tclvl
+                              , ic_wanted = wanted
+                              , ic_binds  = ev_binds_var
+                              , ic_info   = InstSkol }
 
-       ; return (implic, ev_binds_var, result) }
+       ; return (implic', ev_binds_var, result) }
 
 {-
 Note [Recursive superclasses]
@@ -1265,12 +1263,19 @@ tcMethods dfun_id clas tyvars dfun_ev_vars inst_tys
        ; checkMinimalDefinition
        ; checkMethBindMembership
        ; (ids, binds, mb_implics) <- set_exts exts $
+                                     unset_warnings_deriving $
                                      mapAndUnzip3M tc_item op_items
        ; return (ids, listToBag binds, listToBag (catMaybes mb_implics)) }
   where
     set_exts :: [LangExt.Extension] -> TcM a -> TcM a
     set_exts es thing = foldr setXOptM thing es
 
+    -- See Note [Avoid -Winaccessible-code when deriving]
+    unset_warnings_deriving :: TcM a -> TcM a
+    unset_warnings_deriving
+      | is_derived = unsetWOptM Opt_WarnInaccessibleCode
+      | otherwise  = id
+
     hs_sig_fn = mkHsSigFun sigs
     inst_loc  = getSrcSpan dfun_id
 
@@ -1359,6 +1364,55 @@ case, Template Haskell will provide fully resolved names (e.g.,
 `GHC.Classes.compare`), so the renamer won't notice the sleight-of-hand going
 on. For this reason, we also put an extra validity check for this in the
 typechecker as a last resort.
+
+Note [Avoid -Winaccessible-code when deriving]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+-Winaccessible-code can be particularly noisy when deriving instances for
+GADTs. Consider the following example (adapted from #8128):
+
+  data T a where
+    MkT1 :: Int -> T Int
+    MkT2 :: T Bool
+    MkT3 :: T Bool
+  deriving instance Eq (T a)
+  deriving instance Ord (T a)
+
+In the derived Ord instance, GHC will generate the following code:
+
+  instance Ord (T a) where
+    compare x y
+      = case x of
+          MkT2
+            -> case y of
+                 MkT1 {} -> GT
+                 MkT2    -> EQ
+                 _       -> LT
+          ...
+
+However, that MkT1 is unreachable, since the type indices for MkT1 and MkT2
+differ, so if -Winaccessible-code is enabled, then deriving this instance will
+result in unwelcome warnings.
+
+One conceivable approach to fixing this issue would be to change `deriving Ord`
+such that it becomes smarter about not generating unreachable cases. This,
+however, would be a highly nontrivial refactor, as we'd have to propagate
+through typing information everywhere in the algorithm that generates Ord
+instances in order to determine which cases were unreachable. This seems like
+a lot of work for minimal gain, so we have opted not to go for this approach.
+
+Instead, we take the much simpler approach of always disabling
+-Winaccessible-code for derived code. To accomplish this, we do the following:
+
+1. In tcMethods (which typechecks method bindings), disable
+   -Winaccessible-code.
+2. When creating Implications during typechecking, record the Env
+   (through ic_env) at the time of creation. Since the Env also stores
+   DynFlags, this will remember that -Winaccessible-code was disabled over
+   the scope of that implication.
+3. After typechecking comes error reporting, where GHC must decide how to
+   report inaccessible code to the user, on an Implication-by-Implication
+   basis. If an Implication's DynFlags indicate that -Winaccessible-code was
+   disabled, then don't bother reporting it. That's it!
 -}
 
 ------------------------
diff --git a/compiler/typecheck/TcRnTypes.hs b/compiler/typecheck/TcRnTypes.hs
index 0a443a0639..e8f0762d94 100644
--- a/compiler/typecheck/TcRnTypes.hs
+++ b/compiler/typecheck/TcRnTypes.hs
@@ -93,7 +93,7 @@ module TcRnTypes(
         isDroppableCt, insolubleImplic,
         arisesFromGivens,
 
-        Implication(..), newImplication,
+        Implication(..), newImplication, implicLclEnv, implicDynFlags,
         ImplicStatus(..), isInsolubleStatus, isSolvedStatus,
         SubGoalDepth, initialSubGoalDepth, maxSubGoalDepth,
         bumpSubGoalDepth, subGoalDepthExceeded,
@@ -2509,9 +2509,18 @@ data Implication
       ic_no_eqs :: Bool,         -- True  <=> ic_givens have no equalities, for sure
                                  -- False <=> ic_givens might have equalities
 
-      ic_env   :: TcLclEnv,      -- Gives the source location and error context
-                                 -- for the implication, and hence for all the
-                                 -- given evidence variables
+      ic_env   :: Env TcGblEnv TcLclEnv,
+                                 -- Records the Env at the time of creation.
+                                 --
+                                 -- This is primarly needed for the enclosed
+                                 -- TcLclEnv, which gives the source location
+                                 -- and error context for the implication, and
+                                 -- hence for all the given evidence variables.
+                                 --
+                                 -- The enclosed DynFlags also influences error
+                                 -- reporting. See Note [Avoid
+                                 -- -Winaccessible-code when deriving] in
+                                 -- TcInstDcls.
 
       ic_wanted :: WantedConstraints,  -- The wanteds
                                        -- See Invariang (WantedInf) in TcType
@@ -2531,23 +2540,40 @@ data Implication
       ic_status   :: ImplicStatus
     }
 
-newImplication :: Implication
+-- | Create a new 'Implication' with as many sensible defaults for its fields
+-- as possible. Note that the 'ic_tclvl', 'ic_binds', and 'ic_info' fields do
+-- /not/ have sensible defaults, so they are initialized with lazy thunks that
+-- will 'panic' if forced, so one should take care to initialize these fields
+-- after creation.
+--
+-- This is monadic purely to look up the 'Env', which is used to initialize
+-- 'ic_env'.
+newImplication :: TcM Implication
 newImplication
-  = Implic { -- These fields must be initialisad
-             ic_tclvl = panic "newImplic:tclvl"
-           , ic_binds = panic "newImplic:binds"
-           , ic_info  = panic "newImplic:info"
-           , ic_env   = panic "newImplic:env"
-
-             -- The rest have sensible default values
-           , ic_skols      = []
-           , ic_telescope  = Nothing
-           , ic_given      = []
-           , ic_wanted     = emptyWC
-           , ic_no_eqs     = False
-           , ic_status     = IC_Unsolved
-           , ic_need_inner = emptyVarSet
-           , ic_need_outer = emptyVarSet }
+  = do env <- getEnv
+       pure $ Implic { -- These fields must be initialised
+                       ic_tclvl      = panic "newImplic:tclvl"
+                     , ic_binds      = panic "newImplic:binds"
+                     , ic_info       = panic "newImplic:info"
+
+                       -- The rest have sensible default values
+                     , ic_env        = env
+                     , ic_skols      = []
+                     , ic_telescope  = Nothing
+                     , ic_given      = []
+                     , ic_wanted     = emptyWC
+                     , ic_no_eqs     = False
+                     , ic_status     = IC_Unsolved
+                     , ic_need_inner = emptyVarSet
+                     , ic_need_outer = emptyVarSet }
+
+-- | Retrieve the enclosed 'TcLclEnv' from an 'Implication'.
+implicLclEnv :: Implication -> TcLclEnv
+implicLclEnv = env_lcl . ic_env
+
+-- | Retrieve the enclosed 'DynFlags' from an 'Implication'.
+implicDynFlags :: Implication -> DynFlags
+implicDynFlags = hsc_dflags . env_top . ic_env
 
 data ImplicStatus
   = IC_Solved     -- All wanteds in the tree are solved, all the way down
diff --git a/compiler/typecheck/TcSMonad.hs b/compiler/typecheck/TcSMonad.hs
index 3f0db9c012..5bf5cefe01 100644
--- a/compiler/typecheck/TcSMonad.hs
+++ b/compiler/typecheck/TcSMonad.hs
@@ -2848,19 +2848,18 @@ checkTvConstraintsTcS skol_info skol_tvs (TcS thing_inside)
                                         thing_inside new_tcs_env
 
        ; unless (null wanteds) $
-         do { tcl_env <- TcM.getLclEnv
-            ; ev_binds_var <- TcM.newNoTcEvBinds
+         do { ev_binds_var <- TcM.newNoTcEvBinds
+            ; imp <- newImplication
             ; let wc = emptyWC { wc_simple = wanteds }
-                  imp = newImplication { ic_tclvl  = new_tclvl
-                                       , ic_skols  = skol_tvs
-                                       , ic_wanted = wc
-                                       , ic_binds  = ev_binds_var
-                                       , ic_env    = tcl_env
-                                       , ic_info   = skol_info }
+                  imp' = imp { ic_tclvl  = new_tclvl
+                             , ic_skols  = skol_tvs
+                             , ic_wanted = wc
+                             , ic_binds  = ev_binds_var
+                             , ic_info   = skol_info }
 
            -- Add the implication to the work-list
            ; TcM.updTcRef (tcs_worklist tcs_env)
-                          (extendWorkListImplic (unitBag imp)) }
+                          (extendWorkListImplic (unitBag imp')) }
 
       ; return res }
 
@@ -2888,20 +2887,19 @@ checkConstraintsTcS skol_info skol_tvs given (TcS thing_inside)
        ; ((res, wanteds), new_tclvl) <- TcM.pushTcLevelM $
                                         thing_inside new_tcs_env
 
-       ; tcl_env <- TcM.getLclEnv
        ; ev_binds_var <- TcM.newTcEvBinds
+       ; imp <- newImplication
        ; let wc = emptyWC { wc_simple = wanteds }
-             imp = newImplication { ic_tclvl  = new_tclvl
-                                  , ic_skols  = skol_tvs
-                                  , ic_given  = given
-                                  , ic_wanted = wc
-                                  , ic_binds  = ev_binds_var
-                                  , ic_env    = tcl_env
-                                  , ic_info   = skol_info }
+             imp' = imp { ic_tclvl  = new_tclvl
+                        , ic_skols  = skol_tvs
+                        , ic_given  = given
+                        , ic_wanted = wc
+                        , ic_binds  = ev_binds_var
+                        , ic_info   = skol_info }
 
            -- Add the implication to the work-list
        ; TcM.updTcRef (tcs_worklist tcs_env)
-                      (extendWorkListImplic (unitBag imp))
+                      (extendWorkListImplic (unitBag imp'))
 
        ; return (res, TcEvBinds ev_binds_var) }
 
diff --git a/compiler/typecheck/TcSimplify.hs b/compiler/typecheck/TcSimplify.hs
index c57ef56409..fb5a70c94c 100644
--- a/compiler/typecheck/TcSimplify.hs
+++ b/compiler/typecheck/TcSimplify.hs
@@ -643,13 +643,14 @@ simplifyInfer rhs_tclvl infer_mode sigs name_taus wanteds
        -- bindings, so we can't just revert to the input
        -- constraint.
 
-       ; tc_lcl_env      <- TcM.getLclEnv
+       ; tc_env          <- TcM.getEnv
        ; ev_binds_var    <- TcM.newTcEvBinds
        ; psig_theta_vars <- mapM TcM.newEvVar psig_theta
        ; wanted_transformed_incl_derivs
             <- setTcLevel rhs_tclvl $
                runTcSWithEvBinds ev_binds_var $
-               do { let loc         = mkGivenLoc rhs_tclvl UnkSkol tc_lcl_env
+               do { let loc         = mkGivenLoc rhs_tclvl UnkSkol $
+                                      env_lcl tc_env
                         psig_givens = mkGivens loc psig_theta_vars
                   ; _ <- solveSimpleGivens psig_givens
                          -- See Note [Add signature contexts as givens]
@@ -692,7 +693,7 @@ simplifyInfer rhs_tclvl infer_mode sigs name_taus wanteds
                            | psig_theta_var <- psig_theta_vars ]
 
        -- Now we can emil the residual constraints
-       ; emitResidualConstraints rhs_tclvl tc_lcl_env ev_binds_var
+       ; emitResidualConstraints rhs_tclvl tc_env ev_binds_var
                                  name_taus co_vars qtvs
                                  bound_theta_vars
                                  (wanted_transformed `andWC` mkSimpleWC psig_wanted)
@@ -710,13 +711,13 @@ simplifyInfer rhs_tclvl infer_mode sigs name_taus wanteds
 
 
 --------------------
-emitResidualConstraints :: TcLevel -> TcLclEnv -> EvBindsVar
+emitResidualConstraints :: TcLevel -> Env TcGblEnv TcLclEnv -> EvBindsVar
                         -> [(Name, TcTauType)]
                         -> VarSet -> [TcTyVar] -> [EvVar]
                         -> WantedConstraints -> TcM ()
 -- Emit the remaining constraints from the RHS.
 -- See Note [Emitting the residual implication in simplifyInfer]
-emitResidualConstraints rhs_tclvl tc_lcl_env ev_binds_var
+emitResidualConstraints rhs_tclvl tc_env ev_binds_var
                         name_taus co_vars qtvs full_theta_vars wanteds
   | isEmptyWC wanteds
   = return ()
@@ -731,21 +732,22 @@ emitResidualConstraints rhs_tclvl tc_lcl_env ev_binds_var
           do { traceTc "emitResidualConstrants:simple" (ppr outer_simple)
              ; emitSimples outer_simple }
 
+        ; implic <- newImplication
         ; let inner_wanted = wanteds { wc_simple = inner_simple }
-              implic       = mk_implic inner_wanted
+              implic'      = mk_implic inner_wanted implic
         ; unless (isEmptyWC inner_wanted) $
-          do { traceTc "emitResidualConstraints:implic" (ppr implic)
-             ; emitImplication implic }
+          do { traceTc "emitResidualConstraints:implic" (ppr implic')
+             ; emitImplication implic' }
      }
   where
-    mk_implic inner_wanted
-       = newImplication { ic_tclvl    = rhs_tclvl
-                        , ic_skols    = qtvs
-                        , ic_given    = full_theta_vars
-                        , ic_wanted   = inner_wanted
-                        , ic_binds    = ev_binds_var
-                        , ic_info     = skol_info
-                        , ic_env      = tc_lcl_env }
+    mk_implic inner_wanted implic
+       = implic { ic_tclvl  = rhs_tclvl
+                , ic_skols  = qtvs
+                , ic_given  = full_theta_vars
+                , ic_wanted = inner_wanted
+                , ic_binds  = ev_binds_var
+                , ic_info   = skol_info
+                , ic_env    = tc_env }
 
     full_theta = map idType full_theta_vars
     skol_info  = InferSkol [ (name, mkSigmaTy [] full_theta ty)
@@ -1483,8 +1485,7 @@ solveImplication imp@(Implic { ic_tclvl  = tclvl
                              , ic_given  = given_ids
                              , ic_wanted = wanteds
                              , ic_info   = info
-                             , ic_status = status
-                             , ic_env    = env })
+                             , ic_status = status })
   | isSolvedStatus status
   = return (emptyCts, Just imp)  -- Do nothing
 
@@ -1501,7 +1502,7 @@ solveImplication imp@(Implic { ic_tclvl  = tclvl
          -- Solve the nested constraints
        ; (no_given_eqs, given_insols, residual_wanted)
             <- nestImplicTcS ev_binds_var tclvl $
-               do { let loc    = mkGivenLoc tclvl info env
+               do { let loc    = mkGivenLoc tclvl info (implicLclEnv imp)
                         givens = mkGivens loc given_ids
                   ; solveSimpleGivens givens
 
diff --git a/compiler/typecheck/TcUnify.hs b/compiler/typecheck/TcUnify.hs
index 31ddf0f69d..2e66d8aba5 100644
--- a/compiler/typecheck/TcUnify.hs
+++ b/compiler/typecheck/TcUnify.hs
@@ -1141,17 +1141,16 @@ checkTvConstraints skol_info m_telescope thing_inside
 
        ; if isEmptyWC wanted
          then return ()
-         else do { tc_lcl_env <- getLclEnv
-                 ; ev_binds   <- newNoTcEvBinds
+         else do { ev_binds <- newNoTcEvBinds
+                 ; implic   <- newImplication
                  ; emitImplication $
-                   newImplication { ic_tclvl     = tclvl
-                                  , ic_skols     = skol_tvs
-                                  , ic_no_eqs    = True
-                                  , ic_telescope = m_telescope
-                                  , ic_wanted    = wanted
-                                  , ic_binds     = ev_binds
-                                  , ic_info      = skol_info
-                                  , ic_env       = tc_lcl_env } }
+                   implic { ic_tclvl     = tclvl
+                          , ic_skols     = skol_tvs
+                          , ic_no_eqs    = True
+                          , ic_telescope = m_telescope
+                          , ic_wanted    = wanted
+                          , ic_binds     = ev_binds
+                          , ic_info      = skol_info } }
        ; return (skol_tvs, result) }
 
 
@@ -1196,16 +1195,15 @@ buildImplicationFor tclvl skol_info skol_tvs given wanted
       -- into scope as a skolem in an implication. This is OK, though,
       -- because SigTvs will always remain tyvars, even after unification.
     do { ev_binds_var <- newTcEvBinds
-       ; env <- getLclEnv
-       ; let implic = newImplication { ic_tclvl  = tclvl
-                                     , ic_skols  = skol_tvs
-                                     , ic_given  = given
-                                     , ic_wanted = wanted
-                                     , ic_binds  = ev_binds_var
-                                     , ic_env    = env
-                                     , ic_info   = skol_info }
-
-       ; return (unitBag implic, TcEvBinds ev_binds_var) }
+       ; implic <- newImplication
+       ; let implic' = implic { ic_tclvl  = tclvl
+                              , ic_skols  = skol_tvs
+                              , ic_given  = given
+                              , ic_wanted = wanted
+                              , ic_binds  = ev_binds_var
+                              , ic_info   = skol_info }
+
+       ; return (unitBag implic', TcEvBinds ev_binds_var) }
 
 {-
 ************************************************************************
diff --git a/testsuite/tests/deriving/should_compile/T15398.hs b/testsuite/tests/deriving/should_compile/T15398.hs
new file mode 100644
index 0000000000..b78df1fa17
--- /dev/null
+++ b/testsuite/tests/deriving/should_compile/T15398.hs
@@ -0,0 +1,20 @@
+{-# LANGUAGE DeriveAnyClass #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE StandaloneDeriving #-}
+
+module T15398 where
+
+newtype Radius a = Radius a deriving (Eq, Ord)
+
+data CourseLine
+data OpenDistance
+data EndOfSpeedSection
+
+data Zone k a where
+    Point :: (Eq a, Ord a) => Zone CourseLine a
+    Vector :: (Eq a, Ord a) => Zone OpenDistance a
+    Conical :: (Eq a, Ord a) => Radius a -> Zone EndOfSpeedSection a
+
+deriving instance Eq a => Eq (Zone k a)
+deriving instance (Eq a, Ord a) => Ord (Zone k a)
diff --git a/testsuite/tests/deriving/should_compile/T8128.stderr b/testsuite/tests/deriving/should_compile/T8128.stderr
deleted file mode 100644
index 5f8b1307d1..0000000000
--- a/testsuite/tests/deriving/should_compile/T8128.stderr
+++ /dev/null
@@ -1,14 +0,0 @@
-
-T8128.hs:9:1: warning: [-Winaccessible-code (in -Wdefault)]
-    • Couldn't match type ‘Int’ with ‘Bool’
-      Inaccessible code in
-        a pattern with constructor: MkT2 :: Bool -> T Bool,
-        in an equation for ‘showsPrec’
-    • In the pattern: MkT2 b1
-      In an equation for ‘showsPrec’:
-          showsPrec a (MkT2 b1)
-            = showParen (a >= 11) ((.) (showString "MkT2 ") (showsPrec 11 b1))
-      When typechecking the code for ‘showsPrec’
-        in a derived instance for ‘Show (T Int)’:
-        To see the code I am typechecking, use -ddump-deriv
-      In the instance declaration for ‘Show (T Int)’
diff --git a/testsuite/tests/deriving/should_compile/T8740.stderr b/testsuite/tests/deriving/should_compile/T8740.stderr
deleted file mode 100644
index 9b60741027..0000000000
--- a/testsuite/tests/deriving/should_compile/T8740.stderr
+++ /dev/null
@@ -1,18 +0,0 @@
-
-T8740.hs:17:1: warning: [-Winaccessible-code (in -Wdefault)]
-    • Couldn't match type ‘Reified’ with ‘Abstract’
-      Inaccessible code in
-        a pattern with constructor:
-          ElectRefAsTypeOf :: forall a.
-                              Int -> Elect Abstract a -> Elect Abstract a,
-        in a case alternative
-    • In the pattern: ElectRefAsTypeOf {}
-      In a case alternative: ElectRefAsTypeOf {} -> GT
-      In the expression:
-        case b of
-          ElectRefAsTypeOf {} -> GT
-          ElectHandle b1 -> (a1 `compare` b1)
-          _ -> LT
-      When typechecking the code for ‘compare’
-        in a derived instance for ‘Ord (Elect p a)’:
-        To see the code I am typechecking, use -ddump-deriv
diff --git a/testsuite/tests/deriving/should_compile/all.T b/testsuite/tests/deriving/should_compile/all.T
index a224871b2a..cc0730f4e0 100644
--- a/testsuite/tests/deriving/should_compile/all.T
+++ b/testsuite/tests/deriving/should_compile/all.T
@@ -111,3 +111,4 @@ test('T14932', normal, compile, [''])
 test('T14933', normal, compile, [''])
 test('T15290c', normal, compile, [''])
 test('T15290d', normal, compile, [''])
+test('T15398', normal, compile, [''])