Refactor TcDeriv and TcGenDeriv

Summary:
Keeping a promise I made to Simon to clean up these modules.

This change splits up the massive `TcDeriv` and `TcGenDeriv` modules into
somewhat more manageable pieces. The new modules are:

* `TcGenFunctor`: This contains the deriving machinery for `Functor`,
  `Foldable`, and `Traversable` (which all use the same underlying algorithm).
* `TcDerivInfer`: This is the new home for `inferConstraints`,
  `simplifyInstanceContexts`, and related functions, whose role is to come up
  with the derived instance context and subsequently simplify it.
* `TcDerivUtils`: This is a grab-bag module that contains several
  error-checking utilities originally in `TcDeriv`, as well as some functions
  that `TcDeriv` and `TcDerivInfer` both need.

The end result is that `TcDeriv` is now less than 1,600 SLOC (originally 2,686
SLOC), and `TcGenDeriv` is now about 2,000 SLOC (originally 2,964).

In addition, this also implements a couple of tiny refactorings:

* I transformed `type Condition = (DynFlags, TyCon) -> Validity` into
  `type Condition = DynFlags -> TyCon -> Validity`
* I killed the `DerivSpecGeneric` constructor for `DerivSpecMechanism`, and
  merged its functionality into `DerivSpecStock`. In addition,
  `hasStockDeriving` now contains key-value pairs for `Generic` and `Generic1`,
  so they're no longer treated as an awkward special case in `TcDeriv`.

Test Plan: ./validate

Reviewers: simonpj, austin, bgamari

Reviewed By: simonpj

Subscribers: thomie, mpickering

Differential Revision: https://phabricator.haskell.org/D2568

7 files changed, 2184 insertions, 2049 deletions

diff --git a/compiler/ghc.cabal.in b/compiler/ghc.cabal.in
index 3d75dae0c1..ab72b455cf 100644
--- a/compiler/ghc.cabal.in
+++ b/compiler/ghc.cabal.in
@@ -405,10 +405,13 @@ Library
         TcClassDcl
         TcDefaults
         TcDeriv
+        TcDerivInfer
+        TcDerivUtils
         TcEnv
         TcExpr
         TcForeign
         TcGenDeriv
+        TcGenFunctor
         TcGenGenerics
         TcHsSyn
         TcHsType
diff --git a/compiler/typecheck/TcDeriv.hs b/compiler/typecheck/TcDeriv.hs
index c5c8387196..04202ed79e 100644
--- a/compiler/typecheck/TcDeriv.hs
+++ b/compiler/typecheck/TcDeriv.hs
@@ -7,7 +7,6 @@ Handles @deriving@ clauses on @data@ declarations.
 -}
 
 {-# LANGUAGE CPP #-}
-{-# LANGUAGE ImplicitParams #-}
 
 module TcDeriv ( tcDeriving, DerivInfo(..), mkDerivInfos ) where
 
@@ -18,19 +17,17 @@ import DynFlags
 
 import TcRnMonad
 import FamInst
-import TcErrors( reportAllUnsolved )
-import TcValidity( validDerivPred, allDistinctTyVars )
+import TcDerivInfer
+import TcDerivUtils
+import TcValidity( allDistinctTyVars )
 import TcClassDcl( tcATDefault, tcMkDeclCtxt )
 import TcEnv
 import TcGenDeriv                       -- Deriv stuff
-import TcGenGenerics
 import InstEnv
 import Inst
 import FamInstEnv
 import TcHsType
 import TcMType
-import TcSimplify
-import TcUnify( buildImplicationFor )
 
 import RnNames( extendGlobalRdrEnvRn )
 import RnBinds
@@ -54,7 +51,6 @@ import Var
 import VarEnv
 import VarSet
 import PrelNames
-import THNames ( liftClassKey )
 import SrcLoc
 import Util
 import Outputable
@@ -84,81 +80,6 @@ Overall plan
 3.  Add the derived bindings, generating InstInfos
 -}
 
--- DerivSpec is purely local to this module
-data DerivSpec theta = DS { ds_loc       :: SrcSpan
-                          , ds_name      :: Name         -- DFun name
-                          , ds_tvs       :: [TyVar]
-                          , ds_theta     :: theta
-                          , ds_cls       :: Class
-                          , ds_tys       :: [Type]
-                          , ds_tc        :: TyCon
-                          , ds_overlap   :: Maybe OverlapMode
-                          , ds_mechanism :: DerivSpecMechanism }
-        -- This spec implies a dfun declaration of the form
-        --       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
-
-        -- ds_mechanism specifies the means by which GHC derives the instance.
-        -- See Note [Deriving strategies]
-
-{-
-Example:
-
-     newtype instance T [a] = MkT (Tree a) deriving( C s )
-==>
-     axiom T [a] = :RTList a
-     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) }
--}
-
--- What action to take in order to derive a class instance.
--- See Note [Deriving strategies]
--- NB: DerivSpecMechanism is purely local to this module
-data DerivSpecMechanism
-  = DerivSpecStock   -- "Standard" classes (except for Generic(1), which is
-                     -- covered by the special case of DerivSpecGeneric)
-      (SrcSpan -> TyCon -> TcM (LHsBinds RdrName, BagDerivStuff))
-
-  | DerivSpecGeneric -- -XDeriveGeneric
-      (TyCon -> [Type] -> TcM (LHsBinds RdrName, FamInst))
-
-  | DerivSpecNewtype -- -XGeneralizedNewtypeDeriving
-      Type -- ^ The newtype rep type
-
-  | DerivSpecAnyClass -- -XDeriveAnyClass
-
-type DerivContext = Maybe ThetaType
-   -- Nothing    <=> Vanilla deriving; infer the context of the instance decl
-   -- Just theta <=> Standalone deriving: context supplied by programmer
-
--- | A 'PredType' annotated with the origin of the constraint 'CtOrigin',
--- and whether or the constraint deals in types or kinds.
-data PredOrigin = PredOrigin PredType CtOrigin TypeOrKind
-type ThetaOrigin = [PredOrigin]
-
-mkPredOrigin :: CtOrigin -> TypeOrKind -> PredType -> PredOrigin
-mkPredOrigin origin t_or_k pred = PredOrigin pred origin t_or_k
-
-mkThetaOrigin :: CtOrigin -> TypeOrKind -> ThetaType -> ThetaOrigin
-mkThetaOrigin origin t_or_k = map (mkPredOrigin origin t_or_k)
-
-substPredOrigin :: HasCallStack => TCvSubst -> PredOrigin -> PredOrigin
-substPredOrigin subst (PredOrigin pred origin t_or_k)
-  = PredOrigin (substTy subst pred) origin t_or_k
-
-substThetaOrigin :: HasCallStack => TCvSubst -> ThetaOrigin -> ThetaOrigin
-substThetaOrigin subst = map (substPredOrigin subst)
-
 data EarlyDerivSpec = InferTheta (DerivSpec ThetaOrigin)
                     | GivenTheta (DerivSpec ThetaType)
         -- InferTheta ds => the context for the instance should be inferred
@@ -170,7 +91,7 @@ data EarlyDerivSpec = InferTheta (DerivSpec ThetaOrigin)
         --
         -- GivenTheta ds => the exact context for the instance is supplied
         --                  by the programmer; it is ds_theta
-        -- See Note [Inferring the instance context]
+        -- See Note [Inferring the instance context] in TcDerivInfer
 
 earlyDSLoc :: EarlyDerivSpec -> SrcSpan
 earlyDSLoc (InferTheta spec) = ds_loc spec
@@ -183,83 +104,11 @@ splitEarlyDerivSpec (InferTheta spec : specs) =
 splitEarlyDerivSpec (GivenTheta spec : specs) =
     case splitEarlyDerivSpec specs of (is, gs) -> (is, spec : gs)
 
-pprDerivSpec :: Outputable theta => DerivSpec theta -> SDoc
-pprDerivSpec (DS { ds_loc = l, ds_name = n, ds_tvs = tvs,
-                   ds_cls = c, ds_tys = tys, ds_theta = rhs })
-  = hang (text "DerivSpec")
-       2 (vcat [ text "ds_loc   =" <+> ppr l
-               , text "ds_name  =" <+> ppr n
-               , text "ds_tvs   =" <+> ppr tvs
-               , text "ds_cls   =" <+> ppr c
-               , text "ds_tys   =" <+> ppr tys
-               , text "ds_theta =" <+> ppr rhs ])
-
-instance Outputable theta => Outputable (DerivSpec theta) where
-  ppr = pprDerivSpec
-
 instance Outputable EarlyDerivSpec where
   ppr (InferTheta spec) = ppr spec <+> text "(Infer)"
   ppr (GivenTheta spec) = ppr spec <+> text "(Given)"
 
