Refactor tcDeriving to generate tyfam insts before any bindingswip/deriving-refactor

Previously, there was an awful hack in `genInst` (now called `genInstBinds`
after this patch) where we had to return a continutation rather than directly
returning the bindings for a derived instance. This was done for staging
purposes, as we had to first infer the instance contexts for derived instances
and then feed these contexts into the continuations to ensure the generated
instance bindings had accurate instance contexts.
`Note [Staging of tcDeriving]` in `GHC.Tc.Deriving` described this confusing
state of affairs.

The root cause of this confusing design was the fact that `genInst` was trying
to generate instance bindings and associated type family instances for derived
instances simultaneously. This really isn't possible, however: as
`Note [Staging of tcDeriving]` explains, one needs to have access to the
associated type family instances before one can properly infer the instance
contexts for derived instances. The use of continuation-returning style was an
attempt to circumvent this dependency, but it did so in an awkward way.

This patch detangles this awkwardness by splitting up `genInst` into two
functions: `genFamInsts` (for associated type family instances) and
`genInstBinds` (for instance bindings). Now, the `tcDeriving` function calls
`genFamInsts` and brings all the family instances into scope before calling
`genInstBinds`. This removes the need for the awkward continuation-returning
style seen in the previous version of `genInst`, making the code easier to
understand.

There are some knock-on changes as well:

1. `hasStockDeriving` now needs to return two separate functions: one that
   describes how to generate family instances for a stock-derived instance,
   and another that describes how to generate the instance bindings. I factored
   out this pattern into a new `StockGenFns` data type.
2. While documenting `StockGenFns`, I realized that there was some
   inconsistency regarding which `StockGenFns` functions needed which
   arguments. In particular, the function in `GHC.Tc.Deriv.Generics` which
   generates `Rep(1)` instances did not take a `SrcSpan` like other `gen_*`
   functions did, and it included an extra `[Type]` argument that was entirely
   redundant. As a consequence, I refactored the code in
   `GHC.Tc.Deriv.Generics` to more closely resemble other `gen_*` functions.
   A happy result of all this is that all `StockGenFns` functions now take
   exactly the same arguments, which makes everything more uniform.

This is purely a refactoring that should not have any effect on user-observable
behavior. The new design paves the way for an eventual fix for #20719.

5 files changed, 198 insertions, 166 deletions

diff --git a/compiler/GHC/Tc/Deriv/Functor.hs b/compiler/GHC/Tc/Deriv/Functor.hs
index 1f781398ca..b3e9fb775c 100644
--- a/compiler/GHC/Tc/Deriv/Functor.hs
+++ b/compiler/GHC/Tc/Deriv/Functor.hs
@@ -149,7 +149,7 @@ is a similar algorithm for generating `p <$ x` (for some constant `p`):
   $(coreplace 'a '(tb -> tc) x) = \(y:tb[b/a]) -> $(coreplace 'a' 'tc' (x $(replace 'a 'tb y)))
 -}
 
-gen_Functor_binds :: SrcSpan -> DerivInstTys -> (LHsBinds GhcPs, BagDerivStuff)
+gen_Functor_binds :: SrcSpan -> DerivInstTys -> (LHsBinds GhcPs, Bag AuxBindSpec)
 -- When the argument is phantom, we can use  fmap _ = coerce
 -- See Note [Phantom types with Functor, Foldable, and Traversable]
 gen_Functor_binds loc (DerivInstTys{dit_rep_tc = tycon})
@@ -784,7 +784,7 @@ could surprise users if they switch to other types, but Ryan Scott seems to
 think it's okay to do it for now.
 -}
 
-gen_Foldable_binds :: SrcSpan -> DerivInstTys -> (LHsBinds GhcPs, BagDerivStuff)
+gen_Foldable_binds :: SrcSpan -> DerivInstTys -> (LHsBinds GhcPs, Bag AuxBindSpec)
 -- When the parameter is phantom, we can use foldMap _ _ = mempty
 -- See Note [Phantom types with Functor, Foldable, and Traversable]
 gen_Foldable_binds loc (DerivInstTys{dit_rep_tc = tycon})
@@ -1018,7 +1018,7 @@ removes all such types from consideration.
 See Note [Generated code for DeriveFoldable and DeriveTraversable].
 -}
 
-gen_Traversable_binds :: SrcSpan -> DerivInstTys -> (LHsBinds GhcPs, BagDerivStuff)
+gen_Traversable_binds :: SrcSpan -> DerivInstTys -> (LHsBinds GhcPs, Bag AuxBindSpec)
 -- When the argument is phantom, we can use traverse = pure . coerce
 -- See Note [Phantom types with Functor, Foldable, and Traversable]
 gen_Traversable_binds loc (DerivInstTys{dit_rep_tc = tycon})
