Fix DeriveAnyClass (Trac #9968)
[ghc.git] / compiler / typecheck / TcDeriv.hs
index f99f78b..aab1e4d 100644 (file)
@@ -8,7 +8,7 @@ Handles @deriving@ clauses on @data@ declarations.
 
 {-# LANGUAGE CPP #-}
 
-module TcDeriv ( tcDeriving ) where
+module TcDeriv ( tcDeriving, DerivInfo(..), mkDerivInfos ) where
 
 #include "HsVersions.h"
 
@@ -19,9 +19,8 @@ import TcRnMonad
 import FamInst
 import TcErrors( reportAllUnsolved )
 import TcValidity( validDerivPred )
+import TcClassDcl( tcATDefault, tcMkDeclCtxt )
 import TcEnv
-import TcTyClsDecls( tcFamTyPats, famTyConShape, tcAddDataFamInstCtxt, kcDataDefn )
-import TcClassDcl( tcAddDeclCtxt )      -- Small helper
 import TcGenDeriv                       -- Deriv stuff
 import TcGenGenerics
 import InstEnv
@@ -52,8 +51,10 @@ import NameSet
 import TyCon
 import TcType
 import Var
+import VarEnv
 import VarSet
 import PrelNames
+import THNames ( liftClassKey )
 import SrcLoc
 import Util
 import Outputable
@@ -139,15 +140,12 @@ data EarlyDerivSpec = InferTheta (DerivSpec ThetaOrigin)
         --      In this case ds_theta is the list of all the constraints
         --      needed, such as (Eq [a], Eq a), together with a suitable CtLoc
         --      to get good error messages.
-        --      The inference process is to reduce this to a simpler form (e.g.
-        --      Eq a)
+        --      The inference process is to reduce this to a
+        --      simpler form (e.g. Eq a)
         --
         -- GivenTheta ds => the exact context for the instance is supplied
         --                  by the programmer; it is ds_theta
-
-forgetTheta :: EarlyDerivSpec -> DerivSpec ()
-forgetTheta (InferTheta spec) = spec { ds_theta = () }
-forgetTheta (GivenTheta spec) = spec { ds_theta = () }
+        -- See Note [Inferring the instance context]
 
 earlyDSLoc :: EarlyDerivSpec -> SrcSpan
 earlyDSLoc (InferTheta spec) = ds_loc spec
@@ -176,86 +174,38 @@ instance Outputable EarlyDerivSpec where
 instance Outputable PredOrigin where
   ppr (PredOrigin ty _) = ppr ty -- The origin is not so interesting when debugging
 
-{-
-Inferring missing contexts
-~~~~~~~~~~~~~~~~~~~~~~~~~~
-Consider
-
-        data T a b = C1 (Foo a) (Bar b)
-                   | C2 Int (T b a)
-                   | C3 (T a a)
-                   deriving (Eq)
-
-[NOTE: See end of these comments for what to do with
-        data (C a, D b) => T a b = ...
-]
-
-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:
-
-        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
+{- Note [Inferring the instance context]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+There are two sorts of 'deriving':
 
-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.  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
+  * 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 ...
 
-        After simplification:
-                   = Eq a u Ping b
-                   u (Eq b u Ping a)
-                   u (Eq a u Ping a)
+  * 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
 
-                   = Eq a u Ping b u Eq b u Ping a
+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
 
-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
+  * (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.
 
-        - the classes constrain only tyvars
-        - the list is sorted by tyvar (major key) and then class (minor key)
-        - no duplicates, of course
+  * (T s1 .. sm) :: * -> *    (the functor-like case)
+    Then we behave like Functor.
 
-So, here are the synonyms for the ``equation'' structures:
+In both cases we produce a bunch of un-simplified constraints
+and them simplify them in simplifyInstanceContexts; see
+Note [Simplifying the instance context].
 
 
 Note [Data decl contexts]
@@ -331,6 +281,33 @@ See Trac #3221.  Consider
 Are T1 and T2 unused?  Well, no: the deriving clause expands to mention
 both of them.  So we gather defs/uses from deriving just like anything else.
 
+-}
+
+-- | Stuff needed to process a `deriving` clause
+data DerivInfo = DerivInfo { di_rep_tc :: TyCon
+                             -- ^ The data tycon for normal datatypes,
+                             -- or the *representation* tycon for data families
+                           , di_preds  :: [LHsSigType Name]
+                           , di_ctxt   :: SDoc -- ^ error context
+                           }
+
+-- | Extract `deriving` clauses of proper data type (skips data families)
+mkDerivInfos :: [TyClGroup Name] -> TcM [DerivInfo]
+mkDerivInfos tycls = concatMapM mk_derivs tycls
+  where
+    mk_derivs (TyClGroup { group_tyclds = decls })
+      = concatMapM (mk_deriv . unLoc) decls
+
+    mk_deriv decl@(DataDecl { tcdLName = L _ data_name
+                            , tcdDataDefn =
+                                HsDataDefn { dd_derivs = Just (L _ preds) } })
+      = do { tycon <- tcLookupTyCon data_name
+           ; return [DerivInfo { di_rep_tc = tycon, di_preds = preds
+                               , di_ctxt = tcMkDeclCtxt decl }] }
+    mk_deriv _ = return []
+
+{-
+
 ************************************************************************
 *                                                                      *
 \subsection[TcDeriv-driver]{Top-level function for \tr{derivings}}
@@ -338,11 +315,10 @@ both of them.  So we gather defs/uses from deriving just like anything else.
 ************************************************************************
 -}
 
-tcDeriving  :: [LTyClDecl Name]  -- All type constructors
-            -> [LInstDecl Name]  -- All instance declarations
+tcDeriving  :: [DerivInfo]       -- All `deriving` clauses
             -> [LDerivDecl Name] -- All stand-alone deriving declarations
             -> TcM (TcGblEnv, Bag (InstInfo Name), HsValBinds Name)
-tcDeriving tycl_decls inst_decls deriv_decls
+tcDeriving deriv_infos deriv_decls
   = recoverM (do { g <- getGblEnv
                  ; return (g, emptyBag, emptyValBindsOut)}) $
     do  {       -- Fish the "deriving"-related information out of the TcEnv
@@ -350,28 +326,23 @@ tcDeriving tycl_decls inst_decls deriv_decls
           is_boot <- tcIsHsBootOrSig
         ; traceTc "tcDeriving" (ppr is_boot)
 
-        ; early_specs <- makeDerivSpecs is_boot tycl_decls inst_decls deriv_decls
+        ; early_specs <- makeDerivSpecs is_boot deriv_infos deriv_decls
         ; traceTc "tcDeriving 1" (ppr early_specs)
 
-        -- for each type, determine the auxliary declarations that are common
-        -- to multiple derivations involving that type (e.g. Generic and
-        -- Generic1 should use the same TcGenGenerics.MetaTyCons)
-        ; (commonAuxs, auxDerivStuff) <- commonAuxiliaries $ map forgetTheta early_specs
-
         ; let (infer_specs, given_specs) = splitEarlyDerivSpec early_specs
-        ; insts1 <- mapM (genInst commonAuxs) given_specs
+        ; insts1 <- mapM genInst given_specs
 
         -- the stand-alone derived instances (@insts1@) are used when inferring
         -- the contexts for "deriving" clauses' instances (@infer_specs@)
         ; final_specs <- extendLocalInstEnv (map (iSpec . fstOf3) insts1) $
-                         inferInstanceContexts infer_specs
+                         simplifyInstanceContexts infer_specs
 
-        ; insts2 <- mapM (genInst commonAuxs) final_specs
+        ; insts2 <- mapM genInst final_specs
 
         ; let (inst_infos, deriv_stuff, maybe_fvs) = unzip3 (insts1 ++ insts2)
         ; loc <- getSrcSpanM
-        ; let (binds, newTyCons, famInsts, extraInstances) =
-                genAuxBinds loc (unionManyBags (auxDerivStuff : deriv_stuff))
+        ; let (binds, famInsts, extraInstances) =
+                genAuxBinds loc (unionManyBags deriv_stuff)
 
         ; dflags <- getDynFlags
 
@@ -380,99 +351,25 @@ tcDeriving tycl_decls inst_decls deriv_decls
 
         ; unless (isEmptyBag inst_info) $
              liftIO (dumpIfSet_dyn dflags Opt_D_dump_deriv "Derived instances"
-                        (ddump_deriving inst_info rn_binds newTyCons famInsts))
+                        (ddump_deriving inst_info rn_binds famInsts))
 
-        ; let all_tycons = map ATyCon (bagToList newTyCons)
-        ; gbl_env <- tcExtendGlobalEnv all_tycons $
-                     tcExtendGlobalEnvImplicit (concatMap implicitTyThings all_tycons) $
-                     tcExtendLocalFamInstEnv (bagToList famInsts) $
+        ; gbl_env <- tcExtendLocalFamInstEnv (bagToList famInsts) $
                      tcExtendLocalInstEnv (map iSpec (bagToList inst_info)) getGblEnv
         ; let all_dus = rn_dus `plusDU` usesOnly (mkFVs $ catMaybes maybe_fvs)
         ; return (addTcgDUs gbl_env all_dus, inst_info, rn_binds) }
   where
     ddump_deriving :: Bag (InstInfo Name) -> HsValBinds Name
-                   -> Bag TyCon               -- ^ Empty data constructors
                    -> Bag FamInst             -- ^ Rep type family instances
                    -> SDoc
-    ddump_deriving inst_infos extra_binds repMetaTys repFamInsts
+    ddump_deriving inst_infos extra_binds repFamInsts
       =    hang (ptext (sLit "Derived instances:"))
               2 (vcat (map (\i -> pprInstInfoDetails i $$ text "") (bagToList inst_infos))
                  $$ ppr extra_binds)
-        $$ hangP "Generic representation:" (
-              hangP "Generated datatypes for meta-information:"
-               (vcat (map ppr (bagToList repMetaTys)))
-           $$ hangP "Representation types:"
-                (vcat (map pprRepTy (bagToList repFamInsts))))
+        $$ hangP "GHC.Generics representation types:"
+             (vcat (map pprRepTy (bagToList repFamInsts)))
 
     hangP s x = text "" $$ hang (ptext (sLit s)) 2 x
 
-{-
-genTypeableTyConReps :: DynFlags ->
-                        [LTyClDecl Name] ->
-                        [LInstDecl Name] ->
-                        TcM (Bag (LHsBind RdrName, LSig RdrName))
-genTypeableTyConReps dflags decls insts =
-  do tcs1 <- mapM tyConsFromDecl decls
-     tcs2 <- mapM tyConsFromInst insts
-     return $ listToBag [ genTypeableTyConRep dflags loc tc
-                                          | (loc,tc) <- concat (tcs1 ++ tcs2) ]
-  where
-
-  tyConFromDataCon (L l n) = do dc <- tcLookupDataCon n
-                                return (do tc <- promoteDataCon_maybe dc
-                                           return (l,tc))
-
-  -- Promoted data constructors from a data declaration, or
-  -- a data-family instance.
-  tyConsFromDataRHS = fmap catMaybes
-                    . mapM tyConFromDataCon
-                    . concatMap (con_names . unLoc)
-                    . dd_cons
-
-  -- Tycons from a data-family declaration; not promotable.
-  tyConFromDataFamDecl FamilyDecl { fdLName = L loc name } =
-    do tc <- tcLookupTyCon name
-       return (loc,tc)
-
-
-  -- tycons from a type-level declaration
-  tyConsFromDecl (L _ d)
-
-    -- data or newtype declaration: promoted tycon, tycon, promoted ctrs.
-    | isDataDecl d =
-      do let L loc name = tcdLName d
-         tc           <- tcLookupTyCon name
-         promotedCtrs <- tyConsFromDataRHS (tcdDataDefn d)
-         let tyCons = (loc,tc) : promotedCtrs
-
-         return (case promotableTyCon_maybe tc of
-                   Nothing -> tyCons
-                   Just kc -> (loc,kc) : tyCons)
-
-    -- data family: just the type constructor;  these are not promotable.
-    | isDataFamilyDecl d =
-      do res <- tyConFromDataFamDecl (tcdFam d)
-         return [res]
-
-    -- class: the type constructors of associated data families
-    | isClassDecl d =
-      let isData FamilyDecl { fdInfo = DataFamily } = True
-          isData _ = False
-
-      in mapM tyConFromDataFamDecl (filter isData (map unLoc (tcdATs d)))
-
-    | otherwise = return []
-
-
-  tyConsFromInst (L _ d) =
-    case d of
-      ClsInstD ci      -> fmap concat
-                        $ mapM (tyConsFromDataRHS . dfid_defn . unLoc)
-                        $ cid_datafam_insts ci
-      DataFamInstD dfi -> tyConsFromDataRHS (dfid_defn dfi)
-      TyFamInstD {}    -> return []
--}
-
 -- Prints the representable type family instance
 pprRepTy :: FamInst -> SDoc
 pprRepTy fi@(FamInst { fi_tys = lhs })
@@ -480,22 +377,6 @@ pprRepTy fi@(FamInst { fi_tys = lhs })
       equals <+> ppr rhs
   where rhs = famInstRHS fi
 
--- As of 24 April 2012, this only shares MetaTyCons between derivations of
--- Generic and Generic1; thus the types and logic are quite simple.
-type CommonAuxiliary = MetaTyCons
-type CommonAuxiliaries = [(TyCon, CommonAuxiliary)] -- NSF what is a more efficient map type?
-
-commonAuxiliaries :: [DerivSpec ()] -> TcM (CommonAuxiliaries, BagDerivStuff)
-commonAuxiliaries = foldM snoc ([], emptyBag) where
-  snoc acc@(cas, stuff) (DS {ds_name = nm, ds_cls = cls, ds_tc = rep_tycon})
-    | getUnique cls `elem` [genClassKey, gen1ClassKey] =
-      extendComAux $ genGenericMetaTyCons rep_tycon (nameModule nm)
-    | otherwise = return acc
-   where extendComAux m -- don't run m if its already in the accumulator
-           | any ((rep_tycon ==) . fst) cas = return acc
-           | otherwise = do (ca, new_stuff) <- m
-                            return $ ((rep_tycon, ca) : cas, stuff `unionBags` new_stuff)
-
 renameDeriv :: Bool
             -> [InstInfo RdrName]
             -> Bag (LHsBind RdrName, LSig RdrName)
@@ -517,11 +398,12 @@ renameDeriv is_boot inst_infos bagBinds
     do  {
         -- Bring the extra deriving stuff into scope
         -- before renaming the instances themselves
+        ; traceTc "rnd" (vcat (map (\i -> pprInstInfoDetails i $$ text "") inst_infos))
         ; (aux_binds, aux_sigs) <- mapAndUnzipBagM return bagBinds
         ; let aux_val_binds = ValBindsIn aux_binds (bagToList aux_sigs)
         ; rn_aux_lhs <- rnTopBindsLHS emptyFsEnv aux_val_binds
         ; let bndrs = collectHsValBinders rn_aux_lhs
-        ; envs <- extendGlobalRdrEnvRn (map Avail bndrs) emptyFsEnv ;
+        ; envs <- extendGlobalRdrEnvRn (map avail bndrs) emptyFsEnv ;
         ; setEnvs envs $
     do  { (rn_aux, dus_aux) <- rnValBindsRHS (TopSigCtxt (mkNameSet bndrs)) rn_aux_lhs
         ; (rn_inst_infos, fvs_insts) <- mapAndUnzipM rn_inst_info inst_infos
@@ -540,7 +422,7 @@ renameDeriv is_boot inst_infos bagBinds
                             , ib_derived = sa } })
         =  ASSERT( null sigs )
            bindLocalNamesFV tyvars $
-           do { (rn_binds, fvs) <- rnMethodBinds (is_cls_nm inst) (\_ -> []) binds
+           do { (rn_binds,_, fvs) <- rnMethodBinds False (is_cls_nm inst) [] binds []
               ; let binds' = InstBindings { ib_binds = rn_binds
                                           , ib_tyvars = tyvars
                                           , ib_pragmas = []
@@ -568,6 +450,20 @@ So we want to signal a user of the data constructor 'MkP'.
 This is the reason behind the (Maybe Name) part of the return type
 of genInst.
 
+Note [Why we don't pass rep_tc into deriveTyData]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Down in the bowels of mkEqnHelp, we need to convert the fam_tc back into
+the rep_tc by means of a lookup. And yet we have the rep_tc right here!
+Why look it up again? Answer: it's just easier this way.
+We drop some number of arguments from the end of the datatype definition
+in deriveTyData. The arguments are dropped from the fam_tc.
+This action may drop a *different* number of arguments
+passed to the rep_tc, depending on how many free variables, etc., the
+dropped patterns have.
+
+Also, this technique carries over the kind substitution from deriveTyData
+nicely.
+
 ************************************************************************
 *                                                                      *
                 From HsSyn to DerivSpec
@@ -578,15 +474,13 @@ of genInst.
 -}
 
 makeDerivSpecs :: Bool
-               -> [LTyClDecl Name]
-               -> [LInstDecl Name]
+               -> [DerivInfo]
                -> [LDerivDecl Name]
                -> TcM [EarlyDerivSpec]
-makeDerivSpecs is_boot tycl_decls inst_decls deriv_decls
-  = do  { eqns1 <- concatMapM (recoverM (return []) . deriveTyDecl)     tycl_decls
-        ; eqns2 <- concatMapM (recoverM (return []) . deriveInstDecl)   inst_decls
-        ; eqns3 <- concatMapM (recoverM (return []) . deriveStandalone) deriv_decls
-        ; let eqns = eqns1 ++ eqns2 ++ eqns3
+makeDerivSpecs is_boot deriv_infos deriv_decls
+  = do  { eqns1 <- concatMapM (recoverM (return []) . deriveDerivInfo)  deriv_infos
+        ; eqns2 <- concatMapM (recoverM (return []) . deriveStandalone) deriv_decls
+        ; let eqns = eqns1 ++ eqns2
 
         ; if is_boot then   -- No 'deriving' at all in hs-boot files
               do { unless (null eqns) (add_deriv_err (head eqns))
@@ -599,63 +493,21 @@ makeDerivSpecs is_boot tycl_decls inst_decls deriv_decls
                     2 (ptext (sLit "Use an instance declaration instead")))
 
 ------------------------------------------------------------------
-deriveTyDecl :: LTyClDecl Name -> TcM [EarlyDerivSpec]
-deriveTyDecl (L _ decl@(DataDecl { tcdLName = L _ tc_name
-                                 , tcdDataDefn = HsDataDefn { dd_derivs = preds } }))
-  = tcAddDeclCtxt decl $
-    do { tc <- tcLookupTyCon tc_name
-       ; let tvs  = tyConTyVars tc
-             tys  = mkTyVarTys tvs
-
-       ; case preds of
-          Just (L _ preds') -> concatMapM (deriveTyData tvs tc tys) preds'
-          Nothing           -> return [] }
-
-deriveTyDecl _ = return []
-
-------------------------------------------------------------------
-deriveInstDecl :: LInstDecl Name -> TcM [EarlyDerivSpec]
-deriveInstDecl (L _ (TyFamInstD {})) = return []
-deriveInstDecl (L _ (DataFamInstD { dfid_inst = fam_inst }))
-  = deriveFamInst fam_inst
-deriveInstDecl (L _ (ClsInstD { cid_inst = ClsInstDecl { cid_datafam_insts = fam_insts } }))
-  = concatMapM (deriveFamInst . unLoc) fam_insts
+-- | Process a `deriving` clause
+deriveDerivInfo :: DerivInfo -> TcM [EarlyDerivSpec]
+deriveDerivInfo (DerivInfo { di_rep_tc = rep_tc, di_preds = preds
+                           , di_ctxt = err_ctxt })
+  = addErrCtxt err_ctxt $
+    concatMapM (deriveTyData tvs tc tys) preds
+  where
+    tvs = tyConTyVars rep_tc
+    (tc, tys) = case tyConFamInstSig_maybe rep_tc of
+                        -- data family:
+                  Just (fam_tc, pats, _) -> (fam_tc, pats)
+      -- NB: deriveTyData wants the *user-specified*
+      -- name. See Note [Why we don't pass rep_tc into deriveTyData]
 
-------------------------------------------------------------------
-deriveFamInst :: DataFamInstDecl Name -> TcM [EarlyDerivSpec]
-deriveFamInst decl@(DataFamInstDecl
-                       { dfid_tycon = L _ tc_name, dfid_pats = pats
-                       , dfid_defn
-                         = defn@(HsDataDefn { dd_derivs = Just (L _ preds) }) })
-  = tcAddDataFamInstCtxt decl $
-    do { fam_tc <- tcLookupTyCon tc_name
-       ; tcFamTyPats (famTyConShape fam_tc) pats (kcDataDefn defn) $
-             -- kcDataDefn defn: see Note [Finding the LHS patterns]
-         \ tvs' pats' _ ->
-           concatMapM (deriveTyData tvs' fam_tc pats') preds }
-
-deriveFamInst _ = return []
-
-{-
-Note [Finding the LHS patterns]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-When kind polymorphism is in play, we need to be careful.  Here is
-Trac #9359:
-  data Cmp a where
-    Sup :: Cmp a
-    V   :: a -> Cmp a
-
-  data family   CmpInterval (a :: Cmp k) (b :: Cmp k) :: *
-  data instance CmpInterval (V c) Sup = Starting c deriving( Show )
-
-So CmpInterval is kind-polymorphic, but the data instance is not
-   CmpInterval :: forall k. Cmp k -> Cmp k -> *
-   data instance CmpInterval * (V (c::*)) Sup = Starting c deriving( Show )
-
-Hence, when deriving the type patterns in deriveFamInst, we must kind
-check the RHS (the data constructor 'Starting c') as well as the LHS,
-so that we correctly see the instantiation to *.
--}
+                  _ -> (rep_tc, mkTyVarTys tvs)     -- datatype
 
 ------------------------------------------------------------------
 deriveStandalone :: LDerivDecl Name -> TcM [EarlyDerivSpec]
@@ -666,7 +518,7 @@ deriveStandalone (L loc (DerivDecl deriv_ty overlap_mode))
   = setSrcSpan loc                   $
     addErrCtxt (standaloneCtxt deriv_ty)  $
     do { traceTc "Standalone deriving decl for" (ppr deriv_ty)
-       ; (tvs, theta, cls, inst_tys) <- tcHsInstHead TcType.InstDeclCtxt deriv_ty
+       ; (tvs, theta, cls, inst_tys) <- tcHsClsInstType TcType.InstDeclCtxt deriv_ty
        ; traceTc "Standalone deriving;" $ vcat
               [ text "tvs:" <+> ppr tvs
               , text "theta:" <+> ppr theta
@@ -685,13 +537,10 @@ deriveStandalone (L loc (DerivDecl deriv_ty overlap_mode))
        ; case tcSplitTyConApp_maybe inst_ty of
            Just (tc, tc_args)
               | className cls == typeableClassName
-              -> do warn <- woptM Opt_WarnDerivingTypeable
-                    when warn
-                       $ addWarnTc
-                       $ text "Standalone deriving `Typeable` has no effect."
+              -> do warnUselessTypeable
                     return []
 
-              | isAlgTyCon tc  -- All other classes
+              | isAlgTyCon tc || isDataFamilyTyCon tc  -- All other classes
               -> do { spec <- mkEqnHelp (fmap unLoc overlap_mode)
                                         tvs cls cls_tys tc tc_args (Just theta)
                     ; return [spec] }
@@ -702,15 +551,22 @@ deriveStandalone (L loc (DerivDecl deriv_ty overlap_mode))
         }
 
 
+warnUselessTypeable :: TcM ()
+warnUselessTypeable
+  = do { warn <- woptM Opt_WarnDerivingTypeable
+       ; when warn $ addWarnTc
+                   $ ptext (sLit "Deriving") <+> quotes (ppr typeableClassName) <+>
+                     ptext (sLit "has no effect: all types now auto-derive Typeable") }
+
 ------------------------------------------------------------------
 deriveTyData :: [TyVar] -> TyCon -> [Type]   -- LHS of data or data instance
                                              --   Can be a data instance, hence [Type] args
-             -> LHsType Name                 -- The deriving predicate
+             -> LHsSigType Name              -- The deriving predicate
              -> TcM [EarlyDerivSpec]
 -- The deriving clause of a data or newtype declaration
 -- I.e. not standalone deriving
-deriveTyData tvs tc tc_args (L loc deriv_pred)
-  = setSrcSpan loc     $        -- Use the location of the 'deriving' item
+deriveTyData tvs tc tc_args deriv_pred
+  = setSrcSpan (getLoc (hsSigType deriv_pred)) $  -- Use loc of the 'deriving' item
     do  { (deriv_tvs, cls, cls_tys, cls_arg_kind)
                 <- tcExtendTyVarEnv tvs $
                    tcHsDeriv deriv_pred
@@ -723,10 +579,7 @@ deriveTyData tvs tc tc_args (L loc deriv_pred)
                 -- so the argument kind 'k' is not decomposable by splitKindFunTys
                 -- as is the case for all other derivable type classes
         ; if className cls == typeableClassName
-          then do warn <- woptM Opt_WarnDerivingTypeable
-                  when warn
-                     $ addWarnTc
-                     $ text "Deriving `Typeable` has no effect."
+          then do warnUselessTypeable
                   return []
           else
 
@@ -735,8 +588,8 @@ deriveTyData tvs tc tc_args (L loc deriv_pred)
           let (arg_kinds, _)  = splitKindFunTys cls_arg_kind
               n_args_to_drop  = length arg_kinds
               n_args_to_keep  = tyConArity tc - n_args_to_drop
-              args_to_drop    = drop n_args_to_keep tc_args
-              tc_args_to_keep = take n_args_to_keep tc_args
+              (tc_args_to_keep, args_to_drop)
+                              = splitAt n_args_to_keep tc_args
               inst_ty_kind    = typeKind (mkTyConApp tc tc_args_to_keep)
               dropped_tvs     = tyVarsOfTypes args_to_drop
 
@@ -754,7 +607,7 @@ deriveTyData tvs tc tc_args (L loc deriv_pred)
               final_cls_tys       = substTys subst' cls_tys
 
         ; traceTc "derivTyData1" (vcat [ pprTvBndrs tvs, ppr tc, ppr tc_args, ppr deriv_pred
-                                       , pprTvBndrs (varSetElems $ tyVarsOfTypes tc_args)
+                                       , pprTvBndrs (tyVarsOfTypesList tc_args)
                                        , ppr n_args_to_keep, ppr n_args_to_drop
                                        , ppr inst_ty_kind, ppr cls_arg_kind, ppr mb_match
                                        , ppr final_tc_args, ppr final_cls_tys ])
@@ -781,6 +634,7 @@ deriveTyData tvs tc tc_args (L loc deriv_pred)
 
         ; spec <- mkEqnHelp Nothing (univ_kvs' ++ univ_tvs')
                             cls final_cls_tys tc final_tc_args Nothing
+        ; traceTc "derivTyData" (ppr spec)
         ; return [spec] } }
 
 
@@ -872,14 +726,7 @@ mkEqnHelp overlap_mode tvs cls cls_tys tycon tc_args mtheta
                                  any not_in_scope data_con_names)
              not_in_scope dc  = null (lookupGRE_Name rdr_env dc)
 
-             -- Make a Qual RdrName that will do for each DataCon
-             -- so we can report it as used (Trac #7969)
-             data_con_rdrs = [ greUsedRdrName gre
-                             | dc_name <- data_con_names
-                             , gre : _ <- [lookupGRE_Name rdr_env dc_name]
-                             , not (isLocalGRE gre) ]
-
-       ; addUsedRdrNames data_con_rdrs
+       ; addUsedDataCons rdr_env rep_tc
        ; unless (isNothing mtheta || not hidden_data_cons)
                 (bale_out (derivingHiddenErr tycon))
 
@@ -950,7 +797,7 @@ write it out
       return x = MkT [x]
       ... etc ...
 
-See Note [Eta reduction for data family axioms] in TcInstDcls.
+See Note [Eta reduction for data families] in FamInstEnv
 
 
 ************************************************************************
@@ -982,18 +829,18 @@ mkDataTypeEqn dflags overlap_mode tvs cls cls_tys
         CanDerive               -> go_for_it
         DerivableViaInstance    -> go_for_it
   where
-    go_for_it    = mk_data_eqn overlap_mode tvs cls tycon tc_args rep_tc rep_tc_args mtheta
+    go_for_it    = mk_data_eqn overlap_mode tvs cls cls_tys tycon tc_args rep_tc rep_tc_args mtheta
     bale_out msg = failWithTc (derivingThingErr False cls cls_tys (mkTyConApp tycon tc_args) msg)
 
-mk_data_eqn :: Maybe OverlapMode -> [TyVar] -> Class
+mk_data_eqn :: Maybe OverlapMode -> [TyVar] -> Class -> [Type]
             -> TyCon -> [TcType] -> TyCon -> [TcType] -> DerivContext
             -> TcM EarlyDerivSpec
-mk_data_eqn overlap_mode tvs cls tycon tc_args rep_tc rep_tc_args mtheta
+mk_data_eqn overlap_mode tvs cls cls_tys tycon tc_args rep_tc rep_tc_args mtheta
   = do loc                  <- getSrcSpanM
-       dfun_name            <- new_dfun_name cls tycon
+       dfun_name            <- newDFunName' cls tycon
        case mtheta of
         Nothing -> do --Infer context
-            inferred_constraints <- inferConstraints cls inst_tys rep_tc rep_tc_args
+            inferred_constraints <- inferConstraints cls cls_tys inst_ty rep_tc rep_tc_args
             return $ InferTheta $ DS
                    { ds_loc = loc
                    , ds_name = dfun_name, ds_tvs = tvs
@@ -1012,77 +859,109 @@ mk_data_eqn overlap_mode tvs cls tycon tc_args rep_tc rep_tc_args mtheta
                    , ds_overlap = overlap_mode
                    , ds_newtype = False }
   where
-    inst_tys = [mkTyConApp tycon tc_args]
+    inst_ty  = mkTyConApp tycon tc_args
+    inst_tys = cls_tys ++ [inst_ty]
 
 ----------------------
 
-inferConstraints :: Class -> [TcType]
+inferConstraints :: Class -> [TcType] -> TcType
                  -> TyCon -> [TcType]
                  -> TcM ThetaOrigin
+-- inferConstraints figures out the constraints needed for the
+-- instance declaration generated by a 'deriving' clause on a
+-- data type declaration.
+-- 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 cls inst_tys rep_tc rep_tc_args
-  | cls `hasKey` genClassKey    -- Generic constraints are easy
+inferConstraints main_cls cls_tys inst_ty rep_tc rep_tc_args
+  | main_cls `hasKey` genClassKey    -- Generic constraints are easy
   = return []
 
-  | cls `hasKey` gen1ClassKey   -- Gen1 needs Functor
-  = ASSERT(length rep_tc_tvs > 0)   -- See Note [Getting base classes]
+  | main_cls `hasKey` gen1ClassKey   -- Gen1 needs Functor
+  = ASSERT( length rep_tc_tvs > 0 )   -- See Note [Getting base classes]
+    ASSERT( null cls_tys )
     do { functorClass <- tcLookupClass functorClassName
-       ; return (con_arg_constraints functorClass (get_gen1_constrained_tys last_tv)) }
+       ; return (con_arg_constraints (get_gen1_constraints functorClass)) }
 
   | otherwise  -- The others are a bit more complicated
-  = ASSERT2( equalLength rep_tc_tvs all_rep_tc_args, ppr cls <+> ppr rep_tc )
-    do { traceTc "inferConstraints" (vcat [ppr cls <+> ppr inst_tys, ppr arg_constraints])
+  = ASSERT2( equalLength rep_tc_tvs all_rep_tc_args
+           , ppr main_cls <+> ppr rep_tc
+             $$ ppr rep_tc_tvs $$ ppr all_rep_tc_args )
+    do { traceTc "inferConstraints" (vcat [ppr main_cls <+> ppr inst_tys, ppr arg_constraints])
        ; return (stupid_constraints ++ extra_constraints
                  ++ sc_constraints
                  ++ arg_constraints) }
   where
-    arg_constraints = con_arg_constraints cls get_std_constrained_tys
+    arg_constraints = con_arg_constraints get_std_constrained_tys
 
        -- Constraints arising from the arguments of each constructor
-    con_arg_constraints cls' get_constrained_tys
-      = [ mkPredOrigin (DerivOriginDC data_con arg_n) (mkClassPred cls' [inner_ty])
+    con_arg_constraints :: (CtOrigin -> Type -> [PredOrigin]) -> [PredOrigin]
+    con_arg_constraints get_arg_constraints
+      = [ pred
         | data_con <- tyConDataCons rep_tc
         , (arg_n, arg_ty) <- ASSERT( isVanillaDataCon data_con )
                              zip [1..] $  -- ASSERT is precondition of dataConInstOrigArgTys
                              dataConInstOrigArgTys data_con all_rep_tc_args
         , not (isUnLiftedType arg_ty)
-        , inner_ty <- get_constrained_tys arg_ty ]
-
+        , let orig = DerivOriginDC data_con arg_n
+        , pred <- get_arg_constraints orig arg_ty ]
                 -- No constraints for unlifted types
                 -- See Note [Deriving and unboxed types]
 
-                -- For functor-like classes, two things are different
-                -- (a) We recurse over argument types to generate constraints
-                --     See Functor examples in TcGenDeriv
-                -- (b) The rep_tc_args will be one short
-    is_functor_like =    getUnique cls `elem` functorLikeClassKeys
-                      || onlyOneAndTypeConstr inst_tys
-    onlyOneAndTypeConstr [inst_ty] =
-      typeKind inst_ty `tcEqKind` mkArrowKind liftedTypeKind liftedTypeKind
-    onlyOneAndTypeConstr _         = False
-
-    get_std_constrained_tys :: Type -> [Type]
-    get_std_constrained_tys ty
-        | is_functor_like = deepSubtypesContaining last_tv ty
-        | otherwise       = [ty]
-
-    rep_tc_tvs = tyConTyVars rep_tc
-    last_tv = last rep_tc_tvs
-    all_rep_tc_args | cls `hasKey` gen1ClassKey || is_functor_like
-                      = rep_tc_args ++ [mkTyVarTy last_tv]
+    -- is_functor_like: see Note [Inferring the instance context]
+    is_functor_like = typeKind inst_ty `tcEqKind` typeToTypeKind
+
+    get_gen1_constraints functor_cls orig ty
+       = mk_functor_like_constraints orig functor_cls $
+         get_gen1_constrained_tys last_tv ty
+
+    get_std_constrained_tys :: CtOrigin -> Type -> [PredOrigin]
+    get_std_constrained_tys orig ty
+        | is_functor_like = mk_functor_like_constraints orig main_cls $
+                            deepSubtypesContaining last_tv ty
+        | otherwise       = [mk_cls_pred orig main_cls ty]
+
+    mk_functor_like_constraints :: CtOrigin -> Class -> [Type] -> [PredOrigin]
+    -- '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) ~ (*->*))
+    -- The second constraint checks that the first is well-kinded.
+    -- Lacking that, as Trac #10561 showed, we can just generate an
+    -- ill-kinded instance.
+    mk_functor_like_constraints orig cls tys
+       = [ pred
+         | ty <- tys
+         , pred <- [ mk_cls_pred orig cls ty
+                   , mkPredOrigin orig (mkEqPred (typeKind ty) 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]
-    sc_constraints = mkThetaOrigin DerivOrigin $
-        substTheta (zipOpenTvSubst (classTyVars cls) inst_tys) (classSCTheta cls)
+    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 $
+                     substTheta cls_subst (classSCTheta main_cls)
+    cls_subst = ASSERT( equalLength cls_tvs inst_tys )
+                zipOpenTvSubst cls_tvs inst_tys
 
         -- Stupid constraints
     stupid_constraints = mkThetaOrigin DerivOrigin $
-        substTheta subst (tyConStupidTheta rep_tc)
-    subst = zipTopTvSubst rep_tc_tvs all_rep_tc_args
+                         substTheta tc_subst (tyConStupidTheta rep_tc)
+    tc_subst = ASSERT( equalLength rep_tc_tvs all_rep_tc_args )
+               zipTopTvSubst rep_tc_tvs all_rep_tc_args
 
         -- Extra Data constraints
         -- The Data class (only) requires that for
@@ -1093,15 +972,18 @@ inferConstraints cls inst_tys rep_tc rep_tc_args
         --             dataCast2 f = gcast2 f
         --         and we need the Data constraints to typecheck the method
     extra_constraints
-      | cls `hasKey` dataClassKey
+      | main_cls `hasKey` dataClassKey
       , all (isLiftedTypeKind . typeKind) rep_tc_args
-      = [mkPredOrigin DerivOrigin (mkClassPred cls [ty]) | ty <- rep_tc_args]
+      = map (mk_cls_pred DerivOrigin main_cls) rep_tc_args
       | otherwise
       = []
 
-{-
-Note [Getting base classes]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~
+    mk_cls_pred orig cls ty   -- Don't forget to apply to cls_tys too
+                              -- In the awkward Generic1 casde, cls_tys is empty
+       = mkPredOrigin orig (mkClassPred cls (cls_tys ++ [ty]))
+
+{- 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.
@@ -1127,7 +1009,7 @@ 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 have have instance declarations be empty, but still
+signatures. These allow us to have instance declarations being empty, but still
 useful, e.g.
 
   data T a = ...blah..blah... deriving( Generic )
@@ -1160,11 +1042,14 @@ cases, standalone deriving can still be used.
 -- the data constructors - but we need to be careful to fall back to the
 -- family tycon (with indexes) in error messages.
 
-data DerivStatus = CanDerive
+data DerivStatus = CanDerive                 -- Standard class, can derive
                  | DerivableClassError SDoc  -- Standard class, but can't do it
                  | DerivableViaInstance      -- See Note [Deriving any class]
                  | NonDerivableClass SDoc    -- Non-standard class
 
+-- A "standard" class is one defined in the Haskell report which GHC knows how
+-- to generate code for, such as Eq, Ord, Ix, etc.
+
 checkSideConditions :: DynFlags -> DerivContext -> Class -> [TcType]
                     -> TyCon -> [Type] -- tycon and its parameters
                     -> DerivStatus
@@ -1176,16 +1061,26 @@ checkSideConditions dflags mtheta cls cls_tys rep_tc rep_tc_args
                                                  -- cls_tys (the type args other than last)
                                                  -- should be null
                  | otherwise    -> DerivableClassError (classArgsErr cls cls_tys)  -- e.g. deriving( Eq s )
-  | otherwise = maybe DerivableViaInstance NonDerivableClass
-                      (canDeriveAnyClass dflags rep_tc cls)
+
+  | 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)) <+> ptext (sLit "is not a class")
 
 nonStdErr :: Class -> SDoc
-nonStdErr cls = quotes (ppr cls) <+> ptext (sLit "is not a derivable class")
+nonStdErr cls =
+      quotes (ppr cls)
+  <+> ptext (sLit "is not a standard derivable class (Eq, Show, etc.)")
 
 sideConditions :: DerivContext -> Class -> Maybe Condition
+-- Side conditions for classes that GHC knows about,
+-- that is, "deriviable classes"
+-- Returns Nothing for a non-derivable class
 sideConditions mtheta cls
   | cls_key == eqClassKey          = Just (cond_std `andCond` cond_args cls)
   | cls_key == ordClassKey         = Just (cond_std `andCond` cond_args cls)
@@ -1199,19 +1094,24 @@ sideConditions mtheta cls
                                            cond_args cls)
   | cls_key == functorClassKey     = Just (checkFlag Opt_DeriveFunctor `andCond`
                                            cond_vanilla `andCond`
-                                           cond_functorOK True)
+                                           cond_functorOK True False)
   | cls_key == foldableClassKey    = Just (checkFlag Opt_DeriveFoldable `andCond`
                                            cond_vanilla `andCond`
-                                           cond_functorOK False) -- Functor/Fold/Trav works ok for rank-n types
+                                           cond_functorOK False True)
+                                           -- Functor/Fold/Trav works ok
+                                           -- for rank-n types
   | cls_key == traversableClassKey = Just (checkFlag Opt_DeriveTraversable `andCond`
                                            cond_vanilla `andCond`
-                                           cond_functorOK False)
+                                           cond_functorOK False False)
   | cls_key == genClassKey         = Just (checkFlag Opt_DeriveGeneric `andCond`
                                            cond_vanilla `andCond`
                                            cond_RepresentableOk)
   | cls_key == gen1ClassKey        = Just (checkFlag Opt_DeriveGeneric `andCond`
                                            cond_vanilla `andCond`
                                            cond_Representable1Ok)
+  | cls_key == liftClassKey        = Just (checkFlag Opt_DeriveLift `andCond`
+                                           cond_vanilla `andCond`
+                                           cond_args cls)
   | otherwise                      = Nothing
   where
     cls_key = getUnique cls
@@ -1220,6 +1120,28 @@ sideConditions mtheta cls
     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 Opt_DeriveAnyClass dflags)
+  = Just (ptext (sLit "Try enabling DeriveAnyClass"))
+  | not (any (target_kind `tcEqKind`) [ liftedTypeKind, typeToTypeKind ])
+  = Just (ptext (sLit "The last argument of class") <+> quotes (ppr clas)
+          <+> ptext (sLit "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 (* -> *).  Becuase only then can we make a resonable
+    -- guess at the instance context
+    target_kind = tyVarKind (last (classTyVars clas))
+
+typeToTypeKind :: Kind
+typeToTypeKind = liftedTypeKind `mkArrowKind` liftedTypeKind
+
 type Condition = (DynFlags, TyCon, [Type]) -> Validity
         -- first Bool is whether or not we are allowed to derive Data and Typeable
         -- second Bool is whether or not we are allowed to derive Functor
@@ -1299,6 +1221,7 @@ cond_args cls (_, tc, _)
      | 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
@@ -1323,17 +1246,14 @@ cond_isProduct (_, rep_tc, _)
     why = quotes (pprSourceTyCon rep_tc) <+>
           ptext (sLit "must have precisely one constructor")
 
-functorLikeClassKeys :: [Unique]
-functorLikeClassKeys = [functorClassKey, foldableClassKey, traversableClassKey]
-
-cond_functorOK :: Bool -> Condition
+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 (_, rep_tc, _)
+cond_functorOK allowFunctions allowExQuantifiedLastTyVar (_, rep_tc, _)
   | null tc_tvs
   = NotValid (ptext (sLit "Data type") <+> quotes (ppr rep_tc)
               <+> ptext (sLit "must have some type parameters"))
@@ -1355,6 +1275,9 @@ cond_functorOK allowFunctions (_, rep_tc, _)
 
     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` tyVarsOfTypes (dataConTheta con))
@@ -1394,27 +1317,20 @@ std_class_via_coercible :: Class -> Bool
 -- 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 Read/Show/Lift 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 by Coercible,
--- even with -XGeneralizedNewtypeDeriving
+-- *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 ])
-
-new_dfun_name :: Class -> TyCon -> TcM Name
-new_dfun_name clas tycon        -- Just a simple wrapper
-  = do { loc <- getSrcSpanM     -- The location of the instance decl, not of the tycon
-        ; newDFunName clas [mkTyConApp tycon []] loc }
-        -- The type passed to newDFunName is only used to generate
-        -- a suitable string; hence the empty type arg list
+                         , traversableClassKey, liftClassKey ])
 
 badCon :: DataCon -> SDoc -> SDoc
 badCon con msg = ptext (sLit "Constructor") <+> quotes (ppr con) <+> msg
@@ -1422,7 +1338,7 @@ badCon con msg = ptext (sLit "Constructor") <+> quotes (ppr con) <+> msg
 {-
 Note [Check that the type variable is truly universal]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-For Functor, Foldable, Traversable, we must check that the *last argument*
+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
@@ -1441,6 +1357,20 @@ Eg. for T1-T3 we can write
      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]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -1485,7 +1415,7 @@ mkNewTypeEqn dflags overlap_mode tvs
     might_derive_via_coercible && ((newtype_deriving && not deriveAnyClass)
                                   || std_class_via_coercible cls)
   = do traceTc "newtype deriving:" (ppr tycon <+> ppr rep_tys <+> ppr all_preds)
-       dfun_name <- new_dfun_name cls tycon
+       dfun_name <- newDFunName' cls tycon
        loc <- getSrcSpanM
        case mtheta of
         Just theta -> return $ GivenTheta $ DS
@@ -1508,15 +1438,18 @@ mkNewTypeEqn dflags overlap_mode tvs
   = case checkSideConditions dflags mtheta cls cls_tys rep_tycon rep_tc_args of
       -- Error with standard class
       DerivableClassError msg
-        | might_derive_via_coercible -> bale_out (msg $$ suggest_nd)
+        | might_derive_via_coercible -> bale_out (msg $$ suggest_gnd)
         | otherwise                  -> bale_out msg
+
       -- Must use newtype deriving or DeriveAnyClass
       NonDerivableClass _msg
         -- Too hard, even with newtype deriving
         | newtype_deriving           -> bale_out cant_derive_err
         -- Try newtype deriving!
-        | might_derive_via_coercible -> bale_out (non_std $$ suggest_nd)
-        | otherwise                  -> bale_out non_std
+        -- Here we suggest GeneralizedNewtypeDeriving even in cases where it may
+        -- not be applicable. See Trac #9600.
+        | otherwise                  -> bale_out (non_std $$ suggest_gnd)
+
       -- CanDerive/DerivableViaInstance
       _ -> do when (newtype_deriving && deriveAnyClass) $
                 addWarnTc (sep [ ptext (sLit "Both DeriveAnyClass and GeneralizedNewtypeDeriving are enabled")
@@ -1525,13 +1458,13 @@ mkNewTypeEqn dflags overlap_mode tvs
   where
         newtype_deriving  = xopt Opt_GeneralizedNewtypeDeriving dflags
         deriveAnyClass    = xopt Opt_DeriveAnyClass             dflags
-        go_for_it         = mk_data_eqn overlap_mode tvs cls tycon tc_args
+        go_for_it         = mk_data_eqn overlap_mode tvs cls cls_tys tycon tc_args
                               rep_tycon rep_tc_args mtheta
         bale_out    = bale_out' newtype_deriving
         bale_out' b = failWithTc . derivingThingErr b cls cls_tys inst_ty
 
-        non_std    = nonStdErr cls
-        suggest_nd = ptext (sLit "Try GeneralizedNewtypeDeriving for GHC's newtype-deriving extension")
+        non_std     = nonStdErr cls
+        suggest_gnd = ptext (sLit "Try GeneralizedNewtypeDeriving for GHC's newtype-deriving extension")
 
         -- Here is the plan for newtype derivings.  We see
         --        newtype T a1...an = MkT (t ak+1...an) deriving (.., C s1 .. sm, ...)
@@ -1680,31 +1613,99 @@ where we're sure that the resulting instance will type-check.
 
 ************************************************************************
 *                                                                      *
-\subsection[TcDeriv-fixpoint]{Finding the fixed point of \tr{deriving} equations}
+         Finding the fixed point of deriving equations
 *                                                                      *
 ************************************************************************
 
-A ``solution'' (to one of the equations) is a list of (k,TyVarTy tv)
-terms, which is the final correct RHS for the corresponding original
-equation.
-\begin{itemize}
-\item
-Each (k,TyVarTy tv) in a solution constrains only a type
-variable, tv.
+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
 
-\item
-The (k,TyVarTy tv) pairs in a solution are canonically
-ordered by sorting on type varible, tv, (major key) and then class, k,
-(minor key)
-\end{itemize}
 -}
 
-inferInstanceContexts :: [DerivSpec ThetaOrigin] -> TcM [DerivSpec ThetaType]
 
-inferInstanceContexts [] = return []
+simplifyInstanceContexts :: [DerivSpec ThetaOrigin] -> TcM [DerivSpec ThetaType]
+-- Used only for deriving clauses (InferTheta)
+-- not for standalone deriving
+-- See Note [Simplifying the instance context]
+
+simplifyInstanceContexts [] = return []
 
-inferInstanceContexts infer_specs
-  = do  { traceTc "inferInstanceContexts" $ vcat (map pprDerivSpec infer_specs)
+simplifyInstanceContexts infer_specs
+  = do  { traceTc "simplifyInstanceContexts" $ vcat (map pprDerivSpec infer_specs)
         ; iterate_deriv 1 initial_solutions }
   where
     ------------------------------------------------------------------
@@ -1797,8 +1798,7 @@ simplifyDeriv pred tvs theta
                 -- We use *non-overlappable* (vanilla) skolems
                 -- See Note [Overlap and deriving]
 
-       ; let subst_skol = zipTopTvSubst tvs_skols $ map mkTyVarTy tvs
-             skol_set   = mkVarSet tvs_skols
+       ; let skol_set = mkVarSet tvs_skols
              doc = ptext (sLit "deriving") <+> parens (ppr pred)
 
        ; wanted <- mapM (\(PredOrigin t o) -> newWanted o (substTy skol_subst t)) theta
@@ -1819,13 +1819,18 @@ simplifyDeriv pred tvs theta
                          | otherwise = Right ct
                          where p = ctPred ct
 
+       ; traceTc "simplifyDeriv 2" $
+         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
        ; unless defer (reportAllUnsolved (residual_wanted { wc_simple = bad }))
 
-       ; let min_theta = mkMinimalBySCs (bagToList good)
+       ; let min_theta  = mkMinimalBySCs (bagToList good)
+             subst_skol = zipTopTvSubst tvs_skols $ map mkTyVarTy tvs
+                          -- The reverse substitution (sigh)
        ; return (substTheta subst_skol min_theta) }
 
 {-
@@ -1976,11 +1981,9 @@ the renamer.  What a great hack!
 -- Representation tycons differ from the tycon in the instance signature in
 -- case of instances for indexed families.
 --
-genInst :: CommonAuxiliaries
-        -> DerivSpec ThetaType
+genInst :: DerivSpec ThetaType
         -> TcM (InstInfo RdrName, BagDerivStuff, Maybe Name)
-genInst comauxs
-        spec@(DS { ds_tvs = tvs, ds_tc = rep_tycon, ds_tc_args = rep_tc_args
+genInst spec@(DS { ds_tvs = tvs, ds_tc = rep_tycon, ds_tc_args = rep_tc_args
                  , ds_theta = theta, ds_newtype = is_newtype, ds_tys = tys
                  , ds_name = dfun_name, ds_cls = clas, ds_loc = loc })
   | is_newtype   -- See Note [Bindings for Generalised Newtype Deriving]
@@ -1989,12 +1992,12 @@ genInst comauxs
        ; return ( InstInfo
                     { iSpec   = inst_spec
                     , iBinds  = InstBindings
-                        { ib_binds = gen_Newtype_binds loc clas tvs tys rhs_ty
-                        , ib_tyvars = map Var.varName tvs   -- Scope over bindings
-                        , ib_pragmas = []
+                        { ib_binds      = gen_Newtype_binds loc clas tvs tys rhs_ty
+                        , ib_tyvars     = map Var.varName tvs   -- Scope over bindings
+                        , ib_pragmas    = []
                         , ib_extensions = [ Opt_ImpredicativeTypes
                                           , Opt_RankNTypes ]
-                        , ib_derived = True } }
+                        , ib_derived    = True } }
                 , emptyBag
                 , Just $ getName $ head $ tyConDataCons rep_tycon ) }
               -- See Note [Newtype deriving and unused constructors]
@@ -2002,7 +2005,7 @@ genInst comauxs
   | otherwise
   = do { (meth_binds, deriv_stuff) <- genDerivStuff loc clas
                                         dfun_name rep_tycon
-                                        (lookup rep_tycon comauxs)
+                                        tys tvs
        ; inst_spec <- newDerivClsInst theta spec
        ; traceTc "newder" (ppr inst_spec)
        ; let inst_info = InstInfo { iSpec   = inst_spec
@@ -2016,23 +2019,49 @@ genInst comauxs
   where
     rhs_ty = newTyConInstRhs rep_tycon rep_tc_args
 
-genDerivStuff :: SrcSpan -> Class -> Name -> TyCon
-              -> Maybe CommonAuxiliary
+-- Generate the bindings needed for a derived class that isn't handled by
+-- -XGeneralizedNewtypeDeriving.
+genDerivStuff :: SrcSpan -> Class -> Name -> TyCon -> [Type] -> [TyVar]
               -> TcM (LHsBinds RdrName, BagDerivStuff)
-genDerivStuff loc clas dfun_name tycon comaux_maybe
+genDerivStuff loc clas dfun_name tycon inst_tys tyvars
+  -- Special case for DeriveGeneric
   | let ck = classKey clas
-  , ck `elem` [genClassKey, gen1ClassKey]   -- Special case because monadic
+  , ck `elem` [genClassKey, gen1ClassKey]
   = let gk = if ck == genClassKey then Gen0 else Gen1
         -- TODO NSF: correctly identify when we're building Both instead of One
-        Just metaTyCons = comaux_maybe -- well-guarded by commonAuxiliaries and genInst
     in do
-      (binds, faminst) <- gen_Generic_binds gk tycon metaTyCons (nameModule dfun_name)
+      (binds, faminst) <- gen_Generic_binds gk tycon (nameModule dfun_name)
       return (binds, unitBag (DerivFamInst faminst))
 
-  | otherwise                      -- Non-monadic generators
+  -- Not deriving Generic(1), so we first check if the compiler has built-in
+  -- support for deriving the class in question.
+  | otherwise
   = do { dflags <- getDynFlags
        ; fix_env <- getDataConFixityFun tycon
-       ; return (genDerivedBinds dflags fix_env clas loc tycon) }
+       ; case hasBuiltinDeriving dflags fix_env clas of
+              Just gen_fn -> return (gen_fn loc tycon)
+              Nothing -> genDerivAnyClass dflags }
+
+  where
+    genDerivAnyClass :: DynFlags -> TcM (LHsBinds RdrName, BagDerivStuff)
+    genDerivAnyClass dflags =
+      do { -- If there isn't compiler support for deriving the class, our last
+           -- resort is -XDeriveAnyClass (since -XGeneralizedNewtypeDeriving
+           -- fell through).
+          let mini_env   = mkVarEnv (classTyVars clas `zip` inst_tys)
+              mini_subst = mkTvSubst (mkInScopeSet (mkVarSet tyvars)) mini_env
+
+         ; tyfam_insts <-
+             ASSERT2( isNothing (canDeriveAnyClass dflags tycon clas)
+                    , ppr "genDerivStuff: bad derived class" <+> ppr clas )
+             mapM (tcATDefault False loc mini_subst emptyNameSet)
+                  (classATItems clas)
+         ; return ( emptyBag -- No method bindings are needed...
+                  , listToBag (map DerivFamInst (concat tyfam_insts))
+                  -- ...but we may need to generate binding for associated type
+                  -- family default instances.
+                  -- See Note [DeriveAnyClass and default family instances]
+                  ) }
 
 getDataConFixityFun :: TyCon -> TcM (Name -> Fixity)
 -- If the TyCon is locally defined, we want the local fixity env;
@@ -2072,6 +2101,31 @@ representation type.
 
 See the paper "Safe zero-cost coercions for Hsakell".
 
+Note [DeriveAnyClass and default family instances]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+When a class has a associated type family with a default instance, e.g.:
+
+  class C a where
+    type T a
+    type T a = Char
+
+then there are a couple of scenarios in which a user would expect T a to
+default to Char. One is when an instance declaration for C is given without
+an implementation for T:
+
+  instance C Int
+
+Another scenario in which this can occur is when the -XDeriveAnyClass extension
+is used:
+
+  data Example = Example deriving (C, Generic)
+
+In the latter case, we must take care to check if C has any associated type
+families with default instances, because -XDeriveAnyClass will never provide
+an implementation for them. We "fill in" the default instances using the
+tcATDefault function from TcClsDcl (which is also used in TcInstDcls to handle
+the empty instance declaration case).
 
 ************************************************************************
 *                                                                      *
@@ -2103,7 +2157,7 @@ derivingThingErr newtype_deriving clas tys ty why
           $$ nest 2 extra) <> colon,
          nest 2 why]
   where
-    extra | newtype_deriving = ptext (sLit "(even with cunning newtype deriving)")
+    extra | newtype_deriving = ptext (sLit "(even with cunning GeneralizedNewtypeDeriving)")
           | otherwise        = Outputable.empty
     pred = mkClassPred clas (tys ++ [ty])
 
@@ -2112,7 +2166,7 @@ derivingHiddenErr tc
   = hang (ptext (sLit "The data constructors of") <+> quotes (ppr tc) <+> ptext (sLit "are not all in scope"))
        2 (ptext (sLit "so you cannot derive an instance for it"))
 
-standaloneCtxt :: LHsType Name -> SDoc
+standaloneCtxt :: LHsSigType Name -> SDoc
 standaloneCtxt ty = hang (ptext (sLit "In the stand-alone deriving instance for"))
                        2 (quotes (ppr ty))