Make the implementation of DeriveAnyClass more robust

Let DeriveAnyClass properly handle multiparameter type classes.
Also use a new strategy for inferring constraints for
derived classes.

This fixes #9968 and #9821.

3 files changed, 345 insertions, 207 deletions

diff --git a/compiler/typecheck/TcDeriv.hs b/compiler/typecheck/TcDeriv.hs
index bbe23087c7..f4b7847926 100644
--- a/compiler/typecheck/TcDeriv.hs
+++ b/compiler/typecheck/TcDeriv.hs
@@ -48,6 +48,7 @@ import ErrUtils
 import DataCon
 import Maybes
 import RdrName
+import Id ( idType )
 import Name
 import NameSet
 import TyCon
@@ -162,7 +163,9 @@ earlyDSClass :: EarlyDerivSpec -> Class
 earlyDSClass (InferTheta spec) = ds_cls spec
 earlyDSClass (GivenTheta spec) = ds_cls spec
 
-splitEarlyDerivSpec :: [EarlyDerivSpec] -> ([DerivSpec ThetaOrigin], [DerivSpec ThetaType])
+splitEarlyDerivSpec :: [EarlyDerivSpec]
+                    -> ( [DerivSpec ThetaOrigin] -- Standard deriving
+                       , [DerivSpec ThetaType])  -- Standlone deriving
 splitEarlyDerivSpec [] = ([],[])
 splitEarlyDerivSpec (InferTheta spec : specs) =
     case splitEarlyDerivSpec specs of (is, gs) -> (spec : is, gs)
@@ -362,25 +365,35 @@ tcDeriving tycl_decls inst_decls deriv_decls
         ; early_specs <- makeDerivSpecs is_boot tycl_decls inst_decls deriv_decls
         ; traceTc "tcDeriving 1" (ppr early_specs)
 
-        -- for each type, determine the auxliary declarations that are common
-        -- to multiple derivations involving that type (e.g. Generic and
-        -- Generic1 should use the same TcGenGenerics.MetaTyCons)
-        ; (commonAuxs, auxDerivStuff) <- commonAuxiliaries $ map forgetTheta early_specs
+        -- Generic/Generic1 derived instances need to be handled first, because
+        -- we might need the Rep family instances when inferring derived
+        -- contexts (See Note [Inferring contexts for DeriveAnyClass])
+        ; genDerivStuff <- genericAuxiliaries $ map forgetTheta early_specs
+        ; let (newTyCons, famInsts, extraInstances) = splitDerivStuff genDerivStuff
 
-        ; let (infer_specs, given_specs) = splitEarlyDerivSpec early_specs
-        ; insts1 <- mapM (genInst commonAuxs) given_specs
+        ; let thingTycons = map ATyCon (bagToList newTyCons)
+        ; tcExtendGlobalEnv thingTycons $
+          tcExtendGlobalEnvImplicit (concatMap implicitTyThings thingTycons) $
+          tcExtendLocalFamInstEnv (bagToList famInsts) $ do {
+
+          let (infer_specs, given_specs) = splitEarlyDerivSpec early_specs
+
+        ; insts1 <- mapM genInst given_specs
+        ; let (earlyInstInfos, _, _) = unzip3 insts1
 
         -- the stand-alone derived instances (@insts1@) are used when inferring
         -- the contexts for "deriving" clauses' instances (@infer_specs@)
-        ; final_specs <- extendLocalInstEnv (map (iSpec . fstOf3) insts1) $
+        ; final_specs <- extendLocalInstEnv
+                           (map iSpec (earlyInstInfos
+                                      -- Don't forget the Generics instances
+                                    ++ bagToList extraInstances)) $
                          inferInstanceContexts infer_specs
 
-        ; insts2 <- mapM (genInst commonAuxs) final_specs
+        ; insts2 <- mapM genInst final_specs
 
-        ; let (inst_infos, deriv_stuff, maybe_fvs) = unzip3 (insts1 ++ insts2)
         ; loc <- getSrcSpanM
-        ; let (binds, newTyCons, famInsts, extraInstances) =
-                genAuxBinds loc (unionManyBags (auxDerivStuff : deriv_stuff))
+        ; let (inst_infos, aux_binds, maybe_fvs) = unzip3 (insts1 ++ insts2)
+        ; let binds = genAuxBinds loc (unionManyBags aux_binds)
 
         ; (inst_info, rn_binds, rn_dus) <-
             renameDeriv is_boot (inst_infos ++ (bagToList extraInstances)) binds
@@ -390,13 +403,9 @@ tcDeriving tycl_decls inst_decls deriv_decls
              liftIO (dumpIfSet_dyn dflags Opt_D_dump_deriv "Derived instances"
                         (ddump_deriving inst_info rn_binds newTyCons famInsts))
 
-        ; let all_tycons = map ATyCon (bagToList newTyCons)
-        ; gbl_env <- tcExtendGlobalEnv all_tycons $
-                     tcExtendGlobalEnvImplicit (concatMap implicitTyThings all_tycons) $
-                     tcExtendLocalFamInstEnv (bagToList famInsts) $
-                     tcExtendLocalInstEnv (map iSpec (bagToList inst_info)) getGblEnv
+        ; gbl_env <- tcExtendLocalInstEnv (map iSpec (bagToList inst_info)) getGblEnv
         ; let all_dus = rn_dus `plusDU` usesOnly (mkFVs $ catMaybes maybe_fvs)
-        ; return (addTcgDUs gbl_env all_dus, inst_info, rn_binds) }
+        ; return (addTcgDUs gbl_env all_dus, inst_info, rn_binds) } }
   where
     ddump_deriving :: Bag (InstInfo Name) -> HsValBinds Name
                    -> Bag TyCon               -- ^ Empty data constructors
@@ -423,19 +432,24 @@ pprRepTy fi@(FamInst { fi_tys = lhs })
 
 -- As of 24 April 2012, this only shares MetaTyCons between derivations of
 -- Generic and Generic1; thus the types and logic are quite simple.
