Refactor TcDeriv to validity-check less in anyclass/via deriving (#13154)wip/T13154-take-two

Due to the way `DerivEnv` is currently structured, there is an
invariant that every derived instance must consist of a class applied
to a non-empty list of argument types, where the last argument *must*
be an application of a type constructor to some arguments. This works
for many cases, but there are also some design patterns in standalone
`anyclass`/`via` deriving that are made impossible due to enforcing
this invariant, as documented in #13154.

This fixes #13154 by refactoring `TcDeriv` and friends to perform
fewer validity checks when using the `anyclass` or `via` strategies.
The highlights are as followed:

* Five fields of `DerivEnv` have been factored out into a new
  `DerivInstTys` data type. These fields only make sense for
  instances that satisfy the invariant mentioned above, so
  `DerivInstTys` is now only used in `stock` and `newtype` deriving,
  but not in other deriving strategies.
* There is now a `Note [DerivEnv and DerivSpecMechanism]` describing
  the bullet point above in more detail, as well as explaining the
  exact requirements that each deriving strategy imposes.
* I've refactored `mkEqnHelp`'s call graph to be slightly less
  complicated. Instead of the previous `mkDataTypeEqn`/`mkNewTypeEqn`
  dichotomy, there is now a single entrypoint `mk_eqn`.
* Various bits of code were tweaked so as not to use fields that are
  specific to `DerivInstTys` so that they may be used by all deriving
  strategies, since not all deriving strategies use `DerivInstTys`.

9 files changed, 622 insertions, 301 deletions

diff --git a/compiler/typecheck/TcDeriv.hs b/compiler/typecheck/TcDeriv.hs
index 055af76743..07e0198625 100644
--- a/compiler/typecheck/TcDeriv.hs
+++ b/compiler/typecheck/TcDeriv.hs
@@ -7,6 +7,7 @@ Handles @deriving@ clauses on @data@ declarations.
 -}
 
 {-# LANGUAGE CPP #-}
+{-# LANGUAGE MultiWayIf #-}
 {-# LANGUAGE TypeFamilies #-}
 
 module TcDeriv ( tcDeriving, DerivInfo(..) ) where
@@ -381,9 +382,9 @@ continuation-returning style, so we opt for that route.
 
 Note [Why we don't pass rep_tc into deriveTyData]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Down in the bowels of mkEqnHelp, we need to convert the fam_tc back into
-the rep_tc by means of a lookup. And yet we have the rep_tc right here!
-Why look it up again? Answer: it's just easier this way.
+Down in the bowels of mk_deriv_inst_tys_maybe, we need to convert the fam_tc
+back into the rep_tc by means of a lookup. And yet we have the rep_tc right
+here! Why look it up again? Answer: it's just easier this way.
 We drop some number of arguments from the end of the datatype definition
 in deriveTyData. The arguments are dropped from the fam_tc.
 This action may drop a *different* number of arguments
@@ -624,16 +625,22 @@ deriveStandalone (L loc (DerivDecl _ deriv_ty mb_lderiv_strat overlap_mode))
        ; (cls_tvs, deriv_ctxt, cls, inst_tys)
            <- tcExtendTyVarEnv via_tvs $
               tcStandaloneDerivInstType ctxt deriv_ty
-       ; checkTc (not (null inst_tys)) derivingNullaryErr
        ; let mb_deriv_strat = fmap unLoc mb_lderiv_strat
              tvs            = via_tvs ++ cls_tvs
-             inst_ty        = last inst_tys
          -- See Note [Unify kinds in deriving]
        ; (tvs', deriv_ctxt', inst_tys', mb_deriv_strat') <-
            case mb_deriv_strat of
              -- Perform an additional unification with the kind of the `via`
              -- type and the result of the previous kind unification.
-             Just (ViaStrategy via_ty) -> do
+             Just (ViaStrategy via_ty)
+                  -- This unification must be performed on the last element of
+                  -- inst_tys, but we have not yet checked for this property.
+                  -- (This is done later in expectNonNullaryClsArgs). For now,
+                  -- simply do nothing if inst_tys is empty, since
+                  -- expectNonNullaryClsArgs will error later if this
+                  -- is the case.
+               |  Just inst_ty <- lastMaybe inst_tys
+               -> do
                let via_kind     = tcTypeKind via_ty
                    inst_ty_kind = tcTypeKind inst_ty
                    mb_match     = tcUnifyTy inst_ty_kind via_kind
@@ -665,8 +672,6 @@ deriveStandalone (L loc (DerivDecl _ deriv_ty mb_lderiv_strat overlap_mode))
                     , Just (ViaStrategy final_via_ty) )
 
              _ -> pure (tvs, deriv_ctxt, inst_tys, mb_deriv_strat)
-       ; let cls_tys' = take (length inst_tys' - 1) inst_tys'
-             inst_ty' = last inst_tys'
        ; traceTc "Standalone deriving;" $ vcat
               [ text "tvs':" <+> ppr tvs'
               , text "mb_deriv_strat':" <+> ppr mb_deriv_strat'
@@ -674,29 +679,13 @@ deriveStandalone (L loc (DerivDecl _ deriv_ty mb_lderiv_strat overlap_mode))
               , text "cls:" <+> ppr cls
               , text "inst_tys':" <+> ppr inst_tys' ]
                 -- C.f. TcInstDcls.tcLocalInstDecl1
-       ; traceTc "Standalone deriving:" $ vcat
-              [ text "class:" <+> ppr cls
-              , text "class types:" <+> ppr cls_tys'
-              , text "type:" <+> ppr inst_ty' ]
-
-       ; let bale_out msg = failWithTc (derivingThingErr False cls cls_tys'
-                              inst_ty' mb_deriv_strat' msg)
-
-       ; case tcSplitTyConApp_maybe inst_ty' of
-           Just (tc, tc_args)
-              | className cls == typeableClassName
-              -> do warnUselessTypeable
-                    return Nothing
-
-              | otherwise
-              -> Just <$> mkEqnHelp (fmap unLoc overlap_mode)
-                                    tvs' cls cls_tys' tc tc_args
-                                    deriv_ctxt' mb_deriv_strat'
-
-           _  -> -- Complain about functions, primitive types, etc,
-                 bale_out $
-                 text "The last argument of the instance must be a data or newtype application"
-        }
+
+       ; if className cls == typeableClassName
+         then do warnUselessTypeable
+                 return Nothing
+         else Just <$> mkEqnHelp (fmap unLoc overlap_mode)
+                                 tvs' cls inst_tys'
+                                 deriv_ctxt' mb_deriv_strat' }
 deriveStandalone (L _ (XDerivDecl nec)) = noExtCon nec
 
 -- Typecheck the type in a standalone deriving declaration.
@@ -851,7 +840,8 @@ deriveTyData tc tc_args mb_deriv_strat deriv_tvs cls cls_tys cls_arg_kind
         ; traceTc "deriveTyData 2" $ vcat
             [ ppr final_tkvs ]
 
-        ; let final_tc_app = mkTyConApp tc final_tc_args
+        ; let final_tc_app   = mkTyConApp tc final_tc_args
+              final_cls_args = final_cls_tys ++ [final_tc_app]
         ; checkTc (allDistinctTyVars (mkVarSet final_tkvs) args_to_drop) -- (a, b, c)
                   (derivingEtaErr cls final_cls_tys final_tc_app)
                 -- Check that
@@ -869,13 +859,11 @@ deriveTyData tc tc_args mb_deriv_strat deriv_tvs cls cls_tys cls_arg_kind
                 -- expand any type synonyms.
                 -- See Note [Eta-reducing type synonyms]
 
-        ; checkValidInstHead DerivClauseCtxt cls $
-                             final_cls_tys ++ [final_tc_app]
+        ; checkValidInstHead DerivClauseCtxt cls final_cls_args
                 -- Check that we aren't deriving an instance of a magical
                 -- type like (~) or Coercible (#14916).
 
-        ; spec <- mkEqnHelp Nothing final_tkvs
-                            cls final_cls_tys tc final_tc_args
+        ; spec <- mkEqnHelp Nothing final_tkvs cls final_cls_args
                             (InferContext Nothing) final_mb_deriv_strat
         ; traceTc "deriveTyData 3" (ppr spec)
         ; return spec }
@@ -1151,7 +1139,6 @@ required to obtain the latter instance just isn't worth it.
 mkEqnHelp :: Maybe OverlapMode
           -> [TyVar]
           -> Class -> [Type]
-          -> TyCon -> [Type]
           -> DerivContext
                -- SupplyContext => context supplied (standalone deriving)
                -- InferContext  => context inferred (deriving on data decl, or
@@ -1163,35 +1150,106 @@ mkEqnHelp :: Maybe OverlapMode
 -- where the 'theta' is optional (that's the Maybe part)
 -- Assumes that this declaration is well-kinded
 
-mkEqnHelp overlap_mode tvs cls cls_tys tycon tc_args deriv_ctxt deriv_strat
-  = do {      -- Find the instance of a data family
-              -- Note [Looking up family instances for deriving]
-         fam_envs <- tcGetFamInstEnvs
-       ; let (rep_tc, rep_tc_args, _co) = tcLookupDataFamInst fam_envs tycon tc_args
-              -- If it's still a data family, the lookup failed; i.e no instance exists
-       ; when (isDataFamilyTyCon rep_tc)
-              (bale_out (text "No family instance for" <+> quotes (pprTypeApp tycon tc_args)))
-       ; is_boot <- tcIsHsBootOrSig
-       ; when is_boot $
-              bale_out (text "Cannot derive instances in hs-boot files"
-                    $+$ text "Write an instance declaration instead")
-
-       ; let deriv_env = DerivEnv
-                         { denv_overlap_mode = overlap_mode
+mkEqnHelp overlap_mode tvs cls cls_args deriv_ctxt deriv_strat = do
+  is_boot <- tcIsHsBootOrSig
+  when is_boot $
+       bale_out (text "Cannot derive instances in hs-boot files"
+             $+$ text "Write an instance declaration instead")
+  runReaderT mk_eqn deriv_env
+  where
+    deriv_env = DerivEnv { denv_overlap_mode = overlap_mode
                          , denv_tvs          = tvs
                          , denv_cls          = cls
-                         , denv_cls_tys      = cls_tys
-                         , denv_tc           = tycon
-                         , denv_tc_args      = tc_args
-                         , denv_rep_tc       = rep_tc
-                         , denv_rep_tc_args  = rep_tc_args
+                         , denv_inst_tys     = cls_args
                          , denv_ctxt         = deriv_ctxt
                          , denv_strat        = deriv_strat }
-       ; flip runReaderT deriv_env $
-         if isNewTyCon rep_tc then mkNewTypeEqn else mkDataTypeEqn }
+
+    bale_out msg = failWithTc $ derivingThingErr False cls cls_args deriv_strat msg
+
+    mk_eqn :: DerivM EarlyDerivSpec
+    mk_eqn = do
+      DerivEnv { denv_inst_tys = cls_args
+               , denv_strat    = mb_strat } <- ask
+      case mb_strat of
+        Just StockStrategy -> do
+          (cls_tys, inst_ty) <- expectNonNullaryClsArgs cls_args
+          dit                <- expectAlgTyConApp cls_tys inst_ty
+          mk_eqn_stock dit
+
+        Just AnyclassStrategy -> mk_eqn_anyclass
+
+        Just (ViaStrategy via_ty) -> do
+          (cls_tys, inst_ty) <- expectNonNullaryClsArgs cls_args
+          mk_eqn_via cls_tys inst_ty via_ty
+
+        Just NewtypeStrategy -> do
+          (cls_tys, inst_ty) <- expectNonNullaryClsArgs cls_args
+          dit                <- expectAlgTyConApp cls_tys inst_ty
+          unless (isNewTyCon (dit_rep_tc dit)) $
+            derivingThingFailWith False gndNonNewtypeErr
+          mkNewTypeEqn True dit
+
+        Nothing -> mk_eqn_no_strategy
+
+-- @expectNonNullaryClsArgs inst_tys@ checks if @inst_tys@ is non-empty.
+-- If so, return @(init inst_tys, last inst_tys)@.
+-- Otherwise, throw an error message.
+-- See @Note [DerivEnv and DerivSpecMechanism]@ in "TcDerivUtils" for why this
+-- property is important.
+expectNonNullaryClsArgs :: [Type] -> DerivM ([Type], Type)
+expectNonNullaryClsArgs inst_tys =
+  maybe (derivingThingFailWith False derivingNullaryErr) pure $
+  snocView inst_tys
+
+-- @expectAlgTyConApp cls_tys inst_ty@ checks if @inst_ty@ is an application
+-- of an algebraic type constructor. If so, return a 'DerivInstTys' consisting
+-- of @cls_tys@ and the constituent pars of @inst_ty@.
+-- Otherwise, throw an error message.
+-- See @Note [DerivEnv and DerivSpecMechanism]@ in "TcDerivUtils" for why this
+-- property is important.
+expectAlgTyConApp :: [Type] -- All but the last argument to the class in a
+                            -- derived instance
+                  -> Type   -- The last argument to the class in a
+                            -- derived instance
+                  -> DerivM DerivInstTys
+expectAlgTyConApp cls_tys inst_ty = do
+  fam_envs <- lift tcGetFamInstEnvs
+  case mk_deriv_inst_tys_maybe fam_envs cls_tys inst_ty of
+    Nothing -> derivingThingFailWith False $
+                   text "The last argument of the instance must be a"
+               <+> text "data or newtype application"
+    Just dit -> do expectNonDataFamTyCon dit
+                   pure dit
+
+-- @expectNonDataFamTyCon dit@ checks if @dit_rep_tc dit@ is a representation
+-- type constructor for a data family instance, and if not,
+-- throws an error message.
+-- See @Note [DerivEnv and DerivSpecMechanism]@ in "TcDerivUtils" for why this
+-- property is important.
+expectNonDataFamTyCon :: DerivInstTys -> DerivM ()
+expectNonDataFamTyCon (DerivInstTys { dit_tc      = tc
+                                    , dit_tc_args = tc_args
+                                    , dit_rep_tc  = rep_tc }) =
+  -- If it's still a data family, the lookup failed; i.e no instance exists
+  when (isDataFamilyTyCon rep_tc) $
+    derivingThingFailWith False $
+    text "No family instance for" <+> quotes (pprTypeApp tc tc_args)
+
+mk_deriv_inst_tys_maybe :: FamInstEnvs
+                        -> [Type] -> Type -> Maybe DerivInstTys
+mk_deriv_inst_tys_maybe fam_envs cls_tys inst_ty =
+  fmap lookup $ tcSplitTyConApp_maybe inst_ty
   where
-     bale_out msg = failWithTc (derivingThingErr False cls cls_tys
-                      (mkTyConApp tycon tc_args) deriv_strat msg)
+    lookup :: (TyCon, [Type]) -> DerivInstTys
+    lookup (tc, tc_args) =
+      -- Find the instance of a data family
+      -- Note [Looking up family instances for deriving]
+      let (rep_tc, rep_tc_args, _co) = tcLookupDataFamInst fam_envs tc tc_args
+      in DerivInstTys { dit_cls_tys     = cls_tys
+                      , dit_tc          = tc
+                      , dit_tc_args     = tc_args
+                      , dit_rep_tc      = rep_tc
+                      , dit_rep_tc_args = rep_tc_args }
 
 {-
 Note [Looking up family instances for deriving]
@@ -1259,34 +1317,15 @@ See Note [Eta reduction for data families] in FamInstEnv
 ************************************************************************
 -}
 
--- | Derive an instance for a data type (i.e., non-newtype).
-mkDataTypeEqn :: DerivM EarlyDerivSpec
-mkDataTypeEqn
-  = do mb_strat <- asks denv_strat
-       case mb_strat of
-         Just StockStrategy    -> mk_eqn_stock
-         Just AnyclassStrategy -> mk_eqn_anyclass
-         Just (ViaStrategy ty) -> mk_eqn_via ty
-         -- GeneralizedNewtypeDeriving makes no sense for non-newtypes
-         Just NewtypeStrategy  -> derivingThingFailWith False gndNonNewtypeErr
-         -- Lacking a user-requested deriving strategy, we will try to pick
-         -- between the stock or anyclass strategies
-         Nothing               -> mk_eqn_no_mechanism
-
 -- Once the DerivSpecMechanism is known, we can finally produce an
 -- EarlyDerivSpec from it.
 mk_eqn_from_mechanism :: DerivSpecMechanism -> DerivM EarlyDerivSpec
 mk_eqn_from_mechanism mechanism
   = do DerivEnv { denv_overlap_mode = overlap_mode
                 , denv_tvs          = tvs
-                , denv_tc           = tc
-                , denv_tc_args      = tc_args
-                , denv_rep_tc       = rep_tc
                 , denv_cls          = cls
-                , denv_cls_tys      = cls_tys
+                , denv_inst_tys     = inst_tys
                 , denv_ctxt         = deriv_ctxt } <- ask
-       let inst_ty  = mkTyConApp tc tc_args
-           inst_tys = cls_tys ++ [inst_ty]
        doDerivInstErrorChecks1 mechanism
        loc       <- lift getSrcSpanM
        dfun_name <- lift $ newDFunName cls inst_tys loc
@@ -1298,7 +1337,6 @@ mk_eqn_from_mechanism mechanism
                    { ds_loc = loc
                    , ds_name = dfun_name, ds_tvs = tvs'
                    , ds_cls = cls, ds_tys = inst_tys'
-                   , ds_tc = rep_tc
                    , ds_theta = inferred_constraints
                    , ds_overlap = overlap_mode
                    , ds_standalone_wildcard = wildcard
@@ -1309,23 +1347,24 @@ mk_eqn_from_mechanism mechanism
                    { ds_loc = loc
                    , ds_name = dfun_name, ds_tvs = tvs
                    , ds_cls = cls, ds_tys = inst_tys
-                   , ds_tc = rep_tc
                    , ds_theta = theta
                    , ds_overlap = overlap_mode
                    , ds_standalone_wildcard = Nothing
                    , ds_mechanism = mechanism }
 
-mk_eqn_stock :: DerivM EarlyDerivSpec
-mk_eqn_stock
-  = do DerivEnv { denv_tc      = tc
-                , denv_rep_tc  = rep_tc
-                , denv_cls     = cls
-                , denv_cls_tys = cls_tys
-                , denv_ctxt    = deriv_ctxt } <- ask
+mk_eqn_stock :: DerivInstTys -- Information about the arguments to the class
+             -> DerivM EarlyDerivSpec
+mk_eqn_stock dit@(DerivInstTys { dit_cls_tys = cls_tys
+                               , dit_tc      = tc
+                               , dit_rep_tc  = rep_tc })
+  = do DerivEnv { denv_cls  = cls
+                , denv_ctxt = deriv_ctxt } <- ask
        dflags <- getDynFlags
        case checkOriginativeSideConditions dflags deriv_ctxt cls cls_tys
                                            tc rep_tc of
-         CanDeriveStock gen_fn -> mk_eqn_from_mechanism $ DerivSpecStock gen_fn
+         CanDeriveStock gen_fn -> mk_eqn_from_mechanism $
+                                  DerivSpecStock { dsm_stock_dit    = dit
+                                                 , dsm_stock_gen_fn = gen_fn }
          StockClassError msg   -> derivingThingFailWith False msg
          _                     -> derivingThingFailWith False (nonStdErr cls)
 
@@ -1336,60 +1375,106 @@ mk_eqn_anyclass
          IsValid      -> mk_eqn_from_mechanism DerivSpecAnyClass
          NotValid msg -> derivingThingFailWith False msg
 
-mk_eqn_newtype :: Type -- The newtype's representation type
+mk_eqn_newtype :: DerivInstTys -- Information about the arguments to the class
+               -> Type         -- The newtype's representation type
                -> DerivM EarlyDerivSpec
-mk_eqn_newtype rep_ty = mk_eqn_from_mechanism (DerivSpecNewtype rep_ty)
+mk_eqn_newtype dit rep_ty =
+  mk_eqn_from_mechanism $ DerivSpecNewtype { dsm_newtype_dit    = dit
+                                           , dsm_newtype_rep_ty = rep_ty }
 
-mk_eqn_via :: Type -- The @via@ type
+mk_eqn_via :: [Type] -- All arguments to the class besides the last
+           -> Type   -- The last argument to the class
+           -> Type   -- The @via@ type
            -> DerivM EarlyDerivSpec
-mk_eqn_via via_ty = mk_eqn_from_mechanism (DerivSpecVia via_ty)
-
-mk_eqn_no_mechanism :: DerivM EarlyDerivSpec
-mk_eqn_no_mechanism
-  = do DerivEnv { denv_tc      = tc
-                , denv_rep_tc  = rep_tc
-                , denv_cls     = cls
-                , denv_cls_tys = cls_tys
-                , denv_ctxt    = deriv_ctxt } <- ask
-       dflags <- getDynFlags
-
-           -- See Note [Deriving instances for classes themselves]
-       let dac_error msg
-             | isClassTyCon rep_tc
-             = quotes (ppr tc) <+> text "is a type class,"
-                               <+> text "and can only have a derived instance"
-                               $+$ text "if DeriveAnyClass is enabled"
-             | otherwise
-             = nonStdErr cls $$ msg
-
-       case checkOriginativeSideConditions dflags deriv_ctxt cls cls_tys
-                                           tc rep_tc of
-           -- NB: pass the *representation* tycon to
-           -- checkOriginativeSideConditions
-           NonDerivableClass   msg -> derivingThingFailWith False (dac_error msg)
-           StockClassError msg     -> derivingThingFailWith False msg
-           CanDeriveStock gen_fn   -> mk_eqn_from_mechanism $ DerivSpecStock gen_fn
-           CanDeriveAnyClass       -> mk_eqn_from_mechanism DerivSpecAnyClass
+mk_eqn_via cls_tys inst_ty via_ty =
+  mk_eqn_from_mechanism $ DerivSpecVia { dsm_via_cls_tys = cls_tys
+                                       , dsm_via_inst_ty = inst_ty
+                                       , dsm_via_ty      = via_ty }
+
+-- Derive an instance without a user-requested deriving strategy. This uses
+-- heuristics to determine which deriving strategy to use.
+-- See Note [Deriving strategies].
+mk_eqn_no_strategy :: DerivM EarlyDerivSpec
+mk_eqn_no_strategy = do
+  DerivEnv { denv_cls      = cls
+           , denv_inst_tys = cls_args } <- ask
+  fam_envs <- lift tcGetFamInstEnvs
+
+  -- First, check if the last argument is an application of a type constructor.
+  -- If not, fall back to DeriveAnyClass.
+  if |  Just (cls_tys, inst_ty) <- snocView cls_args
+     ,  Just dit <- mk_deriv_inst_tys_maybe fam_envs cls_tys inst_ty
+     -> if |  isNewTyCon (dit_rep_tc dit)
+              -- We have a dedicated code path for newtypes (see the
+              -- documentation for mkNewTypeEqn as to why this is the case)
+           -> mkNewTypeEqn False dit
+
+           |  otherwise
+           -> do -- Otherwise, our only other options are stock or anyclass.
+                 -- If it is stock, we must confirm that the last argument's
+                 -- type constructor is algebraic.
+                 -- See Note [DerivEnv and DerivSpecMechanism] in TcDerivUtils
+                 whenIsJust (hasStockDeriving cls) $ \_ ->
+                   expectNonDataFamTyCon dit
+                 mk_eqn_originative dit
+
+     |  otherwise
+     -> mk_eqn_anyclass
+  where
+    -- Use heuristics (checkOriginativeSideConditions) to determine whether
+    -- stock or anyclass deriving should be used.
+    mk_eqn_originative :: DerivInstTys -> DerivM EarlyDerivSpec
+    mk_eqn_originative dit@(DerivInstTys { dit_cls_tys = cls_tys
+                                         , dit_tc      = tc
+                                         , dit_rep_tc  = rep_tc }) = do
+      DerivEnv { denv_cls  = cls
+               , denv_ctxt = deriv_ctxt } <- ask
+      dflags <- getDynFlags
+
+      -- See Note [Deriving instances for classes themselves]
+      let dac_error msg
+            | isClassTyCon rep_tc
+            = quotes (ppr tc) <+> text "is a type class,"
+                              <+> text "and can only have a derived instance"
+                              $+$ text "if DeriveAnyClass is enabled"
+            | otherwise
+            = nonStdErr cls $$ msg
+
+      case checkOriginativeSideConditions dflags deriv_ctxt cls
+             cls_tys tc rep_tc of
+        NonDerivableClass   msg -> derivingThingFailWith False (dac_error msg)
+        StockClassError msg     -> derivingThingFailWith False msg
+        CanDeriveStock gen_fn   -> mk_eqn_from_mechanism $
+                                   DerivSpecStock { dsm_stock_dit    = dit
+                                                  , dsm_stock_gen_fn = gen_fn }
+        CanDeriveAnyClass       -> mk_eqn_from_mechanism DerivSpecAnyClass
 
 {-
 ************************************************************************
 *                                                                      *
-            GeneralizedNewtypeDeriving and DerivingVia
+            Deriving instances for newtypes
 *                                                                      *
 ************************************************************************
 -}
 
--- | Derive an instance for a newtype.
-mkNewTypeEqn :: DerivM EarlyDerivSpec
-mkNewTypeEqn
+-- Derive an instance for a newtype. We put this logic into its own function
+-- because
+--
+-- (a) When no explicit deriving strategy is requested, we have special
+--     heuristics for newtypes to determine which deriving strategy should
+--     actually be used. See Note [Deriving strategies].
+-- (b) We make an effort to give error messages specifically tailored to
+--     newtypes.
+mkNewTypeEqn :: Bool -- Was this instance derived using an explicit @newtype@
+                     -- deriving strategy?
+             -> DerivInstTys -> DerivM EarlyDerivSpec
+mkNewTypeEqn newtype_strat dit@(DerivInstTys { dit_cls_tys     = cls_tys
+                                             , dit_tc          = tycon
+                                             , dit_rep_tc      = rep_tycon
+                                             , dit_rep_tc_args = rep_tc_args })
 -- Want: instance (...) => cls (cls_tys ++ [tycon tc_args]) where ...
-  = do DerivEnv { denv_tc           = tycon
-                , denv_rep_tc       = rep_tycon
-                , denv_rep_tc_args  = rep_tc_args
-                , denv_cls          = cls
-                , denv_cls_tys      = cls_tys
-                , denv_ctxt         = deriv_ctxt
-                , denv_strat        = mb_strat } <- ask
+  = do DerivEnv { denv_cls   = cls
+                , denv_ctxt  = deriv_ctxt } <- ask
        dflags <- getDynFlags
 
        let newtype_deriving  = xopt LangExt.GeneralizedNewtypeDeriving dflags
@@ -1472,10 +1557,8 @@ mkNewTypeEqn
            eta_msg = text "cannot eta-reduce the representation type enough"
 
        MASSERT( cls_tys `lengthIs` (classArity cls - 1) )
-       case mb_strat of
-         Just StockStrategy    -> mk_eqn_stock
-         Just AnyclassStrategy -> mk_eqn_anyclass
-         Just NewtypeStrategy  ->
+       if newtype_strat
+       then
            -- Since the user explicitly asked for GeneralizedNewtypeDeriving,
            -- we don't need to perform all of the checks we normally would,
            -- such as if the class being derived is known to produce ill-roled
@@ -1483,20 +1566,15 @@ mkNewTypeEqn
            -- instance and let it error if need be.
            -- See Note [Determining whether newtype-deriving is appropriate]
            if eta_ok && newtype_deriving
-             then mk_eqn_newtype rep_inst_ty
+             then mk_eqn_newtype dit rep_inst_ty
              else bale_out (cant_derive_err $$
                             if newtype_deriving then empty else suggest_gnd)
-         Just (ViaStrategy via_ty) ->
-           -- NB: For DerivingVia, we don't need to any eta-reduction checking,
-           -- since the @via@ type is already "eta-reduced".
-           mk_eqn_via via_ty
-         Nothing
-           | might_be_newtype_derivable
+       else
+         if might_be_newtype_derivable
              && ((newtype_deriving && not deriveAnyClass)
                   || std_class_via_coercible cls)
-          -> mk_eqn_newtype rep_inst_ty
-           | otherwise
-          -> case checkOriginativeSideConditions dflags deriv_ctxt cls cls_tys
+         then mk_eqn_newtype dit rep_inst_ty
+         else case checkOriginativeSideConditions dflags deriv_ctxt cls cls_tys
                                                  tycon rep_tycon of
                StockClassError msg
                  -- There's a particular corner case where
@@ -1509,7 +1587,7 @@ mkNewTypeEqn
                  -- and the previous cases won't catch it. This fixes the bug
                  -- reported in #10598.
                  | might_be_newtype_derivable && newtype_deriving
-                -> mk_eqn_newtype rep_inst_ty
+                -> mk_eqn_newtype dit rep_inst_ty
                  -- Otherwise, throw an error for a stock class
                  | might_be_newtype_derivable && not newtype_deriving
                 -> bale_out (msg $$ suggest_gnd)
@@ -1544,7 +1622,8 @@ mkNewTypeEqn
                  mk_eqn_from_mechanism DerivSpecAnyClass
                -- CanDeriveStock
                CanDeriveStock gen_fn -> mk_eqn_from_mechanism $
-                                        DerivSpecStock gen_fn
+                                        DerivSpecStock { dsm_stock_dit    = dit
+                                                       , dsm_stock_gen_fn = gen_fn }
 
 {-
 Note [Recursive newtypes]
@@ -1751,25 +1830,19 @@ the renamer.  What a great hack!
 \end{itemize}
 -}
 
--- Generate the InstInfo for the required instance paired with the
---   *representation* tycon for that instance,
+-- Generate the InstInfo for the required instance
 -- plus any auxiliary bindings required
---
--- Representation tycons differ from the tycon in the instance signature in
--- case of instances for indexed families.
---
 genInst :: DerivSpec theta
         -> TcM (ThetaType -> TcM (InstInfo GhcPs), BagDerivStuff, [Name])
 -- We must use continuation-returning style here to get the order in which we
 -- typecheck family instances and derived instances right.
 -- See Note [Staging of tcDeriving]
-genInst spec@(DS { ds_tvs = tvs, ds_tc = rep_tycon
-                 , ds_mechanism = mechanism, ds_tys = tys
-                 , ds_cls = clas, ds_loc = loc
+genInst spec@(DS { ds_tvs = tvs, ds_mechanism = mechanism
+                 , ds_tys = tys, ds_cls = clas, ds_loc = loc
                  , ds_standalone_wildcard = wildcard })
   = do (meth_binds, deriv_stuff, unusedNames)
          <- set_span_and_ctxt $
-            genDerivStuff mechanism loc clas rep_tycon tys tvs
+            genDerivStuff mechanism loc clas tys tvs
        let mk_inst_info theta = set_span_and_ctxt $ do
              inst_spec <- newDerivClsInst theta spec
              doDerivInstErrorChecks2 clas inst_spec theta wildcard mechanism
@@ -1807,11 +1880,15 @@ genInst spec@(DS { ds_tvs = tvs, ds_tc = rep_tycon
 doDerivInstErrorChecks1 :: DerivSpecMechanism -> DerivM ()
 doDerivInstErrorChecks1 mechanism =
   case mechanism of
-    DerivSpecStock{}    -> data_cons_in_scope_check
-    DerivSpecNewtype{}  -> do atf_coerce_based_error_checks
-                              data_cons_in_scope_check
-    DerivSpecAnyClass{} -> pure ()
-    DerivSpecVia{}      -> atf_coerce_based_error_checks
+    DerivSpecStock{dsm_stock_dit = dit}
+      -> data_cons_in_scope_check dit
+    DerivSpecNewtype{dsm_newtype_dit = dit}
+      -> do atf_coerce_based_error_checks
+            data_cons_in_scope_check dit
+    DerivSpecAnyClass{}
+      -> pure ()
+    DerivSpecVia{}
+      -> atf_coerce_based_error_checks
   where
     -- When processing a standalone deriving declaration, check that all of the
     -- constructors for the data type are in scope. For instance:
@@ -1825,11 +1902,11 @@ doDerivInstErrorChecks1 mechanism =
     -- Note that the only strategies that require this check are `stock` and
     -- `newtype`. Neither `anyclass` nor `via` require it as the code that they
     -- generate does not require using data constructors.
-    data_cons_in_scope_check :: DerivM ()
-    data_cons_in_scope_check = do
+    data_cons_in_scope_check :: DerivInstTys -> DerivM ()
+    data_cons_in_scope_check (DerivInstTys { dit_tc     = tc
+                                           , dit_rep_tc = rep_tc }) = do
       standalone <- isStandaloneDeriv
       when standalone $ do
-        DerivEnv { denv_tc = tc, denv_rep_tc = rep_tc } <- ask
         let bale_out msg = do err <- derivingThingErrMechanism mechanism msg
                               lift $ failWithTc err
 
@@ -1951,15 +2028,18 @@ derivingThingFailWith newtype_deriving msg = do
   lift $ failWithTc err
 
 genDerivStuff :: DerivSpecMechanism -> SrcSpan -> Class
-              -> TyCon -> [Type] -> [TyVar]
+              -> [Type] -> [TyVar]
               -> TcM (LHsBinds GhcPs, BagDerivStuff, [Name])
-genDerivStuff mechanism loc clas tycon inst_tys tyvars
+genDerivStuff mechanism loc clas inst_tys tyvars
   = case mechanism of
       -- See Note [Bindings for Generalised Newtype Deriving]
-      DerivSpecNewtype rhs_ty -> gen_newtype_or_via rhs_ty
+      DerivSpecNewtype { dsm_newtype_rep_ty = rhs_ty}
+        -> gen_newtype_or_via rhs_ty
 
       -- Try a stock deriver
-      DerivSpecStock gen_fn -> gen_fn loc tycon inst_tys
+      DerivSpecStock { dsm_stock_dit    = DerivInstTys{dit_rep_tc = rep_tc}
+                     , dsm_stock_gen_fn = gen_fn }
+        -> gen_fn loc rep_tc inst_tys
 
       -- Try DeriveAnyClass
       DerivSpecAnyClass -> do
@@ -1981,7 +2061,8 @@ genDerivStuff mechanism loc clas tycon inst_tys tyvars
                , [] )
 
       -- Try DerivingVia
-      DerivSpecVia via_ty -> gen_newtype_or_via via_ty
+      DerivSpecVia{dsm_via_ty = via_ty}
+        -> gen_newtype_or_via via_ty
   where
     gen_newtype_or_via ty = do
       (binds, faminsts) <- gen_Newtype_binds loc clas tyvars inst_tys ty
@@ -2165,37 +2246,30 @@ derivingEtaErr cls cls_tys inst_ty
          nest 2 (text "instance (...) =>"
                 <+> pprClassPred cls (cls_tys ++ [inst_ty]))]
 
-derivingThingErr :: Bool -> Class -> [Type] -> Type
+derivingThingErr :: Bool -> Class -> [Type]
                  -> Maybe (DerivStrategy GhcTc) -> MsgDoc -> MsgDoc
-derivingThingErr newtype_deriving cls cls_tys inst_ty mb_strat why
-  = derivingThingErr' newtype_deriving cls cls_tys inst_ty mb_strat
+derivingThingErr newtype_deriving cls cls_args mb_strat why
+  = derivingThingErr' newtype_deriving cls cls_args mb_strat
                       (maybe empty derivStrategyName mb_strat) why
 
 derivingThingErrM :: Bool -> MsgDoc -> DerivM MsgDoc
 derivingThingErrM newtype_deriving why
-  = do DerivEnv { denv_tc      = tc
-                , denv_tc_args = tc_args
-                , denv_cls     = cls
-                , denv_cls_tys = cls_tys
-                , denv_strat   = mb_strat } <- ask
-       pure $ derivingThingErr newtype_deriving cls cls_tys
-                               (mkTyConApp tc tc_args) mb_strat why
+  = do DerivEnv { denv_cls      = cls
+                , denv_inst_tys = cls_args
+                , denv_strat    = mb_strat } <- ask
+       pure $ derivingThingErr newtype_deriving cls cls_args mb_strat why
 
 derivingThingErrMechanism :: DerivSpecMechanism -> MsgDoc -> DerivM MsgDoc
 derivingThingErrMechanism mechanism why
-  = do DerivEnv { denv_tc      = tc
-                , denv_tc_args = tc_args
-                , denv_cls     = cls
-                , denv_cls_tys = cls_tys
-                , denv_strat   = mb_strat } <- ask
-       pure $ derivingThingErr' (isDerivSpecNewtype mechanism) cls cls_tys
-                (mkTyConApp tc tc_args) mb_strat
-                (derivStrategyName $ derivSpecMechanismToStrategy mechanism)
-                why
-
-derivingThingErr' :: Bool -> Class -> [Type] -> Type
+  = do DerivEnv { denv_cls      = cls
+                , denv_inst_tys = cls_args
+                , denv_strat    = mb_strat } <- ask
+       pure $ derivingThingErr' (isDerivSpecNewtype mechanism) cls cls_args mb_strat
+                (derivStrategyName $ derivSpecMechanismToStrategy mechanism) why
+
+derivingThingErr' :: Bool -> Class -> [Type]
                   -> Maybe (DerivStrategy GhcTc) -> MsgDoc -> MsgDoc -> MsgDoc
-derivingThingErr' newtype_deriving cls cls_tys inst_ty mb_strat strat_msg why
+derivingThingErr' newtype_deriving cls cls_args mb_strat strat_msg why
   = sep [(hang (text "Can't make a derived instance of")
              2 (quotes (ppr pred) <+> via_mechanism)
           $$ nest 2 extra) <> colon,
@@ -2205,7 +2279,7 @@ derivingThingErr' newtype_deriving cls cls_tys inst_ty mb_strat strat_msg why
     extra | not strat_used, newtype_deriving
           = text "(even with cunning GeneralizedNewtypeDeriving)"
           | otherwise = empty
-    pred = mkClassPred cls (cls_tys ++ [inst_ty])
+    pred = mkClassPred cls cls_args
     via_mechanism | strat_used
                   = text "with the" <+> strat_msg <+> text "strategy"
                   | otherwise
diff --git a/compiler/typecheck/TcDerivInfer.hs b/compiler/typecheck/TcDerivInfer.hs
index 4bb1c76063..25bc156568 100644
--- a/compiler/typecheck/TcDerivInfer.hs
+++ b/compiler/typecheck/TcDerivInfer.hs
@@ -69,23 +69,26 @@ inferConstraints :: DerivSpecMechanism
 -- generated method definitions should succeed.   This set will be simplified
 -- before being used in the instance declaration
 inferConstraints mechanism
-  = do { DerivEnv { denv_tvs         = tvs
-                  , denv_tc          = tc
-                  , denv_tc_args     = tc_args
-                  , denv_cls         = main_cls
-                  , denv_cls_tys     = cls_tys } <- ask
+  = do { DerivEnv { denv_tvs      = tvs
+                  , denv_cls      = main_cls
+                  , denv_inst_tys = inst_tys } <- ask
        ; wildcard <- isStandaloneWildcardDeriv
        ; let infer_constraints :: DerivM ([ThetaOrigin], [TyVar], [TcType])
              infer_constraints =
                case mechanism of
-                 DerivSpecStock{}
-                   -> inferConstraintsStock
+                 DerivSpecStock{dsm_stock_dit = dit}
+                   -> inferConstraintsStock dit
                  DerivSpecAnyClass
-                   -> infer_constraints_simple $ inferConstraintsAnyclass
-                 DerivSpecNewtype rep_ty
-                   -> infer_constraints_simple $ inferConstraintsCoerceBased rep_ty
-                 DerivSpecVia     via_ty
-                   -> infer_constraints_simple $ inferConstraintsCoerceBased via_ty
+                   -> infer_constraints_simple inferConstraintsAnyclass
+                 DerivSpecNewtype { dsm_newtype_dit =
+                                      DerivInstTys{dit_cls_tys = cls_tys}
+                                  , dsm_newtype_rep_ty = rep_ty }
+                   -> infer_constraints_simple $
+                      inferConstraintsCoerceBased cls_tys rep_ty
+                 DerivSpecVia { dsm_via_cls_tys = cls_tys
+                              , dsm_via_ty = via_ty }
+                   -> infer_constraints_simple $
+                      inferConstraintsCoerceBased cls_tys via_ty
 
              -- Most deriving strategies do not need to do anything special to
              -- the type variables and arguments to the class in the derived
@@ -99,9 +102,6 @@ inferConstraints mechanism
                thetas <- infer_thetas
                pure (thetas, tvs, inst_tys)
 
-             inst_ty  = mkTyConApp tc tc_args
-             inst_tys = cls_tys ++ [inst_ty]
-
              -- Constraints arising from superclasses
              -- See Note [Superclasses of derived instance]
              cls_tvs  = classTyVars main_cls
@@ -144,20 +144,19 @@ inferConstraints mechanism
 -- to be well kinded, so we return @[]@/@[Type, f, g]@ for the
 -- 'TyVar's/'TcType's, /not/ @[k]@/@[k, f, g]@.
 -- See Note [Inferring the instance context].
-inferConstraintsStock :: DerivM ([ThetaOrigin], [TyVar], [TcType])
-inferConstraintsStock
-  = do DerivEnv { denv_tvs         = tvs
-                , denv_tc          = tc
-                , denv_tc_args     = tc_args
-                , denv_rep_tc      = rep_tc
-                , denv_rep_tc_args = rep_tc_args
-                , denv_cls         = main_cls
-                , denv_cls_tys     = cls_tys } <- ask
+inferConstraintsStock :: DerivInstTys
+                      -> DerivM ([ThetaOrigin], [TyVar], [TcType])
+inferConstraintsStock (DerivInstTys { dit_cls_tys     = cls_tys
+                                    , dit_tc          = tc
+                                    , dit_tc_args     = tc_args
+                                    , dit_rep_tc      = rep_tc
+                                    , dit_rep_tc_args = rep_tc_args })
+  = do DerivEnv { denv_tvs      = tvs
+                , denv_cls      = main_cls
+                , denv_inst_tys = inst_tys } <- ask
        wildcard <- isStandaloneWildcardDeriv
 
-       let inst_ty  = mkTyConApp tc tc_args
-           inst_tys = cls_tys ++ [inst_ty]
-
+       let inst_ty    = mkTyConApp tc tc_args
            tc_binders = tyConBinders rep_tc
            choose_level bndr
              | isNamedTyConBinder bndr = KindLevel
@@ -336,16 +335,11 @@ inferConstraintsStock
 -- derived instance context.
 inferConstraintsAnyclass :: DerivM [ThetaOrigin]
 inferConstraintsAnyclass
-  = do { DerivEnv { denv_tc      = tc
-                  , denv_tc_args = tc_args
-                  , denv_cls     = cls
-                  , denv_cls_tys = cls_tys } <- ask
+  = do { DerivEnv { denv_cls      = cls
+                  , denv_inst_tys = inst_tys } <- ask
        ; wildcard <- isStandaloneWildcardDeriv
 
-       ; let inst_ty  = mkTyConApp tc tc_args
-             inst_tys = cls_tys ++ [inst_ty]
-
-             gen_dms = [ (sel_id, dm_ty)
+       ; let gen_dms = [ (sel_id, dm_ty)
                        | (sel_id, Just (_, GenericDM dm_ty)) <- classOpItems cls ]
 
              cls_tvs = classTyVars cls
@@ -381,13 +375,12 @@ inferConstraintsAnyclass
 -- We would infer the following constraints ('ThetaOrigin's):
 --
 -- > (Num Int, Coercible Age Int)
-inferConstraintsCoerceBased :: Type -> DerivM [ThetaOrigin]
-inferConstraintsCoerceBased rep_ty = do
-  DerivEnv { denv_tvs     = tvs
-           , denv_tc      = tycon
-           , denv_tc_args = tc_args
-           , denv_cls     = cls
-           , denv_cls_tys = cls_tys } <- ask
+inferConstraintsCoerceBased :: [Type] -> Type
+                            -> DerivM [ThetaOrigin]
+inferConstraintsCoerceBased cls_tys rep_ty = do
+  DerivEnv { denv_tvs      = tvs
+           , denv_cls      = cls
+           , denv_inst_tys = inst_tys } <- ask
   sa_wildcard <- isStandaloneWildcardDeriv
   let -- The following functions are polymorphic over the representation
       -- type, since we might either give it the underlying type of a
@@ -399,8 +392,6 @@ inferConstraintsCoerceBased rep_ty = do
               -- rep_pred is the representation dictionary, from where
               -- we are going to get all the methods for the final
               -- dictionary
-      inst_ty    = mkTyConApp tycon tc_args
-      inst_tys   = cls_tys ++ [inst_ty]
       deriv_origin = mkDerivOrigin sa_wildcard
 
       -- Next we collect constraints for the class methods
diff --git a/compiler/typecheck/TcDerivUtils.hs b/compiler/typecheck/TcDerivUtils.hs
index ae191f937b..bb0af439e6 100644
--- a/compiler/typecheck/TcDerivUtils.hs
+++ b/compiler/typecheck/TcDerivUtils.hs
@@ -10,7 +10,7 @@ Error-checking and other utilities for @deriving@ clauses or declarations.
 
 module TcDerivUtils (
         DerivM, DerivEnv(..),
-        DerivSpec(..), pprDerivSpec,
+        DerivSpec(..), pprDerivSpec, DerivInstTys(..),
         DerivSpecMechanism(..), derivSpecMechanismToStrategy, isDerivSpecStock,
         isDerivSpecNewtype, isDerivSpecAnyClass, isDerivSpecVia,
         DerivContext(..), OriginativeDerivStatus(..),
@@ -89,6 +89,7 @@ mkDerivOrigin standalone_wildcard
 
 -- | Contains all of the information known about a derived instance when
 -- determining what its @EarlyDerivSpec@ should be.
+-- See @Note [DerivEnv and DerivSpecMechanism]@.
 data DerivEnv = DerivEnv
   { denv_overlap_mode :: Maybe OverlapMode
     -- ^ Is this an overlapping instance?
@@ -96,19 +97,8 @@ data DerivEnv = DerivEnv
     -- ^ Universally quantified type variables in the instance
   , denv_cls          :: Class
     -- ^ Class for which we need to derive an instance
-  , denv_cls_tys      :: [Type]
-    -- ^ Other arguments to the class except the last
-  , denv_tc           :: TyCon
-    -- ^ Type constructor for which the instance is requested
-    --   (last arguments to the type class)
-  , denv_tc_args      :: [Type]
-    -- ^ Arguments to the type constructor
-  , denv_rep_tc       :: TyCon
-    -- ^ The representation tycon for 'denv_tc'
-    --   (for data family instances)
-  , denv_rep_tc_args  :: [Type]
-    -- ^ The representation types for 'denv_tc_args'
-    --   (for data family instances)
+  , denv_inst_tys     :: [Type]
+    -- ^ All arguments to to 'denv_cls' in the derived instance.
   , denv_ctxt         :: DerivContext
     -- ^ @'SupplyContext' theta@ for standalone deriving (where @theta@ is the
     --   context of the instance).
@@ -124,22 +114,14 @@ instance Outputable DerivEnv where
   ppr (DerivEnv { denv_overlap_mode = overlap_mode
                 , denv_tvs          = tvs
                 , denv_cls          = cls
-                , denv_cls_tys      = cls_tys
-                , denv_tc           = tc
-                , denv_tc_args      = tc_args
-                , denv_rep_tc       = rep_tc
-                , denv_rep_tc_args  = rep_tc_args
+                , denv_inst_tys     = inst_tys
                 , denv_ctxt         = ctxt
                 , denv_strat        = mb_strat })
     = hang (text "DerivEnv")
          2 (vcat [ text "denv_overlap_mode" <+> ppr overlap_mode
                  , text "denv_tvs"          <+> ppr tvs
                  , text "denv_cls"          <+> ppr cls
-                 , text "denv_cls_tys"      <+> ppr cls_tys
-                 , text "denv_tc"           <+> ppr tc
-                 , text "denv_tc_args"      <+> ppr tc_args
-                 , text "denv_rep_tc"       <+> ppr rep_tc
-                 , text "denv_rep_tc_args"  <+> ppr rep_tc_args
+                 , text "denv_inst_tys"     <+> ppr inst_tys
                  , text "denv_ctxt"         <+> ppr ctxt
                  , text "denv_strat"        <+> ppr mb_strat ])
 
@@ -149,7 +131,6 @@ data DerivSpec theta = DS { ds_loc                 :: SrcSpan
                           , ds_theta               :: theta
                           , ds_cls                 :: Class
                           , ds_tys                 :: [Type]
-                          , ds_tc                  :: TyCon
                           , ds_overlap             :: Maybe OverlapMode
                           , ds_standalone_wildcard :: Maybe SrcSpan
                               -- See Note [Inferring the instance context]
@@ -159,10 +140,6 @@ data DerivSpec theta = DS { ds_loc                 :: SrcSpan
         --       df :: forall tvs. theta => C tys
         -- The Name is the name for the DFun we'll build
         -- The tyvars bind all the variables in the theta
-        -- For type families, the tycon in
-        --       in ds_tys is the *family* tycon
-        --       in ds_tc is the *representation* type
-        -- For non-family tycons, both are the same
 
         -- the theta is either the given and final theta, in standalone deriving,
         -- or the not-yet-simplified list of constraints together with their origin
@@ -179,7 +156,7 @@ Example:
      axiom :RTList a = Tree a
 
      DS { ds_tvs = [a,s], ds_cls = C, ds_tys = [s, T [a]]
-        , ds_tc = :RTList, ds_mechanism = DerivSpecNewtype (Tree a) }
+        , ds_mechanism = DerivSpecNewtype (Tree a) }
 -}
 
 pprDerivSpec :: Outputable theta => DerivSpec theta -> SDoc
@@ -199,41 +176,95 @@ pprDerivSpec (DS { ds_loc = l, ds_name = n, ds_tvs = tvs, ds_cls = c,
 instance Outputable theta => Outputable (DerivSpec theta) where
   ppr = pprDerivSpec
 
--- What action to take in order to derive a class instance.
--- See Note [Deriving strategies] in TcDeriv
+-- | Information about the arguments to the class in a stock- or
+-- newtype-derived instance.
+-- See @Note [DerivEnv and DerivSpecMechanism]@.
+data DerivInstTys = DerivInstTys
+  { dit_cls_tys     :: [Type]
+    -- ^ Other arguments to the class except the last
+  , dit_tc          :: TyCon
+    -- ^ Type constructor for which the instance is requested
+    --   (last arguments to the type class)
+  , dit_tc_args     :: [Type]
+    -- ^ Arguments to the type constructor
+  , dit_rep_tc      :: TyCon
+    -- ^ The representation tycon for 'dit_tc'
+    --   (for data family instances). Otherwise the same as 'dit_tc'.
+  , dit_rep_tc_args :: [Type]
+    -- ^ The representation types for 'dit_tc_args'
+    --   (for data family instances). Otherwise the same as 'dit_tc_args'.
+  }
+
+instance Outputable DerivInstTys where
+  ppr (DerivInstTys { dit_cls_tys = cls_tys, dit_tc = tc, dit_tc_args = tc_args
+                    , dit_rep_tc = rep_tc, dit_rep_tc_args = rep_tc_args })
+    = hang (text "DITTyConHead")
+         2 (vcat [ text "dit_cls_tys"     <+> ppr cls_tys
+                 , text "dit_tc"          <+> ppr tc
+                 , text "dit_tc_args"     <+> ppr tc_args
+                 , text "dit_rep_tc"      <+> ppr rep_tc
+                 , text "dit_rep_tc_args" <+> ppr rep_tc_args ])
+
+-- | What action to take in order to derive a class instance.
+-- See @Note [DerivEnv and DerivSpecMechanism]@, as well as
+-- @Note [Deriving strategies]@ in "TcDeriv".
 data DerivSpecMechanism
-  = DerivSpecStock   -- "Standard" classes
-      (SrcSpan -> TyCon
-               -> [Type]
-               -> TcM (LHsBinds GhcPs, BagDerivStuff, [Name]))
-      -- This function returns three things:
+    -- | \"Standard\" classes
+  = DerivSpecStock
+    { dsm_stock_dit    :: DerivInstTys
+      -- ^ 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 -> TyCon
+                -> [Type]
+                -> TcM (LHsBinds GhcPs, BagDerivStuff, [Name])
+      -- ^ This function returns three things:
       --
       -- 1. @LHsBinds GhcPs@: The derived instance's function bindings
       --    (e.g., @compare (T x) (T y) = compare x y@)
+      --
       -- 2. @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 TcGenDeriv.
+      --    See @Note [Auxiliary binders]@ in "TcGenDeriv".
+      --
       -- 3. @[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].
-
-  | DerivSpecNewtype -- -XGeneralizedNewtypeDeriving
-      Type -- The newtype rep type
-
-  | DerivSpecAnyClass -- -XDeriveAnyClass
-
-  | DerivSpecVia -- -XDerivingVia
-      Type -- The @via@ type
+      --    See @Note [Deriving and unused record selectors]@.
+    }
+
+    -- | @GeneralizedNewtypeDeriving@
+  | DerivSpecNewtype
+    { dsm_newtype_dit    :: DerivInstTys
+      -- ^ 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_newtype_rep_ty :: Type
+      -- ^ The newtype rep type.
+    }
+
+    -- | @DeriveAnyClass@
+  | DerivSpecAnyClass
+
+    -- | @DerivingVia@
+  | DerivSpecVia
+    { dsm_via_cls_tys :: [Type]
+      -- ^ All arguments to the class besides the last one.
+    , dsm_via_inst_ty :: Type
+      -- ^ The last argument to the class.
+    , dsm_via_ty      :: Type
+      -- ^ The @via@ type
+    }
 
 -- | Convert a 'DerivSpecMechanism' to its corresponding 'DerivStrategy'.
 derivSpecMechanismToStrategy :: DerivSpecMechanism -> DerivStrategy GhcTc
-derivSpecMechanismToStrategy DerivSpecStock{}   = StockStrategy
-derivSpecMechanismToStrategy DerivSpecNewtype{} = NewtypeStrategy
-derivSpecMechanismToStrategy DerivSpecAnyClass  = AnyclassStrategy
-derivSpecMechanismToStrategy (DerivSpecVia t)   = ViaStrategy t
+derivSpecMechanismToStrategy DerivSpecStock{}               = StockStrategy
+derivSpecMechanismToStrategy DerivSpecNewtype{}             = NewtypeStrategy
+derivSpecMechanismToStrategy DerivSpecAnyClass              = AnyclassStrategy
+derivSpecMechanismToStrategy (DerivSpecVia{dsm_via_ty = t}) = ViaStrategy t
 
 isDerivSpecStock, isDerivSpecNewtype, isDerivSpecAnyClass, isDerivSpecVia
   :: DerivSpecMechanism -> Bool
@@ -250,10 +281,116 @@ isDerivSpecVia (DerivSpecVia{}) = True
 isDerivSpecVia _                = False
 
 instance Outputable DerivSpecMechanism where
-  ppr (DerivSpecStock{})   = text "DerivSpecStock"
-  ppr (DerivSpecNewtype t) = text "DerivSpecNewtype" <> colon <+> ppr t
-  ppr DerivSpecAnyClass    = text "DerivSpecAnyClass"
-  ppr (DerivSpecVia t)     = text "DerivSpecVia" <> colon <+> ppr t
+  ppr (DerivSpecStock{dsm_stock_dit = dit})
+    = hang (text "DerivSpecStock")
+         2 (vcat [ text "dsm_stock_dit" <+> ppr dit ])
+  ppr (DerivSpecNewtype { dsm_newtype_dit = dit, dsm_newtype_rep_ty = rep_ty })
+    = hang (text "DerivSpecNewtype")
+         2 (vcat [ text "dsm_newtype_dit"    <+> ppr dit
+                 , text "dsm_newtype_rep_ty" <+> ppr rep_ty ])
+  ppr DerivSpecAnyClass = text "DerivSpecAnyClass"
+  ppr (DerivSpecVia { dsm_via_cls_tys = cls_tys, dsm_via_inst_ty = inst_ty
+                    , dsm_via_ty = via_ty })
+    = hang (text "DerivSpecVia")
+         2 (vcat [ text "dsm_via_cls_tys" <+> ppr cls_tys
+                 , text "dsm_via_inst_ty" <+> ppr inst_ty
+                 , text "dsm_via_ty"      <+> ppr via_ty ])
+
+{-
+Note [DerivEnv and DerivSpecMechanism]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+DerivEnv contains all of the bits and pieces that are common to every
+deriving strategy. (See Note [Deriving strategies] in TcDeriv.) Some deriving
+strategies impose stricter requirements on the types involved in the derived
+instance than others, and these differences are factored out into the
+DerivSpecMechanism type. Suppose that the derived instance looks like this:
+
+  instance ... => C arg_1 ... arg_n
+
+Each deriving strategy imposes restrictions on arg_1 through arg_n as follows:
+
+* stock (DerivSpecStock):
+
+  Stock deriving requires that:
+
+  - n must be a positive number. This is checked by
+    TcDeriv.expectNonNullaryClsArgs
+  - arg_n must be an application of an algebraic type constructor. Here,
+    "algebraic type constructor" means:
+
+    + An ordinary data type constructor, or
+    + A data family type constructor such that the arguments it is applied to
+      give rise to a data family instance.
+
+    This is checked by TcDeriv.expectAlgTyConApp.
+
+  This extra structure is witnessed by the DerivInstTys data type, which stores
+  arg_1 through arg_(n-1) (dit_cls_tys), the algebraic type constructor
+  (dit_tc), and its arguments (dit_tc_args). If dit_tc is an ordinary data type
+  constructor, then dit_rep_tc/dit_rep_tc_args are the same as
+  dit_tc/dit_tc_args. If dit_tc is a data family type constructor, then
+  dit_rep_tc is the representation type constructor for the data family
+  instance, and dit_rep_tc_args are the arguments to the representation type
+  constructor in the corresponding instance.
+
+* newtype (DerivSpecNewtype):
+
+  Newtype deriving imposes the same DerivInstTys requirements as stock
+  deriving. This is necessary because we need to know what the underlying type
+  that the newtype wraps is, and this information can only be learned by
+  knowing dit_rep_tc.
+
+* anyclass (DerivSpecAnyclass):
+
+  DeriveAnyClass is the most permissive deriving strategy of all, as it
+  essentially imposes no requirements on the derived instance. This is because
+  DeriveAnyClass simply derives an empty instance, so it does not need any
+  particular knowledge about the types involved. It can do several things
+  that stock/newtype deriving cannot do (#13154):
+
+  - n can be 0. That is, one is allowed to anyclass-derive an instance with
+    no arguments to the class, such as in this example:
+
+      class C
+      deriving anyclass instance C
+
+  - One can derive an instance for a type that is not headed by a type
+    constructor, such as in the following example:
+
+      class C (n :: Nat)
+      deriving instance C 0
+      deriving instance C 1
+      ...
+
+  - One can derive an instance for a data family with no data family instances,
+    such as in the following example:
+
+      data family Foo a
+      class C a
+      deriving anyclass instance C (Foo a)
+
+* via (DerivSpecVia):
+
+  Like newtype deriving, DerivingVia requires that n must be a positive number.
+  This is because when one derives something like this:
+
+    deriving via Foo instance C Bar
+
+  Then the generated code must specifically mention Bar. However, in
+  contrast with newtype deriving, DerivingVia does *not* require Bar to be
+  an application of an algebraic type constructor. This is because the
+  generated code simply defers to invoking `coerce`, which does not need to
+  know anything in particular about Bar (besides that it is representationally
+  equal to Foo). This allows DerivingVia to do some things that are not
+  possible with newtype deriving, such as deriving instances for data families
+  without data instances (#13154):
+
+    data family Foo a
+    newtype ByBar a = ByBar a
+    class Baz a where ...
+    instance Baz (ByBar a) where ...
+    deriving via ByBar (Foo a) instance Baz (Foo a)
+-}
 
 -- | Whether GHC is processing a @deriving@ clause or a standalone deriving
 -- declaration.
@@ -919,12 +1056,9 @@ 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 (when using a
-deriving clause; 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.
+See Note [Gathering and simplifying constraints for DeriveAnyClass] in
+TcDerivInfer for an explanation hof how the instance context is inferred for
+DeriveAnyClass.
 
 Note [Check that the type variable is truly universal]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
diff --git a/testsuite/tests/deriving/should_compile/T13154b.hs b/testsuite/tests/deriving/should_compile/T13154b.hs
new file mode 100644
index 0000000000..9df828b111
--- /dev/null
+++ b/testsuite/tests/deriving/should_compile/T13154b.hs
@@ -0,0 +1,62 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE DeriveAnyClass #-}
+{-# LANGUAGE DerivingStrategies #-}
+{-# LANGUAGE DerivingVia #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE PartialTypeSignatures #-}
+{-# LANGUAGE PolyKinds #-}
+{-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE UnboxedSums #-}
+{-# LANGUAGE UnboxedTuples #-}
+{-# OPTIONS_GHC -Wno-partial-type-signatures #-}
+module T13154b where
+
+import Data.Kind
+import Data.Typeable
+import GHC.Exts
+import GHC.TypeLits
+
+class Foo1 (a :: TYPE ('TupleRep '[]))
+deriving instance Foo1 a
+
+class Foo2 (a :: TYPE ('TupleRep '[]))
+deriving instance Foo2 (##)
+
+class Foo3 (a :: TYPE ('SumRep '[ 'LiftedRep, 'LiftedRep ]))
+deriving instance Foo3 a
+
+class Foo4 (a :: TYPE ('SumRep '[ 'LiftedRep, 'LiftedRep ]))
+deriving instance Foo4 (# a | b #)
+
+class Foo5 (a :: Type)
+deriving instance Foo5 a
+
+class Foo6
+deriving instance Foo6
+
+class Foo7 (a :: Nat)
+deriving anyclass instance Foo7 0
+deriving          instance Foo7 1
+
+class Foo8 (a :: Symbol)
+deriving anyclass instance Foo8 "a"
+deriving          instance Foo8 "b"
+
+class Typeable a => Foo9 a
+deriving instance _ => Foo9 (f a)
+
+data family D1 a
+newtype ByBar a = ByBar a
+class Foo10 a where
+  baz :: a -> a
+instance Foo10 (ByBar a) where
+  baz = id
+deriving via ByBar (D1 a) instance Foo10 (D1 a)
+
+data family D2
+data family D3
+class Foo11 a where
+deriving anyclass instance Foo11 D2
+deriving          instance Foo11 D3
diff --git a/testsuite/tests/deriving/should_compile/all.T b/testsuite/tests/deriving/should_compile/all.T
index 55c7d90f09..e29ae0e0b5 100644
--- a/testsuite/tests/deriving/should_compile/all.T
+++ b/testsuite/tests/deriving/should_compile/all.T
@@ -89,6 +89,7 @@ test('T12616', normal, compile, [''])
 test('T12688', normal, compile, [''])
 test('T12814', normal, compile, ['-Wredundant-constraints'])
 test('T13154a', normal, compile, [''])
+test('T13154b', normal, compile, [''])
 test('T13272', normal, compile, [''])
 test('T13272a', normal, compile, [''])
 test('T13297', normal, compile, [''])
diff --git a/testsuite/tests/deriving/should_fail/T13154c.hs b/testsuite/tests/deriving/should_fail/T13154c.hs
new file mode 100644
index 0000000000..342bb9fc48
--- /dev/null
+++ b/testsuite/tests/deriving/should_fail/T13154c.hs
@@ -0,0 +1,23 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE DerivingStrategies #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE PolyKinds #-}
+{-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE UnboxedTuples #-}
+module T13154c where
+
+import GHC.Exts
+
+-- Test some nonsense configurations
+
+class Foo1 (a :: TYPE ('TupleRep '[]))
+deriving stock   instance Foo1 a
+deriving stock   instance Foo1 (##)
+deriving newtype instance Foo1 a
+deriving newtype instance Foo1 (##)
+
+class Foo2
+deriving stock   instance Foo2
+deriving newtype instance Foo2
diff --git a/testsuite/tests/deriving/should_fail/T13154c.stderr b/testsuite/tests/deriving/should_fail/T13154c.stderr
new file mode 100644
index 0000000000..70031a79b2
--- /dev/null
+++ b/testsuite/tests/deriving/should_fail/T13154c.stderr
@@ -0,0 +1,35 @@
+
+T13154c.hs:16:1: error:
+    • Can't make a derived instance of
+        ‘Foo1 a’ with the stock strategy:
+        The last argument of the instance must be a data or newtype application
+    • In the stand-alone deriving instance for ‘Foo1 a’
+
+T13154c.hs:17:1: error:
+    • Can't make a derived instance of
+        ‘Foo1 (# #)’ with the stock strategy:
+        ‘Foo1’ is not a stock derivable class (Eq, Show, etc.)
+    • In the stand-alone deriving instance for ‘Foo1 (# #)’
+
+T13154c.hs:18:1: error:
+    • Can't make a derived instance of
+        ‘Foo1 a’ with the newtype strategy:
+        The last argument of the instance must be a data or newtype application
+    • In the stand-alone deriving instance for ‘Foo1 a’
+
+T13154c.hs:19:1: error:
+    • Can't make a derived instance of
+        ‘Foo1 (# #)’ with the newtype strategy:
+        GeneralizedNewtypeDeriving cannot be used on non-newtypes
+    • In the stand-alone deriving instance for ‘Foo1 (# #)’
+
+T13154c.hs:22:1: error:
+    • Can't make a derived instance of ‘Foo2’ with the stock strategy:
+        Cannot derive instances for nullary classes
+    • In the stand-alone deriving instance for ‘Foo2’
+
+T13154c.hs:23:1: error:
+    • Can't make a derived instance of
+        ‘Foo2’ with the newtype strategy:
+        Cannot derive instances for nullary classes
+    • In the stand-alone deriving instance for ‘Foo2’
diff --git a/testsuite/tests/deriving/should_fail/T7959.stderr b/testsuite/tests/deriving/should_fail/T7959.stderr
index 254cfedacb..0ba77ffb8b 100644
--- a/testsuite/tests/deriving/should_fail/T7959.stderr
+++ b/testsuite/tests/deriving/should_fail/T7959.stderr
@@ -1,6 +1,6 @@
 
 T7959.hs:5:1: error:
-    • Cannot derive instances for nullary classes
+    • Can't make a derived instance of ‘A’: Try enabling DeriveAnyClass
     • In the stand-alone deriving instance for ‘A’
 
 T7959.hs:6:17: error:
diff --git a/testsuite/tests/deriving/should_fail/all.T b/testsuite/tests/deriving/should_fail/all.T
index bd2c55983a..d195a08691 100644
--- a/testsuite/tests/deriving/should_fail/all.T
+++ b/testsuite/tests/deriving/should_fail/all.T
@@ -66,6 +66,7 @@ test('T11509_1', [when(doing_ghci(), extra_hc_opts('-fobject-code'))],
 test('T12163', normal, compile_fail, [''])
 test('T12512', omit_ways(['ghci']), compile_fail, [''])
 test('T12801', normal, compile_fail, [''])
+test('T13154c', normal, compile_fail, [''])
 test('T14365', [extra_files(['T14365B.hs','T14365B.hs-boot'])],
                multimod_compile_fail, ['T14365A',''])
 test('T14728a', normal, compile_fail, [''])