Delete GenericKind_ in favor of GenericKind_DCwip/T21185

When deriving a `Generic1` instance, we need to know what the last type
variable of a data type is. Previously, there were two mechanisms to determine
this information:

* `GenericKind_`, where `Gen1_` stored the last type variable of a data type
   constructor (i.e., the `tyConTyVars`).
* `GenericKind_DC`, where `Gen1_DC` stored the last universally quantified
  type variable in a data constructor (i.e., the `dataConUnivTyVars`).

These had different use cases, as `GenericKind_` was used for generating
`Rep(1)` instances, while `GenericKind_DC` was used for generating `from(1)`
and `to(1)` implementations. This was already a bit confusing, but things went
from confusing to outright wrong after !6976. This is because after !6976,
the `deriving` machinery stopped using `tyConTyVars` in favor of
`dataConUnivTyVars`. Well, everywhere with the sole exception of
`GenericKind_`, which still continued to use `tyConTyVars`. This lead to
disaster when deriving a `Generic1` instance for a GADT family instance, as
the `tyConTyVars` do not match the `dataConUnivTyVars`. (See #21185.)

The fix is to stop using `GenericKind_` and replace it with `GenericKind_DC`.
For the most part, this proves relatively straightforward. Some highlights:

* The `forgetArgVar` function was deleted entirely, as it no longer proved
  necessary after `GenericKind_`'s demise.
* The substitution that maps from the last type variable to `Any` (see
  `Note [Generating a correctly typed Rep instance]`) had to be moved from
  `tc_mkRepTy` to `tc_mkRepFamInsts`, as `tc_mkRepTy` no longer has access to
  the last type variable.

Fixes #21185.

3 files changed, 89 insertions, 71 deletions

diff --git a/compiler/GHC/Tc/Deriv/Generics.hs b/compiler/GHC/Tc/Deriv/Generics.hs
index 56b7e0de09..65a7329729 100644
--- a/compiler/GHC/Tc/Deriv/Generics.hs
+++ b/compiler/GHC/Tc/Deriv/Generics.hs
@@ -310,21 +310,25 @@ type Alt = (LPat GhcPs, LHsExpr GhcPs)
 -- Generic1 (Gen1).
 data GenericKind = Gen0 | Gen1
 
--- as above, but with a payload of the TyCon's name for "the" parameter
-data GenericKind_ = Gen0_ | Gen1_ TyVar
-
--- as above, but using a single datacon's name for "the" parameter
+-- Like 'GenericKind', but with a payload of a datacon's last universally
+-- quantified 'TyVar' in the 'Generic1' case.
+--
+-- Note that for GADTs, the last TyVar's Name will be different in each data
+-- constructor, so it is not correct to simply use the last TyVar in
+-- 'tyConTyVars' in 'Gen1_DC'. (See #21185 for an example of what would happen
+-- if you tried.)
 data GenericKind_DC = Gen0_DC | Gen1_DC TyVar
 
-forgetArgVar :: GenericKind_DC -> GenericKind
-forgetArgVar Gen0_DC   = Gen0
-forgetArgVar Gen1_DC{} = Gen1
-
--- When working only within a single datacon, "the" parameter's name should
--- match that datacon's name for it.
-gk2gkDC :: GenericKind_ -> DataCon -> GenericKind_DC
-gk2gkDC Gen0_   _ = Gen0_DC
-gk2gkDC Gen1_{} d = Gen1_DC $ last $ dataConUnivTyVars d
+-- Construct a 'GenericKind_DC', retrieving the last universally quantified
+-- type variable of a 'DataCon' in the 'Generic1' case.
+gk2gkDC :: GenericKind -> DataCon -> [Type] -> GenericKind_DC
+gk2gkDC Gen0 _  _       = Gen0_DC
+gk2gkDC Gen1 dc tc_args = Gen1_DC $ assert (isTyVarTy last_dc_inst_univ)
+                                  $ getTyVar "gk2gkDC" last_dc_inst_univ
+  where
+    dc_inst_univs = dataConInstUnivs dc tc_args
+    last_dc_inst_univ = assert (not (null dc_inst_univs)) $
+                        last dc_inst_univs
 
 
 -- Bindings for the Generic instance
@@ -376,12 +380,7 @@ mkBindsRep dflags gk dit@(DerivInstTys{dit_rep_tc = tycon}) = (binds, sigs)
 
         -- Recurse over the sum first
         from_alts, to_alts :: [Alt]
-        (from_alts, to_alts) = mkSum gk_ (1 :: US) dit datacons
-          where gk_ = case gk of
-                  Gen0 -> Gen0_
-                  Gen1 -> assert (tyvars `lengthAtLeast` 1) $
-                          Gen1_ (last tyvars)
-                    where tyvars = tyConTyVars tycon
+        (from_alts, to_alts) = mkSum gk (1 :: US) dit datacons
 
 --------------------------------------------------------------------------------
 -- The type synonym instance and synonym
@@ -419,14 +418,8 @@ tc_mkRepFamInsts gk get_fixity inst_tys dit@(DerivInstTys{dit_rep_tc = tycon}) =
              (Gen1, [arg_k, inst_t]) -> (arg_k,          inst_t)
              _ -> pprPanic "tc_mkRepFamInsts" (ppr inst_tys)
 
-           gk_ = case gk of
-             Gen0 -> Gen0_
-             Gen1 -> assert (not $ null all_tyvars)
-                     Gen1_ $ last all_tyvars
-             where all_tyvars = tyConTyVars tycon
-
        -- `repTy` = D1 ... (C1 ... (S1 ... (Rec0 a))) :: * -> *
-     ; repTy <- tc_mkRepTy gk_ get_fixity dit arg_ki
+     ; repTy <- tc_mkRepTy gk get_fixity dit arg_ki
 
        -- `rep_name` is a name we generate for the synonym
      ; mod <- getModule
@@ -435,23 +428,12 @@ tc_mkRepFamInsts gk get_fixity inst_tys dit@(DerivInstTys{dit_rep_tc = tycon}) =
            rep_occ = case gk of Gen0 -> mkGenR tc_occ; Gen1 -> mkGen1R tc_occ
      ; rep_name <- newGlobalBinder mod rep_occ loc
 
-       -- If deriving Generic1, make sure to substitute the last type variable
-       -- with Any in the generated Rep1 instance. This avoids issues like what
-       -- is documented in the "wrinkle" section of
-       -- Note [Generating a correctly typed Rep instance].
-     ; let env = case gk_ of
-                   Gen0_ -> emptyTvSubstEnv
-                   Gen1_ last_tv
-                     -> zipTyEnv [last_tv] [anyTypeOfKind (tyVarKind last_tv)]
-           in_scope   = mkInScopeSet (tyCoVarsOfTypes inst_tys)
-           subst      = mkTvSubst in_scope env
-           repTy'     = substTyUnchecked  subst repTy
-           tcv'       = tyCoVarsOfTypeList inst_ty
-           (tv', cv') = partition isTyVar tcv'
-           tvs'       = scopedSort tv'
-           cvs'       = scopedSort cv'
-           axiom      = mkSingleCoAxiom Nominal rep_name tvs' [] cvs'
-                                        fam_tc inst_tys repTy'
+     ; let tcv      = tyCoVarsOfTypeList inst_ty
+           (tv, cv) = partition isTyVar tcv
+           tvs      = scopedSort tv
+           cvs      = scopedSort cv
+           axiom    = mkSingleCoAxiom Nominal rep_name tvs [] cvs
+                                      fam_tc inst_tys repTy
 
      ; newFamInst SynFamilyInst axiom  }
 