-type CommonAuxiliary = MetaTyCons
-type CommonAuxiliaries = [(TyCon, CommonAuxiliary)] -- NSF what is a more efficient map type?
-
-commonAuxiliaries :: [DerivSpec ()] -> TcM (CommonAuxiliaries, BagDerivStuff)
-commonAuxiliaries = foldM snoc ([], emptyBag) where
-  snoc acc@(cas, stuff) (DS {ds_name = nm, ds_cls = cls, ds_tc = rep_tycon})
-    | getUnique cls `elem` [genClassKey, gen1ClassKey] =
-      extendComAux $ genGenericMetaTyCons rep_tycon (nameModule nm)
-    | otherwise = return acc
-   where extendComAux m -- don't run m if its already in the accumulator
-           | any ((rep_tycon ==) . fst) cas = return acc
-           | otherwise = do (ca, new_stuff) <- m
-                            return $ ((rep_tycon, ca) : cas, stuff `unionBags` new_stuff)
+genericAuxiliaries :: [DerivSpec ()] -> TcM BagDerivStuff
+genericAuxiliaries = fmap snd . foldM snoc ([], emptyBag) where
+  snoc acc@(gas, metaTyCons) (DS {ds_name = nm, ds_cls = cls, ds_tc = repTycon})
+    | getUnique cls `elem` [genClassKey, gen1ClassKey] = extendComAux
+    | otherwise                                        = return acc
+   where extendComAux
+           | Just thisMetaTyCons <- lookup repTycon gas
+           -- don't generate new MetaTyCons if we've already done this tycon
+           = do famInst <- tc_mkRepFamInst gk repTycon thisMetaTyCons (nameModule nm)
+                return $ (gas, DerivFamInst famInst `consBag` metaTyCons)
+
+           | otherwise
+           = do (newMetaTyCons, newInstances) <- genGenericMetaTyCons repTycon (nameModule nm)
+                let newGas = (repTycon, newMetaTyCons) : gas
+                famInst <- tc_mkRepFamInst gk repTycon newMetaTyCons (nameModule nm)
+                return $ (newGas, DerivFamInst famInst `consBag` metaTyCons `unionBags` newInstances)
+
+         gk = if getUnique cls == genClassKey then Gen0 else Gen1
 
 renameDeriv :: Bool
             -> [InstInfo RdrName]
@@ -723,8 +737,7 @@ deriveTyData :: Bool                         -- False <=> data/newtype
 deriveTyData is_instance tvs tc tc_args (L loc deriv_pred)
   = setSrcSpan loc     $        -- Use the location of the 'deriving' item
     do  { (deriv_tvs, cls, cls_tys, cls_arg_kind)
-                <- tcExtendTyVarEnv tvs $
-                   tcHsDeriv deriv_pred
+                <- tcExtendTyVarEnv tvs (tcHsDeriv deriv_pred)
                 -- Deriving preds may (now) mention
                 -- the type variables for the type constructor, hence tcExtendTyVarenv
                 -- The "deriv_pred" is a LHsType to take account of the fact that for
@@ -772,8 +785,9 @@ deriveTyData is_instance tvs tc tc_args (L loc deriv_pred)
 
         ; traceTc "derivTyData2" (vcat [ ppr univ_tvs ])
 
-        ; checkTc (allDistinctTyVars args_to_drop &&              -- (a) and (b)
-                   not (any (`elemVarSet` dropped_tvs) univ_tvs)) -- (c)
+        ; checkTc (allDistinctTyVars args_to_drop &&  -- (a) and (b)
+                   dropped_tvs `disjointVarSet`
+                     tyVarsOfTypes final_cls_tys)     -- (c)
                   (derivingEtaErr cls final_cls_tys (mkTyConApp tc final_tc_args))
                 -- Check that
                 --  (a) The args to drop are all type variables; eg reject:
@@ -1007,21 +1021,23 @@ mkDataTypeEqn dflags overlap_mode tvs cls cls_tys
         -- NB: pass the *representation* tycon to checkSideConditions
         NonDerivableClass   msg -> bale_out (nonStdErr cls $$ msg)
         DerivableClassError msg -> bale_out msg
-        CanDerive               -> go_for_it
-        DerivableViaInstance    -> go_for_it
+        CanDerive               -> go_for_it True
+        DerivableViaInstance    -> go_for_it False
   where
-    go_for_it    = mk_data_eqn overlap_mode tvs cls tycon tc_args rep_tc rep_tc_args mtheta
-    bale_out msg = failWithTc (derivingThingErr False cls cls_tys (mkTyConApp tycon tc_args) msg)
+    go_for_it std_cls = mk_data_eqn overlap_mode std_cls tvs cls cls_tys tycon
+                                    tc_args rep_tc rep_tc_args mtheta
+    bale_out msg = failWithTc (derivingThingErr False cls cls_tys
+                                                (mkTyConApp tycon tc_args) msg)
 
-mk_data_eqn :: Maybe OverlapMode -> [TyVar] -> Class
+mk_data_eqn :: Maybe OverlapMode -> Bool -> [TyVar] -> Class -> [Type]
             -> TyCon -> [TcType] -> TyCon -> [TcType] -> DerivContext
             -> TcM EarlyDerivSpec
-mk_data_eqn overlap_mode tvs cls tycon tc_args rep_tc rep_tc_args mtheta
+mk_data_eqn overlap_mode std_cls tvs cls cls_tys tycon tc_args rep_tc rep_tc_args mtheta
   = do loc                  <- getSrcSpanM
        dfun_name            <- new_dfun_name cls tycon
        case mtheta of
         Nothing -> do --Infer context
-            inferred_constraints <- inferConstraints cls inst_tys rep_tc rep_tc_args
+            inferred_constraints <- inferConstraints std_cls cls inst_tys rep_tc rep_tc_args
             return $ InferTheta $ DS
                    { ds_loc = loc
                    , ds_name = dfun_name, ds_tvs = tvs
@@ -1040,7 +1056,7 @@ mk_data_eqn overlap_mode tvs cls tycon tc_args rep_tc rep_tc_args mtheta
                    , ds_overlap = overlap_mode
                    , ds_newtype = False }
   where
-    inst_tys = [mkTyConApp tycon tc_args]
+    inst_tys = cls_tys ++ [mkTyConApp tycon tc_args]
 
 ----------------------
 
@@ -1076,13 +1092,14 @@ mkPolyKindedTypeableEqn cls tc
           tc_args = mkTyVarTys kvs
           tc_app  = mkTyConApp tc tc_args
 
-inferConstraints :: Class -> [TcType]
+inferConstraints :: Bool
+                 -> Class -> [TcType]
                  -> TyCon -> [TcType]
                  -> TcM ThetaOrigin
 -- Generate a sufficiently large set of constraints that typechecking the
 -- generated method definitions should succeed.   This set will be simplified
 -- before being used in the instance declaration
-inferConstraints cls inst_tys rep_tc rep_tc_args
+inferConstraints std_cls cls inst_tys rep_tc rep_tc_args
   | cls `hasKey` genClassKey    -- Generic constraints are easy
   = return []
 
@@ -1094,9 +1111,11 @@ inferConstraints cls inst_tys rep_tc rep_tc_args
   | otherwise  -- The others are a bit more complicated
   = ASSERT2( equalLength rep_tc_tvs all_rep_tc_args, ppr cls <+> ppr rep_tc )
     do { traceTc "inferConstraints" (vcat [ppr cls <+> ppr inst_tys, ppr arg_constraints])
-       ; return (stupid_constraints ++ extra_constraints
-                 ++ sc_constraints
-                 ++ arg_constraints) }
+       ; dm_constraints <- get_dm_constraints
+       ; return (stupid_constraints ++ sc_constraints
+                 ++ if std_cls
+                    then extra_constraints ++ arg_constraints
+                    else mkThetaOrigin DerivOrigin (concat dm_constraints)) }
   where
     arg_constraints = con_arg_constraints cls get_std_constrained_tys
 
