Refactor some cruft in TcDerivInfer.inferConstraints

The latest installment in my quest to clean up the code in
`TcDeriv*`. This time, my sights are set on
`TcDerivInfer.inferConstraints`, which infers the context for derived
instances. This function is a wee bit awkward at the moment:

* It's not terribly obvious from a quick glance, but
  `inferConstraints` is only ever invoked when using the `stock` or
  `anyclass` deriving strategies, as the code for inferring the
  context for `newtype`- or `via`-derived instances is located
  separately in `mk_coerce_based_eqn`. But there's no good reason
  for things to be this way, so I moved this code from
  `mk_coerce_based_eqn` to `inferConstraints` so that everything
  related to inferring instance contexts is located in one place.
* In this process, I discovered that the Haddocks for the auxiliary
  function `inferConstraintsDataConArgs` are completely wrong. It
  claims that it handles both `stock` and `newtype` deriving, but
  this is completely wrong, as discussed above—it only handles
  `stock`. To rectify this, I renamed this function to
  `inferConstraintsStock` to reflect its actual purpose and created
  a new `inferConstraintsCoerceBased` function to specifically
  handle `newtype` (and `via`) deriving.

Doing this revealed some opportunities for further simplification:

* Removing the context-inference–related code from
  `mk_coerce_based_eqn` made me realize that the overall structure
  of the function is basically identical to `mk_originative_eqn`.
  In fact, I was easily able to combine the two functions into a
  single `mk_eqn_from_mechanism` function.

  As part of this merger, I now invoke
  `atf_coerce_based_error_checks` from `doDerivInstErrorChecks1`.
* I discovered that GHC defined this function:

  ```hs
  typeToTypeKind = liftedTypeKind `mkVisFunTy` liftedTypeKind
  ```

  No fewer than four times in different modules. I consolidated all
  of these definitions in a single location in `TysWiredIn`.

1 files changed, 127 insertions, 24 deletions

diff --git a/compiler/typecheck/TcDerivInfer.hs b/compiler/typecheck/TcDerivInfer.hs
index d834b09bbe..4bb1c76063 100644
--- a/compiler/typecheck/TcDerivInfer.hs
+++ b/compiler/typecheck/TcDerivInfer.hs
@@ -22,9 +22,11 @@ import DataCon
 import ErrUtils
 import Inst
 import Outputable
+import Pair
 import PrelNames
 import TcDerivUtils
 import TcEnv
+import TcGenDeriv
 import TcGenFunctor
 import TcGenGenerics
 import TcMType
@@ -35,6 +37,7 @@ import Type
 import TcSimplify
 import TcValidity (validDerivPred)
 import TcUnify (buildImplicationFor, checkConstraints)
+import TysWiredIn (typeToTypeKind)
 import Unify (tcUnifyTy)
 import Util
 import Var
@@ -66,15 +69,35 @@ inferConstraints :: DerivSpecMechanism
 -- generated method definitions should succeed.   This set will be simplified
 -- before being used in the instance declaration
 inferConstraints mechanism