@@ -524,8 +506,8 @@ argTyFold argVar (ArgTyAlg {ata_rec0 = mkRec0,
             else mkComp phi `fmap` go beta -- It must be a composition.
 
 
-tc_mkRepTy ::  -- Gen0_ or Gen1_, for Rep or Rep1
-               GenericKind_
+tc_mkRepTy ::  -- Gen0 or Gen1, for Rep or Rep1
+               GenericKind
                -- Get the Fixity for a data constructor Name
             -> (Name -> Fixity)
                -- Information about the last type argument to Generic(1)
@@ -535,7 +517,8 @@ tc_mkRepTy ::  -- Gen0_ or Gen1_, for Rep or Rep1
             -> Kind
                -- Generated representation0 type
             -> TcM Type
-tc_mkRepTy gk_ get_fixity dit@(DerivInstTys{dit_rep_tc = tycon}) k =
+tc_mkRepTy gk get_fixity dit@(DerivInstTys{ dit_rep_tc = tycon
+                                          , dit_rep_tc_args = tycon_args }) k =
   do
     d1      <- tcLookupTyCon d1TyConName
     c1      <- tcLookupTyCon c1TyConName
@@ -583,7 +566,8 @@ tc_mkRepTy gk_ get_fixity dit@(DerivInstTys{dit_rep_tc = tycon}) k =
         mkD    a   = mkTyConApp d1 [ k, metaDataTy, sumP (tyConDataCons a) ]
         mkC      a = mkTyConApp c1 [ k
                                    , metaConsTy a
-                                   , prod (derivDataConInstArgTys a dit)
+                                   , prod (gk2gkDC gk a tycon_args)
+                                          (derivDataConInstArgTys a dit)
                                           (dataConSrcBangs    a)
                                           (dataConImplBangs   a)
                                           (dataConFieldLabels a)]
@@ -592,28 +576,38 @@ tc_mkRepTy gk_ get_fixity dit@(DerivInstTys{dit_rep_tc = tycon}) k =
         -- Sums and products are done in the same way for both Rep and Rep1
         sumP l = foldBal mkSum' (mkTyConApp v1 [k]) . map mkC $ l
         -- The Bool is True if this constructor has labelled fields
-        prod :: [Type] -> [HsSrcBang] -> [HsImplBang] -> [FieldLabel] -> Type
-        prod l sb ib fl = foldBal mkProd (mkTyConApp u1 [k])
+        prod :: GenericKind_DC -> [Type] -> [HsSrcBang] -> [HsImplBang] -> [FieldLabel] -> Type
+        prod gk_ l sb ib fl = foldBal mkProd (mkTyConApp u1 [k])
                                   [ assert (null fl || lengthExceeds fl j) $
-                                    arg t sb' ib' (if null fl
-                                                      then Nothing
-                                                      else Just (fl !! j))
+                                    arg gk_ t sb' ib' (if null fl
+                                                       then Nothing
+                                                       else Just (fl !! j))
                                   | (t,sb',ib',j) <- zip4 l sb ib [0..] ]
 
-        arg :: Type -> HsSrcBang -> HsImplBang -> Maybe FieldLabel -> Type
-        arg t (HsSrcBang _ su ss) ib fl = mkS fl su ss ib $ case gk_ of
+        arg :: GenericKind_DC -> Type -> HsSrcBang -> HsImplBang -> Maybe FieldLabel -> Type
+        arg gk_ t (HsSrcBang _ su ss) ib fl = mkS fl su ss ib $ case gk_ of
             -- Here we previously used Par0 if t was a type variable, but we
             -- realized that we can't always guarantee that we are wrapping-up
             -- all type variables in Par0. So we decided to stop using Par0
             -- altogether, and use Rec0 all the time.
-                      Gen0_        -> mkRec0 t
-                      Gen1_ argVar -> argPar argVar t
+                      Gen0_DC        -> mkRec0 t
+                      Gen1_DC argVar -> argPar argVar t
           where
             -- Builds argument representation for Rep1 (more complicated due to
             -- the presence of composition).
-            argPar argVar = argTyFold argVar $ ArgTyAlg
+            argPar argVar =
+              let -- If deriving Generic1, make sure to substitute the last
+                  -- type variable with Any in the generated Rep1 instance.
+                  -- This avoids issues like what is documented in the
+                  -- "wrinkle" section of
+                  -- Note [Generating a correctly typed Rep instance].
+                  env      = zipTyEnv [argVar] [anyTypeOfKind (tyVarKind argVar)]
+                  in_scope = mkInScopeSet (tyCoVarsOfTypes tycon_args)
+                  subst    = mkTvSubst in_scope env in
+
+              substTy subst . argTyFold argVar (ArgTyAlg
               {ata_rec0 = mkRec0, ata_par1 = mkPar1,
-               ata_rec1 = mkRec1, ata_comp = mkComp comp k}
+               ata_rec1 = mkRec1, ata_comp = mkComp comp k})
 
         tyConName_user = case tyConFamInst_maybe tycon of
                            Just (ptycon, _) -> tyConName ptycon
@@ -713,7 +707,7 @@ mkBoxTy uAddr uChar uDouble uFloat uInt uWord rec0 k ty
 -- Dealing with sums
 --------------------------------------------------------------------------------
 
-mkSum :: GenericKind_ -- Generic or Generic1?
+mkSum :: GenericKind  -- Generic or Generic1?
       -> US           -- Base for generating unique names
       -> DerivInstTys -- Information about the last type argument to Generic(1)
       -> [DataCon]    -- The data constructors
@@ -728,23 +722,24 @@ mkSum _ _ _ [] = ([from_alt], [to_alt])
                -- These M1s are meta-information for the datatype
 
 -- Datatype with at least one constructor
-mkSum gk_ us dit datacons =
+mkSum gk us dit datacons =
   -- switch the payload of gk_ to be datacon-centric instead of tycon-centric
- unzip [ mk1Sum (gk2gkDC gk_ d) us i (length datacons) dit d
+ unzip [ mk1Sum gk us i (length datacons) dit d
            | (d,i) <- zip datacons [1..] ]
 
 -- Build the sum for a particular constructor
-mk1Sum :: GenericKind_DC -- Generic or Generic1?
-       -> US             -- Base for generating unique names
-       -> Int            -- The index of this constructor
-       -> Int            -- Total number of constructors
-       -> DerivInstTys   -- Information about the last type argument to Generic(1)
-       -> DataCon        -- The data constructor
-       -> (Alt,          -- Alternative for the T->Trep "from" function
-           Alt)          -- Alternative for the Trep->T "to" function
-mk1Sum gk_ us i n dit datacon = (from_alt, to_alt)
+mk1Sum :: GenericKind  -- Generic or Generic1?
+       -> US           -- Base for generating unique names
+       -> Int          -- The index of this constructor
+       -> Int          -- Total number of constructors
+       -> DerivInstTys -- Information about the last type argument to Generic(1)
+       -> DataCon      -- The data constructor
+       -> (Alt,        -- Alternative for the T->Trep "from" function
+           Alt)        -- Alternative for the Trep->T "to" function
+mk1Sum gk us i n dit@(DerivInstTys{dit_rep_tc_args = tc_args}) datacon
+  = (from_alt, to_alt)
   where
-    gk = forgetArgVar gk_
+    gk_ = gk2gkDC gk datacon tc_args
 
     -- Existentials already excluded
     argTys = derivDataConInstArgTys datacon dit
diff --git a/testsuite/tests/generics/T21185.hs b/testsuite/tests/generics/T21185.hs
new file mode 100644
index 0000000000..1d2d1f30af
--- /dev/null
+++ b/testsuite/tests/generics/T21185.hs
@@ -0,0 +1,22 @@
+{-# LANGUAGE TypeFamilies #-}
+module T21185 where
+
+import Data.Kind (Type)
+import GHC.Generics (Generic1(..))
+
+type FakeOut x = Int
+
+data D (b :: Type) where
+  MkD :: c -> FakeOut c -> D c
+  deriving Generic1
+
+data family DF (a :: Type)
+data instance DF (b :: Type) where
+  MkDF :: c -> FakeOut c -> DF c
+  deriving Generic1
+
+d :: Rep1 D ()
+d = from1 $ MkD () 42
+
+df :: Rep1 DF ()
+df = from1 $ MkDF () 42
diff --git a/testsuite/tests/generics/all.T b/testsuite/tests/generics/all.T
index 1fccfffc16..a43f585020 100644
--- a/testsuite/tests/generics/all.T
+++ b/testsuite/tests/generics/all.T
@@ -45,3 +45,4 @@ test('T11358', normal, compile_and_run, [''])
 test('T12220', normal, compile, [''])
 test('T15012', [extra_files(['T15012.hs', 'T15012a.hs'])], makefile_test, [])
 test('T19819', normal, compile_and_run, [''])
+test('T21185', normal, compile, [''])