@@ -1117,11 +1136,7 @@ inferConstraints cls inst_tys rep_tc rep_tc_args
                 -- (a) We recurse over argument types to generate constraints
                 --     See Functor examples in TcGenDeriv
                 -- (b) The rep_tc_args will be one short
-    is_functor_like =    getUnique cls `elem` functorLikeClassKeys
-                      || onlyOneAndTypeConstr inst_tys
-    onlyOneAndTypeConstr [inst_ty] =
-      typeKind inst_ty `tcEqKind` mkArrowKind liftedTypeKind liftedTypeKind
-    onlyOneAndTypeConstr _         = False
+    is_functor_like = getUnique cls `elem` functorLikeClassKeys
 
     get_std_constrained_tys :: Type -> [Type]
     get_std_constrained_tys ty
@@ -1131,9 +1146,27 @@ inferConstraints cls inst_tys rep_tc rep_tc_args
     rep_tc_tvs = tyConTyVars rep_tc
     last_tv = last rep_tc_tvs
     all_rep_tc_args | cls `hasKey` gen1ClassKey || is_functor_like
-                      = rep_tc_args ++ [mkTyVarTy last_tv]
+                    = rep_tc_args ++ [mkTyVarTy last_tv]
                     | otherwise       = rep_tc_args
 
+        -- Constraints arising from default methods (only for DeriveAnyClass)
+    get_dm_constraints = mapM getDMTheta dms where
+      dms = filter ((/= NoDefMeth) . snd) (classOpItems cls)
+
+      getDMTheta :: ClassOpItem -> TcM ThetaType
+      getDMTheta (_, DefMeth    name) = do tcLookupId name >>= return . getTheta
+      getDMTheta (_, GenDefMeth name) = do tcLookupId name >>= return . getTheta
+      getDMTheta co                   = pprPanic "dm_constraints" (ppr co)
+
+      getTheta :: Id -> ThetaType
+      getTheta i =
+        let (_, ctx1, t)  = tcSplitSigmaTy (idType i)
+            (_, ctx2, _)  = tcSplitSigmaTy t
+            classTyVarSet = mkVarSet (classTyVars cls)
+            usefulCtx     = filter (\p -> tcTyVarsOfType p `subVarSet`
+                                                   classTyVarSet) (ctx1 ++ ctx2)
+        in substTheta (zipOpenTvSubst (classTyVars cls) inst_tys) usefulCtx
+
         -- Constraints arising from superclasses
         -- See Note [Superclasses of derived instance]
     sc_constraints = mkThetaOrigin DerivOrigin $
@@ -1142,7 +1175,10 @@ inferConstraints cls inst_tys rep_tc rep_tc_args
         -- Stupid constraints
     stupid_constraints = mkThetaOrigin DerivOrigin $
         substTheta subst (tyConStupidTheta rep_tc)
-    subst = zipTopTvSubst rep_tc_tvs all_rep_tc_args
+    subst = zipTopTvSubst (take (length rep_tc_args) rep_tc_tvs) rep_tc_args
+            -- There might be fewer rep_tc_args than rep_tc_tvs, because we've
+            -- dropped args as necessary to match the kind of the class we're
+            -- generating an instance for
 
         -- Extra Data constraints
         -- The Data class (only) requires that for
@@ -1204,12 +1240,61 @@ if DeriveAnyClass is enabled.
 This is not restricted to Generics; any class can be derived, simply giving
 rise to an empty instance.
 