-  = do { DerivEnv { denv_tc          = tc
+  = do { DerivEnv { denv_tvs         = tvs
+                  , denv_tc          = tc
                   , denv_tc_args     = tc_args
                   , denv_cls         = main_cls
                   , denv_cls_tys     = cls_tys } <- ask
        ; wildcard <- isStandaloneWildcardDeriv
-       ; let is_anyclass = isDerivSpecAnyClass mechanism
-             infer_constraints
-               | is_anyclass = inferConstraintsDAC inst_tys
-               | otherwise   = inferConstraintsDataConArgs inst_ty inst_tys
+       ; let infer_constraints :: DerivM ([ThetaOrigin], [TyVar], [TcType])
+             infer_constraints =
+               case mechanism of
+                 DerivSpecStock{}
+                   -> inferConstraintsStock
+                 DerivSpecAnyClass
+                   -> infer_constraints_simple $ inferConstraintsAnyclass
+                 DerivSpecNewtype rep_ty
+                   -> infer_constraints_simple $ inferConstraintsCoerceBased rep_ty
+                 DerivSpecVia     via_ty
+                   -> infer_constraints_simple $ inferConstraintsCoerceBased via_ty
+
+             -- Most deriving strategies do not need to do anything special to
+             -- the type variables and arguments to the class in the derived
+             -- instance, so they can pass through unchanged. The exception to
+             -- this rule is stock deriving. See
+             -- Note [Inferring the instance context].
+             infer_constraints_simple
+               :: DerivM [ThetaOrigin]
+               -> DerivM ([ThetaOrigin], [TyVar], [TcType])
+             infer_constraints_simple infer_thetas = do
+               thetas <- infer_thetas
+               pure (thetas, tvs, inst_tys)
 
              inst_ty  = mkTyConApp tc tc_args
              inst_tys = cls_tys ++ [inst_ty]
@@ -98,20 +121,44 @@ inferConstraints mechanism
        ; return ( sc_constraints ++ inferred_constraints
                 , tvs', inst_tys' ) }
 
--- | Like 'inferConstraints', but used only in the case of deriving strategies
--- where the constraints are inferred by inspecting the fields of each data
--- constructor (i.e., stock- and newtype-deriving).
-inferConstraintsDataConArgs :: TcType -> [TcType]
-                            -> DerivM ([ThetaOrigin], [TyVar], [TcType])
-inferConstraintsDataConArgs inst_ty inst_tys
+-- | Like 'inferConstraints', but used only in the case of the @stock@ deriving
+-- strategy. The constraints are inferred by inspecting the fields of each data
+-- constructor. In this example:
+--
+-- > data Foo = MkFoo Int Char deriving Show
+--
+-- We would infer the following constraints ('ThetaOrigin's):
+--
+-- > (Show Int, Show Char)
+--
+-- Note that this function also returns the type variables ('TyVar's) and
+-- class arguments ('TcType's) for the resulting instance. This is because
+-- when deriving 'Functor'-like classes, we must sometimes perform kind
+-- substitutions to ensure the resulting instance is well kinded, which may
+-- affect the type variables and class arguments. In this example:
+--
+-- > newtype Compose (f :: k -> Type) (g :: Type -> k) (a :: Type) =
+-- >   Compose (f (g a)) deriving stock Functor
+--
+-- We must unify @k@ with @Type@ in order for the resulting 'Functor' instance
+-- 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
        wildcard <- isStandaloneWildcardDeriv
 
-       let tc_binders = tyConBinders rep_tc
+       let inst_ty  = mkTyConApp tc tc_args
+           inst_tys = cls_tys ++ [inst_ty]
+
+           tc_binders = tyConBinders rep_tc
            choose_level bndr
              | isNamedTyConBinder bndr = KindLevel
              | otherwise               = TypeLevel
@@ -272,7 +319,7 @@ inferConstraintsDataConArgs inst_ty inst_tys
                        $$ ppr rep_tc_tvs $$ ppr all_rep_tc_args )
                 do { let (arg_constraints, tvs', inst_tys')
                            = con_arg_constraints get_std_constrained_tys
-                   ; lift $ traceTc "inferConstraintsDataConArgs" $ vcat
+                   ; lift $ traceTc "inferConstraintsStock" $ vcat
                           [ ppr main_cls <+> ppr inst_tys'
                           , ppr arg_constraints
                           ]
@@ -280,9 +327,6 @@ inferConstraintsDataConArgs inst_ty inst_tys
                                                  ++ arg_constraints
                             , tvs', inst_tys') }
 
-typeToTypeKind :: Kind
-typeToTypeKind = liftedTypeKind `mkVisFunTy` liftedTypeKind
-
 -- | Like 'inferConstraints', but used only in the case of @DeriveAnyClass@,
 -- which gathers its constraints based on the type signatures of the class's
 -- methods instead of the types of the data constructor's field.
@@ -290,13 +334,18 @@ typeToTypeKind = liftedTypeKind `mkVisFunTy` liftedTypeKind
 -- See Note [Gathering and simplifying constraints for DeriveAnyClass]
 -- for an explanation of how these constraints are used to determine the
 -- derived instance context.