diff --git a/compiler/GHC/Tc/Deriv/Generate.hs b/compiler/GHC/Tc/Deriv/Generate.hs
index 7c03f52bd0..d61ad20707 100644
--- a/compiler/GHC/Tc/Deriv/Generate.hs
+++ b/compiler/GHC/Tc/Deriv/Generate.hs
@@ -19,7 +19,7 @@
 --
 -- This is where we do all the grimy bindings' generation.
 module GHC.Tc.Deriv.Generate (
-        BagDerivStuff, DerivStuff(..),
+        AuxBindSpec(..),
 
         gen_Eq_binds,
         gen_Ord_binds,
@@ -31,6 +31,7 @@ module GHC.Tc.Deriv.Generate (
         gen_Data_binds,
         gen_Lift_binds,
         gen_Newtype_binds,
+        gen_Newtype_fam_insts,
         mkCoerceClassMethEqn,
         genAuxBinds,
         ordOpTbl, boxConTbl, litConTbl,
@@ -87,8 +88,6 @@ import Data.List  ( find, partition, intersperse )
 import GHC.Data.Maybe ( expectJust )
 import GHC.Unit.Module
 
-type BagDerivStuff = Bag DerivStuff
-
 -- | A declarative description of an auxiliary binding that should be
 -- generated. See @Note [Auxiliary binders]@ for a more detailed description
 -- of how these are used.
@@ -138,23 +137,6 @@ auxBindSpecRdrName (DerivMaxTag       _ maxtag_RDR)  = maxtag_RDR
 auxBindSpecRdrName (DerivDataDataType _ dataT_RDR _) = dataT_RDR
 auxBindSpecRdrName (DerivDataConstr   _ dataC_RDR _) = dataC_RDR
 
-data DerivStuff     -- Please add this auxiliary stuff
-  = DerivAuxBind AuxBindSpec
-    -- ^ A new, top-level auxiliary binding. Used for deriving 'Eq', 'Ord',
-    --   'Enum', 'Ix', and 'Data'. See Note [Auxiliary binders].
-
-  -- Generics and DeriveAnyClass
-  | DerivFamInst FamInst               -- New type family instances
-    -- ^ A new type family instance. Used for:
-    --
-    -- * @DeriveGeneric@, which generates instances of @Rep(1)@
-    --
-    -- * @DeriveAnyClass@, which can fill in associated type family defaults
-    --
-    -- * @GeneralizedNewtypeDeriving@, which generates instances of associated
-    --   type families for newtypes
-
-
 {-
 ************************************************************************
 *                                                                      *
@@ -214,7 +196,7 @@ for the instance decl, which it probably wasn't, so the decls
 produced don't get through the typechecker.
 -}
 
-gen_Eq_binds :: SrcSpan -> DerivInstTys -> TcM (LHsBinds GhcPs, BagDerivStuff)
+gen_Eq_binds :: SrcSpan -> DerivInstTys -> TcM (LHsBinds GhcPs, Bag AuxBindSpec)
 gen_Eq_binds loc dit@(DerivInstTys{ dit_rep_tc = tycon
                                   , dit_rep_tc_args = tycon_args }) = do
     return (method_binds, emptyBag)
@@ -391,7 +373,7 @@ gtResult OrdGE      = true_Expr
 gtResult OrdGT      = true_Expr
 
 ------------
-gen_Ord_binds :: SrcSpan -> DerivInstTys -> TcM (LHsBinds GhcPs, BagDerivStuff)
+gen_Ord_binds :: SrcSpan -> DerivInstTys -> TcM (LHsBinds GhcPs, Bag AuxBindSpec)
 gen_Ord_binds loc dit@(DerivInstTys{ dit_rep_tc = tycon
                                    , dit_rep_tc_args = tycon_args }) = do
     return $ if null tycon_data_cons -- No data-cons => invoke bale-out case
@@ -640,7 +622,7 @@ instance ... Enum (Foo ...) where
 For @enumFromTo@ and @enumFromThenTo@, we use the default methods.
 -}
 
-gen_Enum_binds :: SrcSpan -> DerivInstTys -> TcM (LHsBinds GhcPs, BagDerivStuff)
+gen_Enum_binds :: SrcSpan -> DerivInstTys -> TcM (LHsBinds GhcPs, Bag AuxBindSpec)
 gen_Enum_binds loc (DerivInstTys{dit_rep_tc = tycon}) = do
     -- See Note [Auxiliary binders]
     tag2con_RDR <- new_tag2con_rdr_name loc tycon
@@ -657,7 +639,7 @@ gen_Enum_binds loc (DerivInstTys{dit_rep_tc = tycon}) = do
       , enum_from_then tag2con_RDR maxtag_RDR -- [0, 1 ..]
       , from_enum
       ]
-    aux_binds tag2con_RDR maxtag_RDR = listToBag $ map DerivAuxBind
+    aux_binds tag2con_RDR maxtag_RDR = listToBag
       [ DerivTag2Con tycon tag2con_RDR
       , DerivMaxTag  tycon maxtag_RDR
       ]
@@ -730,7 +712,7 @@ gen_Enum_binds loc (DerivInstTys{dit_rep_tc = tycon}) = do
 ************************************************************************
 -}
 
-gen_Bounded_binds :: SrcSpan -> DerivInstTys -> (LHsBinds GhcPs, BagDerivStuff)
+gen_Bounded_binds :: SrcSpan -> DerivInstTys -> (LHsBinds GhcPs, Bag AuxBindSpec)
 gen_Bounded_binds loc (DerivInstTys{dit_rep_tc = tycon})
   | isEnumerationTyCon tycon
   = (listToBag [ min_bound_enum, max_bound_enum ], emptyBag)
@@ -817,14 +799,14 @@ we follow the scheme given in Figure~19 of the Haskell~1.2 report
 (p.~147).
 -}
 