-Unfortunately, it is not clear how to determine the context (in case of
-standard deriving; in standalone deriving, the user provides the context).
-GHC uses the same heuristic for figuring out the class context that it uses for
-Eq in the case of *-kinded classes, and for Functor in the case of
-* -> *-kinded classes. That may not be optimal or even wrong. But in such
-cases, standalone deriving can still be used.
+Note [Inferring contexts for DeriveAnyClass]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+With DeriveAnyClass, we infer contexts by looking at the default methods in
+the class we're deriving. For example:
+
+  class C a b where
+    c1 :: Read c => a -> b -> c
+    default c1 :: (Show a, Show b, Read c) => a -> b -> c
+    c1 a b = read (show a ++ show b)
+
+    c2 :: a -> b
+
+  data D = D deriving (C Int)
+
+DeriveAnyClass will generate the following instance:
+
+  instance (Show Int, Show D) => C Int D
+
+We basically use the contexts of the default methods, ignoring constraints that
+mention locally-quantified variables (like `Read c` above). Methods without a
+default are ignored too, because we won't produce code for them in the instance
+(and indeed the code above would warn about a missing `c2` method).
+
+One tricky interaction happens when deriving Generic. Deriving Generic gives
+rises to type family instances (see Note [What deriving Generic/Generic1
+generates] in TcGenGenerics), and these might be required in order to solve
+the constraints generated by DeriveAnyClass. A typical use-case of
+DeriveAnyClass is the following:
+
+  data MyDatatype = MyDatatype deriving (Generic, GEq)
+
+  class GEq (a :: *) where
+    geq :: a -> a -> Bool
+    default geq :: (Generic a, GEq' (Rep a)) => a -> a -> Bool
+    geq = geq' . from
+
+  class GEq' (f :: * -> *) where
+    geq' :: f a -> f a -> Bool
+
+  instance GEq' ... -- instances for each representation type
+
+We want to generate the following instance:
+
+  instance (Generic MyDatatype, GEq' (Rep MyDatatype)) => GEq MyDatatype
+
+But when solving this constraint, we won't have the type family instance
+`Rep MyDatatype` in the environment yet. We solve this problem by handling
+Generic differently from the other derivable classes. For Generic, we generate
+everything except the from/to method binds in advance, extend the local
+environment, and only then proceed to generate the rest of the derived
+instances.
+
+(With StandaloneDeriving and DeriveAnyClass, we just use whatever context the
+user provides.)
+
 -}
 
 ------------------------------------------------------------------
@@ -1578,15 +1663,18 @@ mkNewTypeEqn dflags overlap_mode tvs
         | might_derive_via_coercible -> bale_out (non_std $$ suggest_nd)
         | otherwise                  -> bale_out non_std
       -- CanDerive/DerivableViaInstance
-      _ -> do when (newtype_deriving && deriveAnyClass) $
+      DerivableViaInstance ->
+           do when (newtype_deriving && deriveAnyClass) $
                 addWarnTc (sep [ ptext (sLit "Both DeriveAnyClass and GeneralizedNewtypeDeriving are enabled")
                                , ptext (sLit "Defaulting to the DeriveAnyClass strategy for instantiating") <+> ppr cls ])
-              go_for_it
+              go_for_it False
+      CanDerive -> go_for_it True
   where
         newtype_deriving  = xopt Opt_GeneralizedNewtypeDeriving dflags
         deriveAnyClass    = xopt Opt_DeriveAnyClass             dflags
-        go_for_it         = mk_data_eqn overlap_mode tvs cls tycon tc_args
-                              rep_tycon rep_tc_args mtheta
+        go_for_it std_cls = mk_data_eqn overlap_mode std_cls tvs
+                                        cls cls_tys tycon tc_args
+                                        rep_tycon rep_tc_args mtheta
         bale_out    = bale_out' newtype_deriving
         bale_out' b = failWithTc . derivingThingErr b cls cls_tys inst_ty
 
@@ -2037,13 +2125,11 @@ the renamer.  What a great hack!
 -- Representation tycons differ from the tycon in the instance signature in
 -- case of instances for indexed families.
 --
-genInst :: CommonAuxiliaries
-        -> DerivSpec ThetaType
-        -> TcM (InstInfo RdrName, BagDerivStuff, Maybe Name)
-genInst comauxs
-        spec@(DS { ds_tvs = tvs, ds_tc = rep_tycon, ds_tc_args = rep_tc_args
+genInst :: DerivSpec ThetaType
+        -> TcM (InstInfo RdrName, BagAuxBindSpec, Maybe Name)
+genInst spec@(DS { ds_tvs = tvs, ds_tc = rep_tycon, ds_tc_args = rep_tc_args
                  , ds_theta = theta, ds_newtype = is_newtype, ds_tys = tys
-                 , ds_name = dfun_name, ds_cls = clas, ds_loc = loc })
+                 , ds_cls = clas, ds_loc = loc })
   | is_newtype   -- See Note [Bindings for Generalised Newtype Deriving]
   = do { inst_spec <- newDerivClsInst theta spec
        ; traceTc "genInst/is_newtype" (vcat [ppr loc, ppr clas, ppr tvs, ppr tys, ppr rhs_ty])
@@ -2061,9 +2147,7 @@ genInst comauxs
               -- See Note [Newtype deriving and unused constructors]
 
   | otherwise
-  = do { (meth_binds, deriv_stuff) <- genDerivStuff loc clas
-                                        dfun_name rep_tycon
-                                        (lookup rep_tycon comauxs)
+  = do { (meth_binds, aux_binds) <- genAuxStuff loc clas rep_tycon
        ; inst_spec <- newDerivClsInst theta spec
        ; traceTc "newder" (ppr inst_spec)
        ; let inst_info = InstInfo { iSpec   = inst_spec
@@ -2073,27 +2157,44 @@ genInst comauxs
                                                 , ib_pragmas = []
                                                 , ib_extensions = []
                                                 , ib_derived = True } }
-       ; return ( inst_info, deriv_stuff, Nothing ) }
+       ; return ( inst_info, aux_binds, Nothing ) }
   where
     rhs_ty = newTyConInstRhs rep_tycon rep_tc_args
-
-genDerivStuff :: SrcSpan -> Class -> Name -> TyCon
-              -> Maybe CommonAuxiliary
+{-
+genDerivStuff :: GenericAuxiliaries
+              -> DerivSpec ()
               -> TcM (LHsBinds RdrName, BagDerivStuff)
-genDerivStuff loc clas dfun_name tycon comaux_maybe
+genDerivStuff genAuxs
+        spec@(DS { ds_tvs = tvs, ds_tc = rep_tycon, ds_tc_args = rep_tc_args
+                 , ds_newtype = is_newtype, ds_tys = tys
+                 , ds_name = dfun_name, ds_cls = clas, ds_loc = loc })
+  | is_newtype
+  = pprPanic "This shouldn't happen 1" (ppr (clas, rep_tycon))
+
   | let ck = classKey clas
   , ck `elem` [genClassKey, gen1ClassKey]   -- Special case because monadic
   = let gk = if ck == genClassKey then Gen0 else Gen1
         -- TODO NSF: correctly identify when we're building Both instead of One
-        Just metaTyCons = comaux_maybe -- well-guarded by commonAuxiliaries and genInst
+        Just metaTyCons = lookup rep_tycon genAuxs -- well-guarded by genericAuxiliaries and genInst
     in do
-      (binds, faminst) <- gen_Generic_binds gk tycon metaTyCons (nameModule dfun_name)
+      (binds, faminst) <- gen_Generic_binds gk rep_tycon metaTyCons (nameModule dfun_name)
       return (binds, unitBag (DerivFamInst faminst))
 
+  | otherwise
+  = pprPanic "This shouldn't happen 2" (ppr (clas, rep_tycon))
+-}
+genAuxStuff :: SrcSpan -> Class -> TyCon
+            -> TcM (LHsBinds RdrName, BagAuxBindSpec)
+genAuxStuff loc clas tycon
+  | let ck = classKey clas
+  , ck `elem` [genClassKey, gen1ClassKey]   -- Special case because monadic
+  = let gk = if ck == genClassKey then Gen0 else Gen1
+    in return (mkBindsRep gk tycon, emptyBag)
+
   | otherwise                      -- Non-monadic generators
   = do { dflags <- getDynFlags
        ; fix_env <- getDataConFixityFun tycon
-       ; return (genDerivedBinds dflags fix_env clas loc tycon) }
+       ; return $ genDerivedBinds dflags fix_env clas loc tycon }
 
 getDataConFixityFun :: TyCon -> TcM (Name -> Fixity)
 -- If the TyCon is locally defined, we want the local fixity env;
