[commit: ghc] master: Fix #15012 with a well-placed use of Any (b08a6d7)

[git at git.haskell.org]

Repository : ssh://git@git.haskell.org/ghc

On branch  : master
Link       : http://ghc.haskell.org/trac/ghc/changeset/b08a6d75e0440f33260bea5319b8c3f871b42f6e/ghc

>---------------------------------------------------------------

commit b08a6d75e0440f33260bea5319b8c3f871b42f6e
Author: Ryan Scott <ryan.gl.scott at gmail.com>
Date:   Thu Apr 19 12:36:42 2018 -0400

    Fix #15012 with a well-placed use of Any
    
    Previously, derived `Generic1` instances could have associated `Rep1`
    type family instances with unbound variables, such as in the following
    example:
    
    ```lang=haskell
    data T a = MkT (FakeOut a) deriving Generic1
    type FakeOut a = Int
    
    ==>
    
    instance Generic1 T where
      type Rep1 T = ... (Rec0 (FakeOut a))
    ```
    
    Yikes! To avoid this, we simply map the last type variable in a
    derived `Generic1` instance to `Any`.
    
    Test Plan: make test TEST=T15012
    
    Reviewers: bgamari
    
    Reviewed By: bgamari
    
    Subscribers: simonpj, thomie, carter
    
    GHC Trac Issues: #15012
    
    Differential Revision: https://phabricator.haskell.org/D4602


>---------------------------------------------------------------

b08a6d75e0440f33260bea5319b8c3f871b42f6e
 compiler/typecheck/TcGenGenerics.hs | 36 +++++++++++++++++++++++++++++++++++-
 testsuite/tests/generics/Makefile   |  5 +++++
 testsuite/tests/generics/T15012.hs  |  7 +++++++
 testsuite/tests/generics/T15012a.hs | 11 +++++++++++
 testsuite/tests/generics/all.T      |  2 ++
 5 files changed, 60 insertions(+), 1 deletion(-)

diff --git a/compiler/typecheck/TcGenGenerics.hs b/compiler/typecheck/TcGenGenerics.hs
index 61a432e9..9da9428 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 9a36a1c..69a5802 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 0000000..388eddc
--- /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 0000000..5109ea0
--- /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 1d4aeae..f127f78 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'])