-gen_Ix_binds :: SrcSpan -> DerivInstTys -> TcM (LHsBinds GhcPs, BagDerivStuff)
+gen_Ix_binds :: SrcSpan -> DerivInstTys -> TcM (LHsBinds GhcPs, Bag AuxBindSpec)
 
 gen_Ix_binds loc (DerivInstTys{dit_rep_tc = tycon}) = do
     -- See Note [Auxiliary binders]
     tag2con_RDR <- new_tag2con_rdr_name loc tycon
 
     return $ if isEnumerationTyCon tycon
-      then (enum_ixes tag2con_RDR, listToBag $ map DerivAuxBind
+      then (enum_ixes tag2con_RDR, listToBag
                    [ DerivTag2Con tycon tag2con_RDR
                    ])
       else (single_con_ixes, emptyBag)
@@ -1020,7 +1002,7 @@ we want to be able to parse (Left 3) just fine.
 -}
 
 gen_Read_binds :: (Name -> Fixity) -> SrcSpan -> DerivInstTys
-               -> (LHsBinds GhcPs, BagDerivStuff)
+               -> (LHsBinds GhcPs, Bag AuxBindSpec)
 
 gen_Read_binds get_fixity loc dit@(DerivInstTys{dit_rep_tc = tycon})
   = (listToBag [read_prec, default_readlist, default_readlistprec], emptyBag)
@@ -1204,7 +1186,7 @@ Example
 -}
 
 gen_Show_binds :: (Name -> Fixity) -> SrcSpan -> DerivInstTys
-               -> (LHsBinds GhcPs, BagDerivStuff)
+               -> (LHsBinds GhcPs, Bag AuxBindSpec)
 
 gen_Show_binds get_fixity loc dit@(DerivInstTys{ dit_rep_tc = tycon
                                                , dit_rep_tc_args = tycon_args })
@@ -1377,7 +1359,7 @@ we generate
 gen_Data_binds :: SrcSpan
                -> DerivInstTys
                -> TcM (LHsBinds GhcPs,  -- The method bindings
-                       BagDerivStuff)   -- Auxiliary bindings
+                       Bag AuxBindSpec) -- Auxiliary bindings
 gen_Data_binds loc (DerivInstTys{dit_rep_tc = rep_tc})
   = do { -- See Note [Auxiliary binders]
          dataT_RDR  <- new_dataT_rdr_name loc rep_tc
@@ -1387,7 +1369,7 @@ gen_Data_binds loc (DerivInstTys{dit_rep_tc = rep_tc})
                           , toCon_bind dataC_RDRs, dataTypeOf_bind dataT_RDR ]
                 `unionBags` gcast_binds
                           -- Auxiliary definitions: the data type and constructors
-              , listToBag $ map DerivAuxBind
+              , listToBag
                   ( DerivDataDataType rep_tc dataT_RDR dataC_RDRs
                   : zipWith (\data_con dataC_RDR ->
                                DerivDataConstr data_con dataC_RDR dataT_RDR)
@@ -1642,7 +1624,7 @@ lifting warning in derived code. (See #20688)
 -}
 
 
-gen_Lift_binds :: SrcSpan -> DerivInstTys -> (LHsBinds GhcPs, BagDerivStuff)
+gen_Lift_binds :: SrcSpan -> DerivInstTys -> (LHsBinds GhcPs, Bag AuxBindSpec)
 gen_Lift_binds loc (DerivInstTys{ dit_rep_tc = tycon
                                 , dit_rep_tc_args = tycon_args }) =
   (listToBag [lift_bind, liftTyped_bind], emptyBag)
@@ -1971,17 +1953,18 @@ gen_Newtype_binds :: SrcSpan
                              -- newtype itself)
                   -> [Type]  -- instance head parameters (incl. newtype)
                   -> Type    -- the representation type
-                  -> TcM (LHsBinds GhcPs, [LSig GhcPs], BagDerivStuff)
+                  -> (LHsBinds GhcPs, [LSig GhcPs])
 -- See Note [Newtype-deriving instances]
 gen_Newtype_binds loc' cls inst_tvs inst_tys rhs_ty
-  = do let ats = classATs cls
-           (binds, sigs) = mapAndUnzip mk_bind_and_sig (classMethods cls)
-       atf_insts <- assert (all (not . isDataFamilyTyCon) ats) $
-                    mapM mk_atf_inst ats
-       return ( listToBag binds
-              , sigs
-              , listToBag $ map DerivFamInst atf_insts )
+  = (listToBag binds, sigs)
   where
+    (binds, sigs) = mapAndUnzip mk_bind_and_sig (classMethods cls)
+
+    -- Same as inst_tys, but with the last argument type replaced by the
+    -- representation type.
+    underlying_inst_tys :: [Type]
+    underlying_inst_tys = changeLast inst_tys rhs_ty
+
     locn = noAnnSrcSpan loc'
     loca = noAnnSrcSpan loc'
     -- For each class method, generate its derived binding and instance
@@ -2051,6 +2034,33 @@ gen_Newtype_binds loc' cls inst_tvs inst_tys rhs_ty
                      -- Filter out any inferred arguments, since they can't be
                      -- applied with visible type application.
 