diff --git a/compiler/typecheck/TcGenDeriv.hs b/compiler/typecheck/TcGenDeriv.hs
index 1df57d1197..036cbf1cc0 100644
--- a/compiler/typecheck/TcGenDeriv.hs
+++ b/compiler/typecheck/TcGenDeriv.hs
@@ -17,14 +17,14 @@ This is where we do all the grimy bindings' generation.
 
 module TcGenDeriv (
         BagDerivStuff, DerivStuff(..),
-
+        BagAuxBindSpec, AuxBindSpec(..),
         canDeriveAnyClass,
         genDerivedBinds,
         FFoldType(..), functorLikeTraverse,
         deepSubtypesContaining, foldDataConArgs,
         mkCoerceClassMethEqn,
         gen_Newtype_binds,
-        genAuxBinds,
+        genAuxBinds, splitDerivStuff,
         ordOpTbl, boxConTbl,
         mkRdrFunBind
     ) where
@@ -72,26 +72,25 @@ import ListSetOps ( assocMaybe )
 import Data.List  ( partition, intersperse )
 import Data.Maybe ( isNothing )
 
-type BagDerivStuff = Bag DerivStuff
+type BagAuxBindSpec = Bag AuxBindSpec
+type BagDerivStuff  = Bag DerivStuff
 
 data AuxBindSpec
-  = DerivCon2Tag TyCon  -- The con2Tag for given TyCon
-  | DerivTag2Con TyCon  -- ...ditto tag2Con
-  | DerivMaxTag  TyCon  -- ...and maxTag
+  = DerivCon2Tag     TyCon    -- The con2Tag for given TyCon
+  | DerivTag2Con     TyCon    -- ...ditto tag2Con
+  | DerivMaxTag      TyCon    -- ...and maxTag
+  | DerivDataTyCon   TyCon    -- SYB/Data's datatype info ($dT)
+  | DerivDataDataCon DataCon  -- SYB/Data's constructor info ($cT1 etc.)
   deriving( Eq )
   -- All these generate ZERO-BASED tag operations
   -- I.e first constructor has tag 0
 
-data DerivStuff     -- Please add this auxiliary stuff
-  = DerivAuxBind AuxBindSpec
-
-  -- Generics
-  | DerivTyCon TyCon                   -- New data types
-  | DerivFamInst FamInst               -- New type family instances
-
-  -- New top-level auxiliary bindings
-  | DerivHsBind (LHsBind RdrName, LSig RdrName) -- Also used for SYB
-  | DerivInst (InstInfo RdrName)                -- New, auxiliary instances
+data DerivStuff
+  = -- For GHC.Generics
+    -- See Note [What deriving Generic/Generic1 generates] in TcGenGenerics
+    DerivFamInst FamInst         -- Rep/Rep1 type family instances (2)
+  | DerivTyCon TyCon             -- Data types for giving metadata instances (3)
+  | DerivInst (InstInfo RdrName) -- Datatype/Constructor/Selector instances (4)
 
 {-
 ************************************************************************
@@ -103,7 +102,7 @@ data DerivStuff     -- Please add this auxiliary stuff
 
 genDerivedBinds :: DynFlags -> (Name -> Fixity) -> Class -> SrcSpan -> TyCon
                 -> ( LHsBinds RdrName  -- The method bindings of the instance declaration
-                   , BagDerivStuff)    -- Specifies extra top-level declarations needed
+                   , BagAuxBindSpec)   -- Specifies extra top-level declarations needed
                                        -- to support the instance declaration
 genDerivedBinds dflags fix_env clas loc tycon
   | Just gen_fn <- assocMaybe gen_list (getUnique clas)
@@ -117,7 +116,7 @@ genDerivedBinds dflags fix_env clas loc tycon
     (emptyBag, emptyBag)
 
   where
-    gen_list :: [(Unique, SrcSpan -> TyCon -> (LHsBinds RdrName, BagDerivStuff))]
+    gen_list :: [(Unique, SrcSpan -> TyCon -> (LHsBinds RdrName, BagAuxBindSpec))]
     gen_list = [ (eqClassKey,          gen_Eq_binds)
                , (typeableClassKey,    gen_Typeable_binds dflags)
                , (ordClassKey,         gen_Ord_binds)
@@ -126,7 +125,7 @@ genDerivedBinds dflags fix_env clas loc tycon
                , (ixClassKey,          gen_Ix_binds)
                , (showClassKey,        gen_Show_binds fix_env)
                , (readClassKey,        gen_Read_binds fix_env)
-               , (dataClassKey,        gen_Data_binds dflags)
+               , (dataClassKey,        gen_Data_binds)
                , (functorClassKey,     gen_Functor_binds)
                , (foldableClassKey,    gen_Foldable_binds)
                , (traversableClassKey, gen_Traversable_binds) ]
@@ -204,7 +203,7 @@ for the instance decl, which it probably wasn't, so the decls
 produced don't get through the typechecker.
 -}
 
-gen_Eq_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, BagDerivStuff)
+gen_Eq_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, BagAuxBindSpec)
 gen_Eq_binds loc tycon
   = (method_binds, aux_binds)
   where
@@ -236,7 +235,7 @@ gen_Eq_binds loc tycon
                     (genPrimOpApp (nlHsVar ah_RDR) eqInt_RDR (nlHsVar bh_RDR)))]
 
     aux_binds | no_tag_match_cons = emptyBag
-              | otherwise         = unitBag $ DerivAuxBind $ DerivCon2Tag tycon
+              | otherwise         = unitBag $ DerivCon2Tag tycon
 
     method_binds = listToBag [eq_bind, ne_bind]
     eq_bind = mk_FunBind loc eq_RDR (map pats_etc pat_match_cons ++ fall_through_eqn)
@@ -373,7 +372,7 @@ gtResult OrdGE      = true_Expr
 gtResult OrdGT      = true_Expr
 
 ------------
-gen_Ord_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, BagDerivStuff)
+gen_Ord_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, BagAuxBindSpec)
 gen_Ord_binds loc tycon
   | null tycon_data_cons        -- No data-cons => invoke bale-out case
   = (unitBag $ mk_FunBind loc compare_RDR [], emptyBag)
@@ -381,7 +380,7 @@ gen_Ord_binds loc tycon
   = (unitBag (mkOrdOp OrdCompare) `unionBags` other_ops, aux_binds)
   where
     aux_binds | single_con_type = emptyBag
-              | otherwise       = unitBag $ DerivAuxBind $ DerivCon2Tag tycon
+              | otherwise       = unitBag $ DerivCon2Tag tycon
 
         -- Note [Do not rely on compare]
     other_ops | (last_tag - first_tag) <= 2     -- 1-3 constructors