-inferConstraintsDAC :: [TcType] -> DerivM ([ThetaOrigin], [TyVar], [TcType])
-inferConstraintsDAC inst_tys
-  = do { DerivEnv { denv_tvs = tvs
-                  , denv_cls = cls } <- ask
+inferConstraintsAnyclass :: DerivM [ThetaOrigin]
+inferConstraintsAnyclass
+  = do { DerivEnv { denv_tc      = tc
+                  , denv_tc_args = tc_args
+                  , denv_cls     = cls
+                  , denv_cls_tys = cls_tys } <- ask
        ; wildcard <- isStandaloneWildcardDeriv
 
-       ; let gen_dms = [ (sel_id, dm_ty)
+       ; let inst_ty  = mkTyConApp tc tc_args
+             inst_tys = cls_tys ++ [inst_ty]
+
+             gen_dms = [ (sel_id, dm_ty)
                        | (sel_id, Just (_, GenericDM dm_ty)) <- classOpItems cls ]
 
              cls_tvs = classTyVars cls
@@ -320,7 +369,61 @@ inferConstraintsDAC inst_tys
                                 meth_tvs dm_tvs meth_theta (tau_eq:dm_theta)) }
 
        ; theta_origins <- lift $ mapM do_one_meth gen_dms
-       ; return (theta_origins, tvs, inst_tys) }
+       ; return theta_origins }
+
+-- Like 'inferConstraints', but used only for @GeneralizedNewtypeDeriving@ and
+-- @DerivingVia@. Since both strategies generate code involving 'coerce', the
+-- inferred constraints set up the scaffolding needed to typecheck those uses
+-- of 'coerce'. In this example:
+--
+-- > newtype Age = MkAge Int deriving newtype Num
+--
+-- 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
+  sa_wildcard <- isStandaloneWildcardDeriv
+  let -- The following functions are polymorphic over the representation
+      -- type, since we might either give it the underlying type of a
+      -- newtype (for GeneralizedNewtypeDeriving) or a @via@ type
+      -- (for DerivingVia).
+      rep_tys ty  = cls_tys ++ [ty]
+      rep_pred ty = mkClassPred cls (rep_tys ty)
+      rep_pred_o ty = mkPredOrigin deriv_origin TypeLevel (rep_pred ty)
+              -- 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
+      -- If there are no methods, we don't need any constraints
+      -- Otherwise we need (C rep_ty), for the representation methods,
+      -- and constraints to coerce each individual method
+      meth_preds :: Type -> [PredOrigin]
+      meth_preds ty
+        | null meths = [] -- No methods => no constraints
+                          -- (#12814)
+        | otherwise = rep_pred_o ty : coercible_constraints ty
+      meths = classMethods cls
+      coercible_constraints ty
+        = [ mkPredOrigin (DerivOriginCoerce meth t1 t2 sa_wildcard)
+                         TypeLevel (mkReprPrimEqPred t1 t2)
+          | meth <- meths
+          , let (Pair t1 t2) = mkCoerceClassMethEqn cls tvs
+                                       inst_tys ty meth ]
+
+      all_thetas :: Type -> [ThetaOrigin]
+      all_thetas ty = [mkThetaOriginFromPreds $ meth_preds ty]
+
+  pure (all_thetas rep_ty)
 
 {- Note [Inferring the instance context]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -346,7 +449,7 @@ for DerivContext:
     the instance context (theta) is user-supplied
 
 For the InferContext case, we must figure out the
-instance context (inferConstraintsDataConArgs). Suppose we are inferring
+instance context (inferConstraintsStock). Suppose we are inferring
 the instance context for
     C t1 .. tn (T s1 .. sm)
 There are two cases
@@ -456,7 +559,7 @@ Let's call the context reqd for the T instance of class C at types
         Eq (T a b) = (Ping a, Pong b, ...)
 
 Now we can get a (recursive) equation from the data decl.  This part
-is done by inferConstraintsDataConArgs.
+is done by inferConstraintsStock.
 
         Eq (T a b) = Eq (Foo a) u Eq (Bar b)    -- From C1
                    u Eq (T b a) u Eq Int        -- From C2