diff options
author | Ryan Scott <ryan.gl.scott@gmail.com> | 2021-11-06 16:08:48 -0400 |
---|---|---|
committer | Marge Bot <ben+marge-bot@smart-cactus.org> | 2021-11-09 19:55:07 -0500 |
commit | 983a99f0730b230367a327c5ef28cb5ec5dfedc2 (patch) | |
tree | 4643f677f9c424ceb2b799b24d831ff1fbc0d393 | |
parent | e485f4f21132a8a9c178b19272b06826e3dad133 (diff) | |
download | haskell-983a99f0730b230367a327c5ef28cb5ec5dfedc2.tar.gz |
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.
-rw-r--r-- | compiler/GHC/Tc/Deriv/Infer.hs | 37 | ||||
-rw-r--r-- | testsuite/tests/deriving/should_compile/T20501.hs | 12 | ||||
-rw-r--r-- | testsuite/tests/deriving/should_compile/T20501.stderr | 3 | ||||
-rw-r--r-- | testsuite/tests/deriving/should_compile/all.T | 1 |
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, ['']) |