@@ -594,7 +593,7 @@ instance ... Enum (Foo ...) where
 For @enumFromTo@ and @enumFromThenTo@, we use the default methods.
 -}
 
-gen_Enum_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, BagDerivStuff)
+gen_Enum_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, BagAuxBindSpec)
 gen_Enum_binds loc tycon
   = (method_binds, aux_binds)
   where
@@ -606,7 +605,7 @@ gen_Enum_binds loc tycon
                         enum_from_then,
                         from_enum
                     ]
-    aux_binds = listToBag $ map DerivAuxBind
+    aux_binds = listToBag
                   [DerivCon2Tag tycon, DerivTag2Con tycon, DerivMaxTag tycon]
 
     occ_nm = getOccString tycon
@@ -674,7 +673,7 @@ gen_Enum_binds loc tycon
 ************************************************************************
 -}
 
-gen_Bounded_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, BagDerivStuff)
+gen_Bounded_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, BagAuxBindSpec)
 gen_Bounded_binds loc tycon
   | isEnumerationTyCon tycon
   = (listToBag [ min_bound_enum, max_bound_enum ], emptyBag)
@@ -761,15 +760,14 @@ we follow the scheme given in Figure~19 of the Haskell~1.2 report
 (p.~147).
 -}
 
-gen_Ix_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, BagDerivStuff)
+gen_Ix_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, BagAuxBindSpec)
 
 gen_Ix_binds loc tycon
   | isEnumerationTyCon tycon
   = ( enum_ixes
-    , listToBag $ map DerivAuxBind
-                   [DerivCon2Tag tycon, DerivTag2Con tycon, DerivMaxTag tycon])
+    , listToBag [DerivCon2Tag tycon, DerivTag2Con tycon, DerivMaxTag tycon])
   | otherwise
-  = (single_con_ixes, unitBag (DerivAuxBind (DerivCon2Tag tycon)))
+  = (single_con_ixes, unitBag (DerivCon2Tag tycon))
   where
     --------------------------------------------------------------
     enum_ixes = listToBag [ enum_range, enum_index, enum_inRange ]
@@ -950,7 +948,7 @@ These instances are also useful for Read (Either Int Emp), where
 we want to be able to parse (Left 3) just fine.
 -}
 
-gen_Read_binds :: (Name -> Fixity) -> SrcSpan -> TyCon -> (LHsBinds RdrName, BagDerivStuff)
+gen_Read_binds :: (Name -> Fixity) -> SrcSpan -> TyCon -> (LHsBinds RdrName, BagAuxBindSpec)
 
 gen_Read_binds get_fixity loc tycon
   = (listToBag [read_prec, default_readlist, default_readlistprec], emptyBag)
@@ -1118,7 +1116,7 @@ Example
                     -- the most tightly-binding operator
 -}
 
-gen_Show_binds :: (Name -> Fixity) -> SrcSpan -> TyCon -> (LHsBinds RdrName, BagDerivStuff)
+gen_Show_binds :: (Name -> Fixity) -> SrcSpan -> TyCon -> (LHsBinds RdrName, BagAuxBindSpec)
 
 gen_Show_binds get_fixity loc tycon
   = (listToBag [shows_prec, show_list], emptyBag)
@@ -1266,7 +1264,7 @@ We are passed the Typeable2 class as well as T
 -}
 
 gen_Typeable_binds :: DynFlags -> SrcSpan -> TyCon
-                   -> (LHsBinds RdrName, BagDerivStuff)
+                   -> (LHsBinds RdrName, BagAuxBindSpec)
 gen_Typeable_binds dflags loc tycon
   = ( unitBag $ mk_easy_FunBind loc typeRep_RDR [nlWildPat]
                 (nlHsApps mkTyConApp_RDR [tycon_rep, nlList []])
@@ -1330,58 +1328,21 @@ we generate
     dataCast2 = gcast2   -- if T :: * -> * -> *
 -}
 
-gen_Data_binds :: DynFlags
-               -> SrcSpan
+gen_Data_binds :: SrcSpan
                -> TyCon                 -- For data families, this is the
                                         --  *representation* TyCon
                -> (LHsBinds RdrName,    -- The method bindings
-                   BagDerivStuff)       -- Auxiliary bindings
-gen_Data_binds dflags loc rep_tc
+                   BagAuxBindSpec)      -- Auxiliary bindings
+gen_Data_binds loc rep_tc
   = (listToBag [gfoldl_bind, gunfold_bind, toCon_bind, dataTypeOf_bind]
      `unionBags` gcast_binds,
-                -- Auxiliary definitions: the data type and constructors
-     listToBag ( DerivHsBind (genDataTyCon)
-               : map (DerivHsBind . genDataDataCon) data_cons))
+      -- Auxiliary definitions: the data type and constructors
+     listToBag (DerivDataTyCon rep_tc : map DerivDataDataCon data_cons))
   where
     data_cons  = tyConDataCons rep_tc
     n_cons     = length data_cons
     one_constr = n_cons == 1
 
-    genDataTyCon :: (LHsBind RdrName, LSig RdrName)
-    genDataTyCon        --  $dT
-      = (mkHsVarBind loc rdr_name rhs,
-         L loc (TypeSig [L loc rdr_name] sig_ty PlaceHolder))
-      where
-        rdr_name = mk_data_type_name rep_tc
-        sig_ty   = nlHsTyVar dataType_RDR
-        constrs  = [nlHsVar (mk_constr_name con) | con <- tyConDataCons rep_tc]
-        rhs = nlHsVar mkDataType_RDR
-              `nlHsApp` nlHsLit (mkHsString (showSDocOneLine dflags (ppr rep_tc)))
-              `nlHsApp` nlList constrs
-
-    genDataDataCon :: DataCon -> (LHsBind RdrName, LSig RdrName)
-    genDataDataCon dc       --  $cT1 etc
-      = (mkHsVarBind loc rdr_name rhs,
-         L loc (TypeSig [L loc rdr_name] sig_ty PlaceHolder))
-      where
-        rdr_name = mk_constr_name dc
-        sig_ty   = nlHsTyVar constr_RDR
-        rhs      = nlHsApps mkConstr_RDR constr_args
-
-        constr_args
-           = [ -- nlHsIntLit (toInteger (dataConTag dc)), -- Tag
-           nlHsVar (mk_data_type_name (dataConTyCon dc)), -- DataType
-           nlHsLit (mkHsString (occNameString dc_occ)),   -- String name
-               nlList  labels,                            -- Field labels
-           nlHsVar fixity]                                -- Fixity
-
-        labels   = map (nlHsLit . mkHsString . getOccString)
-                       (dataConFieldLabels dc)
-        dc_occ   = getOccName dc
-        is_infix = isDataSymOcc dc_occ
-        fixity | is_infix  = infix_RDR
-           | otherwise = prefix_RDR
-
         ------------ gfoldl
     gfoldl_bind = mk_FunBind loc gfoldl_RDR (map gfoldl_eqn data_cons)
 