+gen_Newtype_fam_insts :: SrcSpan
+                      -> Class   -- the class being derived
+                      -> [TyVar] -- the tvs in the instance head (this includes
+                                 -- the tvs from both the class types and the
+                                 -- newtype itself)
+                      -> [Type]  -- instance head parameters (incl. newtype)
+                      -> Type    -- the representation type
+                      -> TcM [FamInst]
+-- See Note [GND and associated type families] in GHC.Tc.Deriv
+gen_Newtype_fam_insts loc' cls inst_tvs inst_tys rhs_ty
+  = assert (all (not . isDataFamilyTyCon) ats) $
+    mapM mk_atf_inst ats
+  where
+    -- Same as inst_tys, but with the last argument type replaced by the
+    -- representation type.
+    underlying_inst_tys :: [Type]
+    underlying_inst_tys = changeLast inst_tys rhs_ty
+
+    ats       = classATs cls
+    locn      = noAnnSrcSpan loc'
+    cls_tvs   = classTyVars cls
+    in_scope  = mkInScopeSet $ mkVarSet inst_tvs
+    lhs_env   = zipTyEnv cls_tvs inst_tys
+    lhs_subst = mkTvSubst in_scope lhs_env
+    rhs_env   = zipTyEnv cls_tvs underlying_inst_tys
+    rhs_subst = mkTvSubst in_scope rhs_env
+
     mk_atf_inst :: TyCon -> TcM FamInst
     mk_atf_inst fam_tc = do
         rep_tc_name <- newFamInstTyConName (L locn (tyConName fam_tc))
@@ -2061,12 +2071,6 @@ gen_Newtype_binds loc' cls inst_tvs inst_tys rhs_ty
         checkValidCoAxBranch fam_tc (coAxiomSingleBranch axiom)
         newFamInst SynFamilyInst axiom
       where
-        cls_tvs     = classTyVars cls
-        in_scope    = mkInScopeSet $ mkVarSet inst_tvs
-        lhs_env     = zipTyEnv cls_tvs inst_tys
-        lhs_subst   = mkTvSubst in_scope lhs_env
-        rhs_env     = zipTyEnv cls_tvs underlying_inst_tys
-        rhs_subst   = mkTvSubst in_scope rhs_env
         fam_tvs     = tyConTyVars fam_tc
         rep_lhs_tys = substTyVars lhs_subst fam_tvs
         rep_rhs_tys = substTyVars rhs_subst fam_tvs
@@ -2076,11 +2080,6 @@ gen_Newtype_binds loc' cls inst_tvs inst_tys rhs_ty
         rep_tvs'    = scopedSort rep_tvs
         rep_cvs'    = scopedSort rep_cvs
 
-    -- Same as inst_tys, but with the last argument type replaced by the
-    -- representation type.
-    underlying_inst_tys :: [Type]
-    underlying_inst_tys = changeLast inst_tys rhs_ty
-
 nlHsAppType :: LHsExpr GhcPs -> Type -> LHsExpr GhcPs
 nlHsAppType e s = noLocA (HsAppType noSrcSpan e hs_ty)
   where
@@ -2216,25 +2215,13 @@ genAuxBindSpecSig loc spec = case spec of
   where
     mk_sig = mkHsWildCardBndrs . L (noAnnSrcSpan loc) . mkHsImplicitSigType
 
-type SeparateBagsDerivStuff =
-  -- DerivAuxBinds
-  ( Bag (LHsBind GhcPs, LSig GhcPs)
-
-  -- Extra family instances (used by DeriveGeneric, DeriveAnyClass, and
-  -- GeneralizedNewtypeDeriving)
-  , Bag FamInst )
-
--- | Take a 'BagDerivStuff' and partition it into 'SeparateBagsDerivStuff'.
--- Also generate the code for auxiliary bindings based on the declarative
--- descriptions in the supplied 'AuxBindSpec's. See @Note [Auxiliary binders]@.
-genAuxBinds :: DynFlags -> SrcSpan -> BagDerivStuff -> SeparateBagsDerivStuff
-genAuxBinds dflags loc b = (gen_aux_bind_specs b1, b2) where
-  (b1,b2) = partitionBagWith splitDerivAuxBind b
-  splitDerivAuxBind (DerivAuxBind x) = Left x
-  splitDerivAuxBind (DerivFamInst t) = Right t
-
-  gen_aux_bind_specs = snd . foldr gen_aux_bind_spec (emptyOccEnv, emptyBag)
-
+-- | Take a 'Bag' of 'AuxBindSpec's and generate the code for auxiliary
+-- bindings based on the declarative descriptions in the supplied
+-- 'AuxBindSpec's. See @Note [Auxiliary binders]@.
+genAuxBinds :: DynFlags -> SrcSpan -> Bag AuxBindSpec
+            -> Bag (LHsBind GhcPs, LSig GhcPs)
+genAuxBinds dflags loc = snd . foldr gen_aux_bind_spec (emptyOccEnv, emptyBag)
+ where
   -- Perform a CSE-like pass over the generated auxiliary bindings to avoid
   -- code duplication, as described in
   -- Note [Auxiliary binders] (Wrinkle: Reducing code duplication).
diff --git a/compiler/GHC/Tc/Deriv/Generics.hs b/compiler/GHC/Tc/Deriv/Generics.hs
index 65a7329729..dde32082e6 100644
--- a/compiler/GHC/Tc/Deriv/Generics.hs
+++ b/compiler/GHC/Tc/Deriv/Generics.hs
@@ -12,10 +12,11 @@
 
 -- | The deriving code for the Generic class
 module GHC.Tc.Deriv.Generics
