diff options
| -rw-r--r-- | compiler/typecheck/TcDeriv.hs | 4 | ||||
| -rw-r--r-- | compiler/typecheck/TcGenGenerics.hs | 29 | ||||
| -rw-r--r-- | testsuite/tests/deriving/should_compile/T11357.hs | 10 | ||||
| -rw-r--r-- | testsuite/tests/deriving/should_compile/all.T | 1 |
4 files changed, 33 insertions, 11 deletions
diff --git a/compiler/typecheck/TcDeriv.hs b/compiler/typecheck/TcDeriv.hs index e98ca8852d..90d981600d 100644 --- a/compiler/typecheck/TcDeriv.hs +++ b/compiler/typecheck/TcDeriv.hs @@ -1240,10 +1240,10 @@ no_cons_why rep_tc = quotes (pprSourceTyCon rep_tc) <+> text "must have at least one data constructor" cond_RepresentableOk :: Condition -cond_RepresentableOk (_, tc, tc_args) = canDoGenerics tc tc_args +cond_RepresentableOk (dflags, tc, tc_args) = canDoGenerics dflags tc tc_args cond_Representable1Ok :: Condition -cond_Representable1Ok (_, tc, tc_args) = canDoGenerics1 tc tc_args +cond_Representable1Ok (dflags, tc, tc_args) = canDoGenerics1 dflags tc tc_args cond_enumOrProduct :: Class -> Condition cond_enumOrProduct cls = cond_isEnumeration `orCond` diff --git a/compiler/typecheck/TcGenGenerics.hs b/compiler/typecheck/TcGenGenerics.hs index 08b3c9abca..0477767bd2 100644 --- a/compiler/typecheck/TcGenGenerics.hs +++ b/compiler/typecheck/TcGenGenerics.hs @@ -18,6 +18,7 @@ import Type import TcType import TcGenDeriv import DataCon +import DynFlags ( DynFlags, GeneralFlag(Opt_PrintExplicitKinds), gopt ) import TyCon import FamInstEnv ( FamInst, FamFlavor(..), mkSingleCoAxiom ) import FamInst @@ -128,7 +129,7 @@ following constraints are satisfied. -} -canDoGenerics :: TyCon -> [Type] -> Validity +canDoGenerics :: DynFlags -> TyCon -> [Type] -> Validity -- canDoGenerics rep_tc tc_args determines if Generic/Rep can be derived for a -- type expression (rep_tc tc_arg0 tc_arg1 ... tc_argn). -- @@ -136,7 +137,7 @@ canDoGenerics :: TyCon -> [Type] -> Validity -- care of because canDoGenerics is applied to rep tycons. -- -- It returns Nothing if deriving is possible. It returns (Just reason) if not. -canDoGenerics tc tc_args +canDoGenerics dflags tc tc_args = mergeErrors ( -- Check (c) from Note [Requirements for deriving Generic and Rep]. (if (not (null (tyConStupidTheta tc))) @@ -146,7 +147,12 @@ canDoGenerics tc tc_args -- -- Data family indices can be instantiated; the `tc_args` here are -- the representation tycon args - (if (all isTyVarTy (filterOutInvisibleTypes tc tc_args)) + -- + -- NB: Use user_tc here. In the case of a data *instance*, the + -- user_tc is the family tc, which has the right visibility settings. + -- (For a normal datatype, user_tc == tc.) Getting this wrong + -- led to #11357. + (if (all isTyVarTy (filterOutInvisibleTypes user_tc tc_args)) then IsValid else NotValid (tc_name <+> text "must not be instantiated;" <+> text "try deriving `" <> tc_name <+> tc_tys <> @@ -156,9 +162,14 @@ canDoGenerics tc tc_args where -- The tc can be a representation tycon. When we want to display it to the -- user (in an error message) we should print its parent - (tc_name, tc_tys) = case tyConFamInst_maybe tc of - Just (ptc, tys) -> (ppr ptc, hsep (map ppr (tys ++ drop (length tys) tc_args))) - _ -> (ppr tc, hsep (map ppr (tyConTyVars tc))) + (user_tc, tc_name, tc_tys) = case tyConFamInst_maybe tc of + Just (ptc, tys) -> (ptc, ppr ptc, hsep (map ppr (filter_kinds $ tys ++ drop (length tys) tc_args))) + _ -> (tc, ppr tc, hsep (map ppr (filter_kinds $ mkTyVarTys $ tyConTyVars tc))) + + filter_kinds | gopt Opt_PrintExplicitKinds dflags + = id + | otherwise + = filterOutInvisibleTypes user_tc -- Check (d) from Note [Requirements for deriving Generic and Rep]. -- @@ -228,9 +239,9 @@ explicitly, even though foldDataConArgs is also doing this internally. -- are taken care of by the call to canDoGenerics. -- -- It returns Nothing if deriving is possible. It returns (Just reason) if not. -canDoGenerics1 :: TyCon -> [Type] -> Validity -canDoGenerics1 rep_tc tc_args = - canDoGenerics rep_tc tc_args `andValid` additionalChecks +canDoGenerics1 :: DynFlags -> TyCon -> [Type] -> Validity +canDoGenerics1 dflags rep_tc tc_args = + canDoGenerics dflags rep_tc tc_args `andValid` additionalChecks where additionalChecks -- check (f) from Note [Requirements for deriving Generic and Rep] diff --git a/testsuite/tests/deriving/should_compile/T11357.hs b/testsuite/tests/deriving/should_compile/T11357.hs new file mode 100644 index 0000000000..f3dc715f89 --- /dev/null +++ b/testsuite/tests/deriving/should_compile/T11357.hs @@ -0,0 +1,10 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE TypeFamilies #-} +module T11357 where + +import GHC.Generics (Generic1) + +data family ProxyFam (a :: k) +data instance ProxyFam (a :: k) = ProxyCon deriving Generic1 diff --git a/testsuite/tests/deriving/should_compile/all.T b/testsuite/tests/deriving/should_compile/all.T index ad235d695e..e62c50c218 100644 --- a/testsuite/tests/deriving/should_compile/all.T +++ b/testsuite/tests/deriving/should_compile/all.T @@ -64,3 +64,4 @@ test('T9968', normal, compile, ['']) test('T11174', normal, compile, ['']) test('T11416', normal, compile, ['']) test('T11396', normal, compile, ['']) +test('T11357', normal, compile, ['']) |