-instance Outputable PredOrigin where
-  ppr (PredOrigin ty _ _) = ppr ty -- The origin is not so interesting when debugging
-
-{- Note [Inferring the instance context]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-There are two sorts of 'deriving':
-
-  * InferTheta: the deriving clause for a data type
-      data T a = T1 a deriving( Eq )
-    Here we must infer an instance context,
-    and generate instance declaration
-      instance Eq a => Eq (T a) where ...
-
-  * CheckTheta: standalone deriving
-      deriving instance Eq a => Eq (T a)
-    Here we only need to fill in the bindings;
-    the instance context is user-supplied
-
-For a deriving clause (InferTheta) we must figure out the
-instance context (inferConstraints). Suppose we are inferring
-the instance context for
-    C t1 .. tn (T s1 .. sm)
-There are two cases
-
-  * (T s1 .. sm) :: *         (the normal case)
-    Then we behave like Eq and guess (C t1 .. tn t)
-    for each data constructor arg of type t.  More
-    details below.
-
-  * (T s1 .. sm) :: * -> *    (the functor-like case)
-    Then we behave like Functor.
-
-In both cases we produce a bunch of un-simplified constraints
-and them simplify them in simplifyInstanceContexts; see
-Note [Simplifying the instance context].
-
-In the functor-like case, we may need to unify some kind variables with * in
-order for the generated instance to be well-kinded. An example from
-Trac #10524:
-
-  newtype Compose (f :: k2 -> *) (g :: k1 -> k2) (a :: k1)
-    = Compose (f (g a)) deriving Functor
-
-Earlier in the deriving pipeline, GHC unifies the kind of Compose f g
-(k1 -> *) with the kind of Functor's argument (* -> *), so k1 := *. But this
-alone isn't enough, since k2 wasn't unified with *:
-
-  instance (Functor (f :: k2 -> *), Functor (g :: * -> k2)) =>
-    Functor (Compose f g) where ...
-
-The two Functor constraints are ill-kinded. To ensure this doesn't happen, we:
-
-  1. Collect all of a datatype's subtypes which require functor-like
-     constraints.
-  2. For each subtype, create a substitution by unifying the subtype's kind
-     with (* -> *).
-  3. Compose all the substitutions into one, then apply that substitution to
-     all of the in-scope type variables and the instance types.
-
+{-
 Note [Data decl contexts]
 ~~~~~~~~~~~~~~~~~~~~~~~~~
 Consider
@@ -1088,12 +937,7 @@ mk_eqn_stock dflags mtheta cls cls_tys rep_tc go_for_it bale_out
 mk_eqn_stock' :: Class -> (DerivSpecMechanism -> TcRn EarlyDerivSpec)
                 -> TcRn EarlyDerivSpec
 mk_eqn_stock' cls go_for_it
-  | let ck = classKey cls
-  , ck `elem` [genClassKey, gen1ClassKey]
-  = let gk = if ck == genClassKey then Gen0 else Gen1
-    in go_for_it . DerivSpecGeneric . gen_Generic_binds $ gk
-
-  | otherwise = go_for_it $ case hasStockDeriving cls of
+  = go_for_it $ case hasStockDeriving cls of
         Just gen_fn -> DerivSpecStock gen_fn
         Nothing ->
           pprPanic "mk_eqn_stock': Not a stock class!" (ppr cls)
@@ -1119,620 +963,7 @@ mk_eqn_no_mechanism dflags mtheta cls cls_tys rep_tc go_for_it bale_out
         CanDerive               -> mk_eqn_stock' cls go_for_it
         DerivableViaInstance    -> go_for_it DerivSpecAnyClass
 
-
-----------------------
-
-inferConstraints :: [TyVar] -> Class -> [TcType] -> TcType
-                 -> TyCon -> [TcType]
-                 -> (ThetaOrigin -> [TyVar] -> [TcType] -> TcM a)
-                 -> TcM a
--- inferConstraints figures out the constraints needed for the
--- instance declaration generated by a 'deriving' clause on a
--- data type declaration. It also returns the new in-scope type
--- variables and instance types, in case they were changed due to
--- the presence of functor-like constraints.
--- See Note [Inferring the instance context]
-
--- e.g. inferConstraints
---        C Int (T [a])    -- Class and inst_tys
---        :RTList a        -- Rep tycon and its arg tys
--- where T [a] ~R :RTList a
---
--- Generate a sufficiently large set of constraints that typechecking the
--- generated method definitions should succeed.   This set will be simplified
--- before being used in the instance declaration
-inferConstraints tvs main_cls cls_tys inst_ty rep_tc rep_tc_args mkTheta
-  | is_generic                        -- Generic constraints are easy
-  = mkTheta [] tvs inst_tys
-
-  | is_generic1                       -- Generic1 needs Functor
-  = ASSERT( length rep_tc_tvs > 0 )   -- See Note [Getting base classes]
-    ASSERT( length cls_tys   == 1 )   -- Generic1 has a single kind variable
-    do { functorClass <- tcLookupClass functorClassName
-       ; con_arg_constraints (get_gen1_constraints functorClass) mkTheta }
-
-  | otherwise  -- The others are a bit more complicated
-  = ASSERT2( equalLength rep_tc_tvs all_rep_tc_args
-           , ppr main_cls <+> ppr rep_tc
-             $$ ppr rep_tc_tvs $$ ppr all_rep_tc_args )
-    con_arg_constraints get_std_constrained_tys
-      $ \arg_constraints tvs' inst_tys' ->
-      do { traceTc "inferConstraints" $ vcat
-                [ ppr main_cls <+> ppr inst_tys'
-                , ppr arg_constraints
-                ]
-         ; mkTheta (stupid_constraints ++ extra_constraints
-                     ++ sc_constraints ++ arg_constraints)
-                   tvs' inst_tys' }
-  where
-    tc_binders = tyConBinders rep_tc
-    choose_level bndr
-      | isNamedTyConBinder bndr = KindLevel
-      | otherwise               = TypeLevel
-    t_or_ks = map choose_level tc_binders ++ repeat TypeLevel
-       -- want to report *kind* errors when possible
-
-       -- Constraints arising from the arguments of each constructor
-    con_arg_constraints :: (CtOrigin -> TypeOrKind
-                                     -> Type
-                                     -> [(ThetaOrigin, Maybe TCvSubst)])
-                        -> (ThetaOrigin -> [TyVar] -> [TcType] -> TcM a)
-                        -> TcM a
-    con_arg_constraints get_arg_constraints mkTheta
-      = let (predss, mbSubsts) = unzip
-              [ preds_and_mbSubst
-              | data_con <- tyConDataCons rep_tc
-              , (arg_n, arg_t_or_k, arg_ty)
-                  <- zip3 [1..] t_or_ks $
-                     dataConInstOrigArgTys data_con all_rep_tc_args
-                -- No constraints for unlifted types
-                -- See Note [Deriving and unboxed types]
-              , not (isUnliftedType arg_ty)
-              , let orig = DerivOriginDC data_con arg_n
-              , preds_and_mbSubst <- get_arg_constraints orig arg_t_or_k arg_ty
-              ]
-            preds = concat predss
-            -- If the constraints require a subtype to be of kind (* -> *)
-            -- (which is the case for functor-like constraints), then we
-            -- explicitly unify the subtype's kinds with (* -> *).
-            -- See Note [Inferring the instance context]
-            subst        = foldl' composeTCvSubst
-                                  emptyTCvSubst (catMaybes mbSubsts)
-            unmapped_tvs = filter (\v -> v `notElemTCvSubst` subst
-                                      && not (v `isInScope` subst)) tvs
-            (subst', _)  = mapAccumL substTyVarBndr subst unmapped_tvs
-            preds'       = substThetaOrigin subst' preds
-            inst_tys'    = substTys subst' inst_tys
-            tvs'         = tyCoVarsOfTypesWellScoped inst_tys'
-        in mkTheta preds' tvs' inst_tys'
-
-    is_generic  = main_cls `hasKey` genClassKey
-    is_generic1 = main_cls `hasKey` gen1ClassKey
-    -- is_functor_like: see Note [Inferring the instance context]
-    is_functor_like = typeKind inst_ty `tcEqKind` typeToTypeKind
-                   || is_generic1 -- Technically, Generic1 requires a type of
-                                  -- kind (k -> *), not (* -> *), but we still
-                                  -- label it "functor-like" to make sure
-                                  -- all_rep_tc_args has all the necessary type
-                                  -- variables it needs to function.
-
-    get_gen1_constraints :: Class -> CtOrigin -> TypeOrKind -> Type
-                         -> [(ThetaOrigin, Maybe TCvSubst)]
-    get_gen1_constraints functor_cls orig t_or_k ty
-       = mk_functor_like_constraints orig t_or_k functor_cls $
-         get_gen1_constrained_tys last_tv ty
-
-    get_std_constrained_tys :: CtOrigin -> TypeOrKind -> Type
-                            -> [(ThetaOrigin, Maybe TCvSubst)]
-    get_std_constrained_tys orig t_or_k ty
-        | is_functor_like = mk_functor_like_constraints orig t_or_k main_cls $
-                            deepSubtypesContaining last_tv ty
-        | otherwise       = [( [mk_cls_pred orig t_or_k main_cls ty]
-                             , Nothing )]
-
-    mk_functor_like_constraints :: CtOrigin -> TypeOrKind
-                                -> Class -> [Type]
-                                -> [(ThetaOrigin, Maybe TCvSubst)]
-    -- 'cls' is usually main_cls (Functor or Traversable etc), but if
-    -- main_cls = Generic1, then 'cls' can be Functor; see get_gen1_constraints
-    --
-    -- For each type, generate two constraints, [cls ty, kind(ty) ~ (*->*)],
-    -- and a kind substitution that results from unifying kind(ty) with * -> *.
-    -- If the unification is successful, it will ensure that the resulting
-    -- instance is well kinded. If not, the second constraint will result
-    -- in an error message which points out the kind mismatch.
-    -- See Note [Inferring the instance context]
-    mk_functor_like_constraints orig t_or_k cls
-       = map $ \ty -> let ki = typeKind ty in
-                      ( [ mk_cls_pred orig t_or_k cls ty
-                        , mkPredOrigin orig KindLevel
-                            (mkPrimEqPred ki typeToTypeKind) ]
-                      , tcUnifyTy ki typeToTypeKind
-                      )
-
-    rep_tc_tvs      = tyConTyVars rep_tc
-    last_tv         = last rep_tc_tvs
-    all_rep_tc_args | is_functor_like = rep_tc_args ++ [mkTyVarTy last_tv]
-                    | otherwise       = rep_tc_args
-
-        -- Constraints arising from superclasses
-        -- See Note [Superclasses of derived instance]
-    cls_tvs  = classTyVars main_cls
-    inst_tys = cls_tys ++ [inst_ty]
-    sc_constraints = ASSERT2( equalLength cls_tvs inst_tys, ppr main_cls <+> ppr rep_tc)
-                     mkThetaOrigin DerivOrigin TypeLevel $
-                     substTheta cls_subst (classSCTheta main_cls)
-    cls_subst = ASSERT( equalLength cls_tvs inst_tys )
-                zipTvSubst cls_tvs inst_tys
-
-        -- Stupid constraints
-    stupid_constraints = mkThetaOrigin DerivOrigin TypeLevel $
-                         substTheta tc_subst (tyConStupidTheta rep_tc)
-    tc_subst = ASSERT( equalLength rep_tc_tvs all_rep_tc_args )
-               zipTvSubst rep_tc_tvs all_rep_tc_args
-
-        -- Extra Data constraints
-        -- The Data class (only) requires that for
-        --    instance (...) => Data (T t1 t2)
-        -- IF   t1:*, t2:*
-        -- THEN (Data t1, Data t2) are among the (...) constraints
-        -- Reason: when the IF holds, we generate a method
-        --             dataCast2 f = gcast2 f
-        --         and we need the Data constraints to typecheck the method
-    extra_constraints
-      | main_cls `hasKey` dataClassKey
-      , all (isLiftedTypeKind . typeKind) rep_tc_args
-      = [ mk_cls_pred DerivOrigin t_or_k main_cls ty
-        | (t_or_k, ty) <- zip t_or_ks rep_tc_args]
-      | otherwise
-      = []
-
-    mk_cls_pred orig t_or_k cls ty   -- Don't forget to apply to cls_tys' too
-       = mkPredOrigin orig t_or_k (mkClassPred cls (cls_tys' ++ [ty]))
-    cls_tys' | is_generic1 = [] -- In the awkward Generic1 case, cls_tys'
-                                -- should be empty, since we are applying the
-                                -- class Functor.
-             | otherwise   = cls_tys
-
-{- Note [Getting base classes]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Functor and Typeable are defined in package 'base', and that is not available
-when compiling 'ghc-prim'.  So we must be careful that 'deriving' for stuff in
-ghc-prim does not use Functor or Typeable implicitly via these lookups.
-
-Note [Deriving and unboxed types]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-We have some special hacks to support things like
-   data T = MkT Int# deriving ( Show )
-
-Specifically, we use TcGenDeriv.box to box the Int# into an Int
-(which we know how to show), and append a '#'. Parenthesis are not required
-for unboxed values (`MkT -3#` is a valid expression).
-
-Note [Deriving any class]
-~~~~~~~~~~~~~~~~~~~~~~~~~
-Classic uses of a deriving clause, or a standalone-deriving declaration, are
-for:
-  * a stock class like Eq or Show, for which GHC knows how to generate
-    the instance code
-  * a newtype, via the mechanism enabled by GeneralizedNewtypeDeriving
-
-The DeriveAnyClass extension adds a third way to derive instances, based on
-empty instance declarations.
-
-The canonical use case is in combination with GHC.Generics and default method
-signatures. These allow us to have instance declarations being empty, but still
-useful, e.g.
-
-  data T a = ...blah..blah... deriving( Generic )
-  instance C a => C (T a)  -- No 'where' clause
-
-where C is some "random" user-defined class.
-
-This boilerplate code can be replaced by the more compact
-
-  data T a = ...blah..blah... deriving( Generic, C )
-
-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.
--}
-
-------------------------------------------------------------------
--- Check side conditions that dis-allow derivability for particular classes
--- This is *apart* from the newtype-deriving mechanism
---
--- Here we get the representation tycon in case of family instances as it has
--- the data constructors - but we need to be careful to fall back to the
--- family tycon (with indexes) in error messages.
-
-data DerivStatus = CanDerive                 -- Stock class, can derive
-                 | DerivableClassError SDoc  -- Stock class, but can't do it
-                 | DerivableViaInstance      -- See Note [Deriving any class]
-                 | NonDerivableClass SDoc    -- Non-stock class
-
--- 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.
-
-checkSideConditions :: DynFlags -> DerivContext -> Class -> [TcType]
-                    -> TyCon -- tycon
-                    -> DerivStatus
-checkSideConditions dflags mtheta cls cls_tys rep_tc
-  | Just cond <- sideConditions mtheta cls
-  = case (cond (dflags, rep_tc)) of
-        NotValid err -> DerivableClassError err  -- Class-specific error
-        IsValid  | null (filterOutInvisibleTypes (classTyCon cls) cls_tys)
-                   -> CanDerive
-                   -- All stock derivable classes are unary in the sense that
-                   -- there should be not types in cls_tys (i.e., no type args
-                   -- other than last). Note that cls_types can contain
-                   -- invisible types as well (e.g., for Generic1, which is
-                   -- poly-kinded), so make sure those are not counted.
-                 | otherwise -> DerivableClassError (classArgsErr cls cls_tys)
-                   -- e.g. deriving( Eq s )
-
-  | Just err <- canDeriveAnyClass dflags rep_tc cls
-  = NonDerivableClass err  -- DeriveAnyClass does not work
-
-  | otherwise
-  = DerivableViaInstance   -- DeriveAnyClass should work
-
-
-classArgsErr :: Class -> [Type] -> SDoc
-classArgsErr cls cls_tys = quotes (ppr (mkClassPred cls cls_tys)) <+> text "is not a class"
-
-nonUnaryErr :: LHsSigType Name -> SDoc
-nonUnaryErr ct = quotes (ppr ct)
-  <+> text "is not a unary constraint, as expected by a deriving clause"
-
-nonStdErr :: Class -> SDoc
-nonStdErr cls =
-      quotes (ppr cls)
-  <+> text "is not a stock derivable class (Eq, Show, etc.)"
-
-gndNonNewtypeErr :: SDoc
-gndNonNewtypeErr =
-  text "GeneralizedNewtypeDeriving cannot be used on non-newtypes"
-
--- Side conditions (whether the datatype must have at least one constructor,
--- required language extensions, etc.) for using GHC's stock deriving
--- mechanism on certain classes (as opposed to classes that require
--- GeneralizedNewtypeDeriving or DeriveAnyClass). Returns Nothing for a
--- class for which stock deriving isn't possible.
---
--- NB: The classes listed below should be in sync with the ones listed in the
--- definition of hasStockDeriving in TcGenDeriv (except for Generic(1),
--- which are handled specially). If you add new class to sideConditions,
--- make sure to update hasStockDeriving as well!
-sideConditions :: DerivContext -> Class -> Maybe Condition
-sideConditions mtheta cls
-  | cls_key == eqClassKey          = Just (cond_std `andCond` cond_args cls)
-  | cls_key == ordClassKey         = Just (cond_std `andCond` cond_args cls)
-  | cls_key == showClassKey        = Just (cond_std `andCond` cond_args cls)
-  | cls_key == readClassKey        = Just (cond_std `andCond` cond_args cls)
-  | cls_key == enumClassKey        = Just (cond_std `andCond` cond_isEnumeration)
-  | cls_key == ixClassKey          = Just (cond_std `andCond` cond_enumOrProduct cls)
-  | cls_key == boundedClassKey     = Just (cond_std `andCond` cond_enumOrProduct cls)
-  | cls_key == dataClassKey        = Just (checkFlag LangExt.DeriveDataTypeable `andCond`
-                                           cond_std `andCond`
-                                           cond_args cls)
-  | cls_key == functorClassKey     = Just (checkFlag LangExt.DeriveFunctor `andCond`
-                                           cond_vanilla `andCond`
-                                           cond_functorOK True False)
-  | cls_key == foldableClassKey    = Just (checkFlag LangExt.DeriveFoldable `andCond`
-                                           cond_vanilla `andCond`
-                                           cond_functorOK False True)
-                                           -- Functor/Fold/Trav works ok
-                                           -- for rank-n types
-  | cls_key == traversableClassKey = Just (checkFlag LangExt.DeriveTraversable `andCond`
-                                           cond_vanilla `andCond`
-                                           cond_functorOK False False)
-  | cls_key == genClassKey         = Just (checkFlag LangExt.DeriveGeneric `andCond`
-                                           cond_vanilla `andCond`
-                                           cond_RepresentableOk)
-  | cls_key == gen1ClassKey        = Just (checkFlag LangExt.DeriveGeneric `andCond`
-                                           cond_vanilla `andCond`
-                                           cond_Representable1Ok)
-  | cls_key == liftClassKey        = Just (checkFlag LangExt.DeriveLift `andCond`
-                                           cond_vanilla `andCond`
-                                           cond_args cls)
-  | otherwise                      = Nothing
-  where
-    cls_key = getUnique cls
-    cond_std     = cond_stdOK mtheta False  -- Vanilla data constructors, at least one,
-                                            --    and monotype arguments
-    cond_vanilla = cond_stdOK mtheta True   -- Vanilla data constructors but
-                                            --   allow no data cons or polytype arguments
-
-canDeriveAnyClass :: DynFlags -> TyCon -> Class -> Maybe SDoc
--- Nothing: we can (try to) derive it via an empty instance declaration
--- Just s:  we can't, reason s
--- Precondition: the class is not one of the standard ones
-canDeriveAnyClass dflags _tycon clas
-  | not (xopt LangExt.DeriveAnyClass dflags)
-  = Just (text "Try enabling DeriveAnyClass")
-  | not (any (target_kind `tcEqKind`) [ liftedTypeKind, typeToTypeKind ])
-  = Just (text "The last argument of class" <+> quotes (ppr clas)
-          <+> text "does not have kind * or (* -> *)")
-  | otherwise
-  = Nothing   -- OK!
-  where
-    -- We are making an instance  (C t1 .. tn (T s1 .. sm))
-    -- and we can only do so if the kind of C's last argument
-    -- is * or (* -> *).  Because only then can we make a reasonable
-    -- guess at the instance context
-    target_kind = tyVarKind (last (classTyVars clas))
-
-typeToTypeKind :: Kind
-typeToTypeKind = liftedTypeKind `mkFunTy` liftedTypeKind
-
-type Condition = (DynFlags, TyCon) -> Validity
-        -- TyCon is the *representation* tycon if the data type is an indexed one
-        -- Nothing => OK
-
-orCond :: Condition -> Condition -> Condition
-orCond c1 c2 tc
-  = case (c1 tc, c2 tc) of
-     (IsValid,    _)          -> IsValid    -- c1 succeeds
-     (_,          IsValid)    -> IsValid    -- c21 succeeds
-     (NotValid x, NotValid y) -> NotValid (x $$ text "  or" $$ y)
-                                            -- Both fail
-
-andCond :: Condition -> Condition -> Condition
-andCond c1 c2 tc = c1 tc `andValid` c2 tc
-
-cond_stdOK :: DerivContext -- Says whether this is standalone deriving or not;
-                           --     if standalone, we just say "yes, go for it"
-           -> Bool         -- True <=> permissive: allow higher rank
-                           --          args and no data constructors
-           -> Condition
-cond_stdOK (Just _) _ _
-  = IsValid     -- Don't check these conservative conditions for
-                -- standalone deriving; just generate the code
-                -- and let the typechecker handle the result
-cond_stdOK Nothing permissive (_, rep_tc)
-  | null data_cons
-  , not permissive      = NotValid (no_cons_why rep_tc $$ suggestion)
-  | not (null con_whys) = NotValid (vcat con_whys $$ suggestion)
-  | otherwise           = IsValid
-  where
-    suggestion = text "Possible fix: use a standalone deriving declaration instead"
-    data_cons  = tyConDataCons rep_tc
-    con_whys   = getInvalids (map check_con data_cons)
-
-    check_con :: DataCon -> Validity
-    check_con con
-      | not (null eq_spec)
-      = bad "is a GADT"
-      | not (null ex_tvs)
-      = bad "has existential type variables in its type"
-      | not (null theta)
-      = bad "has constraints in its type"
-      | not (permissive || all isTauTy (dataConOrigArgTys con))
-      = bad "has a higher-rank type"
-      | otherwise
-      = IsValid
-      where
-        (_, ex_tvs, eq_spec, theta, _, _) = dataConFullSig con
-        bad msg = NotValid (badCon con (text msg))
-
-no_cons_why :: TyCon -> SDoc
-no_cons_why rep_tc = quotes (pprSourceTyCon rep_tc) <+>
-                     text "must have at least one data constructor"
-
-cond_RepresentableOk :: Condition
-cond_RepresentableOk (_, tc) = canDoGenerics tc
-
-cond_Representable1Ok :: Condition
-cond_Representable1Ok (_, tc) = canDoGenerics1 tc
-
-cond_enumOrProduct :: Class -> Condition
-cond_enumOrProduct cls = cond_isEnumeration `orCond`
-                         (cond_isProduct `andCond` cond_args cls)
-
-cond_args :: Class -> Condition
--- For some classes (eg Eq, Ord) we allow unlifted arg types
--- by generating specialised code.  For others (eg Data) we don't.
-cond_args cls (_, tc)
-  = case bad_args of
-      []     -> IsValid
-      (ty:_) -> NotValid (hang (text "Don't know how to derive" <+> quotes (ppr cls))
-                             2 (text "for type" <+> quotes (ppr ty)))
-  where
-    bad_args = [ arg_ty | con <- tyConDataCons tc
-                        , arg_ty <- dataConOrigArgTys con
-                        , isUnliftedType arg_ty
-                        , not (ok_ty arg_ty) ]
-
-    cls_key = classKey cls
-    ok_ty arg_ty
-     | cls_key == eqClassKey   = check_in arg_ty ordOpTbl
-     | cls_key == ordClassKey  = check_in arg_ty ordOpTbl
-     | cls_key == showClassKey = check_in arg_ty boxConTbl
-     | cls_key == liftClassKey = check_in arg_ty litConTbl
-     | otherwise               = False    -- Read, Ix etc
-
-    check_in :: Type -> [(Type,a)] -> Bool
-    check_in arg_ty tbl = any (eqType arg_ty . fst) tbl
-
-
-cond_isEnumeration :: Condition
-cond_isEnumeration (_, rep_tc)
-  | isEnumerationTyCon rep_tc = IsValid
-  | otherwise                 = NotValid why
-  where
-    why = sep [ quotes (pprSourceTyCon rep_tc) <+>
-                  text "must be an enumeration type"
-              , text "(an enumeration consists of one or more nullary, non-GADT constructors)" ]
-                  -- See Note [Enumeration types] in TyCon
-
-cond_isProduct :: Condition
-cond_isProduct (_, rep_tc)
-  | isProductTyCon rep_tc = IsValid
-  | otherwise             = NotValid why
-  where
-    why = quotes (pprSourceTyCon rep_tc) <+>
-          text "must have precisely one constructor"
-
-cond_functorOK :: Bool -> Bool -> Condition
--- OK for Functor/Foldable/Traversable class
--- Currently: (a) at least one argument
---            (b) don't use argument contravariantly
---            (c) don't use argument in the wrong place, e.g. data T a = T (X a a)
---            (d) optionally: don't use function types
---            (e) no "stupid context" on data type
-cond_functorOK allowFunctions allowExQuantifiedLastTyVar (_, rep_tc)
-  | null tc_tvs
-  = NotValid (text "Data type" <+> quotes (ppr rep_tc)
-              <+> text "must have some type parameters")
-
-  | not (null bad_stupid_theta)
-  = NotValid (text "Data type" <+> quotes (ppr rep_tc)
-              <+> text "must not have a class context:" <+> pprTheta bad_stupid_theta)
-
-  | otherwise
-  = allValid (map check_con data_cons)
-  where
-    tc_tvs            = tyConTyVars rep_tc
-    Just (_, last_tv) = snocView tc_tvs
-    bad_stupid_theta  = filter is_bad (tyConStupidTheta rep_tc)
-    is_bad pred       = last_tv `elemVarSet` tyCoVarsOfType pred
-
-    data_cons = tyConDataCons rep_tc
-    check_con con = allValid (check_universal con : foldDataConArgs (ft_check con) con)
-
-    check_universal :: DataCon -> Validity
-    check_universal con
-      | allowExQuantifiedLastTyVar
-      = IsValid -- See Note [DeriveFoldable with ExistentialQuantification]
-                -- in TcGenDeriv
-      | Just tv <- getTyVar_maybe (last (tyConAppArgs (dataConOrigResTy con)))
-      , tv `elem` dataConUnivTyVars con
-      , not (tv `elemVarSet` tyCoVarsOfTypes (dataConTheta con))
-      = IsValid   -- See Note [Check that the type variable is truly universal]
-      | otherwise
-      = NotValid (badCon con existential)
-
-    ft_check :: DataCon -> FFoldType Validity
-    ft_check con = FT { ft_triv = IsValid, ft_var = IsValid
-                      , ft_co_var = NotValid (badCon con covariant)
-                      , ft_fun = \x y -> if allowFunctions then x `andValid` y
-                                                           else NotValid (badCon con functions)
-                      , ft_tup = \_ xs  -> allValid xs
-                      , ft_ty_app = \_ x   -> x
-                      , ft_bad_app = NotValid (badCon con wrong_arg)
-                      , ft_forall = \_ x   -> x }
-
-    existential = text "must be truly polymorphic in the last argument of the data type"
-    covariant   = text "must not use the type variable in a function argument"
-    functions   = text "must not contain function types"
-    wrong_arg   = text "must use the type variable only as the last argument of a data type"
-
-checkFlag :: LangExt.Extension -> Condition
-checkFlag flag (dflags, _)
-  | xopt flag dflags = IsValid
-  | otherwise        = NotValid why
-  where
-    why = text "You need " <> text flag_str
-          <+> text "to derive an instance for this class"
-    flag_str = case [ flagSpecName f | f <- xFlags , flagSpecFlag f == flag ] of
-                 [s]   -> s
-                 other -> pprPanic "checkFlag" (ppr other)
-
-std_class_via_coercible :: Class -> Bool
--- These standard classes can be derived for a newtype
--- using the coercible trick *even if no -XGeneralizedNewtypeDeriving
--- because giving so gives the same results as generating the boilerplate
-std_class_via_coercible clas
-  = classKey clas `elem` [eqClassKey, ordClassKey, ixClassKey, boundedClassKey]
-        -- Not Read/Show because they respect the type
-        -- Not Enum, because newtypes are never in Enum
-
-
-non_coercible_class :: Class -> Bool
--- *Never* derive Read, Show, Typeable, Data, Generic, Generic1, Lift
--- by Coercible, even with -XGeneralizedNewtypeDeriving
--- Also, avoid Traversable, as the Coercible-derived instance and the "normal"-derived
--- instance behave differently if there's a non-lawful Applicative out there.
--- Besides, with roles, Coercible-deriving Traversable is ill-roled.
-non_coercible_class cls
-  = classKey cls `elem` ([ readClassKey, showClassKey, dataClassKey
-                         , genClassKey, gen1ClassKey, typeableClassKey
-                         , traversableClassKey, liftClassKey ])
-
-badCon :: DataCon -> SDoc -> SDoc
-badCon con msg = text "Constructor" <+> quotes (ppr con) <+> msg
-
 {-
-Note [Check that the type variable is truly universal]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-For Functor and Traversable instances, we must check that the *last argument*
-of the type constructor is used truly universally quantified.  Example
-
-   data T a b where
-     T1 :: a -> b -> T a b      -- Fine! Vanilla H-98
-     T2 :: b -> c -> T a b      -- Fine! Existential c, but we can still map over 'b'
-     T3 :: b -> T Int b         -- Fine! Constraint 'a', but 'b' is still polymorphic
-     T4 :: Ord b => b -> T a b  -- No!  'b' is constrained
-     T5 :: b -> T b b           -- No!  'b' is constrained
-     T6 :: T a (b,b)            -- No!  'b' is constrained
-
-Notice that only the first of these constructors is vanilla H-98. We only
-need to take care about the last argument (b in this case).  See Trac #8678.
-Eg. for T1-T3 we can write
-
-     fmap f (T1 a b) = T1 a (f b)
-     fmap f (T2 b c) = T2 (f b) c
-     fmap f (T3 x)   = T3 (f x)
-
-We need not perform these checks for Foldable instances, however, since
-functions in Foldable can only consume existentially quantified type variables,
-rather than produce them (as is the case in Functor and Traversable functions.)
-As a result, T can have a derived Foldable instance:
-
-    foldr f z (T1 a b) = f b z
-    foldr f z (T2 b c) = f b z
-    foldr f z (T3 x)   = f x z
-    foldr f z (T4 x)   = f x z
-    foldr f z (T5 x)   = f x z
-    foldr _ z T6       = z
-
-See Note [DeriveFoldable with ExistentialQuantification] in TcGenDeriv.
-
-
-Note [Superclasses of derived instance]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-In general, a derived instance decl needs the superclasses of the derived
-class too.  So if we have
-        data T a = ...deriving( Ord )
-then the initial context for Ord (T a) should include Eq (T a).  Often this is
-redundant; we'll also generate an Ord constraint for each constructor argument,
-and that will probably generate enough constraints to make the Eq (T a) constraint
-be satisfied too.  But not always; consider:
-
- data S a = S
- instance Eq (S a)
- instance Ord (S a)
-
- data T a = MkT (S a) deriving( Ord )
- instance Num a => Eq (T a)
-
-The derived instance for (Ord (T a)) must have a (Num a) constraint!
-Similarly consider:
-        data T a = MkT deriving( Data )
-Here there *is* no argument field, but we must nevertheless generate
-a context for the Data instances:
-        instance Typeable a => Data (T a) where ...
-
 ************************************************************************
 *                                                                      *
                 Deriving newtypes
@@ -2005,355 +1236,6 @@ where we're sure that the resulting instance will type-check.
 
 ************************************************************************
 *                                                                      *
-         Finding the fixed point of deriving equations
-*                                                                      *
-************************************************************************
-
-Note [Simplifying the instance context]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Consider
-
-        data T a b = C1 (Foo a) (Bar b)
-                   | C2 Int (T b a)
-                   | C3 (T a a)
-                   deriving (Eq)
-
-We want to come up with an instance declaration of the form
-
-        instance (Ping a, Pong b, ...) => Eq (T a b) where
-                x == y = ...
-
-It is pretty easy, albeit tedious, to fill in the code "...".  The
-trick is to figure out what the context for the instance decl is,
-namely Ping, Pong and friends.
-
-Let's call the context reqd for the T instance of class C at types
-(a,b, ...)  C (T a b).  Thus:
-
-        Eq (T a b) = (Ping a, Pong b, ...)
-
-Now we can get a (recursive) equation from the data decl.  This part
-is done by inferConstraints.
-
-        Eq (T a b) = Eq (Foo a) u Eq (Bar b)    -- From C1
-                   u Eq (T b a) u Eq Int        -- From C2
-                   u Eq (T a a)                 -- From C3
-
-
-Foo and Bar may have explicit instances for Eq, in which case we can
-just substitute for them.  Alternatively, either or both may have
-their Eq instances given by deriving clauses, in which case they
-form part of the system of equations.
-
-Now all we need do is simplify and solve the equations, iterating to
-find the least fixpoint.  This is done by simplifyInstanceConstraints.
-Notice that the order of the arguments can
-switch around, as here in the recursive calls to T.
-
-Let's suppose Eq (Foo a) = Eq a, and Eq (Bar b) = Ping b.
-
-We start with:
-
-        Eq (T a b) = {}         -- The empty set
-
-Next iteration:
-        Eq (T a b) = Eq (Foo a) u Eq (Bar b)    -- From C1
-                   u Eq (T b a) u Eq Int        -- From C2
-                   u Eq (T a a)                 -- From C3
-
-        After simplification:
-                   = Eq a u Ping b u {} u {} u {}
-                   = Eq a u Ping b
-
-Next iteration:
-
-        Eq (T a b) = Eq (Foo a) u Eq (Bar b)    -- From C1
-                   u Eq (T b a) u Eq Int        -- From C2
-                   u Eq (T a a)                 -- From C3
-
-        After simplification:
-                   = Eq a u Ping b
-                   u (Eq b u Ping a)
-                   u (Eq a u Ping a)
-
-                   = Eq a u Ping b u Eq b u Ping a
-
-The next iteration gives the same result, so this is the fixpoint.  We
-need to make a canonical form of the RHS to ensure convergence.  We do
-this by simplifying the RHS to a form in which
-
-        - the classes constrain only tyvars
-        - the list is sorted by tyvar (major key) and then class (minor key)
-        - no duplicates, of course
-
-Note [Deterministic simplifyInstanceContexts]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Canonicalisation uses nonDetCmpType which is nondeterministic. Sorting
-with nonDetCmpType puts the returned lists in a nondeterministic order.
-If we were to return them, we'd get class constraints in
-nondeterministic order.
-
-Consider:
-
-  data ADT a b = Z a b deriving Eq
-
-The generated code could be either:
-
-  instance (Eq a, Eq b) => Eq (Z a b) where
-
-Or:
-
-  instance (Eq b, Eq a) => Eq (Z a b) where
-
-To prevent the order from being nondeterministic we only
-canonicalize when comparing and return them in the same order as
-simplifyDeriv returned them.
-See also Note [nonDetCmpType nondeterminism]
--}
-
-
-simplifyInstanceContexts :: [DerivSpec ThetaOrigin] -> TcM [DerivSpec ThetaType]
--- Used only for deriving clauses (InferTheta)
--- not for standalone deriving
--- See Note [Simplifying the instance context]
-
-simplifyInstanceContexts [] = return []
-
-simplifyInstanceContexts infer_specs
-  = do  { traceTc "simplifyInstanceContexts" $ vcat (map pprDerivSpec infer_specs)
-        ; iterate_deriv 1 initial_solutions }
-  where
-    ------------------------------------------------------------------
-        -- The initial solutions for the equations claim that each
-        -- instance has an empty context; this solution is certainly
-        -- in canonical form.
-    initial_solutions :: [ThetaType]
-    initial_solutions = [ [] | _ <- infer_specs ]
-
-    ------------------------------------------------------------------
-        -- iterate_deriv calculates the next batch of solutions,
-        -- compares it with the current one; finishes if they are the
-        -- same, otherwise recurses with the new solutions.
-        -- It fails if any iteration fails
-    iterate_deriv :: Int -> [ThetaType] -> TcM [DerivSpec ThetaType]
-    iterate_deriv n current_solns
-      | n > 20  -- Looks as if we are in an infinite loop
-                -- This can happen if we have -XUndecidableInstances
-                -- (See TcSimplify.tcSimplifyDeriv.)
-      = pprPanic "solveDerivEqns: probable loop"
-                 (vcat (map pprDerivSpec infer_specs) $$ ppr current_solns)
-      | 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
-           ; new_solns <- checkNoErrs $
-                          extendLocalInstEnv inst_specs $
-                          mapM gen_soln infer_specs
-
-           ; if (current_solns `eqSolution` new_solns) then
-                return [ spec { ds_theta = soln }
-                       | (spec, soln) <- zip infer_specs current_solns ]
-             else
-                iterate_deriv (n+1) new_solns }
-
-    eqSolution a b = eqListBy (eqListBy eqType) (canSolution a) (canSolution b)
-       -- Canonicalise for comparison
-       -- See Note [Deterministic simplifyInstanceContexts]
-    canSolution = map (sortBy nonDetCmpType)
-    ------------------------------------------------------------------
-    gen_soln :: DerivSpec ThetaOrigin -> TcM ThetaType
-    gen_soln (DS { ds_loc = loc, ds_tvs = tyvars
-                 , ds_cls = clas, ds_tys = inst_tys, ds_theta = deriv_rhs })
-      = setSrcSpan loc  $
-        addErrCtxt (derivInstCtxt the_pred) $
-        do { theta <- simplifyDeriv the_pred tyvars deriv_rhs
-                -- checkValidInstance tyvars theta clas inst_tys
-                -- Not necessary; see Note [Exotic derived instance contexts]
-
-           ; traceTc "TcDeriv" (ppr deriv_rhs $$ ppr theta)
-                -- Claim: the result instance declaration is guaranteed valid
-                -- Hence no need to call:
-                --   checkValidInstance tyvars theta clas inst_tys
-           ; return theta }
-      where
-        the_pred = mkClassPred clas inst_tys
-
-------------------------------------------------------------------
-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 })
-  = newClsInst overlap_mode dfun_name tvs theta clas tys
-
-extendLocalInstEnv :: [ClsInst] -> TcM a -> TcM a
--- Add new locally-defined instances; don't bother to check
--- for functional dependency errors -- that'll happen in TcInstDcls
-extendLocalInstEnv dfuns thing_inside
- = do { env <- getGblEnv
-      ; let  inst_env' = extendInstEnvList (tcg_inst_env env) dfuns
-             env'      = env { tcg_inst_env = inst_env' }
-      ; setGblEnv env' thing_inside }
-
-{-
-***********************************************************************************
-*                                                                                 *
-*            Simplify derived constraints
-*                                                                                 *
-***********************************************************************************
--}
-
--- | Given @instance (wanted) => C inst_ty@, simplify 'wanted' as much
--- as possible. Fail if not possible.
-simplifyDeriv :: PredType -- ^ @C inst_ty@, head of the instance we are
-                          -- deriving.  Only used for SkolemInfo.
-              -> [TyVar]  -- ^ The tyvars bound by @inst_ty@.
-              -> ThetaOrigin   -- ^ @wanted@ constraints, i.e. @['PredOrigin']@.
-              -> TcM ThetaType -- ^ Needed constraints (after simplification),
-                               -- i.e. @['PredType']@.
-simplifyDeriv pred tvs theta
-  = do { (skol_subst, tvs_skols) <- tcInstSkolTyVars tvs -- Skolemize
-                -- The constraint solving machinery
-                -- expects *TcTyVars* not TyVars.
-                -- We use *non-overlappable* (vanilla) skolems
-                -- See Note [Overlap and deriving]
-
-       ; let skol_set  = mkVarSet tvs_skols
-             skol_info = DerivSkol pred
-             doc = text "deriving" <+> parens (ppr pred)
-             mk_ct (PredOrigin t o t_or_k)
-                 = newWanted o (Just t_or_k) (substTy skol_subst t)
-
-       -- Generate the wanted constraints with the skolemized variables
-       ; (wanted, tclvl) <- pushTcLevelM (mapM mk_ct theta)
-
-       ; traceTc "simplifyDeriv inputs" $
-         vcat [ pprTvBndrs tvs $$ ppr theta $$ ppr wanted, doc ]
-       -- Simplify the constraints
-       ; residual_wanted <- simplifyWantedsTcM wanted
-            -- Result is zonked
-
-       -- Split the resulting constraints into bad and good constraints,
-       -- building an @unsolved :: WantedConstraints@ representing all
-       -- the constraints we can't just shunt to the predicates.
-       -- See Note [Exotic derived instance contexts]
-       ; let residual_simple = wc_simple residual_wanted
-             (bad, good) = partitionBagWith get_good residual_simple
-             unsolved    = residual_wanted { wc_simple = bad }
-
-                         -- See Note [Exotic derived instance contexts]
-
-             get_good :: Ct -> Either Ct PredType
-             get_good ct | validDerivPred skol_set p
-                         , isWantedCt ct
-                         = Right p
-                          -- NB re 'isWantedCt': residual_wanted may contain
-                          -- unsolved CtDerived and we stick them into the
-                          -- bad set so that reportUnsolved may decide what
-                          -- to do with them
-                         | otherwise
-                         = Left ct
-                           where p = ctPred ct
-
-       ; traceTc "simplifyDeriv outputs" $
-         vcat [ ppr tvs_skols, ppr residual_simple, ppr good, ppr bad ]
-
-       -- If we are deferring type errors, simply ignore any insoluble
-       -- constraints.  They'll come up again when we typecheck the
-       -- generated instance declaration
-       ; defer <- goptM Opt_DeferTypeErrors
-       ; (implic, _) <- buildImplicationFor tclvl skol_info tvs_skols [] unsolved
-                   -- The buildImplicationFor is just to bind the skolems,
-                   -- in case they are mentioned in error messages
-                   -- See Trac #11347
-       -- Report the (bad) unsolved constraints
-       ; unless defer (reportAllUnsolved (mkImplicWC implic))
-
-
-       -- Return the good unsolved constraints (unskolemizing on the way out.)
-       ; let min_theta  = mkMinimalBySCs (bagToList good)
-             subst_skol = zipTvSubst tvs_skols $ mkTyVarTys tvs
-                          -- The reverse substitution (sigh)
-       ; return (substTheta subst_skol min_theta) }
-
-{-
-Note [Overlap and deriving]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Consider some overlapping instances:
-  data Show a => Show [a] where ..
-  data Show [Char] where ...
-
-Now a data type with deriving:
-  data T a = MkT [a] deriving( Show )
-
-We want to get the derived instance
-  instance Show [a] => Show (T a) where...
-and NOT
-  instance Show a => Show (T a) where...
-so that the (Show (T Char)) instance does the Right Thing
-
-It's very like the situation when we're inferring the type
-of a function
-   f x = show [x]
-and we want to infer
-   f :: Show [a] => a -> String
-
-BOTTOM LINE: use vanilla, non-overlappable skolems when inferring
-             the context for the derived instance.
-             Hence tcInstSkolTyVars not tcInstSuperSkolTyVars
-
-Note [Exotic derived instance contexts]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-In a 'derived' instance declaration, we *infer* the context.  It's a
-bit unclear what rules we should apply for this; the Haskell report is
-silent.  Obviously, constraints like (Eq a) are fine, but what about
-        data T f a = MkT (f a) deriving( Eq )
-where we'd get an Eq (f a) constraint.  That's probably fine too.
-
-One could go further: consider
-        data T a b c = MkT (Foo a b c) deriving( Eq )
-        instance (C Int a, Eq b, Eq c) => Eq (Foo a b c)
-
-Notice that this instance (just) satisfies the Paterson termination
-conditions.  Then we *could* derive an instance decl like this:
-
-        instance (C Int a, Eq b, Eq c) => Eq (T a b c)
-even though there is no instance for (C Int a), because there just
-*might* be an instance for, say, (C Int Bool) at a site where we
-need the equality instance for T's.
-
-However, this seems pretty exotic, and it's quite tricky to allow
-this, and yet give sensible error messages in the (much more common)
-case where we really want that instance decl for C.
-
-So for now we simply require that the derived instance context
-should have only type-variable constraints.
-
-Here is another example:
-        data Fix f = In (f (Fix f)) deriving( Eq )
-Here, if we are prepared to allow -XUndecidableInstances we
-could derive the instance
-        instance Eq (f (Fix f)) => Eq (Fix f)
-but this is so delicate that I don't think it should happen inside
-'deriving'. If you want this, write it yourself!
-
-NB: if you want to lift this condition, make sure you still meet the
-termination conditions!  If not, the deriving mechanism generates
-larger and larger constraints.  Example:
-  data Succ a = S a
-  data Seq a = Cons a (Seq (Succ a)) | Nil deriving Show
-
-Note the lack of a Show instance for Succ.  First we'll generate
-  instance (Show (Succ a), Show a) => Show (Seq a)
-and then
-  instance (Show (Succ (Succ a)), Show (Succ a), Show a) => Show (Seq a)
-and so on.  Instead we want to complain of no instance for (Show (Succ a)).
-
-The bottom line
-~~~~~~~~~~~~~~~
-Allow constraints which consist only of type variables, with no repeats.
-
-
-************************************************************************
-*                                                                      *
 \subsection[TcDeriv-normal-binds]{Bindings for the various classes}
 *                                                                      *
 ************************************************************************
@@ -2475,8 +1357,8 @@ doDerivInstErrorChecks clas clas_inst mechanism
             ; when (safeInferOn dflags) (recordUnsafeInfer emptyBag) } }
   where
     exotic_mechanism = case mechanism of
-      DerivSpecGeneric _ -> False
-      _                  -> True
+      DerivSpecStock{} -> False
+      _                -> True
 
     gen_inst_err = hang (text ("Generic instances can only be derived in "
                             ++ "Safe Haskell using the stock strategy.") $+$
@@ -2490,18 +1372,11 @@ genDerivStuff :: DerivSpecMechanism -> SrcSpan -> Class
               -> TcM (LHsBinds RdrName, BagDerivStuff)
 genDerivStuff mechanism loc clas tycon inst_tys tyvars
   = case mechanism of
-      -- Special case for DeriveGeneric, since it's monadic
-      DerivSpecGeneric gen_fn -> do
-        -- TODO NSF: correctly identify when we're building Both instead of One
-        (binds, faminst) <- gen_fn tycon inst_tys
-        return (binds, unitBag (DerivFamInst faminst))
-
-      -- The rest of the stock derivers
-      DerivSpecStock gen_fn -> gen_fn loc tycon
-
-      -- If there isn't compiler support for deriving the class, our last
-      -- resort is -XDeriveAnyClass (since -XGeneralizedNewtypeDeriving
-      -- fell through).
+      -- Try a stock deriver
+      DerivSpecStock gen_fn -> gen_fn loc tycon inst_tys
+
+      -- If there isn't a stock deriver, our last resort is -XDeriveAnyClass
+      -- (since -XGeneralizedNewtypeDeriving fell through).
       DerivSpecAnyClass -> do
         let mini_env   = mkVarEnv (classTyVars clas `zip` inst_tys)
             mini_subst = mkTvSubst (mkInScopeSet (mkVarSet tyvars)) mini_env
@@ -2622,6 +1497,19 @@ ask for a particular DerivStrategy (using the algorithm linked to above).
 ************************************************************************
 -}
 
+nonUnaryErr :: LHsSigType Name -> SDoc
+nonUnaryErr ct = quotes (ppr ct)
+  <+> text "is not a unary constraint, as expected by a deriving clause"
+
+nonStdErr :: Class -> SDoc
+nonStdErr cls =
+      quotes (ppr cls)
+  <+> text "is not a stock derivable class (Eq, Show, etc.)"
+
+gndNonNewtypeErr :: SDoc
+gndNonNewtypeErr =
+  text "GeneralizedNewtypeDeriving cannot be used on non-newtypes"
+
 derivingNullaryErr :: MsgDoc
 derivingNullaryErr = text "Cannot derive instances for nullary classes"
 
@@ -2672,10 +1560,6 @@ standaloneCtxt :: LHsSigType Name -> SDoc
 standaloneCtxt ty = hang (text "In the stand-alone deriving instance for")
                        2 (quotes (ppr ty))
 
-derivInstCtxt :: PredType -> MsgDoc
-derivInstCtxt pred
-  = text "When deriving the instance for" <+> parens (ppr pred)
-
 unboxedTyConErr :: String -> MsgDoc
 unboxedTyConErr thing =
   text "The last argument of the instance cannot be an unboxed" <+> text thing
diff --git a/compiler/typecheck/TcDerivInfer.hs b/compiler/typecheck/TcDerivInfer.hs
new file mode 100644
index 0000000000..63ff90489f
--- /dev/null
+++ b/compiler/typecheck/TcDerivInfer.hs
@@ -0,0 +1,653 @@
+{-
+(c) The University of Glasgow 2006
+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998
+
+
+Functions for inferring (and simplifying) the context for derived instances.
+-}
+
+{-# LANGUAGE CPP #-}
+
+module TcDerivInfer (inferConstraints, simplifyInstanceContexts) where
+
+#include "HsVersions.h"
+
+import Bag
+import Class
+import DataCon
+import DynFlags
+import ErrUtils
+import Inst
+import Outputable
+import PrelNames
+import TcDerivUtils
+import TcEnv
+import TcErrors (reportAllUnsolved)
+import TcGenFunctor
+import TcGenGenerics
+import TcMType
+import TcRnMonad
+import TcType
+import TyCon
+import Type
+import TcSimplify
+import TcValidity (validDerivPred)
+import TcUnify (buildImplicationFor)
+import Unify (tcUnifyTy)
+import Util
+import VarSet
+
+import Control.Monad
+import Data.List
+import Data.Maybe
+
+----------------------
+
+inferConstraints :: [TyVar] -> Class -> [TcType] -> TcType
+                 -> TyCon -> [TcType]
+                 -> (ThetaOrigin -> [TyVar] -> [TcType] -> TcM a)
+                 -> TcM a
+-- inferConstraints figures out the constraints needed for the
+-- instance declaration generated by a 'deriving' clause on a
+-- data type declaration. It also returns the new in-scope type
+-- variables and instance types, in case they were changed due to
+-- the presence of functor-like constraints.
+-- See Note [Inferring the instance context]
+
+-- e.g. inferConstraints
+--        C Int (T [a])    -- Class and inst_tys
+--        :RTList a        -- Rep tycon and its arg tys
+-- where T [a] ~R :RTList a
+--
+-- Generate a sufficiently large set of constraints that typechecking the
+-- generated method definitions should succeed.   This set will be simplified
+-- before being used in the instance declaration
+inferConstraints tvs main_cls cls_tys inst_ty rep_tc rep_tc_args mkTheta
+  | is_generic                        -- Generic constraints are easy
+  = mkTheta [] tvs inst_tys
+
+  | is_generic1                       -- Generic1 needs Functor
+  = ASSERT( length rep_tc_tvs > 0 )   -- See Note [Getting base classes]
+    ASSERT( length cls_tys   == 1 )   -- Generic1 has a single kind variable
+    do { functorClass <- tcLookupClass functorClassName
+       ; con_arg_constraints (get_gen1_constraints functorClass) mkTheta }
+
+  | otherwise  -- The others are a bit more complicated
+  = ASSERT2( equalLength rep_tc_tvs all_rep_tc_args
+           , ppr main_cls <+> ppr rep_tc
+             $$ ppr rep_tc_tvs $$ ppr all_rep_tc_args )
+    con_arg_constraints get_std_constrained_tys
+      $ \arg_constraints tvs' inst_tys' ->
+      do { traceTc "inferConstraints" $ vcat
+                [ ppr main_cls <+> ppr inst_tys'
+                , ppr arg_constraints
+                ]
+         ; mkTheta (stupid_constraints ++ extra_constraints
+                     ++ sc_constraints ++ arg_constraints)
+                   tvs' inst_tys' }
+  where
+    tc_binders = tyConBinders rep_tc
+    choose_level bndr
+      | isNamedTyConBinder bndr = KindLevel
+      | otherwise               = TypeLevel
+    t_or_ks = map choose_level tc_binders ++ repeat TypeLevel
+       -- want to report *kind* errors when possible
+
+       -- Constraints arising from the arguments of each constructor
+    con_arg_constraints :: (CtOrigin -> TypeOrKind
+                                     -> Type
+                                     -> [(ThetaOrigin, Maybe TCvSubst)])
+                        -> (ThetaOrigin -> [TyVar] -> [TcType] -> TcM a)
+                        -> TcM a
+    con_arg_constraints get_arg_constraints mkTheta
+      = let (predss, mbSubsts) = unzip
+              [ preds_and_mbSubst
+              | data_con <- tyConDataCons rep_tc
+              , (arg_n, arg_t_or_k, arg_ty)
+                  <- zip3 [1..] t_or_ks $
+                     dataConInstOrigArgTys data_con all_rep_tc_args
+                -- No constraints for unlifted types
+                -- See Note [Deriving and unboxed types]
+              , not (isUnliftedType arg_ty)
+              , let orig = DerivOriginDC data_con arg_n
+              , preds_and_mbSubst <- get_arg_constraints orig arg_t_or_k arg_ty
+              ]
+            preds = concat predss
+            -- If the constraints require a subtype to be of kind (* -> *)
+            -- (which is the case for functor-like constraints), then we
+            -- explicitly unify the subtype's kinds with (* -> *).
+            -- See Note [Inferring the instance context]
+            subst        = foldl' composeTCvSubst
+                                  emptyTCvSubst (catMaybes mbSubsts)
+            unmapped_tvs = filter (\v -> v `notElemTCvSubst` subst
+                                      && not (v `isInScope` subst)) tvs
+            (subst', _)  = mapAccumL substTyVarBndr subst unmapped_tvs
+            preds'       = substThetaOrigin subst' preds
+            inst_tys'    = substTys subst' inst_tys
+            tvs'         = tyCoVarsOfTypesWellScoped inst_tys'
+        in mkTheta preds' tvs' inst_tys'
+
+    is_generic  = main_cls `hasKey` genClassKey
+    is_generic1 = main_cls `hasKey` gen1ClassKey
+    -- is_functor_like: see Note [Inferring the instance context]
+    is_functor_like = typeKind inst_ty `tcEqKind` typeToTypeKind
+                   || is_generic1 -- Technically, Generic1 requires a type of
+                                  -- kind (k -> *), not (* -> *), but we still
+                                  -- label it "functor-like" to make sure
+                                  -- all_rep_tc_args has all the necessary type
+                                  -- variables it needs to function.
+
+    get_gen1_constraints :: Class -> CtOrigin -> TypeOrKind -> Type
+                         -> [(ThetaOrigin, Maybe TCvSubst)]
+    get_gen1_constraints functor_cls orig t_or_k ty
+       = mk_functor_like_constraints orig t_or_k functor_cls $
+         get_gen1_constrained_tys last_tv ty
+
+    get_std_constrained_tys :: CtOrigin -> TypeOrKind -> Type
+                            -> [(ThetaOrigin, Maybe TCvSubst)]
+    get_std_constrained_tys orig t_or_k ty
+        | is_functor_like = mk_functor_like_constraints orig t_or_k main_cls $
+                            deepSubtypesContaining last_tv ty
+        | otherwise       = [( [mk_cls_pred orig t_or_k main_cls ty]
+                             , Nothing )]
+
+    mk_functor_like_constraints :: CtOrigin -> TypeOrKind
+                                -> Class -> [Type]
+                                -> [(ThetaOrigin, Maybe TCvSubst)]
+    -- 'cls' is usually main_cls (Functor or Traversable etc), but if
+    -- main_cls = Generic1, then 'cls' can be Functor; see get_gen1_constraints
+    --
+    -- For each type, generate two constraints, [cls ty, kind(ty) ~ (*->*)],
+    -- and a kind substitution that results from unifying kind(ty) with * -> *.
+    -- If the unification is successful, it will ensure that the resulting
+    -- instance is well kinded. If not, the second constraint will result
+    -- in an error message which points out the kind mismatch.
+    -- See Note [Inferring the instance context]
+    mk_functor_like_constraints orig t_or_k cls
+       = map $ \ty -> let ki = typeKind ty in
+                      ( [ mk_cls_pred orig t_or_k cls ty
+                        , mkPredOrigin orig KindLevel
+                            (mkPrimEqPred ki typeToTypeKind) ]
+                      , tcUnifyTy ki typeToTypeKind
+                      )
+
+    rep_tc_tvs      = tyConTyVars rep_tc
+    last_tv         = last rep_tc_tvs
+    all_rep_tc_args | is_functor_like = rep_tc_args ++ [mkTyVarTy last_tv]
+                    | otherwise       = rep_tc_args
+
+        -- Constraints arising from superclasses
+        -- See Note [Superclasses of derived instance]
+    cls_tvs  = classTyVars main_cls
+    inst_tys = cls_tys ++ [inst_ty]
+    sc_constraints = ASSERT2( equalLength cls_tvs inst_tys, ppr main_cls <+> ppr rep_tc)
+                     mkThetaOrigin DerivOrigin TypeLevel $
+                     substTheta cls_subst (classSCTheta main_cls)
+    cls_subst = ASSERT( equalLength cls_tvs inst_tys )
+                zipTvSubst cls_tvs inst_tys
+
+        -- Stupid constraints
+    stupid_constraints = mkThetaOrigin DerivOrigin TypeLevel $
+                         substTheta tc_subst (tyConStupidTheta rep_tc)
+    tc_subst = ASSERT( equalLength rep_tc_tvs all_rep_tc_args )
+               zipTvSubst rep_tc_tvs all_rep_tc_args
+
+        -- Extra Data constraints
+        -- The Data class (only) requires that for
+        --    instance (...) => Data (T t1 t2)
+        -- IF   t1:*, t2:*
+        -- THEN (Data t1, Data t2) are among the (...) constraints
+        -- Reason: when the IF holds, we generate a method
+        --             dataCast2 f = gcast2 f
+        --         and we need the Data constraints to typecheck the method
+    extra_constraints
+      | main_cls `hasKey` dataClassKey
+      , all (isLiftedTypeKind . typeKind) rep_tc_args
+      = [ mk_cls_pred DerivOrigin t_or_k main_cls ty
+        | (t_or_k, ty) <- zip t_or_ks rep_tc_args]
+      | otherwise
+      = []
+
+    mk_cls_pred orig t_or_k cls ty   -- Don't forget to apply to cls_tys' too
+       = mkPredOrigin orig t_or_k (mkClassPred cls (cls_tys' ++ [ty]))
+    cls_tys' | is_generic1 = [] -- In the awkward Generic1 case, cls_tys'
+                                -- should be empty, since we are applying the
+                                -- class Functor.
+             | otherwise   = cls_tys
+
+typeToTypeKind :: Kind
+typeToTypeKind = liftedTypeKind `mkFunTy` liftedTypeKind
+
+{-
+Note [Inferring the instance context]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+There are two sorts of 'deriving':
+
+  * InferTheta: the deriving clause for a data type
+      data T a = T1 a deriving( Eq )
+    Here we must infer an instance context,
+    and generate instance declaration
+      instance Eq a => Eq (T a) where ...
+
+  * CheckTheta: standalone deriving
+      deriving instance Eq a => Eq (T a)
+    Here we only need to fill in the bindings;
+    the instance context is user-supplied
+
+For a deriving clause (InferTheta) we must figure out the
+instance context (inferConstraints). Suppose we are inferring
+the instance context for
+    C t1 .. tn (T s1 .. sm)
+There are two cases
+
+  * (T s1 .. sm) :: *         (the normal case)
+    Then we behave like Eq and guess (C t1 .. tn t)
+    for each data constructor arg of type t.  More
+    details below.
+
+  * (T s1 .. sm) :: * -> *    (the functor-like case)
+    Then we behave like Functor.
+
+In both cases we produce a bunch of un-simplified constraints
+and them simplify them in simplifyInstanceContexts; see
+Note [Simplifying the instance context].
+
+In the functor-like case, we may need to unify some kind variables with * in
+order for the generated instance to be well-kinded. An example from
+Trac #10524:
+
+  newtype Compose (f :: k2 -> *) (g :: k1 -> k2) (a :: k1)
+    = Compose (f (g a)) deriving Functor
+
+Earlier in the deriving pipeline, GHC unifies the kind of Compose f g
+(k1 -> *) with the kind of Functor's argument (* -> *), so k1 := *. But this
+alone isn't enough, since k2 wasn't unified with *:
+
+  instance (Functor (f :: k2 -> *), Functor (g :: * -> k2)) =>
+    Functor (Compose f g) where ...
+
+The two Functor constraints are ill-kinded. To ensure this doesn't happen, we:
+
+  1. Collect all of a datatype's subtypes which require functor-like
+     constraints.
+  2. For each subtype, create a substitution by unifying the subtype's kind
+     with (* -> *).
+  3. Compose all the substitutions into one, then apply that substitution to
+     all of the in-scope type variables and the instance types.
+
+Note [Getting base classes]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Functor and Typeable are defined in package 'base', and that is not available
+when compiling 'ghc-prim'.  So we must be careful that 'deriving' for stuff in
+ghc-prim does not use Functor or Typeable implicitly via these lookups.
+
+Note [Deriving and unboxed types]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We have some special hacks to support things like
+   data T = MkT Int# deriving ( Show )
+
+Specifically, we use TcGenDeriv.box to box the Int# into an Int
+(which we know how to show), and append a '#'. Parenthesis are not required
+for unboxed values (`MkT -3#` is a valid expression).
+
+Note [Superclasses of derived instance]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+In general, a derived instance decl needs the superclasses of the derived
+class too.  So if we have
+        data T a = ...deriving( Ord )
+then the initial context for Ord (T a) should include Eq (T a).  Often this is
+redundant; we'll also generate an Ord constraint for each constructor argument,
+and that will probably generate enough constraints to make the Eq (T a) constraint
+be satisfied too.  But not always; consider:
+
+ data S a = S
+ instance Eq (S a)
+ instance Ord (S a)
+
+ data T a = MkT (S a) deriving( Ord )
+ instance Num a => Eq (T a)
+
+The derived instance for (Ord (T a)) must have a (Num a) constraint!
+Similarly consider:
+        data T a = MkT deriving( Data )
+Here there *is* no argument field, but we must nevertheless generate
+a context for the Data instances:
+        instance Typeable a => Data (T a) where ...
+
+************************************************************************
+*                                                                      *
+         Finding the fixed point of deriving equations
+*                                                                      *
+************************************************************************
+
+Note [Simplifying the instance context]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider
+
+        data T a b = C1 (Foo a) (Bar b)
+                   | C2 Int (T b a)
+                   | C3 (T a a)
+                   deriving (Eq)
+
+We want to come up with an instance declaration of the form
+
+        instance (Ping a, Pong b, ...) => Eq (T a b) where
+                x == y = ...
+
+It is pretty easy, albeit tedious, to fill in the code "...".  The
+trick is to figure out what the context for the instance decl is,
+namely Ping, Pong and friends.
+
+Let's call the context reqd for the T instance of class C at types
+(a,b, ...)  C (T a b).  Thus:
+
+        Eq (T a b) = (Ping a, Pong b, ...)
+
+Now we can get a (recursive) equation from the data decl.  This part
+is done by inferConstraints.
+
+        Eq (T a b) = Eq (Foo a) u Eq (Bar b)    -- From C1
+                   u Eq (T b a) u Eq Int        -- From C2
+                   u Eq (T a a)                 -- From C3
+
+
+Foo and Bar may have explicit instances for Eq, in which case we can
+just substitute for them.  Alternatively, either or both may have
+their Eq instances given by deriving clauses, in which case they
+form part of the system of equations.
+
+Now all we need do is simplify and solve the equations, iterating to
+find the least fixpoint.  This is done by simplifyInstanceConstraints.
+Notice that the order of the arguments can
+switch around, as here in the recursive calls to T.
+
+Let's suppose Eq (Foo a) = Eq a, and Eq (Bar b) = Ping b.
+
+We start with:
+
+        Eq (T a b) = {}         -- The empty set
+
+Next iteration:
+        Eq (T a b) = Eq (Foo a) u Eq (Bar b)    -- From C1
+                   u Eq (T b a) u Eq Int        -- From C2
+                   u Eq (T a a)                 -- From C3
+
+        After simplification:
+                   = Eq a u Ping b u {} u {} u {}
+                   = Eq a u Ping b
+
+Next iteration:
+
+        Eq (T a b) = Eq (Foo a) u Eq (Bar b)    -- From C1
+                   u Eq (T b a) u Eq Int        -- From C2
+                   u Eq (T a a)                 -- From C3
+
+        After simplification:
+                   = Eq a u Ping b
+                   u (Eq b u Ping a)
+                   u (Eq a u Ping a)
+
+                   = Eq a u Ping b u Eq b u Ping a
+
+The next iteration gives the same result, so this is the fixpoint.  We
+need to make a canonical form of the RHS to ensure convergence.  We do
+this by simplifying the RHS to a form in which
+
+        - the classes constrain only tyvars
+        - the list is sorted by tyvar (major key) and then class (minor key)
+        - no duplicates, of course
+
+Note [Deterministic simplifyInstanceContexts]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Canonicalisation uses nonDetCmpType which is nondeterministic. Sorting
+with nonDetCmpType puts the returned lists in a nondeterministic order.
+If we were to return them, we'd get class constraints in
+nondeterministic order.
+
+Consider:
+
+  data ADT a b = Z a b deriving Eq
+
+The generated code could be either:
+
+  instance (Eq a, Eq b) => Eq (Z a b) where
+
+Or:
+
+  instance (Eq b, Eq a) => Eq (Z a b) where
+
+To prevent the order from being nondeterministic we only
+canonicalize when comparing and return them in the same order as
+simplifyDeriv returned them.
+See also Note [nonDetCmpType nondeterminism]
+-}
+
+
+simplifyInstanceContexts :: [DerivSpec ThetaOrigin] -> TcM [DerivSpec ThetaType]
+-- Used only for deriving clauses (InferTheta)
+-- not for standalone deriving
+-- See Note [Simplifying the instance context]
+
+simplifyInstanceContexts [] = return []
+
+simplifyInstanceContexts infer_specs
+  = do  { traceTc "simplifyInstanceContexts" $ vcat (map pprDerivSpec infer_specs)
+        ; iterate_deriv 1 initial_solutions }
+  where
+    ------------------------------------------------------------------
+        -- The initial solutions for the equations claim that each
+        -- instance has an empty context; this solution is certainly
+        -- in canonical form.
+    initial_solutions :: [ThetaType]
+    initial_solutions = [ [] | _ <- infer_specs ]
+
+    ------------------------------------------------------------------
+        -- iterate_deriv calculates the next batch of solutions,
+        -- compares it with the current one; finishes if they are the
+        -- same, otherwise recurses with the new solutions.
+        -- It fails if any iteration fails
+    iterate_deriv :: Int -> [ThetaType] -> TcM [DerivSpec ThetaType]
+    iterate_deriv n current_solns
+      | n > 20  -- Looks as if we are in an infinite loop
+                -- This can happen if we have -XUndecidableInstances
+                -- (See TcSimplify.tcSimplifyDeriv.)
+      = pprPanic "solveDerivEqns: probable loop"
+                 (vcat (map pprDerivSpec infer_specs) $$ ppr current_solns)
+      | 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
+           ; new_solns <- checkNoErrs $
+                          extendLocalInstEnv inst_specs $
+                          mapM gen_soln infer_specs
+
+           ; if (current_solns `eqSolution` new_solns) then
+                return [ spec { ds_theta = soln }
+                       | (spec, soln) <- zip infer_specs current_solns ]
+             else
+                iterate_deriv (n+1) new_solns }
+
+    eqSolution a b = eqListBy (eqListBy eqType) (canSolution a) (canSolution b)
+       -- Canonicalise for comparison
+       -- See Note [Deterministic simplifyInstanceContexts]
+    canSolution = map (sortBy nonDetCmpType)
+    ------------------------------------------------------------------
+    gen_soln :: DerivSpec ThetaOrigin -> TcM ThetaType
+    gen_soln (DS { ds_loc = loc, ds_tvs = tyvars
+                 , ds_cls = clas, ds_tys = inst_tys, ds_theta = deriv_rhs })
+      = setSrcSpan loc  $
+        addErrCtxt (derivInstCtxt the_pred) $
+        do { theta <- simplifyDeriv the_pred tyvars deriv_rhs
+                -- checkValidInstance tyvars theta clas inst_tys
+                -- Not necessary; see Note [Exotic derived instance contexts]
+
+           ; traceTc "TcDeriv" (ppr deriv_rhs $$ ppr theta)
+                -- Claim: the result instance declaration is guaranteed valid
+                -- Hence no need to call:
+                --   checkValidInstance tyvars theta clas inst_tys
+           ; return theta }
+      where
+        the_pred = mkClassPred clas inst_tys
+
+derivInstCtxt :: PredType -> MsgDoc
+derivInstCtxt pred
+  = text "When deriving the instance for" <+> parens (ppr pred)
+
+{-
+***********************************************************************************
+*                                                                                 *
+*            Simplify derived constraints
+*                                                                                 *
+***********************************************************************************
+-}
+
+-- | Given @instance (wanted) => C inst_ty@, simplify 'wanted' as much
+-- as possible. Fail if not possible.
+simplifyDeriv :: PredType -- ^ @C inst_ty@, head of the instance we are
+                          -- deriving.  Only used for SkolemInfo.
+              -> [TyVar]  -- ^ The tyvars bound by @inst_ty@.
+              -> ThetaOrigin   -- ^ @wanted@ constraints, i.e. @['PredOrigin']@.
+              -> TcM ThetaType -- ^ Needed constraints (after simplification),
+                               -- i.e. @['PredType']@.
+simplifyDeriv pred tvs theta
+  = do { (skol_subst, tvs_skols) <- tcInstSkolTyVars tvs -- Skolemize
+                -- The constraint solving machinery
+                -- expects *TcTyVars* not TyVars.
+                -- We use *non-overlappable* (vanilla) skolems
+                -- See Note [Overlap and deriving]
+
+       ; let skol_set  = mkVarSet tvs_skols
+             skol_info = DerivSkol pred
+             doc = text "deriving" <+> parens (ppr pred)
+             mk_ct (PredOrigin t o t_or_k)
+                 = newWanted o (Just t_or_k) (substTy skol_subst t)
+
+       -- Generate the wanted constraints with the skolemized variables
+       ; (wanted, tclvl) <- pushTcLevelM (mapM mk_ct theta)
+
+       ; traceTc "simplifyDeriv inputs" $
+         vcat [ pprTvBndrs tvs $$ ppr theta $$ ppr wanted, doc ]
+       -- Simplify the constraints
+       ; residual_wanted <- simplifyWantedsTcM wanted
+            -- Result is zonked
+
+       -- Split the resulting constraints into bad and good constraints,
+       -- building an @unsolved :: WantedConstraints@ representing all
+       -- the constraints we can't just shunt to the predicates.
+       -- See Note [Exotic derived instance contexts]
+       ; let residual_simple = wc_simple residual_wanted
+             (bad, good) = partitionBagWith get_good residual_simple
+             unsolved    = residual_wanted { wc_simple = bad }
+
+                         -- See Note [Exotic derived instance contexts]
+
+             get_good :: Ct -> Either Ct PredType
+             get_good ct | validDerivPred skol_set p
+                         , isWantedCt ct
+                         = Right p
+                          -- NB re 'isWantedCt': residual_wanted may contain
+                          -- unsolved CtDerived and we stick them into the
+                          -- bad set so that reportUnsolved may decide what
+                          -- to do with them
+                         | otherwise
+                         = Left ct
+                           where p = ctPred ct
+
+       ; traceTc "simplifyDeriv outputs" $
+         vcat [ ppr tvs_skols, ppr residual_simple, ppr good, ppr bad ]
+
+       -- If we are deferring type errors, simply ignore any insoluble
+       -- constraints.  They'll come up again when we typecheck the
+       -- generated instance declaration
+       ; defer <- goptM Opt_DeferTypeErrors
+       ; (implic, _) <- buildImplicationFor tclvl skol_info tvs_skols [] unsolved
+                   -- The buildImplicationFor is just to bind the skolems,
+                   -- in case they are mentioned in error messages
+                   -- See Trac #11347
+       -- Report the (bad) unsolved constraints
+       ; unless defer (reportAllUnsolved (mkImplicWC implic))
+
+
+       -- Return the good unsolved constraints (unskolemizing on the way out.)
+       ; let min_theta  = mkMinimalBySCs (bagToList good)
+             subst_skol = zipTvSubst tvs_skols $ mkTyVarTys tvs
+                          -- The reverse substitution (sigh)
+       ; return (substTheta subst_skol min_theta) }
+
+{-
+Note [Overlap and deriving]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider some overlapping instances:
+  data Show a => Show [a] where ..
+  data Show [Char] where ...
+
+Now a data type with deriving:
+  data T a = MkT [a] deriving( Show )
+
+We want to get the derived instance
+  instance Show [a] => Show (T a) where...
+and NOT
+  instance Show a => Show (T a) where...
+so that the (Show (T Char)) instance does the Right Thing
+
+It's very like the situation when we're inferring the type
+of a function
+   f x = show [x]
+and we want to infer
+   f :: Show [a] => a -> String
+
+BOTTOM LINE: use vanilla, non-overlappable skolems when inferring
+             the context for the derived instance.
+             Hence tcInstSkolTyVars not tcInstSuperSkolTyVars
+
+Note [Exotic derived instance contexts]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+In a 'derived' instance declaration, we *infer* the context.  It's a
+bit unclear what rules we should apply for this; the Haskell report is
+silent.  Obviously, constraints like (Eq a) are fine, but what about
+        data T f a = MkT (f a) deriving( Eq )
+where we'd get an Eq (f a) constraint.  That's probably fine too.
+
+One could go further: consider
+        data T a b c = MkT (Foo a b c) deriving( Eq )
+        instance (C Int a, Eq b, Eq c) => Eq (Foo a b c)
+
+Notice that this instance (just) satisfies the Paterson termination
+conditions.  Then we *could* derive an instance decl like this:
+
+        instance (C Int a, Eq b, Eq c) => Eq (T a b c)
+even though there is no instance for (C Int a), because there just
+*might* be an instance for, say, (C Int Bool) at a site where we
+need the equality instance for T's.
+
+However, this seems pretty exotic, and it's quite tricky to allow
+this, and yet give sensible error messages in the (much more common)
+case where we really want that instance decl for C.
+
+So for now we simply require that the derived instance context
+should have only type-variable constraints.
+
+Here is another example:
+        data Fix f = In (f (Fix f)) deriving( Eq )
+Here, if we are prepared to allow -XUndecidableInstances we
+could derive the instance
+        instance Eq (f (Fix f)) => Eq (Fix f)
+but this is so delicate that I don't think it should happen inside
+'deriving'. If you want this, write it yourself!
+
+NB: if you want to lift this condition, make sure you still meet the
+termination conditions!  If not, the deriving mechanism generates
+larger and larger constraints.  Example:
+  data Succ a = S a
+  data Seq a = Cons a (Seq (Succ a)) | Nil deriving Show
+
+Note the lack of a Show instance for Succ.  First we'll generate
+  instance (Show (Succ a), Show a) => Show (Seq a)
+and then
+  instance (Show (Succ (Succ a)), Show (Succ a), Show a) => Show (Seq a)
+and so on.  Instead we want to complain of no instance for (Show (Succ a)).
+
+The bottom line
+~~~~~~~~~~~~~~~
+Allow constraints which consist only of type variables, with no repeats.
+-}
diff --git a/compiler/typecheck/TcDerivUtils.hs b/compiler/typecheck/TcDerivUtils.hs
new file mode 100644
index 0000000000..9eef9f1738
--- /dev/null
+++ b/compiler/typecheck/TcDerivUtils.hs
@@ -0,0 +1,610 @@
+{-
+(c) The University of Glasgow 2006
+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998
+
+
+Error-checking and other utilities for @deriving@ clauses or declarations.
+-}
+
+{-# LANGUAGE ImplicitParams #-}
+
+module TcDerivUtils (
+        DerivSpec(..), pprDerivSpec, DerivSpecMechanism(..),
+        DerivContext, DerivStatus(..),
+        PredOrigin(..), ThetaOrigin, mkPredOrigin,
+        mkThetaOrigin, substPredOrigin, substThetaOrigin,
+        checkSideConditions, hasStockDeriving,
+        canDeriveAnyClass,
+        std_class_via_coercible, non_coercible_class,
+        newDerivClsInst, extendLocalInstEnv
+    ) where
+
+import Bag
+import BasicTypes
+import Class
+import DataCon
+import DynFlags
+import ErrUtils
+import HscTypes (lookupFixity, mi_fix)
+import HsSyn
+import Inst
+import InstEnv
+import LoadIface (loadInterfaceForName)
+import Module (getModule)
+import Name
+import Outputable
+import PrelNames
+import RdrName
+import SrcLoc
+import TcGenDeriv
+import TcGenFunctor
+import TcGenGenerics
+import TcRnMonad
+import TcType
+import THNames (liftClassKey)
+import TyCon
+import Type
+import Util
+import VarSet
+
+import qualified GHC.LanguageExtensions as LangExt
+import ListSetOps (assocMaybe)
+
+data DerivSpec theta = DS { ds_loc       :: SrcSpan
+                          , ds_name      :: Name         -- DFun name
+                          , ds_tvs       :: [TyVar]
+                          , ds_theta     :: theta
+                          , ds_cls       :: Class
+                          , ds_tys       :: [Type]
+                          , ds_tc        :: TyCon
+                          , ds_overlap   :: Maybe OverlapMode
+                          , ds_mechanism :: DerivSpecMechanism }
+        -- This spec implies a dfun declaration of the form
+        --       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
+
+        -- ds_mechanism specifies the means by which GHC derives the instance.
+        -- See Note [Deriving strategies] in TcDeriv
+
+{-
+Example:
+
+     newtype instance T [a] = MkT (Tree a) deriving( C s )
+==>
+     axiom T [a] = :RTList a
+     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) }
+-}
+
+pprDerivSpec :: Outputable theta => DerivSpec theta -> SDoc
+pprDerivSpec (DS { ds_loc = l, ds_name = n, ds_tvs = tvs,
+                   ds_cls = c, ds_tys = tys, ds_theta = rhs })
+  = hang (text "DerivSpec")
+       2 (vcat [ text "ds_loc   =" <+> ppr l
+               , text "ds_name  =" <+> ppr n
+               , text "ds_tvs   =" <+> ppr tvs
+               , text "ds_cls   =" <+> ppr c
+               , text "ds_tys   =" <+> ppr tys
+               , text "ds_theta =" <+> ppr rhs ])
+
+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
+-- NB: DerivSpecMechanism is purely local to this module
+data DerivSpecMechanism
+  = DerivSpecStock   -- "Standard" classes
+      (SrcSpan -> TyCon -> [Type] -> TcM (LHsBinds RdrName, BagDerivStuff))
+
+  | DerivSpecNewtype -- -XGeneralizedNewtypeDeriving
+      Type -- ^ The newtype rep type
+
+  | DerivSpecAnyClass -- -XDeriveAnyClass
+
+type DerivContext = Maybe ThetaType
+   -- Nothing    <=> Vanilla deriving; infer the context of the instance decl
+   -- Just theta <=> Standalone deriving: context supplied by programmer
+
+data DerivStatus = CanDerive                 -- Stock class, can derive
+                 | DerivableClassError SDoc  -- Stock class, but can't do it
+                 | DerivableViaInstance      -- See Note [Deriving any class]
+                 | NonDerivableClass SDoc    -- Non-stock class
+
+-- 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.
+
+-- | A 'PredType' annotated with the origin of the constraint 'CtOrigin',
+-- and whether or the constraint deals in types or kinds.
+data PredOrigin = PredOrigin PredType CtOrigin TypeOrKind
+type ThetaOrigin = [PredOrigin]
+
+instance Outputable PredOrigin where
+  ppr (PredOrigin ty _ _) = ppr ty -- The origin is not so interesting when debugging
+
+mkPredOrigin :: CtOrigin -> TypeOrKind -> PredType -> PredOrigin
+mkPredOrigin origin t_or_k pred = PredOrigin pred origin t_or_k
+
+mkThetaOrigin :: CtOrigin -> TypeOrKind -> ThetaType -> ThetaOrigin
+mkThetaOrigin origin t_or_k = map (mkPredOrigin origin t_or_k)
+
+substPredOrigin :: HasCallStack => TCvSubst -> PredOrigin -> PredOrigin
+substPredOrigin subst (PredOrigin pred origin t_or_k)
+  = PredOrigin (substTy subst pred) origin t_or_k
+
+substThetaOrigin :: HasCallStack => TCvSubst -> ThetaOrigin -> ThetaOrigin
+substThetaOrigin subst = map (substPredOrigin subst)
+
+{-
+************************************************************************
+*                                                                      *
+                Class deriving diagnostics
+*                                                                      *
+************************************************************************
+
+Only certain blessed classes can be used in a deriving clause (without the
+assistance of GeneralizedNewtypeDeriving or DeriveAnyClass). These classes
+are listed below in the definition of hasStockDeriving. The sideConditions
+function determines the criteria that needs to be met in order for a particular
+class to be able to be derived successfully.
+
+A class might be able to be used in a deriving clause if -XDeriveAnyClass
+is willing to support it. The canDeriveAnyClass function checks if this is the
+case.
+-}
+
+hasStockDeriving :: Class
+                   -> Maybe (SrcSpan
+                             -> TyCon
+                             -> [Type]
+                             -> TcM (LHsBinds RdrName, BagDerivStuff))
+hasStockDeriving clas
+  = assocMaybe gen_list (getUnique clas)
+  where
+    gen_list :: [(Unique, SrcSpan
+                          -> TyCon
+                          -> [Type]
+                          -> TcM (LHsBinds RdrName, BagDerivStuff))]
+    gen_list = [ (eqClassKey,          simple gen_Eq_binds)
+               , (ordClassKey,         simple gen_Ord_binds)
+               , (enumClassKey,        simple gen_Enum_binds)
+               , (boundedClassKey,     simple gen_Bounded_binds)
+               , (ixClassKey,          simple gen_Ix_binds)
+               , (showClassKey,        with_fix_env gen_Show_binds)
+               , (readClassKey,        with_fix_env 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 tc _
+      = return (gen_fn loc tc)
+
+    simpleM gen_fn loc tc _
+      = gen_fn loc tc
+
+    with_fix_env gen_fn loc tc _
+      = do { fix_env <- getDataConFixityFun tc
+           ; return (gen_fn fix_env loc tc) }
+
+    generic gen_fn _ tc inst_tys
+      = do { (binds, faminst) <- gen_fn tc inst_tys
+           ; return (binds, unitBag (DerivFamInst faminst)) }
+
+getDataConFixityFun :: TyCon -> TcM (Name -> Fixity)
+-- If the TyCon is locally defined, we want the local fixity env;
+-- but if it is imported (which happens for standalone deriving)
+-- we need to get the fixity env from the interface file
+-- c.f. RnEnv.lookupFixity, and Trac #9830
+getDataConFixityFun tc
+  = do { this_mod <- getModule
+       ; if nameIsLocalOrFrom this_mod name
+         then do { fix_env <- getFixityEnv
+                 ; return (lookupFixity fix_env) }
+         else do { iface <- loadInterfaceForName doc name
+                            -- Should already be loaded!
+                 ; return (mi_fix iface . nameOccName) } }
+  where
+    name = tyConName tc
+    doc = text "Data con fixities for" <+> ppr name
+
+------------------------------------------------------------------
+-- Check side conditions that dis-allow derivability for particular classes
+-- This is *apart* from the newtype-deriving mechanism
+--
+-- Here we get the representation tycon in case of family instances as it has
+-- the data constructors - but we need to be careful to fall back to the
+-- family tycon (with indexes) in error messages.
+
+checkSideConditions :: DynFlags -> DerivContext -> Class -> [TcType]
+                    -> TyCon -- tycon
+                    -> DerivStatus
+checkSideConditions dflags mtheta cls cls_tys rep_tc
+  | Just cond <- sideConditions mtheta cls
+  = case (cond dflags rep_tc) of
+        NotValid err -> DerivableClassError err  -- Class-specific error
+        IsValid  | null (filterOutInvisibleTypes (classTyCon cls) cls_tys)
+                   -> CanDerive
+                   -- All stock derivable classes are unary in the sense that
+                   -- there should be not types in cls_tys (i.e., no type args
+                   -- other than last). Note that cls_types can contain
+                   -- invisible types as well (e.g., for Generic1, which is
+                   -- poly-kinded), so make sure those are not counted.
+                 | otherwise -> DerivableClassError (classArgsErr cls cls_tys)
+                   -- e.g. deriving( Eq s )
+
+  | Just err <- canDeriveAnyClass dflags rep_tc cls
+  = NonDerivableClass err  -- DeriveAnyClass does not work
+
+  | otherwise
+  = DerivableViaInstance   -- DeriveAnyClass should work
+
+classArgsErr :: Class -> [Type] -> SDoc
+classArgsErr cls cls_tys = quotes (ppr (mkClassPred cls cls_tys)) <+> text "is not a class"
+
+-- Side conditions (whether the datatype must have at least one constructor,
+-- required language extensions, etc.) for using GHC's stock deriving
+-- mechanism on certain classes (as opposed to classes that require
+-- GeneralizedNewtypeDeriving or DeriveAnyClass). Returns Nothing for a
+-- class for which stock deriving isn't possible.
+sideConditions :: DerivContext -> Class -> Maybe Condition
+sideConditions mtheta cls
+  | cls_key == eqClassKey          = Just (cond_std `andCond` cond_args cls)
+  | cls_key == ordClassKey         = Just (cond_std `andCond` cond_args cls)
+  | cls_key == showClassKey        = Just (cond_std `andCond` cond_args cls)
+  | cls_key == readClassKey        = Just (cond_std `andCond` cond_args cls)
+  | cls_key == enumClassKey        = Just (cond_std `andCond` cond_isEnumeration)
+  | cls_key == ixClassKey          = Just (cond_std `andCond` cond_enumOrProduct cls)
+  | cls_key == boundedClassKey     = Just (cond_std `andCond` cond_enumOrProduct cls)
+  | cls_key == dataClassKey        = Just (checkFlag LangExt.DeriveDataTypeable `andCond`
+                                           cond_std `andCond`
+                                           cond_args cls)
+  | cls_key == functorClassKey     = Just (checkFlag LangExt.DeriveFunctor `andCond`
+                                           cond_vanilla `andCond`
+                                           cond_functorOK True False)
+  | cls_key == foldableClassKey    = Just (checkFlag LangExt.DeriveFoldable `andCond`
+                                           cond_vanilla `andCond`
+                                           cond_functorOK False True)
+                                           -- Functor/Fold/Trav works ok
+                                           -- for rank-n types
+  | cls_key == traversableClassKey = Just (checkFlag LangExt.DeriveTraversable `andCond`
+                                           cond_vanilla `andCond`
+                                           cond_functorOK False False)
+  | cls_key == genClassKey         = Just (checkFlag LangExt.DeriveGeneric `andCond`
+                                           cond_vanilla `andCond`
+                                           cond_RepresentableOk)
+  | cls_key == gen1ClassKey        = Just (checkFlag LangExt.DeriveGeneric `andCond`
+                                           cond_vanilla `andCond`
+                                           cond_Representable1Ok)
+  | cls_key == liftClassKey        = Just (checkFlag LangExt.DeriveLift `andCond`
+                                           cond_vanilla `andCond`
+                                           cond_args cls)
+  | otherwise                      = Nothing
+  where
+    cls_key = getUnique cls
+    cond_std     = cond_stdOK mtheta False  -- Vanilla data constructors, at least one,
+                                            --    and monotype arguments
+    cond_vanilla = cond_stdOK mtheta True   -- Vanilla data constructors but
+                                            --   allow no data cons or polytype arguments
+
+canDeriveAnyClass :: DynFlags -> TyCon -> Class -> Maybe SDoc
+-- Nothing: we can (try to) derive it via an empty instance declaration
+-- Just s:  we can't, reason s
+-- Precondition: the class is not one of the standard ones
+canDeriveAnyClass dflags _tycon clas
+  | not (xopt LangExt.DeriveAnyClass dflags)
+  = Just (text "Try enabling DeriveAnyClass")
+  | not (any (target_kind `tcEqKind`) [ liftedTypeKind, typeToTypeKind ])
+  = Just (text "The last argument of class" <+> quotes (ppr clas)
+          <+> text "does not have kind * or (* -> *)")
+  | otherwise
+  = Nothing   -- OK!
+  where
+    -- We are making an instance  (C t1 .. tn (T s1 .. sm))
+    -- and we can only do so if the kind of C's last argument
+    -- is * or (* -> *).  Because only then can we make a reasonable
+    -- guess at the instance context
+    target_kind = tyVarKind (last (classTyVars clas))
+
+typeToTypeKind :: Kind
+typeToTypeKind = liftedTypeKind `mkFunTy` liftedTypeKind
+
+type Condition = DynFlags -> TyCon -> Validity
+        -- TyCon is the *representation* tycon if the data type is an indexed one
+        -- Nothing => OK
+
+orCond :: Condition -> Condition -> Condition
+orCond c1 c2 dflags tc
+  = case (c1 dflags tc, c2 dflags tc) of
+     (IsValid,    _)          -> IsValid    -- c1 succeeds
+     (_,          IsValid)    -> IsValid    -- c21 succeeds
+     (NotValid x, NotValid y) -> NotValid (x $$ text "  or" $$ y)
+                                            -- Both fail
+
+andCond :: Condition -> Condition -> Condition
+andCond c1 c2 dflags tc = c1 dflags tc `andValid` c2 dflags tc
+
+cond_stdOK :: DerivContext -- Says whether this is standalone deriving or not;
+                           --     if standalone, we just say "yes, go for it"
+           -> Bool         -- True <=> permissive: allow higher rank
+                           --          args and no data constructors
+           -> Condition
+cond_stdOK (Just _) _ _ _
+  = IsValid     -- Don't check these conservative conditions for
+                -- standalone deriving; just generate the code
+                -- and let the typechecker handle the result
+cond_stdOK Nothing permissive _ rep_tc
+  | null data_cons
+  , not permissive      = NotValid (no_cons_why rep_tc $$ suggestion)
+  | not (null con_whys) = NotValid (vcat con_whys $$ suggestion)
+  | otherwise           = IsValid
+  where
+    suggestion = text "Possible fix: use a standalone deriving declaration instead"
+    data_cons  = tyConDataCons rep_tc
+    con_whys   = getInvalids (map check_con data_cons)
+
+    check_con :: DataCon -> Validity
+    check_con con
+      | not (null eq_spec)
+      = bad "is a GADT"
+      | not (null ex_tvs)
+      = bad "has existential type variables in its type"
+      | not (null theta)
+      = bad "has constraints in its type"
+      | not (permissive || all isTauTy (dataConOrigArgTys con))
+      = bad "has a higher-rank type"
+      | otherwise
+      = IsValid
+      where
+        (_, ex_tvs, eq_spec, theta, _, _) = dataConFullSig con
+        bad msg = NotValid (badCon con (text msg))
+
+no_cons_why :: TyCon -> SDoc
+no_cons_why rep_tc = quotes (pprSourceTyCon rep_tc) <+>
+                     text "must have at least one data constructor"
+
+cond_RepresentableOk :: Condition
+cond_RepresentableOk _ tc = canDoGenerics tc
+
+cond_Representable1Ok :: Condition
+cond_Representable1Ok _ tc = canDoGenerics1 tc
+
+cond_enumOrProduct :: Class -> Condition
+cond_enumOrProduct cls = cond_isEnumeration `orCond`
+                         (cond_isProduct `andCond` cond_args cls)
+
+cond_args :: Class -> Condition
+-- For some classes (eg Eq, Ord) we allow unlifted arg types
+-- by generating specialised code.  For others (eg Data) we don't.
+cond_args cls _ tc
+  = case bad_args of
+      []     -> IsValid
+      (ty:_) -> NotValid (hang (text "Don't know how to derive" <+> quotes (ppr cls))
+                             2 (text "for type" <+> quotes (ppr ty)))
+  where
+    bad_args = [ arg_ty | con <- tyConDataCons tc
+                        , arg_ty <- dataConOrigArgTys con
+                        , isUnliftedType arg_ty
+                        , not (ok_ty arg_ty) ]
+
+    cls_key = classKey cls
+    ok_ty arg_ty
+     | cls_key == eqClassKey   = check_in arg_ty ordOpTbl
+     | cls_key == ordClassKey  = check_in arg_ty ordOpTbl
+     | cls_key == showClassKey = check_in arg_ty boxConTbl
+     | cls_key == liftClassKey = check_in arg_ty litConTbl
+     | otherwise               = False    -- Read, Ix etc
+
+    check_in :: Type -> [(Type,a)] -> Bool
+    check_in arg_ty tbl = any (eqType arg_ty . fst) tbl
+
+
+cond_isEnumeration :: Condition
+cond_isEnumeration _ rep_tc
+  | isEnumerationTyCon rep_tc = IsValid
+  | otherwise                 = NotValid why
+  where
+    why = sep [ quotes (pprSourceTyCon rep_tc) <+>
+                  text "must be an enumeration type"
+              , text "(an enumeration consists of one or more nullary, non-GADT constructors)" ]
+                  -- See Note [Enumeration types] in TyCon
+
+cond_isProduct :: Condition
+cond_isProduct _ rep_tc
+  | isProductTyCon rep_tc = IsValid
+  | otherwise             = NotValid why
+  where
+    why = quotes (pprSourceTyCon rep_tc) <+>
+          text "must have precisely one constructor"
+
+cond_functorOK :: Bool -> Bool -> Condition
+-- OK for Functor/Foldable/Traversable class
+-- Currently: (a) at least one argument
+--            (b) don't use argument contravariantly
+--            (c) don't use argument in the wrong place, e.g. data T a = T (X a a)
+--            (d) optionally: don't use function types
+--            (e) no "stupid context" on data type
+cond_functorOK allowFunctions allowExQuantifiedLastTyVar _ rep_tc
+  | null tc_tvs
+  = NotValid (text "Data type" <+> quotes (ppr rep_tc)
+              <+> text "must have some type parameters")
+
+  | not (null bad_stupid_theta)
+  = NotValid (text "Data type" <+> quotes (ppr rep_tc)
+              <+> text "must not have a class context:" <+> pprTheta bad_stupid_theta)
+
+  | otherwise
+  = allValid (map check_con data_cons)
+  where
+    tc_tvs            = tyConTyVars rep_tc
+    Just (_, last_tv) = snocView tc_tvs
+    bad_stupid_theta  = filter is_bad (tyConStupidTheta rep_tc)
+    is_bad pred       = last_tv `elemVarSet` tyCoVarsOfType pred
+
+    data_cons = tyConDataCons rep_tc
+    check_con con = allValid (check_universal con : foldDataConArgs (ft_check con) con)
+
+    check_universal :: DataCon -> Validity
+    check_universal con
+      | allowExQuantifiedLastTyVar
+      = IsValid -- See Note [DeriveFoldable with ExistentialQuantification]
+                -- in TcGenFunctor
+      | Just tv <- getTyVar_maybe (last (tyConAppArgs (dataConOrigResTy con)))
+      , tv `elem` dataConUnivTyVars con
+      , not (tv `elemVarSet` tyCoVarsOfTypes (dataConTheta con))
+      = IsValid   -- See Note [Check that the type variable is truly universal]
+      | otherwise
+      = NotValid (badCon con existential)
+
+    ft_check :: DataCon -> FFoldType Validity
+    ft_check con = FT { ft_triv = IsValid, ft_var = IsValid
+                      , ft_co_var = NotValid (badCon con covariant)
+                      , ft_fun = \x y -> if allowFunctions then x `andValid` y
+                                                           else NotValid (badCon con functions)
+                      , ft_tup = \_ xs  -> allValid xs
+                      , ft_ty_app = \_ x   -> x
+                      , ft_bad_app = NotValid (badCon con wrong_arg)
+                      , ft_forall = \_ x   -> x }
+
+    existential = text "must be truly polymorphic in the last argument of the data type"
+    covariant   = text "must not use the type variable in a function argument"
+    functions   = text "must not contain function types"
+    wrong_arg   = text "must use the type variable only as the last argument of a data type"
+
+checkFlag :: LangExt.Extension -> Condition
+checkFlag flag dflags _
+  | xopt flag dflags = IsValid
+  | otherwise        = NotValid why
+  where
+    why = text "You need " <> text flag_str
+          <+> text "to derive an instance for this class"
+    flag_str = case [ flagSpecName f | f <- xFlags , flagSpecFlag f == flag ] of
+                 [s]   -> s
+                 other -> pprPanic "checkFlag" (ppr other)
+
+std_class_via_coercible :: Class -> Bool
+-- These standard classes can be derived for a newtype
+-- using the coercible trick *even if no -XGeneralizedNewtypeDeriving
+-- because giving so gives the same results as generating the boilerplate
+std_class_via_coercible clas
+  = classKey clas `elem` [eqClassKey, ordClassKey, ixClassKey, boundedClassKey]
+        -- Not Read/Show because they respect the type
+        -- Not Enum, because newtypes are never in Enum
+
+
+non_coercible_class :: Class -> Bool
+-- *Never* derive Read, Show, Typeable, Data, Generic, Generic1, Lift
+-- by Coercible, even with -XGeneralizedNewtypeDeriving
+-- Also, avoid Traversable, as the Coercible-derived instance and the "normal"-derived
+-- instance behave differently if there's a non-lawful Applicative out there.
+-- Besides, with roles, Coercible-deriving Traversable is ill-roled.
+non_coercible_class cls
+  = classKey cls `elem` ([ readClassKey, showClassKey, dataClassKey
+                         , genClassKey, gen1ClassKey, typeableClassKey
+                         , traversableClassKey, liftClassKey ])
+
+badCon :: DataCon -> SDoc -> SDoc
+badCon con msg = text "Constructor" <+> quotes (ppr con) <+> msg
+
+------------------------------------------------------------------
+
+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 })
+  = newClsInst overlap_mode dfun_name tvs theta clas tys
+
+extendLocalInstEnv :: [ClsInst] -> TcM a -> TcM a
+-- Add new locally-defined instances; don't bother to check
+-- for functional dependency errors -- that'll happen in TcInstDcls
+extendLocalInstEnv dfuns thing_inside
+ = do { env <- getGblEnv
+      ; let  inst_env' = extendInstEnvList (tcg_inst_env env) dfuns
+             env'      = env { tcg_inst_env = inst_env' }
+      ; setGblEnv env' thing_inside }
+
+{-
+Note [Deriving any class]
+~~~~~~~~~~~~~~~~~~~~~~~~~
+Classic uses of a deriving clause, or a standalone-deriving declaration, are
+for:
+  * a stock class like Eq or Show, for which GHC knows how to generate
+    the instance code
+  * a newtype, via the mechanism enabled by GeneralizedNewtypeDeriving
+
+The DeriveAnyClass extension adds a third way to derive instances, based on
+empty instance declarations.
+
+The canonical use case is in combination with GHC.Generics and default method
+signatures. These allow us to have instance declarations being empty, but still
+useful, e.g.
+
+  data T a = ...blah..blah... deriving( Generic )
+  instance C a => C (T a)  -- No 'where' clause
+
+where C is some "random" user-defined class.
+
+This boilerplate code can be replaced by the more compact
+
+  data T a = ...blah..blah... deriving( Generic, C )
+
+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.
+
+Note [Check that the type variable is truly universal]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+For Functor and Traversable instances, we must check that the *last argument*
+of the type constructor is used truly universally quantified.  Example
+
+   data T a b where
+     T1 :: a -> b -> T a b      -- Fine! Vanilla H-98
+     T2 :: b -> c -> T a b      -- Fine! Existential c, but we can still map over 'b'
+     T3 :: b -> T Int b         -- Fine! Constraint 'a', but 'b' is still polymorphic
+     T4 :: Ord b => b -> T a b  -- No!  'b' is constrained
+     T5 :: b -> T b b           -- No!  'b' is constrained
+     T6 :: T a (b,b)            -- No!  'b' is constrained
+
+Notice that only the first of these constructors is vanilla H-98. We only
+need to take care about the last argument (b in this case).  See Trac #8678.
+Eg. for T1-T3 we can write
+
+     fmap f (T1 a b) = T1 a (f b)
+     fmap f (T2 b c) = T2 (f b) c
+     fmap f (T3 x)   = T3 (f x)
+
+We need not perform these checks for Foldable instances, however, since
+functions in Foldable can only consume existentially quantified type variables,
+rather than produce them (as is the case in Functor and Traversable functions.)
+As a result, T can have a derived Foldable instance:
+
+    foldr f z (T1 a b) = f b z
+    foldr f z (T2 b c) = f b z
+    foldr f z (T3 x)   = f x z
+    foldr f z (T4 x)   = f x z
+    foldr f z (T5 x)   = f x z
+    foldr _ z T6       = z
+
+See Note [DeriveFoldable with ExistentialQuantification] in TcGenFunctor.
+-}
diff --git a/compiler/typecheck/TcGenDeriv.hs b/compiler/typecheck/TcGenDeriv.hs
index 0a5fbb0cf9..6c44d0db81 100644
--- a/compiler/typecheck/TcGenDeriv.hs
+++ b/compiler/typecheck/TcGenDeriv.hs
@@ -18,26 +18,28 @@ This is where we do all the grimy bindings' generation.
 module TcGenDeriv (
         BagDerivStuff, DerivStuff(..),
 
-        hasStockDeriving,
-        FFoldType(..), functorLikeTraverse,
-        deepSubtypesContaining, foldDataConArgs,
-        mkCoerceClassMethEqn,
+        gen_Eq_binds,
+        gen_Ord_binds,
+        gen_Enum_binds,
+        gen_Bounded_binds,
+        gen_Ix_binds,
+        gen_Show_binds,
+        gen_Read_binds,
+        gen_Data_binds,
+        gen_Lift_binds,
         gen_Newtype_binds,
+        mkCoerceClassMethEqn,
         genAuxBinds,
         ordOpTbl, boxConTbl, litConTbl,
-        mkRdrFunBind
+        mkRdrFunBind, error_Expr
     ) where
 
 #include "HsVersions.h"
 
-
-import LoadIface( loadInterfaceForName )
-import HscTypes( lookupFixity, mi_fix )
 import TcRnMonad
 import HsSyn
 import RdrName
 import BasicTypes
-import Module( getModule )
 import DataCon
 import Name
 import Fingerprint
@@ -59,10 +61,8 @@ import TysPrim
 import TysWiredIn
 import Type
 import Class
-import TyCoRep
 import VarSet
 import VarEnv
-import State
 import Util
 import Var
 import Outputable
@@ -72,9 +72,7 @@ import Pair
 import Bag
 import StaticFlags( opt_PprStyle_Debug )
 
-import ListSetOps ( assocMaybe )
 import Data.List  ( partition, intersperse )
-import Data.Maybe ( catMaybes, isJust )
 
 type BagDerivStuff = Bag DerivStuff
 
@@ -95,72 +93,6 @@ data DerivStuff     -- Please add this auxiliary stuff
   -- New top-level auxiliary bindings
   | DerivHsBind (LHsBind RdrName, LSig RdrName) -- Also used for SYB
 
-{-
-************************************************************************
-*                                                                      *
-                Class deriving diagnostics
-*                                                                      *
-************************************************************************
-
-Only certain blessed classes can be used in a deriving clause (without the
-assistance of GeneralizedNewtypeDeriving or DeriveAnyClass). These classes
-are listed below in the definition of hasStockDeriving (with the exception
-of Generic and Generic1, which are handled separately in TcGenGenerics).
-
-A class might be able to be used in a deriving clause if -XDeriveAnyClass
-is willing to support it. The canDeriveAnyClass function in TcDeriv checks
-if this is the case.
--}
-
--- NB: The classes listed below should be in sync with the ones listed in
--- the definition of sideConditions in TcDeriv (except for Generic(1), as
--- noted above). If you add a new class to hasStockDeriving, make sure to
--- update sideConditions as well!
-hasStockDeriving :: Class
-                   -> Maybe (SrcSpan
-                             -> TyCon
-                             -> TcM (LHsBinds RdrName, BagDerivStuff))
-hasStockDeriving clas
-  = assocMaybe gen_list (getUnique clas)
-  where
-    gen_list :: [(Unique, SrcSpan -> TyCon -> TcM (LHsBinds RdrName, BagDerivStuff))]
-    gen_list = [ (eqClassKey,          simple gen_Eq_binds)
-               , (ordClassKey,         simple gen_Ord_binds)
-               , (enumClassKey,        simple gen_Enum_binds)
-               , (boundedClassKey,     simple gen_Bounded_binds)
-               , (ixClassKey,          simple gen_Ix_binds)
-               , (showClassKey,        with_fix_env gen_Show_binds)
-               , (readClassKey,        with_fix_env gen_Read_binds)
-               , (dataClassKey,        gen_Data_binds)
-               , (functorClassKey,     simple gen_Functor_binds)
-               , (foldableClassKey,    simple gen_Foldable_binds)
-               , (traversableClassKey, simple gen_Traversable_binds)
-               , (liftClassKey,        simple gen_Lift_binds) ]
-
-    simple gen_fn loc tc
-      = return (gen_fn loc tc)
-
-    with_fix_env gen_fn loc tc
-      = do { fix_env <- getDataConFixityFun tc
-           ; return (gen_fn fix_env loc tc) }
-
-getDataConFixityFun :: TyCon -> TcM (Name -> Fixity)
--- If the TyCon is locally defined, we want the local fixity env;
--- but if it is imported (which happens for standalone deriving)
--- we need to get the fixity env from the interface file
--- c.f. RnEnv.lookupFixity, and Trac #9830
-getDataConFixityFun tc
-  = do { this_mod <- getModule
-       ; if nameIsLocalOrFrom this_mod name
-         then do { fix_env <- getFixityEnv
-                 ; return (lookupFixity fix_env) }
-         else do { iface <- loadInterfaceForName doc name
-                            -- Should already be loaded!
-                 ; return (mi_fix iface . nameOccName) } }
-  where
-    name = tyConName tc
-    doc = text "Data con fixities for" <+> ppr name
-
 
 {-
 ************************************************************************
@@ -1533,589 +1465,6 @@ geDouble_RDR   = varQual_RDR  gHC_PRIM (fsLit ">=##")
 {-
 ************************************************************************
 *                                                                      *
-                        Functor instances
-
- see http://www.mail-archive.com/haskell-prime@haskell.org/msg02116.html
-
-*                                                                      *
-************************************************************************
-
-For the data type:
-
-  data T a = T1 Int a | T2 (T a)
-
-We generate the instance:
-
-  instance Functor T where
-      fmap f (T1 b1 a) = T1 b1 (f a)
-      fmap f (T2 ta)   = T2 (fmap f ta)
-
-Notice that we don't simply apply 'fmap' to the constructor arguments.
-Rather
-  - Do nothing to an argument whose type doesn't mention 'a'
-  - Apply 'f' to an argument of type 'a'
-  - Apply 'fmap f' to other arguments
-That's why we have to recurse deeply into the constructor argument types,
-rather than just one level, as we typically do.
-
-What about types with more than one type parameter?  In general, we only
-derive Functor for the last position:
-
-  data S a b = S1 [b] | S2 (a, T a b)
-  instance Functor (S a) where
-    fmap f (S1 bs)    = S1 (fmap f bs)
-    fmap f (S2 (p,q)) = S2 (a, fmap f q)
-
-However, we have special cases for
-         - tuples
-         - functions
-
-More formally, we write the derivation of fmap code over type variable
-'a for type 'b as ($fmap 'a 'b).  In this general notation the derived
-instance for T is:
-
-  instance Functor T where
-      fmap f (T1 x1 x2) = T1 ($(fmap 'a 'b1) x1) ($(fmap 'a 'a) x2)
-      fmap f (T2 x1)    = T2 ($(fmap 'a '(T a)) x1)
-
-  $(fmap 'a 'b)          =  \x -> x     -- when b does not contain a
-  $(fmap 'a 'a)          =  f
-  $(fmap 'a '(b1,b2))    =  \x -> case x of (x1,x2) -> ($(fmap 'a 'b1) x1, $(fmap 'a 'b2) x2)
-  $(fmap 'a '(T b1 b2))  =  fmap $(fmap 'a 'b2)   -- when a only occurs in the last parameter, b2
-  $(fmap 'a '(b -> c))   =  \x b -> $(fmap 'a' 'c) (x ($(cofmap 'a 'b) b))
-
-For functions, the type parameter 'a can occur in a contravariant position,
-which means we need to derive a function like:
-
-  cofmap :: (a -> b) -> (f b -> f a)
-
-This is pretty much the same as $fmap, only without the $(cofmap 'a 'a) case:
-
-  $(cofmap 'a 'b)          =  \x -> x     -- when b does not contain a
-  $(cofmap 'a 'a)          =  error "type variable in contravariant position"
-  $(cofmap 'a '(b1,b2))    =  \x -> case x of (x1,x2) -> ($(cofmap 'a 'b1) x1, $(cofmap 'a 'b2) x2)
-  $(cofmap 'a '[b])        =  map $(cofmap 'a 'b)
-  $(cofmap 'a '(T b1 b2))  =  fmap $(cofmap 'a 'b2)   -- when a only occurs in the last parameter, b2
-  $(cofmap 'a '(b -> c))   =  \x b -> $(cofmap 'a' 'c) (x ($(fmap 'a 'c) b))
-
-Note that the code produced by $(fmap _ _) is always a higher order function,
-with type `(a -> b) -> (g a -> g b)` for some g. When we need to do pattern
-matching on the type, this means create a lambda function (see the (,) case above).
-The resulting code for fmap can look a bit weird, for example:
-
-  data X a = X (a,Int)
-  -- generated instance
-  instance Functor X where
-      fmap f (X x) = (\y -> case y of (x1,x2) -> X (f x1, (\z -> z) x2)) x
-
-The optimizer should be able to simplify this code by simple inlining.
-
-An older version of the deriving code tried to avoid these applied
-lambda functions by producing a meta level function. But the function to
-be mapped, `f`, is a function on the code level, not on the meta level,
-so it was eta expanded to `\x -> [| f $x |]`. This resulted in too much eta expansion.
-It is better to produce too many lambdas than to eta expand, see ticket #7436.
--}
-
-gen_Functor_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, BagDerivStuff)
-gen_Functor_binds loc tycon
-  = (unitBag fmap_bind, emptyBag)
-  where
-    data_cons = tyConDataCons tycon
-    fun_name = L loc fmap_RDR
-    fmap_bind = mkRdrFunBind fun_name eqns
-
-    fmap_eqn con = evalState (match_for_con [f_Pat] con =<< parts) bs_RDRs
-      where
-        parts = sequence $ foldDataConArgs ft_fmap con
-
-    eqns | null data_cons = [mkSimpleMatch (FunRhs fun_name Prefix)
-                                           [nlWildPat, nlWildPat]
-                                           (error_Expr "Void fmap")]
-         | otherwise      = map fmap_eqn data_cons
-
-    ft_fmap :: FFoldType (State [RdrName] (LHsExpr RdrName))
-    ft_fmap = FT { ft_triv = mkSimpleLam $ \x -> return x
-                   -- fmap f = \x -> x
-                 , ft_var  = return f_Expr
-                   -- fmap f = f
-                 , ft_fun  = \g h -> do
-                     gg <- g
-                     hh <- h
-                     mkSimpleLam2 $ \x b -> return $
-                       nlHsApp hh (nlHsApp x (nlHsApp gg b))
-                   -- fmap f = \x b -> h (x (g b))
-                 , ft_tup = \t gs -> do
-                     gg <- sequence gs
-                     mkSimpleLam $ mkSimpleTupleCase match_for_con t gg
-                   -- fmap f = \x -> case x of (a1,a2,..) -> (g1 a1,g2 a2,..)
-                 , ft_ty_app = \_ g -> nlHsApp fmap_Expr <$> g
-                   -- fmap f = fmap g
-                 , ft_forall = \_ g -> g
-                 , ft_bad_app = panic "in other argument"
-                 , ft_co_var = panic "contravariant" }
-
-    -- Con a1 a2 ... -> Con (f1 a1) (f2 a2) ...
-    match_for_con :: [LPat RdrName] -> DataCon -> [LHsExpr RdrName]
-                  -> State [RdrName] (LMatch RdrName (LHsExpr RdrName))
-    match_for_con = mkSimpleConMatch CaseAlt $
-        \con_name xs -> return $ nlHsApps con_name xs  -- Con x1 x2 ..
-
-{-
-Utility functions related to Functor deriving.
-
-Since several things use the same pattern of traversal, this is abstracted into functorLikeTraverse.
-This function works like a fold: it makes a value of type 'a' in a bottom up way.
--}
-
--- Generic traversal for Functor deriving
--- See Note [FFoldType and functorLikeTraverse]
-data FFoldType a      -- Describes how to fold over a Type in a functor like way
-   = FT { ft_triv    :: a
-          -- ^ Does not contain variable
-        , ft_var     :: a
-          -- ^ The variable itself
-        , ft_co_var  :: a
-          -- ^ The variable itself, contravariantly
-        , ft_fun     :: a -> a -> a
-          -- ^ Function type
-        , ft_tup     :: TyCon -> [a] -> a
-          -- ^ Tuple type
-        , ft_ty_app  :: Type -> a -> a
-          -- ^ Type app, variable only in last argument
-        , ft_bad_app :: a
-          -- ^ Type app, variable other than in last argument
-        , ft_forall  :: TcTyVar -> a -> a
-          -- ^ Forall type
-     }
-
-functorLikeTraverse :: forall a.
-                       TyVar         -- ^ Variable to look for
-                    -> FFoldType a   -- ^ How to fold
-                    -> Type          -- ^ Type to process
-                    -> a
-functorLikeTraverse var (FT { ft_triv = caseTrivial,     ft_var = caseVar
-                            , ft_co_var = caseCoVar,     ft_fun = caseFun
-                            , ft_tup = caseTuple,        ft_ty_app = caseTyApp
-                            , ft_bad_app = caseWrongArg, ft_forall = caseForAll })
-                    ty
-  = fst (go False ty)
-  where
-    go :: Bool        -- Covariant or contravariant context
-       -> Type
-       -> (a, Bool)   -- (result of type a, does type contain var)
-
-    go co ty | Just ty' <- coreView ty = go co ty'
-    go co (TyVarTy    v) | v == var = (if co then caseCoVar else caseVar,True)
-    go co (FunTy x y)  | isPredTy x = go co y
-                       | xc || yc   = (caseFun xr yr,True)
-        where (xr,xc) = go (not co) x
-              (yr,yc) = go co       y
-    go co (AppTy    x y) | xc = (caseWrongArg,   True)
-                         | yc = (caseTyApp x yr, True)
-        where (_, xc) = go co x
-              (yr,yc) = go co y
-    go co ty@(TyConApp con args)
-       | not (or xcs)     = (caseTrivial, False)   -- Variable does not occur
-       -- At this point we know that xrs, xcs is not empty,
-       -- and at least one xr is True
-       | isTupleTyCon con = (caseTuple con xrs, True)
-       | or (init xcs)    = (caseWrongArg, True)         -- T (..var..)    ty
-       | Just (fun_ty, _) <- splitAppTy_maybe ty         -- T (..no var..) ty
-                          = (caseTyApp fun_ty (last xrs), True)
-       | otherwise        = (caseWrongArg, True)   -- Non-decomposable (eg type function)
-       where
-         -- When folding over an unboxed tuple, we must explicitly drop the
-         -- runtime rep arguments, or else GHC will generate twice as many
-         -- variables in a unboxed tuple pattern match and expression as it
-         -- actually needs. See Trac #12399
-         (xrs,xcs) = unzip (map (go co) (dropRuntimeRepArgs args))
-    go co (ForAllTy (TvBndr v vis) x)
-       | isVisibleArgFlag vis = panic "unexpected visible binder"
-       | v /= var && xc       = (caseForAll v xr,True)
-       where (xr,xc) = go co x
-
-    go _ _ = (caseTrivial,False)
-
--- Return all syntactic subterms of ty that contain var somewhere
--- These are the things that should appear in instance constraints
-deepSubtypesContaining :: TyVar -> Type -> [TcType]
-deepSubtypesContaining tv
-  = functorLikeTraverse tv
-        (FT { ft_triv = []
-            , ft_var = []
-            , ft_fun = (++)
-            , ft_tup = \_ xs -> concat xs
-            , ft_ty_app = (:)
-            , ft_bad_app = panic "in other argument"
-            , ft_co_var = panic "contravariant"
-            , ft_forall = \v xs -> filterOut ((v `elemVarSet`) . tyCoVarsOfType) xs })
-
-
-foldDataConArgs :: FFoldType a -> DataCon -> [a]
--- Fold over the arguments of the datacon
-foldDataConArgs ft con
-  = map foldArg (dataConOrigArgTys con)
-  where
-    foldArg
-      = case getTyVar_maybe (last (tyConAppArgs (dataConOrigResTy con))) of
-             Just tv -> functorLikeTraverse tv ft
-             Nothing -> const (ft_triv ft)
-    -- If we are deriving Foldable for a GADT, there is a chance that the last
-    -- type variable in the data type isn't actually a type variable at all.
-    -- (for example, this can happen if the last type variable is refined to
-    -- be a concrete type such as Int). If the last type variable is refined
-    -- to be a specific type, then getTyVar_maybe will return Nothing.
-    -- See Note [DeriveFoldable with ExistentialQuantification]
-    --
-    -- The kind checks have ensured the last type parameter is of kind *.
-
--- Make a HsLam using a fresh variable from a State monad
-mkSimpleLam :: (LHsExpr RdrName -> State [RdrName] (LHsExpr RdrName))
-            -> State [RdrName] (LHsExpr RdrName)
--- (mkSimpleLam fn) returns (\x. fn(x))
-mkSimpleLam lam = do
-    (n:names) <- get
-    put names
-    body <- lam (nlHsVar n)
-    return (mkHsLam [nlVarPat n] body)
-
-mkSimpleLam2 :: (LHsExpr RdrName -> LHsExpr RdrName
-             -> State [RdrName] (LHsExpr RdrName))
-             -> State [RdrName] (LHsExpr RdrName)
-mkSimpleLam2 lam = do
-    (n1:n2:names) <- get
-    put names
-    body <- lam (nlHsVar n1) (nlHsVar n2)
-    return (mkHsLam [nlVarPat n1,nlVarPat n2] body)
-
--- "Con a1 a2 a3 -> fold [x1 a1, x2 a2, x3 a3]"
---
--- @mkSimpleConMatch fold extra_pats con insides@ produces a match clause in
--- which the LHS pattern-matches on @extra_pats@, followed by a match on the
--- constructor @con@ and its arguments. The RHS folds (with @fold@) over @con@
--- and its arguments, applying an expression (from @insides@) to each of the
--- respective arguments of @con@.
-mkSimpleConMatch :: Monad m => HsMatchContext RdrName
-                 -> (RdrName -> [LHsExpr RdrName] -> m (LHsExpr RdrName))
-                 -> [LPat RdrName]
-                 -> DataCon
-                 -> [LHsExpr RdrName]
-                 -> m (LMatch RdrName (LHsExpr RdrName))
-mkSimpleConMatch ctxt fold extra_pats con insides = do
-    let con_name = getRdrName con
-    let vars_needed = takeList insides as_RDRs
-    let pat = nlConVarPat con_name vars_needed
-    rhs <- fold con_name (zipWith nlHsApp insides (map nlHsVar vars_needed))
-    return $ mkMatch ctxt (extra_pats ++ [pat]) rhs
-                     (noLoc emptyLocalBinds)
-
--- "Con a1 a2 a3 -> fmap (\b2 -> Con a1 b2 a3) (traverse f a2)"
---
--- @mkSimpleConMatch2 fold extra_pats con insides@ behaves very similarly to
--- 'mkSimpleConMatch', with two key differences:
---
--- 1. @insides@ is a @[Maybe (LHsExpr RdrName)]@ instead of a
---    @[LHsExpr RdrName]@. This is because it filters out the expressions
---    corresponding to arguments whose types do not mention the last type
---    variable in a derived 'Foldable' or 'Traversable' instance (i.e., the
---    'Nothing' elements of @insides@).
---
--- 2. @fold@ takes an expression as its first argument instead of a
---    constructor name. This is because it uses a specialized
---    constructor function expression that only takes as many parameters as
---    there are argument types that mention the last type variable.
---
--- See Note [Generated code for DeriveFoldable and DeriveTraversable]
-mkSimpleConMatch2 :: Monad m
-                  => HsMatchContext RdrName
-                  -> (LHsExpr RdrName -> [LHsExpr RdrName]
-                                      -> m (LHsExpr RdrName))
-                  -> [LPat RdrName]
-                  -> DataCon
-                  -> [Maybe (LHsExpr RdrName)]
-                  -> m (LMatch RdrName (LHsExpr RdrName))
-mkSimpleConMatch2 ctxt fold extra_pats con insides = do
-    let con_name = getRdrName con
-        vars_needed = takeList insides as_RDRs
-        pat = nlConVarPat con_name vars_needed
-        -- Make sure to zip BEFORE invoking catMaybes. We want the variable
-        -- indicies in each expression to match up with the argument indices
-        -- in con_expr (defined below).
-        exps = catMaybes $ zipWith (\i v -> (`nlHsApp` v) <$> i)
-                                   insides (map nlHsVar vars_needed)
-        -- An element of argTysTyVarInfo is True if the constructor argument
-        -- with the same index has a type which mentions the last type
-        -- variable.
-        argTysTyVarInfo = map isJust insides
-        (asWithTyVar, asWithoutTyVar) = partitionByList argTysTyVarInfo as_RDRs
-
-        con_expr
-          | null asWithTyVar = nlHsApps con_name $ map nlHsVar asWithoutTyVar
-          | otherwise =
-              let bs   = filterByList  argTysTyVarInfo bs_RDRs
-                  vars = filterByLists argTysTyVarInfo
-                                       (map nlHsVar bs_RDRs)
-                                       (map nlHsVar as_RDRs)
-              in mkHsLam (map nlVarPat bs) (nlHsApps con_name vars)
-
-    rhs <- fold con_expr exps
-    return $ mkMatch ctxt (extra_pats ++ [pat]) rhs
-                     (noLoc emptyLocalBinds)
-
--- "case x of (a1,a2,a3) -> fold [x1 a1, x2 a2, x3 a3]"
-mkSimpleTupleCase :: Monad m => ([LPat RdrName] -> DataCon -> [a]
-                                 -> m (LMatch RdrName (LHsExpr RdrName)))
-                  -> TyCon -> [a] -> LHsExpr RdrName -> m (LHsExpr RdrName)
-mkSimpleTupleCase match_for_con tc insides x
-  = do { let data_con = tyConSingleDataCon tc
-       ; match <- match_for_con [] data_con insides
-       ; return $ nlHsCase x [match] }
-
-{-
-************************************************************************
-*                                                                      *
-                        Foldable instances
-
- see http://www.mail-archive.com/haskell-prime@haskell.org/msg02116.html
-
-*                                                                      *
-************************************************************************
-
-Deriving Foldable instances works the same way as Functor instances,
-only Foldable instances are not possible for function types at all.
-Given (data T a = T a a (T a) deriving Foldable), we get:
-
-  instance Foldable T where
-      foldr f z (T x1 x2 x3) =
-        $(foldr 'a 'a) x1 ( $(foldr 'a 'a) x2 ( $(foldr 'a '(T a)) x3 z ) )
-
--XDeriveFoldable is different from -XDeriveFunctor in that it filters out
-arguments to the constructor that would produce useless code in a Foldable
-instance. For example, the following datatype:
-
-  data Foo a = Foo Int a Int deriving Foldable
-
-would have the following generated Foldable instance:
-
-  instance Foldable Foo where
-    foldr f z (Foo x1 x2 x3) = $(foldr 'a 'a) x2
-
-since neither of the two Int arguments are folded over.
-
-The cases are:
-
-  $(foldr 'a 'a)         =  f
-  $(foldr 'a '(b1,b2))   =  \x z -> case x of (x1,x2) -> $(foldr 'a 'b1) x1 ( $(foldr 'a 'b2) x2 z )
-  $(foldr 'a '(T b1 b2)) =  \x z -> foldr $(foldr 'a 'b2) z x  -- when a only occurs in the last parameter, b2
-
-Note that the arguments to the real foldr function are the wrong way around,
-since (f :: a -> b -> b), while (foldr f :: b -> t a -> b).
-
-One can envision a case for types that don't contain the last type variable:
-
-  $(foldr 'a 'b)         =  \x z -> z     -- when b does not contain a
-
-But this case will never materialize, since the aforementioned filtering
-removes all such types from consideration.
-See Note [Generated code for DeriveFoldable and DeriveTraversable].
-
-Foldable instances differ from Functor and Traversable instances in that
-Foldable instances can be derived for data types in which the last type
-variable is existentially quantified. In particular, if the last type variable
-is refined to a more specific type in a GADT:
-
-  data GADT a where
-      G :: a ~ Int => a -> G Int
-
-then the deriving machinery does not attempt to check that the type a contains
-Int, since it is not syntactically equal to a type variable. That is, the
-derived Foldable instance for GADT is:
-
-  instance Foldable GADT where
-      foldr _ z (GADT _) = z
-
-See Note [DeriveFoldable with ExistentialQuantification].
-
--}
-
-gen_Foldable_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, BagDerivStuff)
-gen_Foldable_binds loc tycon
-  = (listToBag [foldr_bind, foldMap_bind], emptyBag)
-  where
-    data_cons = tyConDataCons tycon
-
-    foldr_bind = mkRdrFunBind (L loc foldable_foldr_RDR) eqns
-    eqns = map foldr_eqn data_cons
-    foldr_eqn con
-      = evalState (match_foldr z_Expr [f_Pat,z_Pat] con =<< parts) bs_RDRs
-      where
-        parts = sequence $ foldDataConArgs ft_foldr con
-
-    foldMap_bind = mkRdrFunBind (L loc foldMap_RDR) (map foldMap_eqn data_cons)
-    foldMap_eqn con
-      = evalState (match_foldMap [f_Pat] con =<< parts) bs_RDRs
-      where
-        parts = sequence $ foldDataConArgs ft_foldMap con
-
-    -- Yields 'Just' an expression if we're folding over a type that mentions
-    -- the last type parameter of the datatype. Otherwise, yields 'Nothing'.
-    -- See Note [FFoldType and functorLikeTraverse]
-    ft_foldr :: FFoldType (State [RdrName] (Maybe (LHsExpr RdrName)))
-    ft_foldr
-      = FT { ft_triv    = return Nothing
-             -- foldr f = \x z -> z
-           , ft_var     = return $ Just f_Expr
-             -- foldr f = f
-           , ft_tup     = \t g -> do
-               gg  <- sequence g
-               lam <- mkSimpleLam2 $ \x z ->
-                 mkSimpleTupleCase (match_foldr z) t gg x
-               return (Just lam)
-             -- foldr f = (\x z -> case x of ...)
-           , ft_ty_app  = \_ g -> do
-               gg <- g
-               mapM (\gg' -> mkSimpleLam2 $ \x z -> return $
-                 nlHsApps foldable_foldr_RDR [gg',z,x]) gg
-             -- foldr f = (\x z -> foldr g z x)
-           , ft_forall  = \_ g -> g
-           , ft_co_var  = panic "contravariant"
-           , ft_fun     = panic "function"
-           , ft_bad_app = panic "in other argument" }
-
-    match_foldr :: LHsExpr RdrName
-                -> [LPat RdrName]
-                -> DataCon
-                -> [Maybe (LHsExpr RdrName)]
-                -> State [RdrName] (LMatch RdrName (LHsExpr RdrName))
-    match_foldr z = mkSimpleConMatch2 LambdaExpr $ \_ xs -> return (mkFoldr xs)
-      where
-        -- g1 v1 (g2 v2 (.. z))
-        mkFoldr :: [LHsExpr RdrName] -> LHsExpr RdrName
-        mkFoldr = foldr nlHsApp z
-
-    -- See Note [FFoldType and functorLikeTraverse]
-    ft_foldMap :: FFoldType (State [RdrName] (Maybe (LHsExpr RdrName)))
-    ft_foldMap
-      = FT { ft_triv = return Nothing
-             -- foldMap f = \x -> mempty
-           , ft_var  = return (Just f_Expr)
-             -- foldMap f = f
-           , ft_tup  = \t g -> do
-               gg  <- sequence g
-               lam <- mkSimpleLam $ mkSimpleTupleCase match_foldMap t gg
-               return (Just lam)
-             -- foldMap f = \x -> case x of (..,)
-           , ft_ty_app = \_ g -> fmap (nlHsApp foldMap_Expr) <$> g
-             -- foldMap f = foldMap g
-           , ft_forall = \_ g -> g
-           , ft_co_var = panic "contravariant"
-           , ft_fun = panic "function"
-           , ft_bad_app = panic "in other argument" }
-
-    match_foldMap :: [LPat RdrName]
-                  -> DataCon
-                  -> [Maybe (LHsExpr RdrName)]
-                  -> State [RdrName] (LMatch RdrName (LHsExpr RdrName))
-    match_foldMap = mkSimpleConMatch2 CaseAlt $ \_ xs -> return (mkFoldMap xs)
-      where
-        -- mappend v1 (mappend v2 ..)
-        mkFoldMap :: [LHsExpr RdrName] -> LHsExpr RdrName
-        mkFoldMap [] = mempty_Expr
-        mkFoldMap xs = foldr1 (\x y -> nlHsApps mappend_RDR [x,y]) xs
-
-{-
-************************************************************************
-*                                                                      *
-                        Traversable instances
-
- see http://www.mail-archive.com/haskell-prime@haskell.org/msg02116.html
-*                                                                      *
-************************************************************************
-
-Again, Traversable is much like Functor and Foldable.
-
-The cases are:
-
-  $(traverse 'a 'a)          =  f
-  $(traverse 'a '(b1,b2))    =  \x -> case x of (x1,x2) -> (,) <$> $(traverse 'a 'b1) x1 <*> $(traverse 'a 'b2) x2
-  $(traverse 'a '(T b1 b2))  =  traverse $(traverse 'a 'b2)  -- when a only occurs in the last parameter, b2
-
-Like -XDeriveFoldable, -XDeriveTraversable filters out arguments whose types
-do not mention the last type parameter. Therefore, the following datatype:
-
-  data Foo a = Foo Int a Int
-
-would have the following derived Traversable instance:
-
-  instance Traversable Foo where
-    traverse f (Foo x1 x2 x3) =
-      fmap (\b2 -> Foo x1 b2 x3) ( $(traverse 'a 'a) x2 )
-
-since the two Int arguments do not produce any effects in a traversal.
-
-One can envision a case for types that do not mention the last type parameter:
-
-  $(traverse 'a 'b)          =  pure     -- when b does not contain a
-
-But this case will never materialize, since the aforementioned filtering
-removes all such types from consideration.
-See Note [Generated code for DeriveFoldable and DeriveTraversable].
--}
-
-gen_Traversable_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, BagDerivStuff)
-gen_Traversable_binds loc tycon
-  = (unitBag traverse_bind, emptyBag)
-  where
-    data_cons = tyConDataCons tycon
-
-    traverse_bind = mkRdrFunBind (L loc traverse_RDR) eqns
-    eqns = map traverse_eqn data_cons
-    traverse_eqn con
-      = evalState (match_for_con [f_Pat] con =<< parts) bs_RDRs
-      where
-        parts = sequence $ foldDataConArgs ft_trav con
-
-    -- Yields 'Just' an expression if we're folding over a type that mentions
-    -- the last type parameter of the datatype. Otherwise, yields 'Nothing'.
-    -- See Note [FFoldType and functorLikeTraverse]
-    ft_trav :: FFoldType (State [RdrName] (Maybe (LHsExpr RdrName)))
-    ft_trav
-      = FT { ft_triv    = return Nothing
-             -- traverse f = pure x
-           , ft_var     = return (Just f_Expr)
-             -- traverse f = f x
-           , ft_tup     = \t gs -> do
-               gg  <- sequence gs
-               lam <- mkSimpleLam $ mkSimpleTupleCase match_for_con t gg
-               return (Just lam)
-             -- traverse f = \x -> case x of (a1,a2,..) ->
-             --                           (,,) <$> g1 a1 <*> g2 a2 <*> ..
-           , ft_ty_app  = \_ g -> fmap (nlHsApp traverse_Expr) <$> g
-             -- traverse f = traverse g
-           , ft_forall  = \_ g -> g
-           , ft_co_var  = panic "contravariant"
-           , ft_fun     = panic "function"
-           , ft_bad_app = panic "in other argument" }
-
-    -- Con a1 a2 ... -> fmap (\b1 b2 ... -> Con b1 b2 ...) (g1 a1)
-    --                    <*> g2 a2 <*> ...
-    match_for_con :: [LPat RdrName]
-                  -> DataCon
-                  -> [Maybe (LHsExpr RdrName)]
-                  -> State [RdrName] (LMatch RdrName (LHsExpr RdrName))
-    match_for_con = mkSimpleConMatch2 CaseAlt $
-                                             \con xs -> return (mkApCon con xs)
-      where
-        -- fmap (\b1 b2 ... -> Con b1 b2 ...) x1 <*> x2 <*> ..
-        mkApCon :: LHsExpr RdrName -> [LHsExpr RdrName] -> LHsExpr RdrName
-        mkApCon con [] = nlHsApps pure_RDR [con]
-        mkApCon con (x:xs) = foldl appAp (nlHsApps fmap_RDR [con,x]) xs
-          where appAp x y = nlHsApps ap_RDR [x,y]
-
-{-
-************************************************************************
-*                                                                      *
                         Lift instances
 *                                                                      *
 ************************************************************************
@@ -2228,7 +1577,7 @@ to say how it should be instantiated.  Recall
   coerce :: Coeercible a b => a -> b
 
 By giving it explicit type arguments we deal with the case where
-'op' has a higher rank type, and so we must instantiae 'coerce' with
+'op' has a higher rank type, and so we must instantiate 'coerce' with
 a polytype.  E.g.
    class C a where op :: forall b. a -> b -> b
    newtype T x = MkT <rep-ty>
@@ -2649,31 +1998,22 @@ as_RDRs         = [ mkVarUnqual (mkFastString ("a"++show i)) | i <- [(1::Int) ..
 bs_RDRs         = [ mkVarUnqual (mkFastString ("b"++show i)) | i <- [(1::Int) .. ] ]
 cs_RDRs         = [ mkVarUnqual (mkFastString ("c"++show i)) | i <- [(1::Int) .. ] ]
 
-a_Expr, b_Expr, c_Expr, f_Expr, z_Expr, ltTag_Expr, eqTag_Expr, gtTag_Expr,
-    false_Expr, true_Expr, fmap_Expr,
-    mempty_Expr, foldMap_Expr, traverse_Expr :: LHsExpr RdrName
+a_Expr, b_Expr, c_Expr, ltTag_Expr, eqTag_Expr, gtTag_Expr, false_Expr,
+    true_Expr :: LHsExpr RdrName
 a_Expr          = nlHsVar a_RDR
 b_Expr          = nlHsVar b_RDR
 c_Expr          = nlHsVar c_RDR
-f_Expr          = nlHsVar f_RDR
-z_Expr          = nlHsVar z_RDR
 ltTag_Expr      = nlHsVar ltTag_RDR
 eqTag_Expr      = nlHsVar eqTag_RDR
 gtTag_Expr      = nlHsVar gtTag_RDR
 false_Expr      = nlHsVar false_RDR
 true_Expr       = nlHsVar true_RDR
-fmap_Expr       = nlHsVar fmap_RDR
--- pure_Expr       = nlHsVar pure_RDR
-mempty_Expr     = nlHsVar mempty_RDR
-foldMap_Expr    = nlHsVar foldMap_RDR
-traverse_Expr   = nlHsVar traverse_RDR
 
-a_Pat, b_Pat, c_Pat, d_Pat, f_Pat, k_Pat, z_Pat :: LPat RdrName
+a_Pat, b_Pat, c_Pat, d_Pat, k_Pat, z_Pat :: LPat RdrName
 a_Pat           = nlVarPat a_RDR
 b_Pat           = nlVarPat b_RDR
 c_Pat           = nlVarPat c_RDR
 d_Pat           = nlVarPat d_RDR
-f_Pat           = nlVarPat f_RDR
 k_Pat           = nlVarPat k_RDR
 z_Pat           = nlVarPat z_RDR
 
@@ -2704,7 +2044,7 @@ mkAuxBinderName parent occ_fun
     parent_stable_hash =
       let Fingerprint high low = fingerprintString parent_stable
       in toBase62 high ++ toBase62Padded low
-      -- See Note [Base 62 encoding 128-bit integers]
+      -- See Note [Base 62 encoding 128-bit integers] in Encoding
     parent_occ  = nameOccName parent
 
 
@@ -2730,235 +2070,4 @@ To make the symbol names short we take a base62 hash of the full name.
 
 In the past we used the *unique* from the parent, but that's not stable across
 recompilations as uniques are nondeterministic.
-
-Note [DeriveFoldable with ExistentialQuantification]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Functor and Traversable instances can only be derived for data types whose
-last type parameter is truly universally polymorphic. For example:
-
-  data T a b where
-    T1 ::                 b   -> T a b   -- YES, b is unconstrained
-    T2 :: Ord b   =>      b   -> T a b   -- NO, b is constrained by (Ord b)
-    T3 :: b ~ Int =>      b   -> T a b   -- NO, b is constrained by (b ~ Int)
-    T4 ::                 Int -> T a Int -- NO, this is just like T3
-    T5 :: Ord a   => a -> b   -> T a b   -- YES, b is unconstrained, even
-                                         -- though a is existential
-    T6 ::                 Int -> T Int b -- YES, b is unconstrained
-
-For Foldable instances, however, we can completely lift the constraint that
-the last type parameter be truly universally polymorphic. This means that T
-(as defined above) can have a derived Foldable instance:
-
-  instance Foldable (T a) where
-    foldr f z (T1 b)   = f b z
-    foldr f z (T2 b)   = f b z
-    foldr f z (T3 b)   = f b z
-    foldr f z (T4 b)   = z
-    foldr f z (T5 a b) = f b z
-    foldr f z (T6 a)   = z
-
-    foldMap f (T1 b)   = f b
-    foldMap f (T2 b)   = f b
-    foldMap f (T3 b)   = f b
-    foldMap f (T4 b)   = mempty
-    foldMap f (T5 a b) = f b
-    foldMap f (T6 a)   = mempty
-
-In a Foldable instance, it is safe to fold over an occurrence of the last type
-parameter that is not truly universally polymorphic. However, there is a bit
-of subtlety in determining what is actually an occurrence of a type parameter.
-T3 and T4, as defined above, provide one example:
-
-  data T a b where
-    ...
-    T3 :: b ~ Int => b   -> T a b
-    T4 ::            Int -> T a Int
-    ...
-
-  instance Foldable (T a) where
-    ...
-    foldr f z (T3 b) = f b z
-    foldr f z (T4 b) = z
-    ...
-    foldMap f (T3 b) = f b
-    foldMap f (T4 b) = mempty
-    ...
-
-Notice that the argument of T3 is folded over, whereas the argument of T4 is
-not. This is because we only fold over constructor arguments that
-syntactically mention the universally quantified type parameter of that
-particular data constructor. See foldDataConArgs for how this is implemented.
-
-As another example, consider the following data type. The argument of each
-constructor has the same type as the last type parameter:
-
-  data E a where
-    E1 :: (a ~ Int) => a   -> E a
-    E2 ::              Int -> E Int
-    E3 :: (a ~ Int) => a   -> E Int
-    E4 :: (a ~ Int) => Int -> E a
-
-Only E1's argument is an occurrence of a universally quantified type variable
-that is syntactically equivalent to the last type parameter, so only E1's
-argument will be be folded over in a derived Foldable instance.
-
-See Trac #10447 for the original discussion on this feature. Also see
-https://ghc.haskell.org/trac/ghc/wiki/Commentary/Compiler/DeriveFunctor
-for a more in-depth explanation.
-
-Note [FFoldType and functorLikeTraverse]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Deriving Functor, Foldable, and Traversable all require generating expressions
-which perform an operation on each argument of a data constructor depending
-on the argument's type. In particular, a generated operation can be different
-depending on whether the type mentions the last type variable of the datatype
-(e.g., if you have data T a = MkT a Int, then a generated foldr expresion would
-fold over the first argument of MkT, but not the second).
-
-This pattern is abstracted with the FFoldType datatype, which provides hooks
-for the user to specify how a constructor argument should be folded when it
-has a type with a particular "shape". The shapes are as follows (assume that
-a is the last type variable in a given datatype):
-
-* ft_triv:    The type does not mention the last type variable at all.
-              Examples: Int, b
-
-* ft_var:     The type is syntactically equal to the last type variable.
-              Moreover, the type appears in a covariant position (see
-              the Deriving Functor instances section of the users' guide
-              for an in-depth explanation of covariance vs. contravariance).
-              Example: a (covariantly)
-
-* ft_co_var:  The type is syntactically equal to the last type variable.
-              Moreover, the type appears in a contravariant position.
-              Example: a (contravariantly)
-
-* ft_fun:     A function type which mentions the last type variable in
-              the argument position, result position or both.
-              Examples: a -> Int, Int -> a, Maybe a -> [a]
-
-* ft_tup:     A tuple type which mentions the last type variable in at least
-              one of its fields. The TyCon argument of ft_tup represents the
-              particular tuple's type constructor.
-              Examples: (a, Int), (Maybe a, [a], Either a Int), (# Int, a #)
-
-* ft_ty_app:  A type is being applied to the last type parameter, where the
-              applied type does not mention the last type parameter (if it
-              did, it would fall under ft_bad_app). The Type argument to
-              ft_ty_app represents the applied type.
-
-              Note that functions, tuples, and foralls are distinct cases
-              and take precedence of ft_ty_app. (For example, (Int -> a) would
-              fall under (ft_fun Int a), not (ft_ty_app ((->) Int) a).
-              Examples: Maybe a, Either b a
-
-* ft_bad_app: A type application uses the last type parameter in a position
-              other than the last argument. This case is singled out because
-              Functor, Foldable, and Traversable instances cannot be derived
-              for datatypes containing arguments with such types.
-              Examples: Either a Int, Const a b
-
-* ft_forall:  A forall'd type mentions the last type parameter on its right-
-              hand side (and is not quantified on the left-hand side). This
-              case is present mostly for plumbing purposes.
-              Example: forall b. Either b a
-
-If FFoldType describes a strategy for folding subcomponents of a Type, then
-functorLikeTraverse is the function that applies that strategy to the entirety
-of a Type, returning the final folded-up result.
-
-foldDataConArgs applies functorLikeTraverse to every argument type of a
-constructor, returning a list of the fold results. This makes foldDataConArgs
-a natural way to generate the subexpressions in a generated fmap, foldr,
-foldMap, or traverse definition (the subexpressions must then be combined in
-a method-specific fashion to form the final generated expression).
-
-Deriving Generic1 also does validity checking by looking for the last type
-variable in certain positions of a constructor's argument types, so it also
-uses foldDataConArgs. See Note [degenerate use of FFoldType] in TcGenGenerics.
-
-Note [Generated code for DeriveFoldable and DeriveTraversable]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-We adapt the algorithms for -XDeriveFoldable and -XDeriveTraversable based on
-that of -XDeriveFunctor. However, there an important difference between deriving
-the former two typeclasses and the latter one, which is best illustrated by the
-following scenario:
-
-  data WithInt a = WithInt a Int# deriving (Functor, Foldable, Traversable)
-
-The generated code for the Functor instance is straightforward:
-
-  instance Functor WithInt where
-    fmap f (WithInt a i) = WithInt (f a) i
-
-But if we use too similar of a strategy for deriving the Foldable and
-Traversable instances, we end up with this code:
-
-  instance Foldable WithInt where
-    foldMap f (WithInt a i) = f a <> mempty
-
-  instance Traversable WithInt where
-    traverse f (WithInt a i) = fmap WithInt (f a) <*> pure i
-
-This is unsatisfying for two reasons:
-
-1. The Traversable instance doesn't typecheck! Int# is of kind #, but pure
-   expects an argument whose type is of kind *. This effectively prevents
-   Traversable from being derived for any datatype with an unlifted argument
-   type (Trac #11174).
-
-2. The generated code contains superfluous expressions. By the Monoid laws,
-   we can reduce (f a <> mempty) to (f a), and by the Applicative laws, we can
-   reduce (fmap WithInt (f a) <*> pure i) to (fmap (\b -> WithInt b i) (f a)).
-
-We can fix both of these issues by incorporating a slight twist to the usual
-algorithm that we use for -XDeriveFunctor. The differences can be summarized
-as follows:
-
-1. In the generated expression, we only fold over arguments whose types
-   mention the last type parameter. Any other argument types will simply
-   produce useless 'mempty's or 'pure's, so they can be safely ignored.
-
-2. In the case of -XDeriveTraversable, instead of applying ConName,
-   we apply (\b_i ... b_k -> ConName a_1 ... a_n), where
-
-   * ConName has n arguments
-   * {b_i, ..., b_k} is a subset of {a_1, ..., a_n} whose indices correspond
-     to the arguments whose types mention the last type parameter. As a
-     consequence, taking the difference of {a_1, ..., a_n} and
-     {b_i, ..., b_k} yields the all the argument values of ConName whose types
-     do not mention the last type parameter. Note that [i, ..., k] is a
-     strictly increasing—but not necessarily consecutive—integer sequence.
-
-     For example, the datatype
-
-       data Foo a = Foo Int a Int a
-
-     would generate the following Traversable instance:
-
-       instance Traversable Foo where
-         traverse f (Foo a1 a2 a3 a4) =
-           fmap (\b2 b4 -> Foo a1 b2 a3 b4) (f a2) <*> f a4
-
-Technically, this approach would also work for -XDeriveFunctor as well, but we
-decide not to do so because:
-
-1. There's not much benefit to generating, e.g., ((\b -> WithInt b i) (f a))
-   instead of (WithInt (f a) i).
-
-2. There would be certain datatypes for which the above strategy would
-   generate Functor code that would fail to typecheck. For example:
-
-     data Bar f a = Bar (forall f. Functor f => f a) deriving Functor
-
-   With the conventional algorithm, it would generate something like:
-
-     fmap f (Bar a) = Bar (fmap f a)
-
-   which typechecks. But with the strategy mentioned above, it would generate:
-
-     fmap f (Bar a) = (\b -> Bar b) (fmap f a)
-
-   which does not typecheck, since GHC cannot unify the rank-2 type variables
-   in the types of b and (fmap f a).
 -}
diff --git a/compiler/typecheck/TcGenFunctor.hs b/compiler/typecheck/TcGenFunctor.hs
new file mode 100644
index 0000000000..c57740324e
--- /dev/null
+++ b/compiler/typecheck/TcGenFunctor.hs
@@ -0,0 +1,875 @@
+{-
+(c) The University of Glasgow 2011
+
+
+The deriving code for the Functor, Foldable, and Traversable classes
+(equivalent to the code in TcGenDeriv, for other classes)
+-}
+
+{-# LANGUAGE ScopedTypeVariables #-}
+
+module TcGenFunctor (
+        FFoldType(..), functorLikeTraverse,
+        deepSubtypesContaining, foldDataConArgs,
+
+        gen_Functor_binds, gen_Foldable_binds, gen_Traversable_binds
+    ) where
+
+import Bag
+import DataCon
+import FastString
+import HsSyn
+import Panic
+import PrelNames
+import RdrName
+import SrcLoc
+import State
+import TcGenDeriv
+import TcType
+import TyCon
+import TyCoRep
+import Type
+import Util
+import Var
+import VarSet
+
+import Data.Maybe (catMaybes, isJust)
+
+{-
+************************************************************************
+*                                                                      *
+                        Functor instances
+
+ see http://www.mail-archive.com/haskell-prime@haskell.org/msg02116.html
+
+*                                                                      *
+************************************************************************
+
+For the data type:
+
+  data T a = T1 Int a | T2 (T a)
+
+We generate the instance:
+
+  instance Functor T where
+      fmap f (T1 b1 a) = T1 b1 (f a)
+      fmap f (T2 ta)   = T2 (fmap f ta)
+
+Notice that we don't simply apply 'fmap' to the constructor arguments.
+Rather
+  - Do nothing to an argument whose type doesn't mention 'a'
+  - Apply 'f' to an argument of type 'a'
+  - Apply 'fmap f' to other arguments
+That's why we have to recurse deeply into the constructor argument types,
+rather than just one level, as we typically do.
+
+What about types with more than one type parameter?  In general, we only
+derive Functor for the last position:
+
+  data S a b = S1 [b] | S2 (a, T a b)
+  instance Functor (S a) where
+    fmap f (S1 bs)    = S1 (fmap f bs)
+    fmap f (S2 (p,q)) = S2 (a, fmap f q)
+
+However, we have special cases for
+         - tuples
+         - functions
+
+More formally, we write the derivation of fmap code over type variable
+'a for type 'b as ($fmap 'a 'b).  In this general notation the derived
+instance for T is:
+
+  instance Functor T where
+      fmap f (T1 x1 x2) = T1 ($(fmap 'a 'b1) x1) ($(fmap 'a 'a) x2)
+      fmap f (T2 x1)    = T2 ($(fmap 'a '(T a)) x1)
+
+  $(fmap 'a 'b)          =  \x -> x     -- when b does not contain a
+  $(fmap 'a 'a)          =  f
+  $(fmap 'a '(b1,b2))    =  \x -> case x of (x1,x2) -> ($(fmap 'a 'b1) x1, $(fmap 'a 'b2) x2)
+  $(fmap 'a '(T b1 b2))  =  fmap $(fmap 'a 'b2)   -- when a only occurs in the last parameter, b2
+  $(fmap 'a '(b -> c))   =  \x b -> $(fmap 'a' 'c) (x ($(cofmap 'a 'b) b))
+
+For functions, the type parameter 'a can occur in a contravariant position,
+which means we need to derive a function like:
+
+  cofmap :: (a -> b) -> (f b -> f a)
+
+This is pretty much the same as $fmap, only without the $(cofmap 'a 'a) case:
+
+  $(cofmap 'a 'b)          =  \x -> x     -- when b does not contain a
+  $(cofmap 'a 'a)          =  error "type variable in contravariant position"
+  $(cofmap 'a '(b1,b2))    =  \x -> case x of (x1,x2) -> ($(cofmap 'a 'b1) x1, $(cofmap 'a 'b2) x2)
+  $(cofmap 'a '[b])        =  map $(cofmap 'a 'b)
+  $(cofmap 'a '(T b1 b2))  =  fmap $(cofmap 'a 'b2)   -- when a only occurs in the last parameter, b2
+  $(cofmap 'a '(b -> c))   =  \x b -> $(cofmap 'a' 'c) (x ($(fmap 'a 'c) b))
+
+Note that the code produced by $(fmap _ _) is always a higher order function,
+with type `(a -> b) -> (g a -> g b)` for some g. When we need to do pattern
+matching on the type, this means create a lambda function (see the (,) case above).
+The resulting code for fmap can look a bit weird, for example:
+
+  data X a = X (a,Int)
+  -- generated instance
+  instance Functor X where
+      fmap f (X x) = (\y -> case y of (x1,x2) -> X (f x1, (\z -> z) x2)) x
+
+The optimizer should be able to simplify this code by simple inlining.
+
+An older version of the deriving code tried to avoid these applied
+lambda functions by producing a meta level function. But the function to
+be mapped, `f`, is a function on the code level, not on the meta level,
+so it was eta expanded to `\x -> [| f $x |]`. This resulted in too much eta expansion.
+It is better to produce too many lambdas than to eta expand, see ticket #7436.
+-}
+
+gen_Functor_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, BagDerivStuff)
+gen_Functor_binds loc tycon
+  = (unitBag fmap_bind, emptyBag)
+  where
+    data_cons = tyConDataCons tycon
+    fun_name = L loc fmap_RDR
+    fmap_bind = mkRdrFunBind fun_name eqns
+
+    fmap_eqn con = evalState (match_for_con [f_Pat] con =<< parts) bs_RDRs
+      where
+        parts = sequence $ foldDataConArgs ft_fmap con
+
+    eqns | null data_cons = [mkSimpleMatch (FunRhs fun_name Prefix)
+                                           [nlWildPat, nlWildPat]
+                                           (error_Expr "Void fmap")]
+         | otherwise      = map fmap_eqn data_cons
+
+    ft_fmap :: FFoldType (State [RdrName] (LHsExpr RdrName))
+    ft_fmap = FT { ft_triv = mkSimpleLam $ \x -> return x
+                   -- fmap f = \x -> x
+                 , ft_var  = return f_Expr
+                   -- fmap f = f
+                 , ft_fun  = \g h -> do
+                     gg <- g
+                     hh <- h
+                     mkSimpleLam2 $ \x b -> return $
+                       nlHsApp hh (nlHsApp x (nlHsApp gg b))
+                   -- fmap f = \x b -> h (x (g b))
+                 , ft_tup = \t gs -> do
+                     gg <- sequence gs
+                     mkSimpleLam $ mkSimpleTupleCase match_for_con t gg
+                   -- fmap f = \x -> case x of (a1,a2,..) -> (g1 a1,g2 a2,..)
+                 , ft_ty_app = \_ g -> nlHsApp fmap_Expr <$> g
+                   -- fmap f = fmap g
+                 , ft_forall = \_ g -> g
+                 , ft_bad_app = panic "in other argument"
+                 , ft_co_var = panic "contravariant" }
+
+    -- Con a1 a2 ... -> Con (f1 a1) (f2 a2) ...
+    match_for_con :: [LPat RdrName] -> DataCon -> [LHsExpr RdrName]
+                  -> State [RdrName] (LMatch RdrName (LHsExpr RdrName))
+    match_for_con = mkSimpleConMatch CaseAlt $
+        \con_name xs -> return $ nlHsApps con_name xs  -- Con x1 x2 ..
+
+{-
+Utility functions related to Functor deriving.
+
+Since several things use the same pattern of traversal, this is abstracted into functorLikeTraverse.
+This function works like a fold: it makes a value of type 'a' in a bottom up way.
+-}
+
+-- Generic traversal for Functor deriving
+-- See Note [FFoldType and functorLikeTraverse]
+data FFoldType a      -- Describes how to fold over a Type in a functor like way
+   = FT { ft_triv    :: a
+          -- ^ Does not contain variable
+        , ft_var     :: a
+          -- ^ The variable itself
+        , ft_co_var  :: a
+          -- ^ The variable itself, contravariantly
+        , ft_fun     :: a -> a -> a
+          -- ^ Function type
+        , ft_tup     :: TyCon -> [a] -> a
+          -- ^ Tuple type
+        , ft_ty_app  :: Type -> a -> a
+          -- ^ Type app, variable only in last argument
+        , ft_bad_app :: a
+          -- ^ Type app, variable other than in last argument
+        , ft_forall  :: TcTyVar -> a -> a
+          -- ^ Forall type
+     }
+
+functorLikeTraverse :: forall a.
+                       TyVar         -- ^ Variable to look for
+                    -> FFoldType a   -- ^ How to fold
+                    -> Type          -- ^ Type to process
+                    -> a
+functorLikeTraverse var (FT { ft_triv = caseTrivial,     ft_var = caseVar
+                            , ft_co_var = caseCoVar,     ft_fun = caseFun
+                            , ft_tup = caseTuple,        ft_ty_app = caseTyApp
+                            , ft_bad_app = caseWrongArg, ft_forall = caseForAll })
+                    ty
+  = fst (go False ty)
+  where
+    go :: Bool        -- Covariant or contravariant context
+       -> Type
+       -> (a, Bool)   -- (result of type a, does type contain var)
+
+    go co ty | Just ty' <- coreView ty = go co ty'
+    go co (TyVarTy    v) | v == var = (if co then caseCoVar else caseVar,True)
+    go co (FunTy x y)  | isPredTy x = go co y
+                       | xc || yc   = (caseFun xr yr,True)
+        where (xr,xc) = go (not co) x
+              (yr,yc) = go co       y
+    go co (AppTy    x y) | xc = (caseWrongArg,   True)
+                         | yc = (caseTyApp x yr, True)
+        where (_, xc) = go co x
+              (yr,yc) = go co y
+    go co ty@(TyConApp con args)
+       | not (or xcs)     = (caseTrivial, False)   -- Variable does not occur
+       -- At this point we know that xrs, xcs is not empty,
+       -- and at least one xr is True
+       | isTupleTyCon con = (caseTuple con xrs, True)
+       | or (init xcs)    = (caseWrongArg, True)         -- T (..var..)    ty
+       | Just (fun_ty, _) <- splitAppTy_maybe ty         -- T (..no var..) ty
+                          = (caseTyApp fun_ty (last xrs), True)
+       | otherwise        = (caseWrongArg, True)   -- Non-decomposable (eg type function)
+       where
+         -- When folding over an unboxed tuple, we must explicitly drop the
+         -- runtime rep arguments, or else GHC will generate twice as many
+         -- variables in a unboxed tuple pattern match and expression as it
+         -- actually needs. See Trac #12399
+         (xrs,xcs) = unzip (map (go co) (dropRuntimeRepArgs args))
+    go co (ForAllTy (TvBndr v vis) x)
+       | isVisibleArgFlag vis = panic "unexpected visible binder"
+       | v /= var && xc       = (caseForAll v xr,True)
+       where (xr,xc) = go co x
+
+    go _ _ = (caseTrivial,False)
+
+-- Return all syntactic subterms of ty that contain var somewhere
+-- These are the things that should appear in instance constraints
+deepSubtypesContaining :: TyVar -> Type -> [TcType]
+deepSubtypesContaining tv
+  = functorLikeTraverse tv
+        (FT { ft_triv = []
+            , ft_var = []
+            , ft_fun = (++)
+            , ft_tup = \_ xs -> concat xs
+            , ft_ty_app = (:)
+            , ft_bad_app = panic "in other argument"
+            , ft_co_var = panic "contravariant"
+            , ft_forall = \v xs -> filterOut ((v `elemVarSet`) . tyCoVarsOfType) xs })
+
+
+foldDataConArgs :: FFoldType a -> DataCon -> [a]
+-- Fold over the arguments of the datacon
+foldDataConArgs ft con
+  = map foldArg (dataConOrigArgTys con)
+  where
+    foldArg
+      = case getTyVar_maybe (last (tyConAppArgs (dataConOrigResTy con))) of
+             Just tv -> functorLikeTraverse tv ft
+             Nothing -> const (ft_triv ft)
+    -- If we are deriving Foldable for a GADT, there is a chance that the last
+    -- type variable in the data type isn't actually a type variable at all.
+    -- (for example, this can happen if the last type variable is refined to
+    -- be a concrete type such as Int). If the last type variable is refined
+    -- to be a specific type, then getTyVar_maybe will return Nothing.
+    -- See Note [DeriveFoldable with ExistentialQuantification]
+    --
+    -- The kind checks have ensured the last type parameter is of kind *.
+
+-- Make a HsLam using a fresh variable from a State monad
+mkSimpleLam :: (LHsExpr RdrName -> State [RdrName] (LHsExpr RdrName))
+            -> State [RdrName] (LHsExpr RdrName)
+-- (mkSimpleLam fn) returns (\x. fn(x))
+mkSimpleLam lam = do
+    (n:names) <- get
+    put names
+    body <- lam (nlHsVar n)
+    return (mkHsLam [nlVarPat n] body)
+
+mkSimpleLam2 :: (LHsExpr RdrName -> LHsExpr RdrName
+             -> State [RdrName] (LHsExpr RdrName))
+             -> State [RdrName] (LHsExpr RdrName)
+mkSimpleLam2 lam = do
+    (n1:n2:names) <- get
+    put names
+    body <- lam (nlHsVar n1) (nlHsVar n2)
+    return (mkHsLam [nlVarPat n1,nlVarPat n2] body)
+
+-- "Con a1 a2 a3 -> fold [x1 a1, x2 a2, x3 a3]"
+--
+-- @mkSimpleConMatch fold extra_pats con insides@ produces a match clause in
+-- which the LHS pattern-matches on @extra_pats@, followed by a match on the
+-- constructor @con@ and its arguments. The RHS folds (with @fold@) over @con@
+-- and its arguments, applying an expression (from @insides@) to each of the
+-- respective arguments of @con@.
+mkSimpleConMatch :: Monad m => HsMatchContext RdrName
+                 -> (RdrName -> [LHsExpr RdrName] -> m (LHsExpr RdrName))
+                 -> [LPat RdrName]
+                 -> DataCon
+                 -> [LHsExpr RdrName]
+                 -> m (LMatch RdrName (LHsExpr RdrName))
+mkSimpleConMatch ctxt fold extra_pats con insides = do
+    let con_name = getRdrName con
+    let vars_needed = takeList insides as_RDRs
+    let pat = nlConVarPat con_name vars_needed
+    rhs <- fold con_name (zipWith nlHsApp insides (map nlHsVar vars_needed))
+    return $ mkMatch ctxt (extra_pats ++ [pat]) rhs
+                     (noLoc emptyLocalBinds)
+
+-- "Con a1 a2 a3 -> fmap (\b2 -> Con a1 b2 a3) (traverse f a2)"
+--
+-- @mkSimpleConMatch2 fold extra_pats con insides@ behaves very similarly to
+-- 'mkSimpleConMatch', with two key differences:
+--
+-- 1. @insides@ is a @[Maybe (LHsExpr RdrName)]@ instead of a
+--    @[LHsExpr RdrName]@. This is because it filters out the expressions
+--    corresponding to arguments whose types do not mention the last type
+--    variable in a derived 'Foldable' or 'Traversable' instance (i.e., the
+--    'Nothing' elements of @insides@).
+--
+-- 2. @fold@ takes an expression as its first argument instead of a
+--    constructor name. This is because it uses a specialized
+--    constructor function expression that only takes as many parameters as
+--    there are argument types that mention the last type variable.
+--
+-- See Note [Generated code for DeriveFoldable and DeriveTraversable]
+mkSimpleConMatch2 :: Monad m
+                  => HsMatchContext RdrName
+                  -> (LHsExpr RdrName -> [LHsExpr RdrName]
+                                      -> m (LHsExpr RdrName))
+                  -> [LPat RdrName]
+                  -> DataCon
+                  -> [Maybe (LHsExpr RdrName)]
+                  -> m (LMatch RdrName (LHsExpr RdrName))
+mkSimpleConMatch2 ctxt fold extra_pats con insides = do
+    let con_name = getRdrName con
+        vars_needed = takeList insides as_RDRs
+        pat = nlConVarPat con_name vars_needed
+        -- Make sure to zip BEFORE invoking catMaybes. We want the variable
+        -- indicies in each expression to match up with the argument indices
+        -- in con_expr (defined below).
+        exps = catMaybes $ zipWith (\i v -> (`nlHsApp` v) <$> i)
+                                   insides (map nlHsVar vars_needed)
+        -- An element of argTysTyVarInfo is True if the constructor argument
+        -- with the same index has a type which mentions the last type
+        -- variable.
+        argTysTyVarInfo = map isJust insides
+        (asWithTyVar, asWithoutTyVar) = partitionByList argTysTyVarInfo as_RDRs
+
+        con_expr
+          | null asWithTyVar = nlHsApps con_name $ map nlHsVar asWithoutTyVar
+          | otherwise =
+              let bs   = filterByList  argTysTyVarInfo bs_RDRs
+                  vars = filterByLists argTysTyVarInfo
+                                       (map nlHsVar bs_RDRs)
+                                       (map nlHsVar as_RDRs)
+              in mkHsLam (map nlVarPat bs) (nlHsApps con_name vars)
+
+    rhs <- fold con_expr exps
+    return $ mkMatch ctxt (extra_pats ++ [pat]) rhs
+                     (noLoc emptyLocalBinds)
+
+-- "case x of (a1,a2,a3) -> fold [x1 a1, x2 a2, x3 a3]"
+mkSimpleTupleCase :: Monad m => ([LPat RdrName] -> DataCon -> [a]
+                                 -> m (LMatch RdrName (LHsExpr RdrName)))
+                  -> TyCon -> [a] -> LHsExpr RdrName -> m (LHsExpr RdrName)
+mkSimpleTupleCase match_for_con tc insides x
+  = do { let data_con = tyConSingleDataCon tc
+       ; match <- match_for_con [] data_con insides
+       ; return $ nlHsCase x [match] }
+
+{-
+************************************************************************
+*                                                                      *
+                        Foldable instances
+
+ see http://www.mail-archive.com/haskell-prime@haskell.org/msg02116.html
+
+*                                                                      *
+************************************************************************
+
+Deriving Foldable instances works the same way as Functor instances,
+only Foldable instances are not possible for function types at all.
+Given (data T a = T a a (T a) deriving Foldable), we get:
+
+  instance Foldable T where
+      foldr f z (T x1 x2 x3) =
+        $(foldr 'a 'a) x1 ( $(foldr 'a 'a) x2 ( $(foldr 'a '(T a)) x3 z ) )
+
+-XDeriveFoldable is different from -XDeriveFunctor in that it filters out
+arguments to the constructor that would produce useless code in a Foldable
+instance. For example, the following datatype:
+
+  data Foo a = Foo Int a Int deriving Foldable
+
+would have the following generated Foldable instance:
+
+  instance Foldable Foo where
+    foldr f z (Foo x1 x2 x3) = $(foldr 'a 'a) x2
+
+since neither of the two Int arguments are folded over.
+
+The cases are:
+
+  $(foldr 'a 'a)         =  f
+  $(foldr 'a '(b1,b2))   =  \x z -> case x of (x1,x2) -> $(foldr 'a 'b1) x1 ( $(foldr 'a 'b2) x2 z )
+  $(foldr 'a '(T b1 b2)) =  \x z -> foldr $(foldr 'a 'b2) z x  -- when a only occurs in the last parameter, b2
+
+Note that the arguments to the real foldr function are the wrong way around,
+since (f :: a -> b -> b), while (foldr f :: b -> t a -> b).
+
+One can envision a case for types that don't contain the last type variable:
+
+  $(foldr 'a 'b)         =  \x z -> z     -- when b does not contain a
+
+But this case will never materialize, since the aforementioned filtering
+removes all such types from consideration.
+See Note [Generated code for DeriveFoldable and DeriveTraversable].
+
+Foldable instances differ from Functor and Traversable instances in that
+Foldable instances can be derived for data types in which the last type
+variable is existentially quantified. In particular, if the last type variable
+is refined to a more specific type in a GADT:
+
+  data GADT a where
+      G :: a ~ Int => a -> G Int
+
+then the deriving machinery does not attempt to check that the type a contains
+Int, since it is not syntactically equal to a type variable. That is, the
+derived Foldable instance for GADT is:
+
+  instance Foldable GADT where
+      foldr _ z (GADT _) = z
+
+See Note [DeriveFoldable with ExistentialQuantification].
+
+-}
+
+gen_Foldable_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, BagDerivStuff)
+gen_Foldable_binds loc tycon
+  = (listToBag [foldr_bind, foldMap_bind], emptyBag)
+  where
+    data_cons = tyConDataCons tycon
+
+    foldr_bind = mkRdrFunBind (L loc foldable_foldr_RDR) eqns
+    eqns = map foldr_eqn data_cons
+    foldr_eqn con
+      = evalState (match_foldr z_Expr [f_Pat,z_Pat] con =<< parts) bs_RDRs
+      where
+        parts = sequence $ foldDataConArgs ft_foldr con
+
+    foldMap_bind = mkRdrFunBind (L loc foldMap_RDR) (map foldMap_eqn data_cons)
+    foldMap_eqn con
+      = evalState (match_foldMap [f_Pat] con =<< parts) bs_RDRs
+      where
+        parts = sequence $ foldDataConArgs ft_foldMap con
+
+    -- Yields 'Just' an expression if we're folding over a type that mentions
+    -- the last type parameter of the datatype. Otherwise, yields 'Nothing'.
+    -- See Note [FFoldType and functorLikeTraverse]
+    ft_foldr :: FFoldType (State [RdrName] (Maybe (LHsExpr RdrName)))
+    ft_foldr
+      = FT { ft_triv    = return Nothing
+             -- foldr f = \x z -> z
+           , ft_var     = return $ Just f_Expr
+             -- foldr f = f
+           , ft_tup     = \t g -> do
+               gg  <- sequence g
+               lam <- mkSimpleLam2 $ \x z ->
+                 mkSimpleTupleCase (match_foldr z) t gg x
+               return (Just lam)
+             -- foldr f = (\x z -> case x of ...)
+           , ft_ty_app  = \_ g -> do
+               gg <- g
+               mapM (\gg' -> mkSimpleLam2 $ \x z -> return $
+                 nlHsApps foldable_foldr_RDR [gg',z,x]) gg
+             -- foldr f = (\x z -> foldr g z x)
+           , ft_forall  = \_ g -> g
+           , ft_co_var  = panic "contravariant"
+           , ft_fun     = panic "function"
+           , ft_bad_app = panic "in other argument" }
+
+    match_foldr :: LHsExpr RdrName
+                -> [LPat RdrName]
+                -> DataCon
+                -> [Maybe (LHsExpr RdrName)]
+                -> State [RdrName] (LMatch RdrName (LHsExpr RdrName))
+    match_foldr z = mkSimpleConMatch2 LambdaExpr $ \_ xs -> return (mkFoldr xs)
+      where
+        -- g1 v1 (g2 v2 (.. z))
+        mkFoldr :: [LHsExpr RdrName] -> LHsExpr RdrName
+        mkFoldr = foldr nlHsApp z
+
+    -- See Note [FFoldType and functorLikeTraverse]
+    ft_foldMap :: FFoldType (State [RdrName] (Maybe (LHsExpr RdrName)))
+    ft_foldMap
+      = FT { ft_triv = return Nothing
+             -- foldMap f = \x -> mempty
+           , ft_var  = return (Just f_Expr)
+             -- foldMap f = f
+           , ft_tup  = \t g -> do
+               gg  <- sequence g
+               lam <- mkSimpleLam $ mkSimpleTupleCase match_foldMap t gg
+               return (Just lam)
+             -- foldMap f = \x -> case x of (..,)
+           , ft_ty_app = \_ g -> fmap (nlHsApp foldMap_Expr) <$> g
+             -- foldMap f = foldMap g
+           , ft_forall = \_ g -> g
+           , ft_co_var = panic "contravariant"
+           , ft_fun = panic "function"
+           , ft_bad_app = panic "in other argument" }
+
+    match_foldMap :: [LPat RdrName]
+                  -> DataCon
+                  -> [Maybe (LHsExpr RdrName)]
+                  -> State [RdrName] (LMatch RdrName (LHsExpr RdrName))
+    match_foldMap = mkSimpleConMatch2 CaseAlt $ \_ xs -> return (mkFoldMap xs)
+      where
+        -- mappend v1 (mappend v2 ..)
+        mkFoldMap :: [LHsExpr RdrName] -> LHsExpr RdrName
+        mkFoldMap [] = mempty_Expr
+        mkFoldMap xs = foldr1 (\x y -> nlHsApps mappend_RDR [x,y]) xs
+
+{-
+************************************************************************
+*                                                                      *
+                        Traversable instances
+
+ see http://www.mail-archive.com/haskell-prime@haskell.org/msg02116.html
+*                                                                      *
+************************************************************************
+
+Again, Traversable is much like Functor and Foldable.
+
+The cases are:
+
+  $(traverse 'a 'a)          =  f
+  $(traverse 'a '(b1,b2))    =  \x -> case x of (x1,x2) -> (,) <$> $(traverse 'a 'b1) x1 <*> $(traverse 'a 'b2) x2
+  $(traverse 'a '(T b1 b2))  =  traverse $(traverse 'a 'b2)  -- when a only occurs in the last parameter, b2
+
+Like -XDeriveFoldable, -XDeriveTraversable filters out arguments whose types
+do not mention the last type parameter. Therefore, the following datatype:
+
+  data Foo a = Foo Int a Int
+
+would have the following derived Traversable instance:
+
+  instance Traversable Foo where
+    traverse f (Foo x1 x2 x3) =
+      fmap (\b2 -> Foo x1 b2 x3) ( $(traverse 'a 'a) x2 )
+
+since the two Int arguments do not produce any effects in a traversal.
+
+One can envision a case for types that do not mention the last type parameter:
+
+  $(traverse 'a 'b)          =  pure     -- when b does not contain a
+
+But this case will never materialize, since the aforementioned filtering
+removes all such types from consideration.
+See Note [Generated code for DeriveFoldable and DeriveTraversable].
+-}
+
+gen_Traversable_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, BagDerivStuff)
+gen_Traversable_binds loc tycon
+  = (unitBag traverse_bind, emptyBag)
+  where
+    data_cons = tyConDataCons tycon
+
+    traverse_bind = mkRdrFunBind (L loc traverse_RDR) eqns
+    eqns = map traverse_eqn data_cons
+    traverse_eqn con
+      = evalState (match_for_con [f_Pat] con =<< parts) bs_RDRs
+      where
+        parts = sequence $ foldDataConArgs ft_trav con
+
+    -- Yields 'Just' an expression if we're folding over a type that mentions
+    -- the last type parameter of the datatype. Otherwise, yields 'Nothing'.
+    -- See Note [FFoldType and functorLikeTraverse]
+    ft_trav :: FFoldType (State [RdrName] (Maybe (LHsExpr RdrName)))
+    ft_trav
+      = FT { ft_triv    = return Nothing
+             -- traverse f = pure x
+           , ft_var     = return (Just f_Expr)
+             -- traverse f = f x
+           , ft_tup     = \t gs -> do
+               gg  <- sequence gs
+               lam <- mkSimpleLam $ mkSimpleTupleCase match_for_con t gg
+               return (Just lam)
+             -- traverse f = \x -> case x of (a1,a2,..) ->
+             --                           (,,) <$> g1 a1 <*> g2 a2 <*> ..
+           , ft_ty_app  = \_ g -> fmap (nlHsApp traverse_Expr) <$> g
+             -- traverse f = traverse g
+           , ft_forall  = \_ g -> g
+           , ft_co_var  = panic "contravariant"
+           , ft_fun     = panic "function"
+           , ft_bad_app = panic "in other argument" }
+
+    -- Con a1 a2 ... -> fmap (\b1 b2 ... -> Con b1 b2 ...) (g1 a1)
+    --                    <*> g2 a2 <*> ...
+    match_for_con :: [LPat RdrName]
+                  -> DataCon
+                  -> [Maybe (LHsExpr RdrName)]
+                  -> State [RdrName] (LMatch RdrName (LHsExpr RdrName))
+    match_for_con = mkSimpleConMatch2 CaseAlt $
+                                             \con xs -> return (mkApCon con xs)
+      where
+        -- fmap (\b1 b2 ... -> Con b1 b2 ...) x1 <*> x2 <*> ..
+        mkApCon :: LHsExpr RdrName -> [LHsExpr RdrName] -> LHsExpr RdrName
+        mkApCon con [] = nlHsApps pure_RDR [con]
+        mkApCon con (x:xs) = foldl appAp (nlHsApps fmap_RDR [con,x]) xs
+          where appAp x y = nlHsApps ap_RDR [x,y]
+
+-----------------------------------------------------------------------
+
+f_Expr, z_Expr, fmap_Expr, mempty_Expr, foldMap_Expr,
+    traverse_Expr :: LHsExpr RdrName
+f_Expr        = nlHsVar f_RDR
+z_Expr        = nlHsVar z_RDR
+fmap_Expr     = nlHsVar fmap_RDR
+mempty_Expr   = nlHsVar mempty_RDR
+foldMap_Expr  = nlHsVar foldMap_RDR
+traverse_Expr = nlHsVar traverse_RDR
+
+f_RDR, z_RDR :: RdrName
+f_RDR = mkVarUnqual (fsLit "f")
+z_RDR = mkVarUnqual (fsLit "z")
+
+as_RDRs, bs_RDRs :: [RdrName]
+as_RDRs = [ mkVarUnqual (mkFastString ("a"++show i)) | i <- [(1::Int) .. ] ]
+bs_RDRs = [ mkVarUnqual (mkFastString ("b"++show i)) | i <- [(1::Int) .. ] ]
+
+f_Pat, z_Pat :: LPat RdrName
+f_Pat = nlVarPat f_RDR
+z_Pat = nlVarPat z_RDR
+
+{-
+Note [DeriveFoldable with ExistentialQuantification]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Functor and Traversable instances can only be derived for data types whose
+last type parameter is truly universally polymorphic. For example:
+
+  data T a b where
+    T1 ::                 b   -> T a b   -- YES, b is unconstrained
+    T2 :: Ord b   =>      b   -> T a b   -- NO, b is constrained by (Ord b)
+    T3 :: b ~ Int =>      b   -> T a b   -- NO, b is constrained by (b ~ Int)
+    T4 ::                 Int -> T a Int -- NO, this is just like T3
+    T5 :: Ord a   => a -> b   -> T a b   -- YES, b is unconstrained, even
+                                         -- though a is existential
+    T6 ::                 Int -> T Int b -- YES, b is unconstrained
+
+For Foldable instances, however, we can completely lift the constraint that
+the last type parameter be truly universally polymorphic. This means that T
+(as defined above) can have a derived Foldable instance:
+
+  instance Foldable (T a) where
+    foldr f z (T1 b)   = f b z
+    foldr f z (T2 b)   = f b z
+    foldr f z (T3 b)   = f b z
+    foldr f z (T4 b)   = z
+    foldr f z (T5 a b) = f b z
+    foldr f z (T6 a)   = z
+
+    foldMap f (T1 b)   = f b
+    foldMap f (T2 b)   = f b
+    foldMap f (T3 b)   = f b
+    foldMap f (T4 b)   = mempty
+    foldMap f (T5 a b) = f b
+    foldMap f (T6 a)   = mempty
+
+In a Foldable instance, it is safe to fold over an occurrence of the last type
+parameter that is not truly universally polymorphic. However, there is a bit
+of subtlety in determining what is actually an occurrence of a type parameter.
+T3 and T4, as defined above, provide one example:
+
+  data T a b where
+    ...
+    T3 :: b ~ Int => b   -> T a b
+    T4 ::            Int -> T a Int
+    ...
+
+  instance Foldable (T a) where
+    ...
+    foldr f z (T3 b) = f b z
+    foldr f z (T4 b) = z
+    ...
+    foldMap f (T3 b) = f b
+    foldMap f (T4 b) = mempty
+    ...
+
+Notice that the argument of T3 is folded over, whereas the argument of T4 is
+not. This is because we only fold over constructor arguments that
+syntactically mention the universally quantified type parameter of that
+particular data constructor. See foldDataConArgs for how this is implemented.
+
+As another example, consider the following data type. The argument of each
+constructor has the same type as the last type parameter:
+
+  data E a where
+    E1 :: (a ~ Int) => a   -> E a
+    E2 ::              Int -> E Int
+    E3 :: (a ~ Int) => a   -> E Int
+    E4 :: (a ~ Int) => Int -> E a
+
+Only E1's argument is an occurrence of a universally quantified type variable
+that is syntactically equivalent to the last type parameter, so only E1's
+argument will be be folded over in a derived Foldable instance.
+
+See Trac #10447 for the original discussion on this feature. Also see
+https://ghc.haskell.org/trac/ghc/wiki/Commentary/Compiler/DeriveFunctor
+for a more in-depth explanation.
+
+Note [FFoldType and functorLikeTraverse]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Deriving Functor, Foldable, and Traversable all require generating expressions
+which perform an operation on each argument of a data constructor depending
+on the argument's type. In particular, a generated operation can be different
+depending on whether the type mentions the last type variable of the datatype
+(e.g., if you have data T a = MkT a Int, then a generated foldr expresion would
+fold over the first argument of MkT, but not the second).
+
+This pattern is abstracted with the FFoldType datatype, which provides hooks
+for the user to specify how a constructor argument should be folded when it
+has a type with a particular "shape". The shapes are as follows (assume that
+a is the last type variable in a given datatype):
+
+* ft_triv:    The type does not mention the last type variable at all.
+              Examples: Int, b
+
+* ft_var:     The type is syntactically equal to the last type variable.
+              Moreover, the type appears in a covariant position (see
+              the Deriving Functor instances section of the users' guide
+              for an in-depth explanation of covariance vs. contravariance).
+              Example: a (covariantly)
+
+* ft_co_var:  The type is syntactically equal to the last type variable.
+              Moreover, the type appears in a contravariant position.
+              Example: a (contravariantly)
+
+* ft_fun:     A function type which mentions the last type variable in
+              the argument position, result position or both.
+              Examples: a -> Int, Int -> a, Maybe a -> [a]
+
+* ft_tup:     A tuple type which mentions the last type variable in at least
+              one of its fields. The TyCon argument of ft_tup represents the
+              particular tuple's type constructor.
+              Examples: (a, Int), (Maybe a, [a], Either a Int), (# Int, a #)
+
+* ft_ty_app:  A type is being applied to the last type parameter, where the
+              applied type does not mention the last type parameter (if it
+              did, it would fall under ft_bad_app). The Type argument to
+              ft_ty_app represents the applied type.
+
+              Note that functions, tuples, and foralls are distinct cases
+              and take precedence of ft_ty_app. (For example, (Int -> a) would
+              fall under (ft_fun Int a), not (ft_ty_app ((->) Int) a).
+              Examples: Maybe a, Either b a
+
+* ft_bad_app: A type application uses the last type parameter in a position
+              other than the last argument. This case is singled out because
+              Functor, Foldable, and Traversable instances cannot be derived
+              for datatypes containing arguments with such types.
+              Examples: Either a Int, Const a b
+
+* ft_forall:  A forall'd type mentions the last type parameter on its right-
+              hand side (and is not quantified on the left-hand side). This
+              case is present mostly for plumbing purposes.
+              Example: forall b. Either b a
+
+If FFoldType describes a strategy for folding subcomponents of a Type, then
+functorLikeTraverse is the function that applies that strategy to the entirety
+of a Type, returning the final folded-up result.
+
+foldDataConArgs applies functorLikeTraverse to every argument type of a
+constructor, returning a list of the fold results. This makes foldDataConArgs
+a natural way to generate the subexpressions in a generated fmap, foldr,
+foldMap, or traverse definition (the subexpressions must then be combined in
+a method-specific fashion to form the final generated expression).
+
+Deriving Generic1 also does validity checking by looking for the last type
+variable in certain positions of a constructor's argument types, so it also
+uses foldDataConArgs. See Note [degenerate use of FFoldType] in TcGenGenerics.
+
+Note [Generated code for DeriveFoldable and DeriveTraversable]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We adapt the algorithms for -XDeriveFoldable and -XDeriveTraversable based on
+that of -XDeriveFunctor. However, there an important difference between deriving
+the former two typeclasses and the latter one, which is best illustrated by the
+following scenario:
+
+  data WithInt a = WithInt a Int# deriving (Functor, Foldable, Traversable)
+
+The generated code for the Functor instance is straightforward:
+
+  instance Functor WithInt where
+    fmap f (WithInt a i) = WithInt (f a) i
+
+But if we use too similar of a strategy for deriving the Foldable and
+Traversable instances, we end up with this code:
+
+  instance Foldable WithInt where
+    foldMap f (WithInt a i) = f a <> mempty
+
+  instance Traversable WithInt where
+    traverse f (WithInt a i) = fmap WithInt (f a) <*> pure i
+
+This is unsatisfying for two reasons:
+
+1. The Traversable instance doesn't typecheck! Int# is of kind #, but pure
+   expects an argument whose type is of kind *. This effectively prevents
+   Traversable from being derived for any datatype with an unlifted argument
+   type (Trac #11174).
+
+2. The generated code contains superfluous expressions. By the Monoid laws,
+   we can reduce (f a <> mempty) to (f a), and by the Applicative laws, we can
+   reduce (fmap WithInt (f a) <*> pure i) to (fmap (\b -> WithInt b i) (f a)).
+
+We can fix both of these issues by incorporating a slight twist to the usual
+algorithm that we use for -XDeriveFunctor. The differences can be summarized
+as follows:
+
+1. In the generated expression, we only fold over arguments whose types
+   mention the last type parameter. Any other argument types will simply
+   produce useless 'mempty's or 'pure's, so they can be safely ignored.
+
+2. In the case of -XDeriveTraversable, instead of applying ConName,
+   we apply (\b_i ... b_k -> ConName a_1 ... a_n), where
+
+   * ConName has n arguments
+   * {b_i, ..., b_k} is a subset of {a_1, ..., a_n} whose indices correspond
+     to the arguments whose types mention the last type parameter. As a
+     consequence, taking the difference of {a_1, ..., a_n} and
+     {b_i, ..., b_k} yields the all the argument values of ConName whose types
+     do not mention the last type parameter. Note that [i, ..., k] is a
+     strictly increasing—but not necessarily consecutive—integer sequence.
+
+     For example, the datatype
+
+       data Foo a = Foo Int a Int a
+
+     would generate the following Traversable instance:
+
+       instance Traversable Foo where
+         traverse f (Foo a1 a2 a3 a4) =
+           fmap (\b2 b4 -> Foo a1 b2 a3 b4) (f a2) <*> f a4
+
+Technically, this approach would also work for -XDeriveFunctor as well, but we
+decide not to do so because:
+
+1. There's not much benefit to generating, e.g., ((\b -> WithInt b i) (f a))
+   instead of (WithInt (f a) i).
+
+2. There would be certain datatypes for which the above strategy would
+   generate Functor code that would fail to typecheck. For example:
+
+     data Bar f a = Bar (forall f. Functor f => f a) deriving Functor
+
+   With the conventional algorithm, it would generate something like:
+
+     fmap f (Bar a) = Bar (fmap f a)
+
+   which typechecks. But with the strategy mentioned above, it would generate:
+
+     fmap f (Bar a) = (\b -> Bar b) (fmap f a)
+
+   which does not typecheck, since GHC cannot unify the rank-2 type variables
+   in the types of b and (fmap f a).
+-}
diff --git a/compiler/typecheck/TcGenGenerics.hs b/compiler/typecheck/TcGenGenerics.hs
index 5757e98592..0c65f686c2 100644
--- a/compiler/typecheck/TcGenGenerics.hs
+++ b/compiler/typecheck/TcGenGenerics.hs
@@ -17,6 +17,7 @@ import HsSyn
 import Type
 import TcType
 import TcGenDeriv
+import TcGenFunctor
 import DataCon
 import TyCon
 import FamInstEnv       ( FamInst, FamFlavor(..), mkSingleCoAxiom )