deriving: infer DatatypeContexts from data constructors, not type constructor

Previously, derived instances that use `deriving` clauses would infer
`DatatypeContexts` by using `tyConStupidTheta`. But this sometimes causes
redundant constraints to be included in the derived instance contexts, as the
constraints that appear in the `tyConStupidTheta` may not actually appear in
the types of the data constructors (i.e., the `dataConStupidTheta`s). For
instance, in `data Show a => T a = MkT deriving Eq`, the type of `MkT` does
not require `Show`, so the derived `Eq` instance should not require `Show`
either. This patch makes it so with some small tweaks to
`inferConstraintsStock`.

Fixes #20501.

4 files changed, 40 insertions, 13 deletions

diff --git a/compiler/GHC/Tc/Deriv/Infer.hs b/compiler/GHC/Tc/Deriv/Infer.hs
index fef3cfa670..7276bfde83 100644
--- a/compiler/GHC/Tc/Deriv/Infer.hs
+++ b/compiler/GHC/Tc/Deriv/Infer.hs
@@ -178,7 +178,8 @@ inferConstraintsStock (DerivInstTys { dit_cls_tys     = cls_tys
                           -> [([PredOrigin], Maybe TCvSubst)])
              -> ([ThetaOrigin], [TyVar], [TcType])
            con_arg_constraints get_arg_constraints
-             = let (predss, mbSubsts) = unzip
+             = let -- Constraints from the fields of each data constructor.
+                   (predss, mbSubsts) = unzip
                      [ preds_and_mbSubst
                      | data_con <- tyConDataCons rep_tc
                      , (arg_n, arg_t_or_k, arg_ty)
@@ -191,6 +192,23 @@ inferConstraintsStock (DerivInstTys { dit_cls_tys     = cls_tys
                      , preds_and_mbSubst
                          <- get_arg_constraints orig arg_t_or_k (irrelevantMult arg_ty)
                      ]
+                   -- Stupid constraints from DatatypeContexts. Note that we
+                   -- must gather these constraints from the data constructors,
+                   -- not from the parent type constructor, as the latter can
+                   -- lead to redundant constraints in some cases. For example,
+                   -- the derived Eq instance for:
+                   --
+                   --   data Show a => T a = MkT deriving Eq
+                   --
+                   -- Should not have Show in the instance context (#20501).
+                   stupid_theta =
+                     [ substTyWith (dataConUnivTyVars data_con)
+                                   all_rep_tc_args
+                                   stupid_pred
+                     | data_con <- tyConDataCons rep_tc
+                     , stupid_pred <- dataConStupidTheta data_con
+                     ]
+
                    preds = concat predss
                    -- If the constraints require a subtype to be of kind
                    -- (* -> *) (which is the case for functor-like
@@ -202,10 +220,13 @@ inferConstraintsStock (DerivInstTys { dit_cls_tys     = cls_tys
                    unmapped_tvs = filter (\v -> v `notElemTCvSubst` subst
                                              && not (v `isInScope` subst)) tvs
                    (subst', _)  = substTyVarBndrs subst unmapped_tvs
+                   stupid_theta_origin = mkThetaOrigin deriv_origin TypeLevel [] [] [] $
+                                         substTheta subst' stupid_theta
                    preds'       = map (substPredOrigin subst') preds
                    inst_tys'    = substTys subst' inst_tys
                    tvs'         = tyCoVarsOfTypesWellScoped inst_tys'
-               in ([mkThetaOriginFromPreds preds'], tvs', inst_tys')
+               in ( [stupid_theta_origin, mkThetaOriginFromPreds preds']
+                  , tvs', inst_tys' )
 
            is_generic  = main_cls `hasKey` genClassKey
            is_generic1 = main_cls `hasKey` gen1ClassKey
@@ -262,15 +283,6 @@ inferConstraintsStock (DerivInstTys { dit_cls_tys     = cls_tys
            -- the same order as the type variables.
            all_rep_tc_args = tyConInstArgTys rep_tc rep_tc_args
 
-               -- Stupid constraints
-           stupid_constraints
-             = [ mkThetaOrigin deriv_origin TypeLevel [] [] [] $
-                 substTheta tc_subst (tyConStupidTheta rep_tc) ]
-           tc_subst = -- See the comment with all_rep_tc_args for an
-                      -- explanation of this assertion
-                      assert (equalLength rep_tc_tvs all_rep_tc_args) $
-                      zipTvSubst rep_tc_tvs all_rep_tc_args
-
            -- Extra Data constraints
            -- The Data class (only) requires that for
            --    instance (...) => Data (T t1 t2)
@@ -327,8 +339,7 @@ inferConstraintsStock (DerivInstTys { dit_cls_tys     = cls_tys
                           [ ppr main_cls <+> ppr inst_tys'
                           , ppr arg_constraints
                           ]
-                   ; return ( stupid_constraints ++ extra_constraints
-                                                 ++ arg_constraints
+                   ; return ( extra_constraints ++ arg_constraints
                             , tvs', inst_tys') }
 
 -- | Like 'inferConstraints', but used only in the case of @DeriveAnyClass@,
diff --git a/testsuite/tests/deriving/should_compile/T20501.hs b/testsuite/tests/deriving/should_compile/T20501.hs
new file mode 100644
index 0000000000..6f3a8b101d
--- /dev/null
+++ b/testsuite/tests/deriving/should_compile/T20501.hs
@@ -0,0 +1,12 @@
+{-# LANGUAGE DatatypeContexts #-}
+module T20501 where
+
+data Show a => T1 a = MkT1
+  deriving Eq
+
+-- Should compile even with Eq constraints
+eqT1 :: T1 a -> T1 a -> Bool
+eqT1 MkT1 MkT1 = True
+
+data Show a => T2 a = MkT2
+deriving instance Eq (T2 a)
diff --git a/testsuite/tests/deriving/should_compile/T20501.stderr b/testsuite/tests/deriving/should_compile/T20501.stderr
new file mode 100644
index 0000000000..acb15a7255
--- /dev/null
+++ b/testsuite/tests/deriving/should_compile/T20501.stderr
@@ -0,0 +1,3 @@
+
+T20501.hs:1:14: warning: [-Wdeprecated-flags (in -Wdefault)]
+    -XDatatypeContexts is deprecated: It was widely considered a misfeature, and has been removed from the Haskell language.
diff --git a/testsuite/tests/deriving/should_compile/all.T b/testsuite/tests/deriving/should_compile/all.T
index 87908020f6..eb558b11cf 100644
--- a/testsuite/tests/deriving/should_compile/all.T
+++ b/testsuite/tests/deriving/should_compile/all.T
@@ -132,3 +132,4 @@ test('T18914', normal, compile, [''])
 # They are printed in tcDeriv beginning with "rnd" line
 # and are indented with spaces.
 test('T20496', multiline_grep_errmsg(r"rnd\n( .*\n)*"), compile, ['-ddump-tc-trace'])
+test('T20501', normal, compile, [''])