diff options
| -rw-r--r-- | compiler/typecheck/TcGenGenerics.hs | 36 | ||||
| -rw-r--r-- | testsuite/tests/generics/Makefile | 5 | ||||
| -rw-r--r-- | testsuite/tests/generics/T15012.hs | 7 | ||||
| -rw-r--r-- | testsuite/tests/generics/T15012a.hs | 11 | ||||
| -rw-r--r-- | testsuite/tests/generics/all.T | 2 |
5 files changed, 60 insertions, 1 deletions
diff --git a/compiler/typecheck/TcGenGenerics.hs b/compiler/typecheck/TcGenGenerics.hs index 61a432e9dc..9da94280ce 100644 --- a/compiler/typecheck/TcGenGenerics.hs +++ b/compiler/typecheck/TcGenGenerics.hs @@ -420,7 +420,15 @@ tc_mkRepFamInsts gk tycon inst_tys = -- type arguments before generating the Rep/Rep1 instance, since some -- of the tyvars might have been instantiated when deriving. -- See Note [Generating a correctly typed Rep instance]. - ; let env = zipTyEnv tyvars inst_args + ; let (env_tyvars, env_inst_args) + = case gk_ of + Gen0_ -> (tyvars, inst_args) + Gen1_ last_tv + -- See the "wrinkle" in + -- Note [Generating a correctly typed Rep instance] + -> ( last_tv : tyvars + , anyTypeOfKind (tyVarKind last_tv) : inst_args ) + env = zipTyEnv env_tyvars env_inst_args in_scope = mkInScopeSet (tyCoVarsOfTypes inst_tys) subst = mkTvSubst in_scope env repTy' = substTy subst repTy @@ -923,6 +931,32 @@ the tyConTyVars of the TyCon to their counterparts in the fully instantiated type. (For example, using T above as example, you'd map a :-> Int.) We then apply the substitution to the RHS before generating the instance. +A wrinkle in all of this: when forming the type variable substitution for +Generic1 instances, we map the last type variable of the tycon to Any. Why? +It's because of wily data types like this one (#15012): + + data T a = MkT (FakeOut a) + type FakeOut a = Int + +If we ignore a, then we'll produce the following Rep1 instance: + + instance Generic1 T where + type Rep1 T = ... (Rec0 (FakeOut a)) + ... + +Oh no! Now we have `a` on the RHS, but it's completely unbound. Instead, we +ensure that `a` is mapped to Any: + + instance Generic1 T where + type Rep1 T = ... (Rec0 (FakeOut Any)) + ... + +And now all is good. + +Alternatively, we could have avoided this problem by expanding all type +synonyms on the RHSes of Rep1 instances. But we might blow up the size of +these types even further by doing this, so we choose not to do so. + Note [Handling kinds in a Rep instance] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Because Generic1 is poly-kinded, the representation types were generalized to diff --git a/testsuite/tests/generics/Makefile b/testsuite/tests/generics/Makefile index 9a36a1c5fe..69a5802b96 100644 --- a/testsuite/tests/generics/Makefile +++ b/testsuite/tests/generics/Makefile @@ -1,3 +1,8 @@ TOP=../.. include $(TOP)/mk/boilerplate.mk include $(TOP)/mk/test.mk + +T15012: + $(RM) T15012.hi T15012.o T15012a.hi T15012a.o + '$(TEST_HC)' $(TEST_HC_OPTS) -c T15012a.hs + '$(TEST_HC)' $(TEST_HC_OPTS) -c T15012.hs diff --git a/testsuite/tests/generics/T15012.hs b/testsuite/tests/generics/T15012.hs new file mode 100644 index 0000000000..388eddc0ed --- /dev/null +++ b/testsuite/tests/generics/T15012.hs @@ -0,0 +1,7 @@ +module T15012 where + +import GHC.Generics +import T15012a + +blah :: IO () +blah = print $ from1 $ TyFamily 1 2 diff --git a/testsuite/tests/generics/T15012a.hs b/testsuite/tests/generics/T15012a.hs new file mode 100644 index 0000000000..5109ea08f0 --- /dev/null +++ b/testsuite/tests/generics/T15012a.hs @@ -0,0 +1,11 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE TypeFamilies #-} +module T15012a where + +import GHC.Generics + +type FakeOut a = Int + +data family TyFamily y z +data instance TyFamily a b = TyFamily Int (FakeOut b) + deriving Generic1 diff --git a/testsuite/tests/generics/all.T b/testsuite/tests/generics/all.T index 1d4aeaee38..f127f7895f 100644 --- a/testsuite/tests/generics/all.T +++ b/testsuite/tests/generics/all.T @@ -43,3 +43,5 @@ test('T10361a', normal, compile, ['']) test('T10361b', normal, compile, ['']) test('T11358', normal, compile_and_run, ['']) test('T12220', normal, compile, ['']) +test('T15012', [extra_files(['T15012.hs', 'T15012a.hs'])], run_command, + ['$MAKE -s --no-print-directory T15012']) |