@@ -1607,7 +1568,7 @@ so it was eta expanded to `\x -> [| f $x |]`. This resulted in too much eta expa
 It is better to produce too many lambdas than to eta expand, see ticket #7436.
 -}
 
-gen_Functor_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, BagDerivStuff)
+gen_Functor_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, BagAuxBindSpec)
 gen_Functor_binds loc tycon
   = (unitBag fmap_bind, emptyBag)
   where
@@ -1797,7 +1758,7 @@ Note that the arguments to the real foldr function are the wrong way around,
 since (f :: a -> b -> b), while (foldr f :: b -> t a -> b).
 -}
 
-gen_Foldable_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, BagDerivStuff)
+gen_Foldable_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, BagAuxBindSpec)
 gen_Foldable_binds loc tycon
   = (listToBag [foldr_bind, foldMap_bind], emptyBag)
   where
@@ -1870,7 +1831,7 @@ gives the function: traverse f (T x y) = T <$> pure x <*> f y
 instead of:         traverse f (T x y) = T x <$> f y
 -}
 
-gen_Traversable_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, BagDerivStuff)
+gen_Traversable_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, BagAuxBindSpec)
 gen_Traversable_binds loc tycon
   = (unitBag traverse_bind, emptyBag)
   where
@@ -2034,36 +1995,61 @@ genAuxBindSpec loc (DerivMaxTag tycon)
     max_tag =  case (tyConDataCons tycon) of
                  data_cons -> toInteger ((length data_cons) - fIRST_TAG)
 
-type SeparateBagsDerivStuff = -- AuxBinds and SYB bindings
-                              ( Bag (LHsBind RdrName, LSig RdrName)
-                                -- Extra bindings (used by Generic only)
-                              , Bag TyCon   -- Extra top-level datatypes
-                              , Bag (FamInst)           -- Extra family instances
-                              , Bag (InstInfo RdrName)) -- Extra instances
+genAuxBindSpec loc (DerivDataTyCon rep_tc) --  $dT
+      = (mkHsVarBind loc rdr_name rhs,
+         L loc (TypeSig [L loc rdr_name] sig_ty PlaceHolder))
+      where
+        rdr_name = mk_data_type_name rep_tc
+        sig_ty   = nlHsTyVar dataType_RDR
+        constrs  = [nlHsVar (mk_constr_name con) | con <- tyConDataCons rep_tc]
+        rhs = nlHsVar mkDataType_RDR
+              -- `nlHsApp` nlHsLit (mkHsString (showSDocOneLine dflags (ppr rep_tc)))
+              `nlHsApp` nlHsLit (mkHsString (showSDocSimple (ppr rep_tc)))
+              `nlHsApp` nlList constrs
 
-genAuxBinds :: SrcSpan -> BagDerivStuff -> SeparateBagsDerivStuff
-genAuxBinds loc b = genAuxBinds' b2 where
-  (b1,b2) = partitionBagWith splitDerivAuxBind b
-  splitDerivAuxBind (DerivAuxBind x) = Left x
-  splitDerivAuxBind  x               = Right x
+genAuxBindSpec loc (DerivDataDataCon dc)  -- $cT1 etc
+      = (mkHsVarBind loc rdr_name rhs,
+         L loc (TypeSig [L loc rdr_name] sig_ty PlaceHolder))
+      where
+        rdr_name = mk_constr_name dc
+        sig_ty   = nlHsTyVar constr_RDR
+        rhs      = nlHsApps mkConstr_RDR constr_args
 
-  rm_dups = foldrBag dup_check emptyBag
-  dup_check a b = if anyBag (== a) b then b else consBag a b
+        constr_args
+           = [ -- nlHsIntLit (toInteger (dataConTag dc)), -- Tag
+           nlHsVar (mk_data_type_name (dataConTyCon dc)), -- DataType
+           nlHsLit (mkHsString (occNameString dc_occ)),   -- String name
+               nlList  labels,                            -- Field labels
+           nlHsVar fixity]                                -- Fixity
 
-  genAuxBinds' :: BagDerivStuff -> SeparateBagsDerivStuff
-  genAuxBinds' = foldrBag f ( mapBag (genAuxBindSpec loc) (rm_dups b1)
-                            , emptyBag, emptyBag, emptyBag)
+        labels   = map (nlHsLit . mkHsString . getOccString)
+                       (dataConFieldLabels dc)
+        dc_occ   = getOccName dc
+        is_infix = isDataSymOcc dc_occ
+        fixity | is_infix  = infix_RDR
+               | otherwise = prefix_RDR
+
+type SeparateBagsDerivStuff =
+  ( -- Extra bindings (used only by Generic)
+    -- See Note [What deriving Generic/Generic1 generates] in TcGenGenerics
+    Bag TyCon               -- Extra top-level datatypes
+  , Bag (FamInst)           -- Extra family instances
+  , Bag (InstInfo RdrName)) -- Extra instances
+
+splitDerivStuff :: BagDerivStuff -> SeparateBagsDerivStuff
+splitDerivStuff = foldrBag f (emptyBag, emptyBag, emptyBag) where
   f :: DerivStuff -> SeparateBagsDerivStuff -> SeparateBagsDerivStuff
-  f (DerivAuxBind _) = panic "genAuxBinds'" -- We have removed these before
-  f (DerivHsBind  b) = add1 b
-  f (DerivTyCon   t) = add2 t
-  f (DerivFamInst t) = add3 t
-  f (DerivInst    i) = add4 i
-
-  add1 x (a,b,c,d) = (x `consBag` a,b,c,d)
-  add2 x (a,b,c,d) = (a,x `consBag` b,c,d)
-  add3 x (a,b,c,d) = (a,b,x `consBag` c,d)
-  add4 x (a,b,c,d) = (a,b,c,x `consBag` d)
+  f (DerivTyCon   t) = add1 t
+  f (DerivFamInst t) = add2 t
+  f (DerivInst    i) = add3 i
+  add1 x (a,b,c) = (x `consBag` a,b,c)
+  add2 x (a,b,c) = (a,x `consBag` b,c)
+  add3 x (a,b,c) = (a,b,x `consBag` c)
+
+genAuxBinds :: SrcSpan -> BagAuxBindSpec -> Bag (LHsBind RdrName, LSig RdrName)
+genAuxBinds loc = mapBag (genAuxBindSpec loc) . rm_dups where
+  rm_dups = foldrBag dup_check emptyBag
+  dup_check a b = if anyBag (== a) b then b else consBag a b
 
 mk_data_type_name :: TyCon -> RdrName   -- "$tT"
 mk_data_type_name tycon = mkAuxBinderName (tyConName tycon) mkDataTOcc