-   (canDoGenerics
+   ( canDoGenerics
    , canDoGenerics1
    , GenericKind(..)
    , gen_Generic_binds
+   , gen_Generic_fam_inst
    , get_gen1_constrained_tys
    )
 where
@@ -76,13 +77,11 @@ For the generic representation we need to generate:
 \end{itemize}
 -}
 
-gen_Generic_binds :: GenericKind -> (Name -> Fixity) -> [Type] -> DerivInstTys
-                  -> TcM (LHsBinds GhcPs, [LSig GhcPs], FamInst)
-gen_Generic_binds gk get_fixity inst_tys dit = do
+gen_Generic_binds :: GenericKind -> SrcSpan -> DerivInstTys
+                  -> TcM (LHsBinds GhcPs, [LSig GhcPs])
+gen_Generic_binds gk loc dit = do
   dflags <- getDynFlags
-  repTyInsts <- tc_mkRepFamInsts gk get_fixity inst_tys dit
-  let (binds, sigs) = mkBindsRep dflags gk dit
-  return (binds, sigs, repTyInsts)
+  return $ mkBindsRep dflags gk loc dit
 
 {-
 ************************************************************************
@@ -332,8 +331,8 @@ gk2gkDC Gen1 dc tc_args = Gen1_DC $ assert (isTyVarTy last_dc_inst_univ)
 
 
 -- Bindings for the Generic instance
-mkBindsRep :: DynFlags -> GenericKind -> DerivInstTys -> (LHsBinds GhcPs, [LSig GhcPs])
-mkBindsRep dflags gk dit@(DerivInstTys{dit_rep_tc = tycon}) = (binds, sigs)
+mkBindsRep :: DynFlags -> GenericKind -> SrcSpan -> DerivInstTys -> (LHsBinds GhcPs, [LSig GhcPs])
+mkBindsRep dflags gk loc dit@(DerivInstTys{dit_rep_tc = tycon}) = (binds, sigs)
       where
         binds = unitBag (mkRdrFunBind (L loc' from01_RDR) [from_eqn])
               `unionBags`
@@ -369,7 +368,6 @@ mkBindsRep dflags gk dit@(DerivInstTys{dit_rep_tc = tycon}) = (binds, sigs)
 
         from_matches  = [mkHsCaseAlt pat rhs | (pat,rhs) <- from_alts]
         to_matches    = [mkHsCaseAlt pat rhs | (pat,rhs) <- to_alts  ]
-        loc           = srcLocSpan (getSrcLoc tycon)
         loc'          = noAnnSrcSpan loc
         loc''         = noAnnSrcSpan loc
         datacons      = tyConDataCons tycon
@@ -388,14 +386,17 @@ mkBindsRep dflags gk dit@(DerivInstTys{dit_rep_tc = tycon}) = (binds, sigs)
 --       type Rep_D a b = ...representation type for D ...
 --------------------------------------------------------------------------------
 
-tc_mkRepFamInsts :: GenericKind      -- Gen0 or Gen1
-                 -> (Name -> Fixity) -- Get the Fixity for a data constructor Name
-                 -> [Type]           -- The type(s) to which Generic(1) is applied
-                                     -- in the generated instance
-                 -> DerivInstTys     -- Information about the last type argument,
-                                     -- including the data type's TyCon
-                 -> TcM FamInst      -- Generated representation0 coercion
-tc_mkRepFamInsts gk get_fixity inst_tys dit@(DerivInstTys{dit_rep_tc = tycon}) =
+gen_Generic_fam_inst :: GenericKind      -- Gen0 or Gen1
+                     -> (Name -> Fixity) -- Get the Fixity for a data constructor Name
+                     -> SrcSpan          -- The current source location
+                     -> DerivInstTys     -- Information about the type(s) to which
+                                         -- Generic(1) is applied in the generated
+                                         -- instance, including the data type's TyCon
+                     -> TcM FamInst      -- Generated representation0 coercion
+gen_Generic_fam_inst gk get_fixity loc
+       dit@(DerivInstTys{ dit_cls_tys = cls_tys
+                        , dit_tc = tc, dit_tc_args = tc_args
+                        , dit_rep_tc = tycon }) =
        -- 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 }
@@ -413,17 +414,18 @@ tc_mkRepFamInsts gk get_fixity inst_tys dit@(DerivInstTys{dit_rep_tc = tycon}) =
            --   instance Generic1 (Bar x :: k -> *)
            -- then:
            --   `arg_k` = k, `inst_ty` = Bar x :: k -> *
-           (arg_ki, inst_ty) = case (gk, inst_tys) of
-             (Gen0, [inst_t])        -> (liftedTypeKind, inst_t)
-             (Gen1, [arg_k, inst_t]) -> (arg_k,          inst_t)
-             _ -> pprPanic "tc_mkRepFamInsts" (ppr inst_tys)
+           arg_ki = case (gk, cls_tys) of
+             (Gen0, [])      -> liftedTypeKind
+             (Gen1, [arg_k]) -> arg_k
+             _ -> pprPanic "gen_Generic_fam_insts" (ppr cls_tys)
+           inst_ty = mkTyConApp tc tc_args
+           inst_tys = cls_tys ++ [inst_ty]
 
        -- `repTy` = D1 ... (C1 ... (S1 ... (Rec0 a))) :: * -> *
      ; repTy <- tc_mkRepTy gk get_fixity dit arg_ki
 
        -- `rep_name` is a name we generate for the synonym
      ; mod <- getModule
-     ; loc <- getSrcSpanM
      ; let tc_occ  = nameOccName (tyConName tycon)
            rep_occ = case gk of Gen0 -> mkGenR tc_occ; Gen1 -> mkGen1R tc_occ
      ; rep_name <- newGlobalBinder mod rep_occ loc
diff --git a/compiler/GHC/Tc/Deriv/Infer.hs b/compiler/GHC/Tc/Deriv/Infer.hs
index ccc44df2b4..3b2d3f80dd 100644
--- a/compiler/GHC/Tc/Deriv/Infer.hs
+++ b/compiler/GHC/Tc/Deriv/Infer.hs
@@ -665,13 +665,14 @@ simplifyInstanceContexts infer_specs
       | otherwise
       = do {      -- Extend the inst info from the explicit instance decls
                   -- with the current set of solutions, and simplify each RHS
-             inst_specs <- zipWithM newDerivClsInst current_solns infer_specs
+             inst_specs <- zipWithM (\soln -> newDerivClsInst . setDerivSpecTheta soln)
+                                    current_solns infer_specs
            ; new_solns <- checkNoErrs $
                           extendLocalInstEnv inst_specs $
                           mapM gen_soln infer_specs
 
            ; if (current_solns `eqSolution` new_solns) then
-                return [ spec { ds_theta = soln }
+                return [ setDerivSpecTheta soln spec
                        | (spec, soln) <- zip infer_specs current_solns ]
              else
                 iterate_deriv (n+1) new_solns }
diff --git a/compiler/GHC/Tc/Deriv/Utils.hs b/compiler/GHC/Tc/Deriv/Utils.hs
index 8a5b376767..5fe1f6b185 100644
--- a/compiler/GHC/Tc/Deriv/Utils.hs
+++ b/compiler/GHC/Tc/Deriv/Utils.hs
@@ -10,10 +10,10 @@
 -- | Error-checking and other utilities for @deriving@ clauses or declarations.
 module GHC.Tc.Deriv.Utils (
         DerivM, DerivEnv(..),
-        DerivSpec(..), pprDerivSpec,
+        DerivSpec(..), pprDerivSpec, setDerivSpecTheta,
         DerivSpecMechanism(..), derivSpecMechanismToStrategy, isDerivSpecStock,
         isDerivSpecNewtype, isDerivSpecAnyClass, isDerivSpecVia,
-        DerivContext(..), OriginativeDerivStatus(..),
+        DerivContext(..), OriginativeDerivStatus(..), StockGenFns(..),
         isStandaloneDeriv, isStandaloneWildcardDeriv, mkDerivOrigin,
         PredOrigin(..), ThetaOrigin(..), mkPredOrigin,
         mkThetaOrigin, mkThetaOriginFromPreds, substPredOrigin,
@@ -28,6 +28,7 @@ import GHC.Data.Bag
 import GHC.Types.Basic
 import GHC.Core.Class
 import GHC.Core.DataCon
+import GHC.Core.FamInstEnv
 import GHC.Driver.Session
 import GHC.Utils.Error
 import GHC.Types.Fixity.Env (lookupFixity)
@@ -179,6 +180,10 @@ pprDerivSpec (DS { ds_loc = l, ds_name = n, ds_tvs = tvs, ds_cls = c,
 instance Outputable theta => Outputable (DerivSpec theta) where
   ppr = pprDerivSpec
 
+-- | Set the 'ds_theta' in a 'DerivSpec'.
+setDerivSpecTheta :: theta' -> DerivSpec theta -> DerivSpec theta'
+setDerivSpecTheta theta ds = ds{ds_theta = theta}
+
 -- | What action to take in order to derive a class instance.
 -- See @Note [DerivEnv and DerivSpecMechanism]@, as well as
 -- @Note [Deriving strategies]@ in "GHC.Tc.Deriv".
@@ -189,28 +194,9 @@ data DerivSpecMechanism
       -- ^ Information about the arguments to the class in the derived
       -- instance, including what type constructor the last argument is
       -- headed by. See @Note [DerivEnv and DerivSpecMechanism]@.
-    , dsm_stock_gen_fn ::
-        SrcSpan -> [Type]       -- inst_tys
-                -> DerivInstTys -- dsm_stock_dit
-                -> TcM (LHsBinds GhcPs, [LSig GhcPs], BagDerivStuff, [Name])
-      -- ^ This function returns four things:
-      --
-      -- 1. @LHsBinds GhcPs@: The derived instance's function bindings
-      --    (e.g., @compare (T x) (T y) = compare x y@)
-      --
-      -- 2. @[LSig GhcPs]@: A list of instance specific signatures/pragmas.
-      --    Most likely INLINE pragmas for class methods.
-      --
-      -- 3. @BagDerivStuff@: Auxiliary bindings needed to support the derived
-      --    instance. As examples, derived 'Generic' instances require
-      --    associated type family instances, and derived 'Eq' and 'Ord'
-      --    instances require top-level @con2tag@ functions.
-      --    See @Note [Auxiliary binders]@ in "GHC.Tc.Deriv.Generate".
-      --
-      -- 4. @[Name]@: A list of Names for which @-Wunused-binds@ should be
-      --    suppressed. This is used to suppress unused warnings for record
-      --    selectors when deriving 'Read', 'Show', or 'Generic'.
-      --    See @Note [Deriving and unused record selectors]@.
+    , dsm_stock_gen_fns :: StockGenFns
+      -- ^ How to generate the instance bindings and associated type family
+      -- instances.
     }
 
     -- | @GeneralizedNewtypeDeriving@
@@ -401,13 +387,61 @@ instance Outputable DerivContext where
 --
 -- See @Note [Deriving strategies]@ in "GHC.Tc.Deriv".
 data OriginativeDerivStatus
-  = CanDeriveStock            -- Stock class, can derive
-      (SrcSpan -> [Type] -> DerivInstTys
-               -> TcM (LHsBinds GhcPs, [LSig GhcPs], BagDerivStuff, [Name]))
+  = CanDeriveStock StockGenFns -- Stock class, can derive
   | StockClassError !DeriveInstanceErrReason -- Stock class, but can't do it
   | CanDeriveAnyClass         -- See Note [Deriving any class]
   | NonDerivableClass -- Cannot derive with either stock or anyclass
 
+-- | Describes how to generate instance bindings ('stock_gen_binds') and
+-- associated type family instances ('stock_gen_fam_insts') for a particular
+-- stock-derived instance.
+data StockGenFns = StockGenFns
+  { stock_gen_binds ::
+         SrcSpan -> DerivInstTys
+      -> TcM (LHsBinds GhcPs, [LSig GhcPs], Bag AuxBindSpec, [Name])
+    -- ^ Describes how to generate instance bindings for a stock-derived
+    -- instance.
+    --
+    -- This function takes two arguments:
+    --
+    -- 1. 'SrcSpan': the source location where the instance is being derived.
+    --    This will eventually be instantiated with the 'ds_loc' field of a
+    --    'DerivSpec'.
+    --
+    -- 2. 'DerivInstTys': information about the argument types to which a
+    --    class is applied in a derived instance. This will eventually be
+    --    instantiated with the 'dsm_stock_dit' field of a
+    --    'DerivSpecMechanism'.
+    --
+    -- This function returns four things:
+    --
+    -- 1. @'LHsBinds' 'GhcPs'@: The derived instance's function bindings
+    --    (e.g., @compare (T x) (T y) = compare x y@)
+    --
+    -- 2. @['LSig' 'GhcPs']@: A list of instance specific signatures/pragmas.
+    --    Most likely @INLINE@ pragmas for class methods.
+    --
+    -- 3. @'Bag' 'AuxBindSpec'@: Auxiliary bindings needed to support the
+    --    derived instance. As examples, derived 'Eq' and 'Ord' instances
+    --    sometimes require top-level @con2tag@ functions.
+    --    See @Note [Auxiliary binders]@ in "GHC.Tc.Deriv.Generate".
+    --
+    -- 4. @['Name']@: A list of Names for which @-Wunused-binds@ should be
+    --    suppressed. This is used to suppress unused warnings for record
+    --    selectors when deriving 'Read', 'Show', or 'Generic'.
+    --    See @Note [Deriving and unused record selectors]@.
+  , stock_gen_fam_insts ::
+         SrcSpan -> DerivInstTys
+      -> TcM [FamInst]
+    -- ^ Describes how to generate associated type family instances for a
+    -- stock-derived instance. This function takes the same arguments as the
+    -- 'stock_gen_binds' function but returns a list of 'FamInst's instead.
+    -- Generating type family instances is done separately from
+    -- 'stock_gen_binds' since the type family instances must be generated
+    -- before the instance bindings can be typechecked. See
+    -- @Note [Staging of tcDeriving]@ in "GHC.Tc.Deriv".
+  }
+
 -- A stock class is one either defined in the Haskell report or for which GHC
 -- otherwise knows how to generate code for (possibly requiring the use of a
 -- language extension), such as Eq, Ord, Ix, Data, Generic, etc.)
@@ -542,58 +576,65 @@ is willing to support it.
 -}
 
 hasStockDeriving
-  :: Class -> Maybe (SrcSpan
-                     -> [Type]
-                     -> DerivInstTys
-                     -> TcM (LHsBinds GhcPs, [LSig GhcPs], BagDerivStuff, [Name]))
+  :: Class -> Maybe StockGenFns
 hasStockDeriving clas
   = assocMaybe gen_list (getUnique clas)
   where
-    gen_list
-      :: [(Unique, SrcSpan
-                   -> [Type]
-                   -> DerivInstTys
-                   -> TcM (LHsBinds GhcPs, [LSig GhcPs], BagDerivStuff, [Name]))]
-    gen_list = [ (eqClassKey,          simpleM gen_Eq_binds)
-               , (ordClassKey,         simpleM gen_Ord_binds)
-               , (enumClassKey,        simpleM gen_Enum_binds)
-               , (boundedClassKey,     simple gen_Bounded_binds)
-               , (ixClassKey,          simpleM gen_Ix_binds)
-               , (showClassKey,        read_or_show gen_Show_binds)
-               , (readClassKey,        read_or_show gen_Read_binds)
-               , (dataClassKey,        simpleM gen_Data_binds)
-               , (functorClassKey,     simple gen_Functor_binds)
-               , (foldableClassKey,    simple gen_Foldable_binds)
-               , (traversableClassKey, simple gen_Traversable_binds)
-               , (liftClassKey,        simple gen_Lift_binds)
-               , (genClassKey,         generic (gen_Generic_binds Gen0))
-               , (gen1ClassKey,        generic (gen_Generic_binds Gen1)) ]
-
-    simple gen_fn loc _ dit
-      = let (binds, deriv_stuff) = gen_fn loc dit
-        in return (binds, [], deriv_stuff, [])
+    gen_list :: [(Unique, StockGenFns)]
+    gen_list =
+      [ (eqClassKey,          mk (simple_bindsM gen_Eq_binds) no_fam_insts)
+      , (ordClassKey,         mk (simple_bindsM gen_Ord_binds) no_fam_insts)
+      , (enumClassKey,        mk (simple_bindsM gen_Enum_binds) no_fam_insts)
+      , (boundedClassKey,     mk (simple_binds gen_Bounded_binds) no_fam_insts)
+      , (ixClassKey,          mk (simple_bindsM gen_Ix_binds) no_fam_insts)
+      , (showClassKey,        mk (read_or_show_binds gen_Show_binds) no_fam_insts)
+      , (readClassKey,        mk (read_or_show_binds gen_Read_binds) no_fam_insts)
+      , (dataClassKey,        mk (simple_bindsM gen_Data_binds) no_fam_insts)
+      , (functorClassKey,     mk (simple_binds gen_Functor_binds) no_fam_insts)
+      , (foldableClassKey,    mk (simple_binds gen_Foldable_binds) no_fam_insts)
+      , (traversableClassKey, mk (simple_binds gen_Traversable_binds) no_fam_insts)
+      , (liftClassKey,        mk (simple_binds gen_Lift_binds) no_fam_insts)
+      , (genClassKey,         mk (generic_binds Gen0) (generic_fam_inst Gen0))
+      , (gen1ClassKey,        mk (generic_binds Gen1) (generic_fam_inst Gen1))
+      ]
+
+    mk gen_binds_fn gen_fam_insts_fn = StockGenFns
+      { stock_gen_binds     = gen_binds_fn
+      , stock_gen_fam_insts = gen_fam_insts_fn
+      }
+
+    simple_binds gen_fn loc dit
+      = let (binds, aux_specs) = gen_fn loc dit
+        in return (binds, [], aux_specs, [])
 
     -- Like `simple`, but monadic. The only monadic thing that these functions
     -- do is allocate new Uniques, which are used for generating the names of
     -- auxiliary bindings.
     -- See Note [Auxiliary binders] in GHC.Tc.Deriv.Generate.
-    simpleM gen_fn loc _ dit
-      = do { (binds, deriv_stuff) <- gen_fn loc dit
-           ; return (binds, [], deriv_stuff, []) }
+    simple_bindsM gen_fn loc dit
+      = do { (binds, aux_specs) <- gen_fn loc dit
+           ; return (binds, [], aux_specs, []) }
 
-    read_or_show gen_fn loc _ dit
+    read_or_show_binds gen_fn loc dit
       = do { let tc = dit_rep_tc dit
            ; fix_env <- getDataConFixityFun tc
-           ; let (binds, deriv_stuff) = gen_fn fix_env loc dit
-                 field_names          = all_field_names tc
-           ; return (binds, [], deriv_stuff, field_names) }
+           ; let (binds, aux_specs) = gen_fn fix_env loc dit
+                 field_names        = all_field_names tc
+           ; return (binds, [], aux_specs, field_names) }
 
-    generic gen_fn _ inst_tys dit
+    generic_binds gk loc dit
       = do { let tc = dit_rep_tc dit
-           ; fix_env <- getDataConFixityFun tc
-           ; (binds, sigs, faminst) <- gen_fn fix_env inst_tys dit
+           ; (binds, sigs) <- gen_Generic_binds gk loc dit
            ; let field_names = all_field_names tc
-           ; return (binds, sigs, unitBag (DerivFamInst faminst), field_names) }
+           ; return (binds, sigs, emptyBag, field_names) }
+
+    generic_fam_inst gk loc dit
+      = do { let tc = dit_rep_tc dit
+           ; fix_env <- getDataConFixityFun tc
+           ; faminst <- gen_Generic_fam_inst gk fix_env loc dit
+           ; return [faminst] }
+
+    no_fam_insts _ _ = pure []
 
     -- See Note [Deriving and unused record selectors]
     all_field_names = map flSelector . concatMap dataConFieldLabels
@@ -983,9 +1024,10 @@ non_coercible_class cls
 
 ------------------------------------------------------------------
 
-newDerivClsInst :: ThetaType -> DerivSpec theta -> TcM ClsInst
-newDerivClsInst theta (DS { ds_name = dfun_name, ds_overlap = overlap_mode
-                          , ds_tvs = tvs, ds_cls = clas, ds_tys = tys })
+newDerivClsInst :: DerivSpec ThetaType -> TcM ClsInst
+newDerivClsInst (DS { ds_name = dfun_name, ds_overlap = overlap_mode
+                    , ds_tvs = tvs, ds_theta = theta
+                    , ds_cls = clas, ds_tys = tys })
   = newClsInst overlap_mode dfun_name tvs theta clas tys
 
 extendLocalInstEnv :: [ClsInst] -> TcM a -> TcM a