diff --git a/compiler/typecheck/TcGenGenerics.hs b/compiler/typecheck/TcGenGenerics.hs
index 649aa5fc99..5f921f3ac4 100644
--- a/compiler/typecheck/TcGenGenerics.hs
+++ b/compiler/typecheck/TcGenGenerics.hs
@@ -11,8 +11,8 @@ The deriving code for the Generic class
 
 module TcGenGenerics (canDoGenerics, canDoGenerics1,
                       GenericKind(..),
-                      MetaTyCons, genGenericMetaTyCons,
-                      gen_Generic_binds, get_gen1_constrained_tys) where
+                      MetaTyCons, genGenericMetaTyCons, mkBindsRep,
+                      tc_mkRepFamInst, get_gen1_constrained_tys) where
 
 import DynFlags
 import HsSyn
@@ -57,20 +57,72 @@ import Control.Monad (mplus,forM)
 *                                                                      *
 ************************************************************************
 
+Note [What deriving Generic/Generic1 generates]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
 For the generic representation we need to generate:
-\begin{itemize}
-\item A Generic instance
-\item A Rep type instance
-\item Many auxiliary datatypes and instances for them (for the meta-information)
+1) A Generic/Generic1 instance
+2) A Rep/Rep1 type instance
+3) Many auxiliary datatypes (shared for both Generic and Generic1), and
+4) Instances for them (for the meta-information)
 \end{itemize}
--}
 
-gen_Generic_binds :: GenericKind -> TyCon -> MetaTyCons -> Module
-                 -> TcM (LHsBinds RdrName, FamInst)
-gen_Generic_binds gk tc metaTyCons mod = do
-  repTyInsts <- tc_mkRepFamInsts gk tc metaTyCons mod
-  return (mkBindsRep gk tc, repTyInsts)
+For example, given the following datatype:
+
+  data List a = Nil | Cons a (List a)
+
+We'll generate:
+
+1) A Generic and a Generic1 instance:
+
+  instance Generic (List a) where
+    from Nil = M1 (L1 (M1 U1))
+    from (Cons g1 g2) = M1 (R1 (M1 ((:*:) (M1 (K1 g1)) (M1 (K1 g2)))))
+    to (M1 (L1 (M1 U1))) = Nil
+    to (M1 (R1 (M1 ((:*:) (M1 (K1 g1)) (M1 (K1 g2)))))) = Cons g1 g2
+
+  instance Generic1 List where
+    from1 Nil = M1 (L1 (M1 U1))
+    from1 (Cons g1 g2) = M1 (R1 (M1 ((:*:) (M1 (Par1 g1)) (M1 (Rec1 g2)))))
+    to1 (M1 (L1 (M1 U1))) = Nil
+    to1 (M1 (R1 (M1 ((:*:) (M1 g1) (M1 g2))))) = Cons (unPar1 g1) (unRec1 g2)
+
+2) A Rep and Rep1 type family instance:
+
+    type Rep (List a) =
+      D1 D1List (C1 C1_0List U1
+             :+: C1 C1_1List (S1 S1_1_0List (Rec0 a)
+                          :*: S1 S1_1_1List (Rec0 (List a))))
+
+    type Rep1 List =
+      D1 D1List (C1 C1_0List U1
+             :+: C1 C1_1List (S1 S1_1_0List Par1
+                          :*: S1 S1_1_1List (Rec1 List)))
 
+3) Auxiliary, empty datatypes:
+
+    data D1List
+    data C1_0List
+    data C1_1List
+    data S1_1_0List
+    data S1_1_1List
+
+4) Instances for these datatypes:
+
+  instance Datatype D1List where
+    datatypeName _ = "List"
+    moduleName _   = "GenDerivOutput"
+    packageName _  = "main"
+
+  instance Constructor C1_0List where
+    conName _ = "Nil"
+
+  instance Constructor C1_1List where
+    conName _     = "Cons"
+    conIsRecord _ = True
+-}
+
+-- This function generates the empty datatypes and their instances (3 and 4)
 genGenericMetaTyCons :: TyCon -> Module -> TcM (MetaTyCons, BagDerivStuff)
 genGenericMetaTyCons tc mod =
   do  loc <- getSrcSpanM
@@ -428,9 +480,7 @@ gk2gkDC :: GenericKind_ -> DataCon -> GenericKind_DC
 gk2gkDC Gen0_   _ = Gen0_DC
 gk2gkDC Gen1_{} d = Gen1_DC $ last $ dataConUnivTyVars d
 
-
-
--- Bindings for the Generic instance
+-- Bindings for the Generic instance (1)
 mkBindsRep :: GenericKind -> TyCon -> LHsBinds RdrName
 mkBindsRep gk tycon =
     unitBag (mkRdrFunBind (L loc from01_RDR) from_matches)
@@ -461,12 +511,13 @@ mkBindsRep gk tycon =
 --       type Rep_D a b = ...representation type for D ...
 --------------------------------------------------------------------------------
 
-tc_mkRepFamInsts :: GenericKind     -- Gen0 or Gen1
-               -> TyCon           -- The type to generate representation for
-               -> MetaTyCons      -- Metadata datatypes to refer to
-               -> Module          -- Used as the location of the new RepTy
-               -> TcM (FamInst)   -- Generated representation0 coercion
-tc_mkRepFamInsts gk tycon metaDts mod =
+-- This function generates the Rep/Rep type family instances (2)
+tc_mkRepFamInst :: GenericKind     -- Gen0 or Gen1
+                -> TyCon           -- The type to generate representation for
+                -> MetaTyCons      -- Metadata datatypes to refer to
+                -> Module          -- Used as the location of the new RepTy
+                -> TcM (FamInst)   -- Generated representation0 coercion
+tc_mkRepFamInst gk tycon metaDts mod =
        -- Consider the example input tycon `D`, where data D a b = D_ a
        -- Also consider `R:DInt`, where { data family D x y :: * -> *
        --                               ; data instance D Int a b = D_ a }