Fix solving of implicit parameter constraints
[ghc.git] / compiler / typecheck / TcGenDeriv.hs
index 188d2b6..bd9902e 100644 (file)
@@ -14,63 +14,70 @@ This is where we do all the grimy bindings' generation.
 
 {-# LANGUAGE CPP, ScopedTypeVariables #-}
 {-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE TypeFamilies #-}
 
 module TcGenDeriv (
         BagDerivStuff, DerivStuff(..),
 
-        canDeriveAnyClass,
-        genDerivedBinds,
-        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,
-        mkRdrFunBind
+        ordOpTbl, boxConTbl, litConTbl,
+        mkRdrFunBind, mkRdrFunBindEC, mkRdrFunBindSE, error_Expr
     ) where
 
 #include "HsVersions.h"
 
+import GhcPrelude
+
+import TcRnMonad
 import HsSyn
 import RdrName
 import BasicTypes
 import DataCon
 import Name
+import Fingerprint
+import Encoding
 
 import DynFlags
 import PrelInfo
-import FamInstEnv( FamInst )
-import MkCore ( eRROR_ID )
-import PrelNames hiding (error_RDR)
+import FamInst
+import FamInstEnv
+import PrelNames
+import THNames
+import Module ( moduleName, moduleNameString
+              , moduleUnitId, unitIdString )
 import MkId ( coerceId )
 import PrimOp
 import SrcLoc
 import TyCon
+import TcEnv
 import TcType
+import TcValidity ( checkValidTyFamEqn )
 import TysPrim
 import TysWiredIn
 import Type
 import Class
-import TypeRep
 import VarSet
 import VarEnv
-import Module
-import State
 import Util
 import Var
-import MonadUtils
 import Outputable
 import Lexeme
 import FastString
 import Pair
 import Bag
-import Fingerprint
-import TcEnv (InstInfo)
-import StaticFlags( opt_PprStyle_Debug )
 
-import ListSetOps ( assocMaybe )
 import Data.List  ( partition, intersperse )
-import Data.Maybe ( isNothing )
 
 type BagDerivStuff = Bag DerivStuff
 
@@ -85,65 +92,12 @@ data AuxBindSpec
 data DerivStuff     -- Please add this auxiliary stuff
   = DerivAuxBind AuxBindSpec
 
-  -- Generics
-  | DerivTyCon TyCon                   -- New data types
+  -- Generics and DeriveAnyClass
   | DerivFamInst FamInst               -- New type family instances
 
   -- New top-level auxiliary bindings
-  | DerivHsBind (LHsBind RdrName, LSig RdrName) -- Also used for SYB
-  | DerivInst (InstInfo RdrName)                -- New, auxiliary instances
-
-{-
-************************************************************************
-*                                                                      *
-                Top level function
-*                                                                      *
-************************************************************************
--}
+  | DerivHsBind (LHsBind GhcPs, LSig GhcPs) -- Also used for SYB
 
-genDerivedBinds :: DynFlags -> (Name -> Fixity) -> Class -> SrcSpan -> TyCon
-                -> ( LHsBinds RdrName  -- The method bindings of the instance declaration
-                   , BagDerivStuff)    -- Specifies extra top-level declarations needed
-                                       -- to support the instance declaration
-genDerivedBinds dflags fix_env clas loc tycon
-  | Just gen_fn <- assocMaybe gen_list (getUnique clas)
-  = gen_fn loc tycon
-
-  | otherwise
-  -- Deriving any class simply means giving an empty instance, so no
-  -- bindings have to be generated.
-  = ASSERT2( isNothing (canDeriveAnyClass dflags tycon clas)
-           , ppr "genDerivStuff: bad derived class" <+> ppr clas )
-    (emptyBag, emptyBag)
-
-  where
-    gen_list :: [(Unique, SrcSpan -> TyCon -> (LHsBinds RdrName, BagDerivStuff))]
-    gen_list = [ (eqClassKey,          gen_Eq_binds)
-               , (typeableClassKey,    gen_Typeable_binds dflags)
-               , (ordClassKey,         gen_Ord_binds)
-               , (enumClassKey,        gen_Enum_binds)
-               , (boundedClassKey,     gen_Bounded_binds)
-               , (ixClassKey,          gen_Ix_binds)
-               , (showClassKey,        gen_Show_binds fix_env)
-               , (readClassKey,        gen_Read_binds fix_env)
-               , (dataClassKey,        gen_Data_binds dflags)
-               , (functorClassKey,     gen_Functor_binds)
-               , (foldableClassKey,    gen_Foldable_binds)
-               , (traversableClassKey, gen_Traversable_binds) ]
-
-
--- Nothing: we can (try to) derive it via Generics
--- Just s:  we can't, reason s
-canDeriveAnyClass :: DynFlags -> TyCon -> Class -> Maybe SDoc
-canDeriveAnyClass dflags _tycon clas =
-  let b `orElse` s = if b then Nothing else Just (ptext (sLit s))
-      Just m  <> _ = Just m
-      Nothing <> n = n
-  -- We can derive a given class for a given tycon via Generics iff
-  in  -- 1) The class is not a "standard" class (like Show, Functor, etc.)
-        (not (getUnique clas `elem` standardClassKeys) `orElse` "")
-      -- 2) Opt_DeriveAnyClass is on
-     <> (xopt Opt_DeriveAnyClass dflags `orElse` "Try enabling DeriveAnyClass")
 
 {-
 ************************************************************************
@@ -204,9 +158,10 @@ for the instance decl, which it probably wasn't, so the decls
 produced don't get through the typechecker.
 -}
 
-gen_Eq_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, BagDerivStuff)
-gen_Eq_binds loc tycon
-  = (method_binds, aux_binds)
+gen_Eq_binds :: SrcSpan -> TyCon -> TcM (LHsBinds GhcPs, BagDerivStuff)
+gen_Eq_binds loc tycon = do
+    dflags <- getDynFlags
+    return (method_binds dflags, aux_binds)
   where
     all_cons = tyConDataCons tycon
     (nullary_cons, non_nullary_cons) = partition isNullarySrcDataCon all_cons
@@ -220,7 +175,7 @@ gen_Eq_binds loc tycon
 
     no_tag_match_cons = null tag_match_cons
 
-    fall_through_eqn
+    fall_through_eqn dflags
       | no_tag_match_cons   -- All constructors have arguments
       = case pat_match_cons of
           []  -> []   -- No constructors; no fall-though case
@@ -232,22 +187,21 @@ gen_Eq_binds loc tycon
       | otherwise -- One or more tag_match cons; add fall-through of
                   -- extract tags compare for equality
       = [([a_Pat, b_Pat],
-         untag_Expr tycon [(a_RDR,ah_RDR), (b_RDR,bh_RDR)]
+         untag_Expr dflags tycon [(a_RDR,ah_RDR), (b_RDR,bh_RDR)]
                     (genPrimOpApp (nlHsVar ah_RDR) eqInt_RDR (nlHsVar bh_RDR)))]
 
     aux_binds | no_tag_match_cons = emptyBag
               | otherwise         = unitBag $ DerivAuxBind $ DerivCon2Tag tycon
 
-    method_binds = listToBag [eq_bind, ne_bind]
-    eq_bind = mk_FunBind loc eq_RDR (map pats_etc pat_match_cons ++ fall_through_eqn)
-    ne_bind = mk_easy_FunBind loc ne_RDR [a_Pat, b_Pat] (
-                        nlHsApp (nlHsVar not_RDR) (nlHsPar (nlHsVarApps eq_RDR [a_RDR, b_RDR])))
+    method_binds dflags = unitBag (eq_bind dflags)
+    eq_bind dflags = mkFunBindSE 2 loc eq_RDR (map pats_etc pat_match_cons
+                                            ++ fall_through_eqn dflags)
 
     ------------------------------------------------------------------
     pats_etc data_con
       = let
-            con1_pat = nlConVarPat data_con_RDR as_needed
-            con2_pat = nlConVarPat data_con_RDR bs_needed
+            con1_pat = nlParPat $ nlConVarPat data_con_RDR as_needed
+            con2_pat = nlParPat $ nlConVarPat data_con_RDR bs_needed
 
             data_con_RDR = getRdrName data_con
             con_arity   = length tys_needed
@@ -317,7 +271,7 @@ Several special cases:
   values we can't call the overloaded functions.
   See function unliftedOrdOp
 
-Note [Do not rely on compare]
+Note [Game plan for deriving Ord]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 It's a bad idea to define only 'compare', and build the other binary
 comparisons on top of it; see Trac #2130, #4019.  Reason: we don't
@@ -329,8 +283,16 @@ binary result, something like this:
                                        True  -> False
                                        False -> True
 
+This being said, we can get away with generating full code only for
+'compare' and '<' thus saving us generation of other three operators.
+Other operators can be cheaply expressed through '<':
+a <= b = not $ b < a
+a > b = b < a
+a >= b = not $ a < b
+
 So for sufficiently small types (few constructors, or all nullary)
 we generate all methods; for large ones we just use 'compare'.
+
 -}
 
 data OrdOp = OrdCompare | OrdLT | OrdLE | OrdGE | OrdGT
@@ -346,7 +308,7 @@ ordMethRdr op
        OrdGT      -> gt_RDR
 
 ------------
-ltResult :: OrdOp -> LHsExpr RdrName
+ltResult :: OrdOp -> LHsExpr GhcPs
 -- Knowing a<b, what is the result for a `op` b?
 ltResult OrdCompare = ltTag_Expr
 ltResult OrdLT      = true_Expr
@@ -355,7 +317,7 @@ ltResult OrdGE      = false_Expr
 ltResult OrdGT      = false_Expr
 
 ------------
-eqResult :: OrdOp -> LHsExpr RdrName
+eqResult :: OrdOp -> LHsExpr GhcPs
 -- Knowing a=b, what is the result for a `op` b?
 eqResult OrdCompare = eqTag_Expr
 eqResult OrdLT      = false_Expr
@@ -364,7 +326,7 @@ eqResult OrdGE      = true_Expr
 eqResult OrdGT      = false_Expr
 
 ------------
-gtResult :: OrdOp -> LHsExpr RdrName
+gtResult :: OrdOp -> LHsExpr GhcPs
 -- Knowing a>b, what is the result for a `op` b?
 gtResult OrdCompare = gtTag_Expr
 gtResult OrdLT      = false_Expr
@@ -373,22 +335,33 @@ gtResult OrdGE      = true_Expr
 gtResult OrdGT      = true_Expr
 
 ------------
-gen_Ord_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, BagDerivStuff)
-gen_Ord_binds loc tycon
-  | null tycon_data_cons        -- No data-cons => invoke bale-out case
-  = (unitBag $ mk_FunBind loc compare_RDR [], emptyBag)
-  | otherwise
-  = (unitBag (mkOrdOp OrdCompare) `unionBags` other_ops, aux_binds)
+gen_Ord_binds :: SrcSpan -> TyCon -> TcM (LHsBinds GhcPs, BagDerivStuff)
+gen_Ord_binds loc tycon = do
+    dflags <- getDynFlags
+    return $ if null tycon_data_cons -- No data-cons => invoke bale-out case
+      then ( unitBag $ mkFunBindSE 2 loc compare_RDR []
+           , emptyBag)
+      else ( unitBag (mkOrdOp dflags OrdCompare) `unionBags` other_ops dflags
+           , aux_binds)
   where
     aux_binds | single_con_type = emptyBag
               | otherwise       = unitBag $ DerivAuxBind $ DerivCon2Tag tycon
 
-        -- Note [Do not rely on compare]
-    other_ops | (last_tag - first_tag) <= 2     -- 1-3 constructors
-                || null non_nullary_cons        -- Or it's an enumeration
-              = listToBag (map mkOrdOp [OrdLT,OrdLE,OrdGE,OrdGT])
-              | otherwise
-              = emptyBag
+        -- Note [Game plan for deriving Ord]
+    other_ops dflags
+      | (last_tag - first_tag) <= 2     -- 1-3 constructors
+        || null non_nullary_cons        -- Or it's an enumeration
+      = listToBag [mkOrdOp dflags OrdLT, lE, gT, gE]
+      | otherwise
+      = emptyBag
+
+    negate_expr = nlHsApp (nlHsVar not_RDR)
+    lE = mk_easy_FunBind loc le_RDR [a_Pat, b_Pat] $
+        negate_expr (nlHsApp (nlHsApp (nlHsVar lt_RDR) b_Expr) a_Expr)
+    gT = mk_easy_FunBind loc gt_RDR [a_Pat, b_Pat] $
+        nlHsApp (nlHsApp (nlHsVar lt_RDR) b_Expr) a_Expr
+    gE = mk_easy_FunBind loc ge_RDR [a_Pat, b_Pat] $
+        negate_expr (nlHsApp (nlHsApp (nlHsVar lt_RDR) a_Expr) b_Expr)
 
     get_tag con = dataConTag con - fIRST_TAG
         -- We want *zero-based* tags, because that's what
@@ -404,89 +377,95 @@ gen_Ord_binds loc tycon
     (nullary_cons, non_nullary_cons) = partition isNullarySrcDataCon tycon_data_cons
 
 
-    mkOrdOp :: OrdOp -> LHsBind RdrName
+    mkOrdOp :: DynFlags -> OrdOp -> LHsBind GhcPs
     -- Returns a binding   op a b = ... compares a and b according to op ....
-    mkOrdOp op = mk_easy_FunBind loc (ordMethRdr op) [a_Pat, b_Pat] (mkOrdOpRhs op)
+    mkOrdOp dflags op = mk_easy_FunBind loc (ordMethRdr op) [a_Pat, b_Pat]
+                                        (mkOrdOpRhs dflags op)
 
-    mkOrdOpRhs :: OrdOp -> LHsExpr RdrName
-    mkOrdOpRhs op       -- RHS for comparing 'a' and 'b' according to op
-      | length nullary_cons <= 2  -- Two nullary or fewer, so use cases
+    mkOrdOpRhs :: DynFlags -> OrdOp -> LHsExpr GhcPs
+    mkOrdOpRhs dflags op       -- RHS for comparing 'a' and 'b' according to op
+      | nullary_cons `lengthAtMost` 2 -- Two nullary or fewer, so use cases
       = nlHsCase (nlHsVar a_RDR) $
-        map (mkOrdOpAlt op) tycon_data_cons
+        map (mkOrdOpAlt dflags op) tycon_data_cons
         -- i.e.  case a of { C1 x y -> case b of C1 x y -> ....compare x,y...
         --                   C2 x   -> case b of C2 x -> ....comopare x.... }
 
       | null non_nullary_cons    -- All nullary, so go straight to comparing tags
-      = mkTagCmp op
+      = mkTagCmp dflags op
 
       | otherwise                -- Mixed nullary and non-nullary
       = nlHsCase (nlHsVar a_RDR) $
-        (map (mkOrdOpAlt op) non_nullary_cons
-         ++ [mkSimpleHsAlt nlWildPat (mkTagCmp op)])
+        (map (mkOrdOpAlt dflags op) non_nullary_cons
+         ++ [mkHsCaseAlt nlWildPat (mkTagCmp dflags op)])
 
 
-    mkOrdOpAlt :: OrdOp -> DataCon -> LMatch RdrName (LHsExpr RdrName)
+    mkOrdOpAlt :: DynFlags -> OrdOp -> DataCon
+                  -> LMatch GhcPs (LHsExpr GhcPs)
     -- Make the alternative  (Ki a1 a2 .. av ->
-    mkOrdOpAlt op data_con
-      = mkSimpleHsAlt (nlConVarPat data_con_RDR as_needed) (mkInnerRhs op data_con)
+    mkOrdOpAlt dflags op data_con
+      = mkHsCaseAlt (nlConVarPat data_con_RDR as_needed)
+                    (mkInnerRhs dflags op data_con)
       where
         as_needed    = take (dataConSourceArity data_con) as_RDRs
         data_con_RDR = getRdrName data_con
 
-    mkInnerRhs op data_con
+    mkInnerRhs dflags op data_con
       | single_con_type
       = nlHsCase (nlHsVar b_RDR) [ mkInnerEqAlt op data_con ]
 
       | tag == first_tag
       = nlHsCase (nlHsVar b_RDR) [ mkInnerEqAlt op data_con
-                                 , mkSimpleHsAlt nlWildPat (ltResult op) ]
+                                 , mkHsCaseAlt nlWildPat (ltResult op) ]
       | tag == last_tag
       = nlHsCase (nlHsVar b_RDR) [ mkInnerEqAlt op data_con
-                                 , mkSimpleHsAlt nlWildPat (gtResult op) ]
+                                 , mkHsCaseAlt nlWildPat (gtResult op) ]
 
       | tag == first_tag + 1
-      = nlHsCase (nlHsVar b_RDR) [ mkSimpleHsAlt (nlConWildPat first_con) (gtResult op)
+      = nlHsCase (nlHsVar b_RDR) [ mkHsCaseAlt (nlConWildPat first_con)
+                                             (gtResult op)
                                  , mkInnerEqAlt op data_con
-                                 , mkSimpleHsAlt nlWildPat (ltResult op) ]
+                                 , mkHsCaseAlt nlWildPat (ltResult op) ]
       | tag == last_tag - 1
-      = nlHsCase (nlHsVar b_RDR) [ mkSimpleHsAlt (nlConWildPat last_con) (ltResult op)
+      = nlHsCase (nlHsVar b_RDR) [ mkHsCaseAlt (nlConWildPat last_con)
+                                             (ltResult op)
                                  , mkInnerEqAlt op data_con
-                                 , mkSimpleHsAlt nlWildPat (gtResult op) ]
+                                 , mkHsCaseAlt nlWildPat (gtResult op) ]
 
       | tag > last_tag `div` 2  -- lower range is larger
-      = untag_Expr tycon [(b_RDR, bh_RDR)] $
+      = untag_Expr dflags tycon [(b_RDR, bh_RDR)] $
         nlHsIf (genPrimOpApp (nlHsVar bh_RDR) ltInt_RDR tag_lit)
                (gtResult op) $  -- Definitely GT
         nlHsCase (nlHsVar b_RDR) [ mkInnerEqAlt op data_con
-                                 , mkSimpleHsAlt nlWildPat (ltResult op) ]
+                                 , mkHsCaseAlt nlWildPat (ltResult op) ]
 
       | otherwise               -- upper range is larger
-      = untag_Expr tycon [(b_RDR, bh_RDR)] $
+      = untag_Expr dflags tycon [(b_RDR, bh_RDR)] $
         nlHsIf (genPrimOpApp (nlHsVar bh_RDR) gtInt_RDR tag_lit)
                (ltResult op) $  -- Definitely LT
         nlHsCase (nlHsVar b_RDR) [ mkInnerEqAlt op data_con
-                                 , mkSimpleHsAlt nlWildPat (gtResult op) ]
+                                 , mkHsCaseAlt nlWildPat (gtResult op) ]
       where
         tag     = get_tag data_con
-        tag_lit = noLoc (HsLit (HsIntPrim "" (toInteger tag)))
+        tag_lit = noLoc (HsLit (HsIntPrim NoSourceText (toInteger tag)))
 
-    mkInnerEqAlt :: OrdOp -> DataCon -> LMatch RdrName (LHsExpr RdrName)
+    mkInnerEqAlt :: OrdOp -> DataCon -> LMatch GhcPs (LHsExpr GhcPs)
     -- First argument 'a' known to be built with K
     -- Returns a case alternative  Ki b1 b2 ... bv -> compare (a1,a2,...) with (b1,b2,...)
     mkInnerEqAlt op data_con
-      = mkSimpleHsAlt (nlConVarPat data_con_RDR bs_needed) $
+      = mkHsCaseAlt (nlConVarPat data_con_RDR bs_needed) $
         mkCompareFields tycon op (dataConOrigArgTys data_con)
       where
         data_con_RDR = getRdrName data_con
         bs_needed    = take (dataConSourceArity data_con) bs_RDRs
 
-    mkTagCmp :: OrdOp -> LHsExpr RdrName
+    mkTagCmp :: DynFlags -> OrdOp -> LHsExpr GhcPs
     -- Both constructors known to be nullary
-    -- genreates (case data2Tag a of a# -> case data2Tag b of b# -> a# `op` b#
-    mkTagCmp op = untag_Expr tycon [(a_RDR, ah_RDR),(b_RDR, bh_RDR)] $
-                  unliftedOrdOp tycon intPrimTy op ah_RDR bh_RDR
+    -- generates (case data2Tag a of a# -> case data2Tag b of b# -> a# `op` b#
+    mkTagCmp dflags op =
+      untag_Expr dflags tycon[(a_RDR, ah_RDR),(b_RDR, bh_RDR)] $
+        unliftedOrdOp tycon intPrimTy op ah_RDR bh_RDR
 
-mkCompareFields :: TyCon -> OrdOp -> [Type] -> LHsExpr RdrName
+mkCompareFields :: TyCon -> OrdOp -> [Type] -> LHsExpr GhcPs
 -- Generates nested comparisons for (a1,a2...) against (b1,b2,...)
 -- where the ai,bi have the given types
 mkCompareFields tycon op tys
@@ -494,7 +473,7 @@ mkCompareFields tycon op tys
   where
     go []   _      _          = eqResult op
     go [ty] (a:_)  (b:_)
-      | isUnLiftedType ty     = unliftedOrdOp tycon ty op a b
+      | isUnliftedType ty     = unliftedOrdOp tycon ty op a b
       | otherwise             = genOpApp (nlHsVar a) (ordMethRdr op) (nlHsVar b)
     go (ty:tys) (a:as) (b:bs) = mk_compare ty a b
                                   (ltResult op)
@@ -506,19 +485,19 @@ mkCompareFields tycon op tys
     --    (case (compare a b) of { LT -> <lt>; EQ -> <eq>; GT -> <bt> })
     -- but with suitable special cases for
     mk_compare ty a b lt eq gt
-      | isUnLiftedType ty
+      | isUnliftedType ty
       = unliftedCompare lt_op eq_op a_expr b_expr lt eq gt
       | otherwise
       = nlHsCase (nlHsPar (nlHsApp (nlHsApp (nlHsVar compare_RDR) a_expr) b_expr))
-          [mkSimpleHsAlt (nlNullaryConPat ltTag_RDR) lt,
-           mkSimpleHsAlt (nlNullaryConPat eqTag_RDR) eq,
-           mkSimpleHsAlt (nlNullaryConPat gtTag_RDR) gt]
+          [mkHsCaseAlt (nlNullaryConPat ltTag_RDR) lt,
+           mkHsCaseAlt (nlNullaryConPat eqTag_RDR) eq,
+           mkHsCaseAlt (nlNullaryConPat gtTag_RDR) gt]
       where
         a_expr = nlHsVar a
         b_expr = nlHsVar b
         (lt_op, _, eq_op, _, _) = primOrdOps "Ord" tycon ty
 
-unliftedOrdOp :: TyCon -> Type -> OrdOp -> RdrName -> RdrName -> LHsExpr RdrName
+unliftedOrdOp :: TyCon -> Type -> OrdOp -> RdrName -> RdrName -> LHsExpr GhcPs
 unliftedOrdOp tycon ty op a b
   = case op of
        OrdCompare -> unliftedCompare lt_op eq_op a_expr b_expr
@@ -534,18 +513,21 @@ unliftedOrdOp tycon ty op a b
    b_expr = nlHsVar b
 
 unliftedCompare :: RdrName -> RdrName
-                -> LHsExpr RdrName -> LHsExpr RdrName   -- What to cmpare
-                -> LHsExpr RdrName -> LHsExpr RdrName -> LHsExpr RdrName  -- Three results
-                -> LHsExpr RdrName
+                -> LHsExpr GhcPs -> LHsExpr GhcPs   -- What to cmpare
+                -> LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
+                                                    -- Three results
+                -> LHsExpr GhcPs
 -- Return (if a < b then lt else if a == b then eq else gt)
 unliftedCompare lt_op eq_op a_expr b_expr lt eq gt
-  = nlHsIf (genPrimOpApp a_expr lt_op b_expr) lt $
+  = nlHsIf (ascribeBool $ genPrimOpApp a_expr lt_op b_expr) lt $
                         -- Test (<) first, not (==), because the latter
                         -- is true less often, so putting it first would
                         -- mean more tests (dynamically)
-        nlHsIf (genPrimOpApp a_expr eq_op b_expr) eq gt
+        nlHsIf (ascribeBool $ genPrimOpApp a_expr eq_op b_expr) eq gt
+  where
+    ascribeBool e = nlExprWithTySig e boolTy
 
-nlConWildPat :: DataCon -> LPat RdrName
+nlConWildPat :: DataCon -> LPat GhcPs
 -- The pattern (K {})
 nlConWildPat con = noLoc (ConPatIn (noLoc (getRdrName con))
                                    (RecCon (HsRecFields { rec_flds = []
@@ -594,76 +576,79 @@ instance ... Enum (Foo ...) where
 For @enumFromTo@ and @enumFromThenTo@, we use the default methods.
 -}
 
-gen_Enum_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, BagDerivStuff)
-gen_Enum_binds loc tycon
-  = (method_binds, aux_binds)
+gen_Enum_binds :: SrcSpan -> TyCon -> TcM (LHsBinds GhcPs, BagDerivStuff)
+gen_Enum_binds loc tycon = do
+    dflags <- getDynFlags
+    return (method_binds dflags, aux_binds)
   where
-    method_binds = listToBag [
-                        succ_enum,
-                        pred_enum,
-                        to_enum,
-                        enum_from,
-                        enum_from_then,
-                        from_enum
-                    ]
+    method_binds dflags = listToBag
+      [ succ_enum      dflags
+      , pred_enum      dflags
+      , to_enum        dflags
+      , enum_from      dflags
+      , enum_from_then dflags
+      , from_enum      dflags
+      ]
     aux_binds = listToBag $ map DerivAuxBind
                   [DerivCon2Tag tycon, DerivTag2Con tycon, DerivMaxTag tycon]
 
     occ_nm = getOccString tycon
 
-    succ_enum
+    succ_enum dflags
       = mk_easy_FunBind loc succ_RDR [a_Pat] $
-        untag_Expr tycon [(a_RDR, ah_RDR)] $
-        nlHsIf (nlHsApps eq_RDR [nlHsVar (maxtag_RDR tycon),
+        untag_Expr dflags tycon [(a_RDR, ah_RDR)] $
+        nlHsIf (nlHsApps eq_RDR [nlHsVar (maxtag_RDR dflags tycon),
                                nlHsVarApps intDataCon_RDR [ah_RDR]])
              (illegal_Expr "succ" occ_nm "tried to take `succ' of last tag in enumeration")
-             (nlHsApp (nlHsVar (tag2con_RDR tycon))
+             (nlHsApp (nlHsVar (tag2con_RDR dflags tycon))
                     (nlHsApps plus_RDR [nlHsVarApps intDataCon_RDR [ah_RDR],
                                         nlHsIntLit 1]))
 
-    pred_enum
+    pred_enum dflags
       = mk_easy_FunBind loc pred_RDR [a_Pat] $
-        untag_Expr tycon [(a_RDR, ah_RDR)] $
+        untag_Expr dflags tycon [(a_RDR, ah_RDR)] $
         nlHsIf (nlHsApps eq_RDR [nlHsIntLit 0,
                                nlHsVarApps intDataCon_RDR [ah_RDR]])
              (illegal_Expr "pred" occ_nm "tried to take `pred' of first tag in enumeration")
-             (nlHsApp (nlHsVar (tag2con_RDR tycon))
-                           (nlHsApps plus_RDR [nlHsVarApps intDataCon_RDR [ah_RDR],
-                                               nlHsLit (HsInt "-1" (-1))]))
+             (nlHsApp (nlHsVar (tag2con_RDR dflags tycon))
+                      (nlHsApps plus_RDR
+                            [ nlHsVarApps intDataCon_RDR [ah_RDR]
+                            , nlHsLit (HsInt def (mkIntegralLit (-1 :: Int)))]))
 
-    to_enum
+    to_enum dflags
       = mk_easy_FunBind loc toEnum_RDR [a_Pat] $
         nlHsIf (nlHsApps and_RDR
                 [nlHsApps ge_RDR [nlHsVar a_RDR, nlHsIntLit 0],
-                 nlHsApps le_RDR [nlHsVar a_RDR, nlHsVar (maxtag_RDR tycon)]])
-             (nlHsVarApps (tag2con_RDR tycon) [a_RDR])
-             (illegal_toEnum_tag occ_nm (maxtag_RDR tycon))
+                 nlHsApps le_RDR [ nlHsVar a_RDR
+                                 , nlHsVar (maxtag_RDR dflags tycon)]])
+             (nlHsVarApps (tag2con_RDR dflags tycon) [a_RDR])
+             (illegal_toEnum_tag occ_nm (maxtag_RDR dflags tycon))
 
-    enum_from
+    enum_from dflags
       = mk_easy_FunBind loc enumFrom_RDR [a_Pat] $
-          untag_Expr tycon [(a_RDR, ah_RDR)] $
+          untag_Expr dflags tycon [(a_RDR, ah_RDR)] $
           nlHsApps map_RDR
-                [nlHsVar (tag2con_RDR tycon),
+                [nlHsVar (tag2con_RDR dflags tycon),
                  nlHsPar (enum_from_to_Expr
                             (nlHsVarApps intDataCon_RDR [ah_RDR])
-                            (nlHsVar (maxtag_RDR tycon)))]
+                            (nlHsVar (maxtag_RDR dflags tycon)))]
 
-    enum_from_then
+    enum_from_then dflags
       = mk_easy_FunBind loc enumFromThen_RDR [a_Pat, b_Pat] $
-          untag_Expr tycon [(a_RDR, ah_RDR), (b_RDR, bh_RDR)] $
-          nlHsApp (nlHsVarApps map_RDR [tag2con_RDR tycon]) $
+          untag_Expr dflags tycon [(a_RDR, ah_RDR), (b_RDR, bh_RDR)] $
+          nlHsApp (nlHsVarApps map_RDR [tag2con_RDR dflags tycon]) $
             nlHsPar (enum_from_then_to_Expr
                     (nlHsVarApps intDataCon_RDR [ah_RDR])
                     (nlHsVarApps intDataCon_RDR [bh_RDR])
                     (nlHsIf  (nlHsApps gt_RDR [nlHsVarApps intDataCon_RDR [ah_RDR],
                                                nlHsVarApps intDataCon_RDR [bh_RDR]])
                            (nlHsIntLit 0)
-                           (nlHsVar (maxtag_RDR tycon))
+                           (nlHsVar (maxtag_RDR dflags tycon))
                            ))
 
-    from_enum
+    from_enum dflags
       = mk_easy_FunBind loc fromEnum_RDR [a_Pat] $
-          untag_Expr tycon [(a_RDR, ah_RDR)] $
+          untag_Expr dflags tycon [(a_RDR, ah_RDR)] $
           (nlHsVarApps intDataCon_RDR [ah_RDR])
 
 {-
@@ -674,7 +659,7 @@ gen_Enum_binds loc tycon
 ************************************************************************
 -}
 
-gen_Bounded_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, BagDerivStuff)
+gen_Bounded_binds :: SrcSpan -> TyCon -> (LHsBinds GhcPs, BagDerivStuff)
 gen_Bounded_binds loc tycon
   | isEnumerationTyCon tycon
   = (listToBag [ min_bound_enum, max_bound_enum ], emptyBag)
@@ -761,54 +746,60 @@ we follow the scheme given in Figure~19 of the Haskell~1.2 report
 (p.~147).
 -}
 
-gen_Ix_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, BagDerivStuff)
+gen_Ix_binds :: SrcSpan -> TyCon -> TcM (LHsBinds GhcPs, BagDerivStuff)
 
-gen_Ix_binds loc tycon
-  | isEnumerationTyCon tycon
-  = ( enum_ixes
-    , listToBag $ map DerivAuxBind
+gen_Ix_binds loc tycon = do
+    dflags <- getDynFlags
+    return $ if isEnumerationTyCon tycon
+      then (enum_ixes dflags, listToBag $ map DerivAuxBind
                    [DerivCon2Tag tycon, DerivTag2Con tycon, DerivMaxTag tycon])
-  | otherwise
-  = (single_con_ixes, unitBag (DerivAuxBind (DerivCon2Tag tycon)))
+      else (single_con_ixes, unitBag (DerivAuxBind (DerivCon2Tag tycon)))
   where
     --------------------------------------------------------------
-    enum_ixes = listToBag [ enum_range, enum_index, enum_inRange ]
+    enum_ixes dflags = listToBag
+      [ enum_range   dflags
+      , enum_index   dflags
+      , enum_inRange dflags
+      ]
 
-    enum_range
+    enum_range dflags
       = mk_easy_FunBind loc range_RDR [nlTuplePat [a_Pat, b_Pat] Boxed] $
-          untag_Expr tycon [(a_RDR, ah_RDR)] $
-          untag_Expr tycon [(b_RDR, bh_RDR)] $
-          nlHsApp (nlHsVarApps map_RDR [tag2con_RDR tycon]) $
+          untag_Expr dflags tycon [(a_RDR, ah_RDR)] $
+          untag_Expr dflags tycon [(b_RDR, bh_RDR)] $
+          nlHsApp (nlHsVarApps map_RDR [tag2con_RDR dflags tycon]) $
               nlHsPar (enum_from_to_Expr
                         (nlHsVarApps intDataCon_RDR [ah_RDR])
                         (nlHsVarApps intDataCon_RDR [bh_RDR]))
 
-    enum_index
+    enum_index dflags
       = mk_easy_FunBind loc unsafeIndex_RDR
                 [noLoc (AsPat (noLoc c_RDR)
                            (nlTuplePat [a_Pat, nlWildPat] Boxed)),
                                 d_Pat] (
-           untag_Expr tycon [(a_RDR, ah_RDR)] (
-           untag_Expr tycon [(d_RDR, dh_RDR)] (
+           untag_Expr dflags tycon [(a_RDR, ah_RDR)] (
+           untag_Expr dflags tycon [(d_RDR, dh_RDR)] (
            let
                 rhs = nlHsVarApps intDataCon_RDR [c_RDR]
            in
            nlHsCase
              (genOpApp (nlHsVar dh_RDR) minusInt_RDR (nlHsVar ah_RDR))
-             [mkSimpleHsAlt (nlVarPat c_RDR) rhs]
+             [mkHsCaseAlt (nlVarPat c_RDR) rhs]
            ))
         )
 
-    enum_inRange
+    -- This produces something like `(ch >= ah) && (ch <= bh)`
+    enum_inRange dflags
       = mk_easy_FunBind loc inRange_RDR [nlTuplePat [a_Pat, b_Pat] Boxed, c_Pat] $
-          untag_Expr tycon [(a_RDR, ah_RDR)] (
-          untag_Expr tycon [(b_RDR, bh_RDR)] (
-          untag_Expr tycon [(c_RDR, ch_RDR)] (
-          nlHsIf (genPrimOpApp (nlHsVar ch_RDR) geInt_RDR (nlHsVar ah_RDR)) (
-             (genPrimOpApp (nlHsVar ch_RDR) leInt_RDR (nlHsVar bh_RDR))
-          ) {-else-} (
-             false_Expr
-          ))))
+          untag_Expr dflags tycon [(a_RDR, ah_RDR)] (
+          untag_Expr dflags tycon [(b_RDR, bh_RDR)] (
+          untag_Expr dflags tycon [(c_RDR, ch_RDR)] (
+          -- This used to use `if`, which interacts badly with RebindableSyntax.
+          -- See #11396.
+          nlHsApps and_RDR
+              [ genPrimOpApp (nlHsVar ch_RDR) geInt_RDR (nlHsVar ah_RDR)
+              , genPrimOpApp (nlHsVar ch_RDR) leInt_RDR (nlHsVar bh_RDR)
+              ]
+          )))
 
     --------------------------------------------------------------
     single_con_ixes
@@ -872,7 +863,12 @@ gen_Ix_binds loc tycon
       = mk_easy_FunBind loc inRange_RDR
                 [nlTuplePat [con_pat as_needed, con_pat bs_needed] Boxed,
                  con_pat cs_needed] $
-          foldl1 and_Expr (zipWith3Equal "single_con_inRange" in_range as_needed bs_needed cs_needed)
+          if con_arity == 0
+             -- If the product type has no fields, inRange is trivially true
+             -- (see Trac #12853).
+             then true_Expr
+             else foldl1 and_Expr (zipWith3Equal "single_con_inRange" in_range
+                    as_needed bs_needed cs_needed)
       where
         in_range a b c = nlHsApps inRange_RDR [mkLHsVarTuple [a,b], nlHsVar c]
 
@@ -950,7 +946,8 @@ These instances are also useful for Read (Either Int Emp), where
 we want to be able to parse (Left 3) just fine.
 -}
 
-gen_Read_binds :: (Name -> Fixity) -> SrcSpan -> TyCon -> (LHsBinds RdrName, BagDerivStuff)
+gen_Read_binds :: (Name -> Fixity) -> SrcSpan -> TyCon
+               -> (LHsBinds GhcPs, BagDerivStuff)
 
 gen_Read_binds get_fixity loc tycon
   = (listToBag [read_prec, default_readlist, default_readlistprec], emptyBag)
@@ -1032,10 +1029,10 @@ gen_Read_binds get_fixity loc tycon
         field_stmts  = zipWithEqual "lbl_stmts" read_field labels as_needed
 
         con_arity    = dataConSourceArity data_con
-        labels       = dataConFieldLabels data_con
+        labels       = map flLabel $ dataConFieldLabels data_con
         dc_nm        = getName data_con
         is_infix     = dataConIsInfix data_con
-        is_record    = length labels > 0
+        is_record    = labels `lengthExceeds` 0
         as_needed    = take con_arity as_RDRs
         read_args    = zipWithEqual "gen_Read_binds" read_arg as_needed (dataConOrigArgTys data_con)
         (read_a1:read_a2:_) = read_args
@@ -1068,7 +1065,7 @@ gen_Read_binds get_fixity loc tycon
 
     data_con_str con = occNameString (getOccName con)
 
-    read_arg a ty = ASSERT( not (isUnLiftedType ty) )
+    read_arg a ty = ASSERT( not (isUnliftedType ty) )
                     noLoc (mkBindStmt (nlVarPat a) (nlHsVarApps step_RDR [readPrec_RDR]))
 
     read_field lbl a = read_lbl lbl ++
@@ -1085,7 +1082,7 @@ gen_Read_binds get_fixity loc tycon
                  | otherwise
                  = ident_h_pat lbl_str
                  where
-                   lbl_str = occNameString (getOccName lbl)
+                   lbl_str = unpackFS lbl
 
 {-
 ************************************************************************
@@ -1118,17 +1115,15 @@ Example
                     -- the most tightly-binding operator
 -}
 
-gen_Show_binds :: (Name -> Fixity) -> SrcSpan -> TyCon -> (LHsBinds RdrName, BagDerivStuff)
+gen_Show_binds :: (Name -> Fixity) -> SrcSpan -> TyCon
+               -> (LHsBinds GhcPs, BagDerivStuff)
 
 gen_Show_binds get_fixity loc tycon
-  = (listToBag [shows_prec, show_list], emptyBag)
+  = (unitBag shows_prec, emptyBag)
   where
-    -----------------------------------------------------------------------
-    show_list = mkHsVarBind loc showList_RDR
-                  (nlHsApp (nlHsVar showList___RDR) (nlHsPar (nlHsApp (nlHsVar showsPrec_RDR) (nlHsIntLit 0))))
-    -----------------------------------------------------------------------
     data_cons = tyConDataCons tycon
-    shows_prec = mk_FunBind loc showsPrec_RDR (map pats_etc data_cons)
+    shows_prec = mkFunBindSE 1 loc showsPrec_RDR (map pats_etc data_cons)
+    comma_space = nlHsVar showCommaSpace_RDR
 
     pats_etc data_con
       | nullary_con =  -- skip the showParen junk...
@@ -1136,8 +1131,8 @@ gen_Show_binds get_fixity loc tycon
          ([nlWildPat, con_pat], mk_showString_app op_con_str)
       | otherwise   =
          ([a_Pat, con_pat],
-          showParen_Expr (nlHsPar (genOpApp a_Expr ge_RDR
-                                        (nlHsLit (HsInt "" con_prec_plus_one))))
+          showParen_Expr (genOpApp a_Expr ge_RDR (nlHsLit
+                                 (HsInt def (mkIntegralLit con_prec_plus_one))))
                          (nlHsPar (nested_compose_Expr show_thingies)))
         where
              data_con_RDR  = getRdrName data_con
@@ -1146,7 +1141,7 @@ gen_Show_binds get_fixity loc tycon
              arg_tys       = dataConOrigArgTys data_con         -- Correspond 1-1 with bs_needed
              con_pat       = nlConVarPat data_con_RDR bs_needed
              nullary_con   = con_arity == 0
-             labels        = dataConFieldLabels data_con
+             labels        = map flLabel $ dataConFieldLabels data_con
              lab_fields    = length labels
              record_syntax = lab_fields > 0
 
@@ -1169,8 +1164,7 @@ gen_Show_binds get_fixity loc tycon
                         -- space after the '=' is necessary, but it
                         -- seems tidier to have them both sides.
                  where
-                   occ_nm   = getOccName l
-                   nm       = wrapOpParens (occNameString occ_nm)
+                   nm       = wrapOpParens (unpackFS l)
 
              show_args               = zipWith show_arg bs_needed arg_tys
              (show_arg1:show_arg2:_) = show_args
@@ -1179,14 +1173,14 @@ gen_Show_binds get_fixity loc tycon
                 -- Assumption for record syntax: no of fields == no of
                 -- labelled fields (and in same order)
              show_record_args = concat $
-                                intersperse [mk_showString_app ", "] $
+                                intersperse [comma_space] $
                                 [ [show_label lbl, arg]
                                 | (lbl,arg) <- zipEqual "gen_Show_binds"
                                                         labels show_args ]
 
-             show_arg :: RdrName -> Type -> LHsExpr RdrName
+             show_arg :: RdrName -> Type -> LHsExpr GhcPs
              show_arg b arg_ty
-               | isUnLiftedType arg_ty
+               | isUnliftedType arg_ty
                -- See Note [Deriving and unboxed types] in TcDeriv
                = nlHsApps compose_RDR [mk_shows_app boxed_arg,
                                        mk_showString_app postfixMod]
@@ -1216,15 +1210,16 @@ isSym ""      = False
 isSym (c : _) = startsVarSym c || startsConSym c
 
 -- | showString :: String -> ShowS
-mk_showString_app :: String -> LHsExpr RdrName
+mk_showString_app :: String -> LHsExpr GhcPs
 mk_showString_app str = nlHsApp (nlHsVar showString_RDR) (nlHsLit (mkHsString str))
 
 -- | showsPrec :: Show a => Int -> a -> ShowS
-mk_showsPrec_app :: Integer -> LHsExpr RdrName -> LHsExpr RdrName
-mk_showsPrec_app p x = nlHsApps showsPrec_RDR [nlHsLit (HsInt "" p), x]
+mk_showsPrec_app :: Integer -> LHsExpr GhcPs -> LHsExpr GhcPs
+mk_showsPrec_app p x
+  = nlHsApps showsPrec_RDR [nlHsLit (HsInt def (mkIntegralLit p)), x]
 
 -- | shows :: Show a => a -> ShowS
-mk_shows_app :: LHsExpr RdrName -> LHsExpr RdrName
+mk_shows_app :: LHsExpr GhcPs -> LHsExpr GhcPs
 mk_shows_app x = nlHsApp (nlHsVar shows_RDR) x
 
 getPrec :: Bool -> (Name -> Fixity) -> Name -> Integer
@@ -1240,7 +1235,7 @@ appPrecedence = fromIntegral maxPrecedence + 1
 getPrecedence :: (Name -> Fixity) -> Name -> Integer
 getPrecedence get_fixity nm
    = case get_fixity nm of
-        Fixity x _assoc -> fromIntegral x
+        Fixity x _assoc -> fromIntegral x
           -- NB: the Report says that associativity is not taken
           --     into account for either Read or Show; hence we
           --     ignore associativity here
@@ -1248,55 +1243,6 @@ getPrecedence get_fixity nm
 {-
 ************************************************************************
 *                                                                      *
-\subsection{Typeable (new)}
-*                                                                      *
-************************************************************************
-
-From the data type
-
-        data T a b = ....
-
-we generate
-
-        instance Typeable2 T where
-                typeOf2 _ = mkTyConApp (mkTyCon <hash-high> <hash-low>
-                                                <pkg> <module> "T") []
-
-We are passed the Typeable2 class as well as T
--}
-
-gen_Typeable_binds :: DynFlags -> SrcSpan -> TyCon
-                   -> (LHsBinds RdrName, BagDerivStuff)
-gen_Typeable_binds dflags loc tycon
-  = ( unitBag $ mk_easy_FunBind loc typeRep_RDR [nlWildPat]
-                (nlHsApps mkTyConApp_RDR [tycon_rep, nlList []])
-    , emptyBag )
-  where
-    tycon_name = tyConName tycon
-    modl       = nameModule tycon_name
-    pkg        = modulePackageKey modl
-
-    modl_fs    = moduleNameFS (moduleName modl)
-    pkg_fs     = packageKeyFS pkg
-    name_fs    = occNameFS (nameOccName tycon_name)
-
-    tycon_rep = nlHsApps mkTyCon_RDR
-                    (map nlHsLit [int64 high,
-                                  int64 low,
-                                  HsString "" pkg_fs,
-                                  HsString "" modl_fs,
-                                  HsString "" name_fs])
-
-    hashThis = unwords $ map unpackFS [pkg_fs, modl_fs, name_fs]
-    Fingerprint high low = fingerprintString hashThis
-
-    int64
-      | wORD_SIZE dflags == 4 = HsWord64Prim "" . fromIntegral
-      | otherwise             = HsWordPrim "" . fromIntegral
-
-{-
-************************************************************************
-*                                                                      *
         Data instances
 *                                                                      *
 ************************************************************************
@@ -1330,64 +1276,78 @@ we generate
     dataCast2 = gcast2   -- if T :: * -> * -> *
 -}
 
-gen_Data_binds :: DynFlags
-               -> SrcSpan
+gen_Data_binds :: SrcSpan
                -> TyCon                 -- For data families, this is the
                                         --  *representation* TyCon
-               -> (LHsBinds RdrName,    -- The method bindings
-                   BagDerivStuff)       -- Auxiliary bindings
-gen_Data_binds dflags loc rep_tc
+               -> TcM (LHsBinds GhcPs,  -- The method bindings
+                       BagDerivStuff)   -- Auxiliary bindings
+gen_Data_binds loc rep_tc
+  = do { dflags  <- getDynFlags
+
+       -- Make unique names for the data type and constructor
+       -- auxiliary bindings.  Start with the name of the TyCon/DataCon
+       -- but that might not be unique: see Trac #12245.
+       ; dt_occ  <- chooseUniqueOccTc (mkDataTOcc (getOccName rep_tc))
+       ; dc_occs <- mapM (chooseUniqueOccTc . mkDataCOcc . getOccName)
+                         (tyConDataCons rep_tc)
+       ; let dt_rdr  = mkRdrUnqual dt_occ
+             dc_rdrs = map mkRdrUnqual dc_occs
+
+       -- OK, now do the work
+       ; return (gen_data dflags dt_rdr dc_rdrs loc rep_tc) }
+
+gen_data :: DynFlags -> RdrName -> [RdrName]
+         -> SrcSpan -> TyCon
+         -> (LHsBinds GhcPs,      -- The method bindings
+             BagDerivStuff)       -- Auxiliary bindings
+gen_data dflags data_type_name constr_names loc rep_tc
   = (listToBag [gfoldl_bind, gunfold_bind, toCon_bind, dataTypeOf_bind]
      `unionBags` gcast_binds,
                 -- Auxiliary definitions: the data type and constructors
-     listToBag ( DerivHsBind (genDataTyCon)
-               : map (DerivHsBind . genDataDataCon) data_cons))
+     listToBag ( genDataTyCon
+               : zipWith genDataDataCon data_cons constr_names ) )
   where
     data_cons  = tyConDataCons rep_tc
     n_cons     = length data_cons
     one_constr = n_cons == 1
-
-    genDataTyCon :: (LHsBind RdrName, LSig RdrName)
+    genDataTyCon :: DerivStuff
     genDataTyCon        --  $dT
-      = (mkHsVarBind loc rdr_name rhs,
-         L loc (TypeSig [L loc rdr_name] sig_ty PlaceHolder))
-      where
-        rdr_name = mk_data_type_name rep_tc
-        sig_ty   = nlHsTyVar dataType_RDR
-        constrs  = [nlHsVar (mk_constr_name con) | con <- tyConDataCons rep_tc]
-        rhs = nlHsVar mkDataType_RDR
-              `nlHsApp` nlHsLit (mkHsString (showSDocOneLine dflags (ppr rep_tc)))
-              `nlHsApp` nlList constrs
-
-    genDataDataCon :: DataCon -> (LHsBind RdrName, LSig RdrName)
-    genDataDataCon dc       --  $cT1 etc
-      = (mkHsVarBind loc rdr_name rhs,
-         L loc (TypeSig [L loc rdr_name] sig_ty PlaceHolder))
+      = DerivHsBind (mkHsVarBind loc data_type_name rhs,
+                     L loc (TypeSig [L loc data_type_name] sig_ty))
+
+    sig_ty = mkLHsSigWcType (nlHsTyVar dataType_RDR)
+    rhs    = nlHsVar mkDataType_RDR
+             `nlHsApp` nlHsLit (mkHsString (showSDocOneLine dflags (ppr rep_tc)))
+             `nlHsApp` nlList (map nlHsVar constr_names)
+
+    genDataDataCon :: DataCon -> RdrName -> DerivStuff
+    genDataDataCon dc constr_name       --  $cT1 etc
+      = DerivHsBind (mkHsVarBind loc constr_name rhs,
+                     L loc (TypeSig [L loc constr_name] sig_ty))
       where
-        rdr_name = mk_constr_name dc
-        sig_ty   = nlHsTyVar constr_RDR
+        sig_ty   = mkLHsSigWcType (nlHsTyVar constr_RDR)
         rhs      = nlHsApps mkConstr_RDR constr_args
 
         constr_args
-           = [ -- nlHsIntLit (toInteger (dataConTag dc)), -- Tag
-           nlHsVar (mk_data_type_name (dataConTyCon dc)), -- DataType
-           nlHsLit (mkHsString (occNameString dc_occ)),   -- String name
-               nlList  labels,                            -- Field labels
-           nlHsVar fixity]                                -- Fixity
+           = [ -- nlHsIntLit (toInteger (dataConTag dc)),   -- Tag
+               nlHsVar (data_type_name)                     -- DataType
+             , nlHsLit (mkHsString (occNameString dc_occ))  -- String name
+             , nlList  labels                               -- Field labels
+             , nlHsVar fixity ]                             -- Fixity
 
-        labels   = map (nlHsLit . mkHsString . getOccString)
+        labels   = map (nlHsLit . mkHsString . unpackFS . flLabel)
                        (dataConFieldLabels dc)
         dc_occ   = getOccName dc
         is_infix = isDataSymOcc dc_occ
         fixity | is_infix  = infix_RDR
-           | otherwise = prefix_RDR
+               | otherwise = prefix_RDR
 
         ------------ gfoldl
-    gfoldl_bind = mk_FunBind loc gfoldl_RDR (map gfoldl_eqn data_cons)
+    gfoldl_bind = mkFunBindSE 3 loc gfoldl_RDR (map gfoldl_eqn data_cons)
 
     gfoldl_eqn con
-      = ([nlVarPat k_RDR, nlVarPat z_RDR, nlConVarPat con_name as_needed],
-                       foldl mk_k_app (nlHsVar z_RDR `nlHsApp` nlHsVar con_name) as_needed)
+      = ([nlVarPat k_RDR, z_Pat, nlConVarPat con_name as_needed],
+                   foldl mk_k_app (z_Expr `nlHsApp` nlHsVar con_name) as_needed)
                    where
                      con_name ::  RdrName
                      con_name = getRdrName con
@@ -1395,39 +1355,40 @@ gen_Data_binds dflags loc rep_tc
                      mk_k_app e v = nlHsPar (nlHsOpApp e k_RDR (nlHsVar v))
 
         ------------ gunfold
-    gunfold_bind = mk_FunBind loc
-                              gunfold_RDR
-                              [([k_Pat, z_Pat, if one_constr then nlWildPat else c_Pat],
-                                gunfold_rhs)]
+    gunfold_bind = mk_easy_FunBind loc
+                     gunfold_RDR
+                     [k_Pat, z_Pat, if one_constr then nlWildPat else c_Pat]
+                     gunfold_rhs
 
     gunfold_rhs
         | one_constr = mk_unfold_rhs (head data_cons)   -- No need for case
         | otherwise  = nlHsCase (nlHsVar conIndex_RDR `nlHsApp` c_Expr)
                                 (map gunfold_alt data_cons)
 
-    gunfold_alt dc = mkSimpleHsAlt (mk_unfold_pat dc) (mk_unfold_rhs dc)
+    gunfold_alt dc = mkHsCaseAlt (mk_unfold_pat dc) (mk_unfold_rhs dc)
     mk_unfold_rhs dc = foldr nlHsApp
-                           (nlHsVar z_RDR `nlHsApp` nlHsVar (getRdrName dc))
+                           (z_Expr `nlHsApp` nlHsVar (getRdrName dc))
                            (replicate (dataConSourceArity dc) (nlHsVar k_RDR))
 
     mk_unfold_pat dc    -- Last one is a wild-pat, to avoid
                         -- redundant test, and annoying warning
       | tag-fIRST_TAG == n_cons-1 = nlWildPat   -- Last constructor
       | otherwise = nlConPat intDataCon_RDR
-                             [nlLitPat (HsIntPrim "" (toInteger tag))]
+                             [nlLitPat (HsIntPrim NoSourceText (toInteger tag))]
       where
         tag = dataConTag dc
 
         ------------ toConstr
-    toCon_bind = mk_FunBind loc toConstr_RDR (map to_con_eqn data_cons)
-    to_con_eqn dc = ([nlWildConPat dc], nlHsVar (mk_constr_name dc))
+    toCon_bind = mkFunBindSE 1 loc toConstr_RDR
+                     (zipWith to_con_eqn data_cons constr_names)
+    to_con_eqn dc con_name = ([nlWildConPat dc], nlHsVar con_name)
 
         ------------ dataTypeOf
     dataTypeOf_bind = mk_easy_FunBind
                         loc
                         dataTypeOf_RDR
                         [nlWildPat]
-                        (nlHsVar (mk_data_type_name rep_tc))
+                        (nlHsVar data_type_name)
 
         ------------ gcast1/2
         -- Make the binding    dataCast1 x = gcast1 x  -- if T :: * -> *
@@ -1455,8 +1416,8 @@ gen_Data_binds dflags loc rep_tc
 
 
 kind1, kind2 :: Kind
-kind1 = liftedTypeKind `mkArrowKind` liftedTypeKind
-kind2 = liftedTypeKind `mkArrowKind` kind1
+kind1 = liftedTypeKind `mkFunTy` liftedTypeKind
+kind2 = liftedTypeKind `mkFunTy` kind1
 
 gfoldl_RDR, gunfold_RDR, toConstr_RDR, dataTypeOf_RDR, mkConstr_RDR,
     mkDataType_RDR, conIndex_RDR, prefix_RDR, infix_RDR,
@@ -1523,451 +1484,254 @@ geDouble_RDR   = varQual_RDR  gHC_PRIM (fsLit ">=##")
 {-
 ************************************************************************
 *                                                                      *
-                        Functor instances
-
- see http://www.mail-archive.com/haskell-prime@haskell.org/msg02116.html
-
+                        Lift instances
 *                                                                      *
 ************************************************************************
 
-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.
+Example:
+
+    data Foo a = Foo a | a :^: a deriving Lift
+
+    ==>
+
+    instance (Lift a) => Lift (Foo a) where
+        lift (Foo a)
+          = appE
+              (conE
+                (mkNameG_d "package-name" "ModuleName" "Foo"))
+              (lift a)
+        lift (u :^: v)
+          = infixApp
+              (lift u)
+              (conE
+                (mkNameG_d "package-name" "ModuleName" ":^:"))
+              (lift v)
+
+Note that (mkNameG_d "package-name" "ModuleName" "Foo") is equivalent to what
+'Foo would be when using the -XTemplateHaskell extension. To make sure that
+-XDeriveLift can be used on stage-1 compilers, however, we explicitly invoke
+makeG_d.
 -}
 
-gen_Functor_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, BagDerivStuff)
-gen_Functor_binds loc tycon
-  = (unitBag fmap_bind, emptyBag)
+gen_Lift_binds :: SrcSpan -> TyCon -> (LHsBinds GhcPs, BagDerivStuff)
+gen_Lift_binds loc tycon
+  | null data_cons = (unitBag (L loc $ mkFunBind (L loc lift_RDR)
+                       [mkMatch (mkPrefixFunRhs (L loc lift_RDR))
+                                        [nlWildPat] errorMsg_Expr
+                                        (noLoc emptyLocalBinds)])
+                     , emptyBag)
+  | otherwise = (unitBag lift_bind, emptyBag)
   where
-    data_cons = tyConDataCons tycon
-    fmap_bind = mkRdrFunBind (L loc fmap_RDR) 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 [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                      -- fmap f = \x b -> h (x (g b))
-                                 gg <- g
-                                 hh <- h
-                                 mkSimpleLam2 $ \x b -> return $ nlHsApp hh (nlHsApp x (nlHsApp gg b))
-                 , ft_tup = \t gs -> do                      -- fmap f = \x -> case x of (a1,a2,..) -> (g1 a1,g2 a2,..)
-                                 gg <- sequence gs
-                                 mkSimpleLam $ mkSimpleTupleCase match_for_con t gg
-                 , 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 $
-        \con_name xs -> return $ nlHsApps con_name xs  -- Con x1 x2 ..
+    -- We may want to make mkFunBindSE's error message generation general
+    -- enough to avoid needing to duplicate its logic here. On the other
+    -- hand, it may not be worth the trouble.
+    errorMsg_Expr = nlHsVar error_RDR `nlHsApp` nlHsLit
+        (mkHsString $ "Can't lift value of empty datatype " ++ tycon_str)
 
-{-
-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.
--}
+    lift_bind = mkFunBindSE 1 loc lift_RDR (map pats_etc data_cons)
+    data_cons = tyConDataCons tycon
+    tycon_str = occNameString . nameOccName . tyConName $ tycon
 
--- Generic traversal for Functor deriving
-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     :: TupleSort -> [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 (tupleTyConSort con) xrs, True)
-       | or (init xcs)    = (caseWrongArg, True)         -- T (..var..)    ty
-       | otherwise        = case splitAppTy_maybe ty of  -- T (..no var..) ty
-                              Nothing -> (caseWrongArg, True)   -- Non-decomposable (eg type function)
-                              Just (fun_ty, _) -> (caseTyApp fun_ty (last xrs), True)
+    pats_etc data_con
+      = ([con_pat], lift_Expr)
        where
-         (xrs,xcs) = unzip (map (go co) args)
-    go co (ForAllTy v x) | 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`) . tyVarsOfType) xs })
-
-
-foldDataConArgs :: FFoldType a -> DataCon -> [a]
--- Fold over the arguments of the datacon
-foldDataConArgs ft con
-  = map (functorLikeTraverse tv ft) (dataConOrigArgTys con)
-  where
-    Just tv = getTyVar_maybe (last (tyConAppArgs (dataConOrigResTy con)))
-        -- Argument to derive for, 'a in the above description
-        -- The validity and kind checks have ensured that
-        -- the Just will match and a::*
-
--- 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 :: Monad m => (RdrName -> [LHsExpr RdrName] -> m (LHsExpr RdrName))
-                 -> [LPat RdrName]
-                 -> DataCon
-                 -> [LHsExpr RdrName]
-                 -> m (LMatch RdrName (LHsExpr RdrName))
-mkSimpleConMatch 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 (extra_pats ++ [pat]) rhs 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)))
-                  -> TupleSort -> [a] -> LHsExpr RdrName -> m (LHsExpr RdrName)
-mkSimpleTupleCase match_for_con sort insides x = do
-    let con = tupleCon sort (length insides)
-    match <- match_for_con [] con insides
-    return $ nlHsCase x [match]
+            con_pat      = nlConVarPat data_con_RDR as_needed
+            data_con_RDR = getRdrName data_con
+            con_arity    = dataConSourceArity data_con
+            as_needed    = take con_arity as_RDRs
+            lifted_as    = zipWithEqual "mk_lift_app" mk_lift_app
+                             tys_needed as_needed
+            tycon_name   = tyConName tycon
+            is_infix     = dataConIsInfix data_con
+            tys_needed   = dataConOrigArgTys data_con
+
+            mk_lift_app ty a
+              | not (isUnliftedType ty) = nlHsApp (nlHsVar lift_RDR)
+                                                  (nlHsVar a)
+              | otherwise = nlHsApp (nlHsVar litE_RDR)
+                              (primLitOp (mkBoxExp (nlHsVar a)))
+              where (primLitOp, mkBoxExp) = primLitOps "Lift" tycon ty
+
+            pkg_name = unitIdString . moduleUnitId
+                     . nameModule $ tycon_name
+            mod_name = moduleNameString . moduleName . nameModule $ tycon_name
+            con_name = occNameString . nameOccName . dataConName $ data_con
+
+            conE_Expr = nlHsApp (nlHsVar conE_RDR)
+                                (nlHsApps mkNameG_dRDR
+                                  (map (nlHsLit . mkHsString)
+                                    [pkg_name, mod_name, con_name]))
+
+            lift_Expr
+              | is_infix  = nlHsApps infixApp_RDR [a1, conE_Expr, a2]
+              | otherwise = foldl mk_appE_app conE_Expr lifted_as
+            (a1:a2:_) = lifted_as
+
+mk_appE_app :: LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
+mk_appE_app a b = nlHsApps appE_RDR [a, b]
 
 {-
 ************************************************************************
 *                                                                      *
-                        Foldable instances
-
- see http://www.mail-archive.com/haskell-prime@haskell.org/msg02116.html
-
+                     Newtype-deriving instances
 *                                                                      *
 ************************************************************************
 
-Deriving Foldable instances works the same way as Functor instances,
-only Foldable instances are not possible for function types at all.
-Here the derived instance for the type T above is:
+Note [Newtype-deriving instances]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We take every method in the original instance and `coerce` it to fit
+into the derived instance. We need a type annotation on the argument
+to `coerce` to make it obvious what instantiation of the method we're
+coercing from.  So from, say,
+  class C a b where
+    op :: a -> [b] -> Int
 
-  instance Foldable T where
-      foldr f z (T1 x1 x2 x3) = $(foldr 'a 'b1) x1 ( $(foldr 'a 'a) x2 ( $(foldr 'a 'b2) x3 z ) )
+  newtype T x = MkT <rep-ty>
 
-The cases are:
+  instance C a <rep-ty> => C a (T x) where
+    op = coerce @ (a -> [<rep-ty>] -> Int)
+                @ (a -> [T x]      -> Int)
+                op
 
-  $(foldr 'a 'b)         =  \x z -> z     -- when b does not contain a
-  $(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
+Notice that we give the 'coerce' two explicitly-visible type arguments
+to say how it should be instantiated.  Recall
 
-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).
--}
+  coerce :: Coeercible a b => a -> b
 
-gen_Foldable_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, BagDerivStuff)
-gen_Foldable_binds loc tycon
-  = (listToBag [foldr_bind, foldMap_bind], emptyBag)
-  where
-    data_cons = tyConDataCons tycon
+By giving it explicit type arguments we deal with the case where
+'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>
+   instance C <rep-ty> => C (T x) where
+     op = coerce @ (forall b. <rep-ty> -> b -> b)
+                 @ (forall b. T x -> b -> b)
+                op
 
-    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
+The type checker checks this code, and it currently requires
+-XImpredicativeTypes to permit that polymorphic type instantiation,
+so we have to switch that flag on locally in TcDeriv.genInst.
 
-    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
-
-    ft_foldr :: FFoldType (State [RdrName] (LHsExpr RdrName))
-    ft_foldr = FT { ft_triv    = mkSimpleLam2 $ \_ z -> return z       -- foldr f = \x z -> z
-                  , ft_var     = return f_Expr                         -- foldr f = f
-                  , ft_tup     = \t g -> do gg <- sequence g           -- foldr f = (\x z -> case x of ...)
-                                            mkSimpleLam2 $ \x z -> mkSimpleTupleCase (match_foldr z) t gg x
-                  , ft_ty_app  = \_ g -> do gg <- g                    -- foldr f = (\x z -> foldr g z x)
-                                            mkSimpleLam2 $ \x z -> return $ nlHsApps foldable_foldr_RDR [gg,z,x]
-                  , ft_forall  = \_ g -> g
-                  , ft_co_var  = panic "contravariant"
-                  , ft_fun     = panic "function"
-                  , ft_bad_app = panic "in other argument" }
-
-    match_foldr z = mkSimpleConMatch $ \_con_name xs -> return $ foldr nlHsApp z xs -- g1 v1 (g2 v2 (.. z))
-
-    ft_foldMap :: FFoldType (State [RdrName] (LHsExpr RdrName))
-    ft_foldMap = FT { ft_triv = mkSimpleLam $ \_ -> return mempty_Expr  -- foldMap f = \x -> mempty
-                    , ft_var  = return f_Expr                           -- foldMap f = f
-                    , ft_tup  = \t g -> do gg <- sequence g             -- foldMap f = \x -> case x of (..,)
-                                           mkSimpleLam $ mkSimpleTupleCase match_foldMap t gg
-                    , ft_ty_app = \_ g -> 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 = mkSimpleConMatch $ \_con_name xs -> return $
-        case xs of
-            [] -> mempty_Expr
-            xs -> foldr1 (\x y -> nlHsApps mappend_RDR [x,y]) xs
+See #8503 for more discussion.
 
-{-
-************************************************************************
-*                                                                      *
-                        Traversable instances
+Note [Newtype-deriving trickiness]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider (Trac #12768):
+  class C a where { op :: D a => a -> a }
 
- see http://www.mail-archive.com/haskell-prime@haskell.org/msg02116.html
-*                                                                      *
-************************************************************************
+  instance C a  => C [a] where { op = opList }
 
-Again, Traversable is much like Functor and Foldable.
+  opList :: (C a, D [a]) => [a] -> [a]
+  opList = ...
 
-The cases are:
+Now suppose we try GND on this:
+  newtype N a = MkN [a] deriving( C )
 
-  $(traverse 'a 'b)          =  pure     -- when b does not contain a
-  $(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
+The GND is expecting to get an implementation of op for N by
+coercing opList, thus:
 
-Note that the generated code is not as efficient as it could be. For instance:
+  instance C a => C (N a) where { op = opN }
 
-  data T a = T Int a  deriving Traversable
+  opN :: (C a, D (N a)) => N a -> N a
+  opN = coerce @(D [a]   => [a] -> [a])
+               @(D (N a) => [N a] -> [N a]
+               opList
 
-gives the function: traverse f (T x y) = T <$> pure x <*> f y
-instead of:         traverse f (T x y) = T x <$> f y
+But there is no reason to suppose that (D [a]) and (D (N a))
+are inter-coercible; these instances might completely different.
+So GHC rightly rejects this code.
 -}
 
-gen_Traversable_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, BagDerivStuff)
-gen_Traversable_binds loc tycon
-  = (unitBag traverse_bind, emptyBag)
+gen_Newtype_binds :: SrcSpan
+                  -> Class   -- the class being derived
+                  -> [TyVar] -- the tvs in the instance head (this includes
+                             -- the tvs from both the class types and the
+                             -- newtype itself)
+                  -> [Type]  -- instance head parameters (incl. newtype)
+                  -> Type    -- the representation type
+                  -> TcM (LHsBinds GhcPs, BagDerivStuff)
+-- See Note [Newtype-deriving instances]
+gen_Newtype_binds loc cls inst_tvs inst_tys rhs_ty
+  = do let ats = classATs cls
+       atf_insts <- ASSERT( all (not . isDataFamilyTyCon) ats )
+                    mapM mk_atf_inst ats
+       return ( listToBag $ map mk_bind (classMethods cls)
+              , listToBag $ map DerivFamInst atf_insts )
   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
+    mk_bind :: Id -> LHsBind GhcPs
+    mk_bind meth_id
+      = mkRdrFunBind (L loc meth_RDR) [mkSimpleMatch
+                                          (mkPrefixFunRhs (L loc meth_RDR))
+                                          [] rhs_expr]
       where
-        parts = sequence $ foldDataConArgs ft_trav con
-
-
-    ft_trav :: FFoldType (State [RdrName] (LHsExpr RdrName))
-    ft_trav = FT { ft_triv    = return pure_Expr                  -- traverse f = pure x
-                 , ft_var     = return f_Expr                     -- traverse f = f x
-                 , ft_tup     = \t gs -> do                       -- traverse f = \x -> case x of (a1,a2,..) ->
-                                    gg <- sequence gs             --                   (,,) <$> g1 a1 <*> g2 a2 <*> ..
-                                    mkSimpleLam $ mkSimpleTupleCase match_for_con t gg
-                 , ft_ty_app  = \_ g -> nlHsApp traverse_Expr <$> g  -- traverse f = travese g
-                 , ft_forall  = \_ g -> g
-                 , ft_co_var  = panic "contravariant"
-                 , ft_fun     = panic "function"
-                 , ft_bad_app = panic "in other argument" }
-
-    -- Con a1 a2 ... -> Con <$> g1 a1 <*> g2 a2 <*> ...
-    match_for_con = mkSimpleConMatch $
-        \con_name xs -> return $ mkApCon (nlHsVar con_name) xs
-
-    -- ((Con <$> x1) <*> x2) <*> ..
-    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]
-
-{-
-************************************************************************
-*                                                                      *
-                     Newtype-deriving instances
-*                                                                      *
-************************************************************************
-
-We take every method in the original instance and `coerce` it to fit
-into the derived instance. We need a type annotation on the argument
-to `coerce` to make it obvious what instantiation of the method we're
-coercing from.
+        Pair from_ty to_ty = mkCoerceClassMethEqn cls inst_tvs inst_tys rhs_ty meth_id
+
+        meth_RDR = getRdrName meth_id
+
+        rhs_expr = nlHsVar (getRdrName coerceId)
+                                      `nlHsAppType` from_ty
+                                      `nlHsAppType` to_ty
+                                      `nlHsApp`     nlHsVar meth_RDR
+
+    mk_atf_inst :: TyCon -> TcM FamInst
+    mk_atf_inst fam_tc = do
+        rep_tc_name <- newFamInstTyConName (L loc (tyConName fam_tc))
+                                           rep_lhs_tys
+        let axiom = mkSingleCoAxiom Nominal rep_tc_name rep_tvs' rep_cvs'
+                                    fam_tc rep_lhs_tys rep_rhs_ty
+        -- Check (c) from Note [GND and associated type families] in TcDeriv
+        checkValidTyFamEqn (Just (cls, cls_tvs, lhs_env)) fam_tc rep_tvs'
+                           rep_cvs' rep_lhs_tys rep_rhs_ty pp_lhs loc
+        newFamInst SynFamilyInst axiom
+      where
+        cls_tvs     = classTyVars cls
+        in_scope    = mkInScopeSet $ mkVarSet inst_tvs
+        lhs_env     = zipTyEnv cls_tvs inst_tys
+        lhs_subst   = mkTvSubst in_scope lhs_env
+        rhs_env     = zipTyEnv cls_tvs $ changeLast inst_tys rhs_ty
+        rhs_subst   = mkTvSubst in_scope rhs_env
+        fam_tvs     = tyConTyVars fam_tc
+        rep_lhs_tys = substTyVars lhs_subst fam_tvs
+        rep_rhs_tys = substTyVars rhs_subst fam_tvs
+        rep_rhs_ty  = mkTyConApp fam_tc rep_rhs_tys
+        rep_tcvs    = tyCoVarsOfTypesList rep_lhs_tys
+        (rep_tvs, rep_cvs) = partition isTyVar rep_tcvs
+        rep_tvs'    = toposortTyVars rep_tvs
+        rep_cvs'    = toposortTyVars rep_cvs
+        pp_lhs      = ppr (mkTyConApp fam_tc rep_lhs_tys)
+
+nlHsAppType :: LHsExpr GhcPs -> Type -> LHsExpr GhcPs
+nlHsAppType e s = noLoc (e `HsAppType` hs_ty)
+  where
+    hs_ty = mkHsWildCardBndrs $ nlHsParTy (typeToLHsType s)
 
-See #8503 for more discussion.
--}
+nlExprWithTySig :: LHsExpr GhcPs -> Type -> LHsExpr GhcPs
+nlExprWithTySig e s = noLoc (e `ExprWithTySig` hs_ty)
+  where
+    hs_ty = mkLHsSigWcType (typeToLHsType s)
 
 mkCoerceClassMethEqn :: Class   -- the class being derived
-                     -> [TyVar] -- the tvs in the instance head
+                     -> [TyVar] -- the tvs in the instance head (this includes
+                                -- the tvs from both the class types and the
+                                -- newtype itself)
                      -> [Type]  -- instance head parameters (incl. newtype)
-                     -> Type    -- the representation type (already eta-reduced)
+                     -> Type    -- the representation type
                      -> Id      -- the method to look at
                      -> Pair Type
-mkCoerceClassMethEqn cls inst_tvs cls_tys rhs_ty id
-  = Pair (substTy rhs_subst user_meth_ty) (substTy lhs_subst user_meth_ty)
+-- See Note [Newtype-deriving instances]
+-- See also Note [Newtype-deriving trickiness]
+-- The pair is the (from_type, to_type), where to_type is
+-- the type of the method we are tyrying to get
+mkCoerceClassMethEqn cls inst_tvs inst_tys rhs_ty id
+  = Pair (substTy rhs_subst user_meth_ty)
+         (substTy lhs_subst user_meth_ty)
   where
     cls_tvs = classTyVars cls
     in_scope = mkInScopeSet $ mkVarSet inst_tvs
-    lhs_subst = mkTvSubst in_scope (zipTyEnv cls_tvs cls_tys)
-    rhs_subst = mkTvSubst in_scope (zipTyEnv cls_tvs (changeLast cls_tys rhs_ty))
-    (_class_tvs, _class_constraint, user_meth_ty) = tcSplitSigmaTy (varType id)
-
-    changeLast :: [a] -> a -> [a]
-    changeLast []     _  = panic "changeLast"
-    changeLast [_]    x  = [x]
-    changeLast (x:xs) x' = x : changeLast xs x'
-
-
-gen_Newtype_binds :: SrcSpan
-                  -> Class   -- the class being derived
-                  -> [TyVar] -- the tvs in the instance head
-                  -> [Type]  -- instance head parameters (incl. newtype)
-                  -> Type    -- the representation type (already eta-reduced)
-                  -> LHsBinds RdrName
-gen_Newtype_binds loc cls inst_tvs cls_tys rhs_ty
-  = listToBag $ zipWith mk_bind
-        (classMethods cls)
-        (map (mkCoerceClassMethEqn cls inst_tvs cls_tys rhs_ty) (classMethods cls))
-  where
-    coerce_RDR = getRdrName coerceId
-    mk_bind :: Id -> Pair Type -> LHsBind RdrName
-    mk_bind id (Pair tau_ty user_ty)
-      = mkRdrFunBind (L loc meth_RDR) [mkSimpleMatch [] rhs_expr]
-      where
-        meth_RDR = getRdrName id
-        rhs_expr
-          = ( nlHsVar coerce_RDR
-                `nlHsApp`
-              (nlHsVar meth_RDR `nlExprWithTySig` toHsType tau_ty'))
-            `nlExprWithTySig` toHsType user_ty
-        -- Open the representation type here, so that it's forall'ed type
-        -- variables refer to the ones bound in the user_ty
-        (_, _, tau_ty')  = tcSplitSigmaTy tau_ty
-
-    nlExprWithTySig :: LHsExpr RdrName -> LHsType RdrName -> LHsExpr RdrName
-    nlExprWithTySig e s = noLoc (ExprWithTySig e s PlaceHolder)
+    lhs_subst = mkTvSubst in_scope (zipTyEnv cls_tvs inst_tys)
+    rhs_subst = mkTvSubst in_scope (zipTyEnv cls_tvs (changeLast inst_tys rhs_ty))
+    (_class_tvs, _class_constraint, user_meth_ty)
+      = tcSplitMethodTy (varType id)
 
 {-
 ************************************************************************
@@ -1988,15 +1752,16 @@ The `tags' here start at zero, hence the @fIRST_TAG@ (currently one)
 fiddling around.
 -}
 
-genAuxBindSpec :: SrcSpan -> AuxBindSpec -> (LHsBind RdrName, LSig RdrName)
-genAuxBindSpec loc (DerivCon2Tag tycon)
-  = (mk_FunBind loc rdr_name eqns,
-     L loc (TypeSig [L loc rdr_name] (L loc sig_ty) PlaceHolder))
+genAuxBindSpec :: DynFlags -> SrcSpan -> AuxBindSpec
+                  -> (LHsBind GhcPs, LSig GhcPs)
+genAuxBindSpec dflags loc (DerivCon2Tag tycon)
+  = (mkFunBindSE 0 loc rdr_name eqns,
+     L loc (TypeSig [L loc rdr_name] sig_ty))
   where
-    rdr_name = con2tag_RDR tycon
+    rdr_name = con2tag_RDR dflags tycon
 
-    sig_ty = HsCoreTy $
-             mkSigmaTy (tyConTyVars tycon) (tyConStupidTheta tycon) $
+    sig_ty = mkLHsSigWcType $ L loc $ HsCoreTy $
+             mkSpecSigmaTy (tyConTyVars tycon) (tyConStupidTheta tycon) $
              mkParentType tycon `mkFunTy` intPrimTy
 
     lots_of_constructors = tyConFamilySize tycon > 8
@@ -2008,41 +1773,42 @@ genAuxBindSpec loc (DerivCon2Tag tycon)
 
     get_tag_eqn = ([nlVarPat a_RDR], nlHsApp (nlHsVar getTag_RDR) a_Expr)
 
-    mk_eqn :: DataCon -> ([LPat RdrName], LHsExpr RdrName)
+    mk_eqn :: DataCon -> ([LPat GhcPs], LHsExpr GhcPs)
     mk_eqn con = ([nlWildConPat con],
-                  nlHsLit (HsIntPrim ""
+                  nlHsLit (HsIntPrim NoSourceText
                                     (toInteger ((dataConTag con) - fIRST_TAG))))
 
-genAuxBindSpec loc (DerivTag2Con tycon)
-  = (mk_FunBind loc rdr_name
+genAuxBindSpec dflags loc (DerivTag2Con tycon)
+  = (mkFunBindSE 0 loc rdr_name
         [([nlConVarPat intDataCon_RDR [a_RDR]],
            nlHsApp (nlHsVar tagToEnum_RDR) a_Expr)],
-     L loc (TypeSig [L loc rdr_name] (L loc sig_ty) PlaceHolder))
+     L loc (TypeSig [L loc rdr_name] sig_ty))
   where
-    sig_ty = HsCoreTy $ mkForAllTys (tyConTyVars tycon) $
+    sig_ty = mkLHsSigWcType $ L loc $
+             HsCoreTy $ mkSpecForAllTys (tyConTyVars tycon) $
              intTy `mkFunTy` mkParentType tycon
 
-    rdr_name = tag2con_RDR tycon
+    rdr_name = tag2con_RDR dflags tycon
 
-genAuxBindSpec loc (DerivMaxTag tycon)
+genAuxBindSpec dflags loc (DerivMaxTag tycon)
   = (mkHsVarBind loc rdr_name rhs,
-     L loc (TypeSig [L loc rdr_name] (L loc sig_ty) PlaceHolder))
+     L loc (TypeSig [L loc rdr_name] sig_ty))
   where
-    rdr_name = maxtag_RDR tycon
-    sig_ty = HsCoreTy intTy
-    rhs = nlHsApp (nlHsVar intDataCon_RDR) (nlHsLit (HsIntPrim "" max_tag))
+    rdr_name = maxtag_RDR dflags tycon
+    sig_ty = mkLHsSigWcType (L loc (HsCoreTy intTy))
+    rhs = nlHsApp (nlHsVar intDataCon_RDR)
+                  (nlHsLit (HsIntPrim NoSourceText max_tag))
     max_tag =  case (tyConDataCons tycon) of
                  data_cons -> toInteger ((length data_cons) - fIRST_TAG)
 
-type SeparateBagsDerivStuff = -- AuxBinds and SYB bindings
-                              ( Bag (LHsBind RdrName, LSig RdrName)
-                                -- Extra bindings (used by Generic only)
-                              , Bag TyCon   -- Extra top-level datatypes
-                              , Bag (FamInst)           -- Extra family instances
-                              , Bag (InstInfo RdrName)) -- Extra instances
+type SeparateBagsDerivStuff =
+  -- AuxBinds and SYB bindings
+  ( Bag (LHsBind GhcPs, LSig GhcPs)
+  -- Extra family instances (used by Generic and DeriveAnyClass)
+  , Bag (FamInst) )
 
-genAuxBinds :: SrcSpan -> BagDerivStuff -> SeparateBagsDerivStuff
-genAuxBinds loc b = genAuxBinds' b2 where
+genAuxBinds :: DynFlags -> SrcSpan -> BagDerivStuff -> SeparateBagsDerivStuff
+genAuxBinds dflags loc b = genAuxBinds' b2 where
   (b1,b2) = partitionBagWith splitDerivAuxBind b
   splitDerivAuxBind (DerivAuxBind x) = Left x
   splitDerivAuxBind  x               = Right x
@@ -2051,25 +1817,15 @@ genAuxBinds loc b = genAuxBinds' b2 where
   dup_check a b = if anyBag (== a) b then b else consBag a b
 
   genAuxBinds' :: BagDerivStuff -> SeparateBagsDerivStuff
-  genAuxBinds' = foldrBag f ( mapBag (genAuxBindSpec loc) (rm_dups b1)
-                            , emptyBag, emptyBag, emptyBag)
+  genAuxBinds' = foldrBag f ( mapBag (genAuxBindSpec dflags loc) (rm_dups b1)
+                            , emptyBag )
   f :: DerivStuff -> SeparateBagsDerivStuff -> SeparateBagsDerivStuff
   f (DerivAuxBind _) = panic "genAuxBinds'" -- We have removed these before
   f (DerivHsBind  b) = add1 b
-  f (DerivTyCon   t) = add2 t
-  f (DerivFamInst t) = add3 t
-  f (DerivInst    i) = add4 i
+  f (DerivFamInst t) = add2 t
 
-  add1 x (a,b,c,d) = (x `consBag` a,b,c,d)
-  add2 x (a,b,c,d) = (a,x `consBag` b,c,d)
-  add3 x (a,b,c,d) = (a,b,x `consBag` c,d)
-  add4 x (a,b,c,d) = (a,b,c,x `consBag` d)
-
-mk_data_type_name :: TyCon -> RdrName   -- "$tT"
-mk_data_type_name tycon = mkAuxBinderName (tyConName tycon) mkDataTOcc
-
-mk_constr_name :: DataCon -> RdrName    -- "$cC"
-mk_constr_name con = mkAuxBinderName (dataConName con) mkDataCOcc
+  add1 x (a,b) = (x `consBag` a,b)
+  add2 x (a,b) = (a,x `consBag` b)
 
 mkParentType :: TyCon -> Type
 -- Turn the representation tycon of a family into
@@ -2087,32 +1843,77 @@ mkParentType tc
 ************************************************************************
 -}
 
-mk_FunBind :: SrcSpan -> RdrName
-           -> [([LPat RdrName], LHsExpr RdrName)]
-           -> LHsBind RdrName
-mk_FunBind loc fun pats_and_exprs
-  = mkRdrFunBind (L loc fun) matches
+-- | Make a function binding. If no equations are given, produce a function
+-- with the given arity that produces a stock error.
+mkFunBindSE :: Arity -> SrcSpan -> RdrName
+             -> [([LPat GhcPs], LHsExpr GhcPs)]
+             -> LHsBind GhcPs
+mkFunBindSE arity loc fun pats_and_exprs
+  = mkRdrFunBindSE arity (L loc fun) matches
   where
-    matches = [mkMatch p e emptyLocalBinds | (p,e) <-pats_and_exprs]
+    matches = [mkMatch (mkPrefixFunRhs (L loc fun)) p e
+                               (noLoc emptyLocalBinds)
+              | (p,e) <-pats_and_exprs]
+
+mkRdrFunBind :: Located RdrName -> [LMatch GhcPs (LHsExpr GhcPs)]
+             -> LHsBind GhcPs
+mkRdrFunBind fun@(L loc _fun_rdr) matches
+  = L loc (mkFunBind fun matches)
+
+-- | Produces a function binding. When no equations are given, it generates
+-- a binding of the given arity and an empty case expression
+-- for the last argument that it passes to the given function to produce
+-- the right-hand side.
+mkRdrFunBindEC :: Arity
+               -> (LHsExpr GhcPs -> LHsExpr GhcPs)
+               -> Located RdrName
+               -> [LMatch GhcPs (LHsExpr GhcPs)]
+               -> LHsBind GhcPs
+mkRdrFunBindEC arity catch_all
+                 fun@(L loc _fun_rdr) matches = L loc (mkFunBind fun matches')
+ where
+   -- Catch-all eqn looks like
+   --     fmap _ z = case z of {}
+   -- or
+   --     traverse _ z = pure (case z of)
+   -- or
+   --     foldMap _ z = mempty
+   -- It's needed if there no data cons at all,
+   -- which can happen with -XEmptyDataDecls
+   -- See Trac #4302
+   matches' = if null matches
+              then [mkMatch (mkPrefixFunRhs fun)
+                            (replicate (arity - 1) nlWildPat ++ [z_Pat])
+                            (catch_all $ nlHsCase z_Expr [])
+                            (noLoc emptyLocalBinds)]
+              else matches
 
-mkRdrFunBind :: Located RdrName -> [LMatch RdrName (LHsExpr RdrName)] -> LHsBind RdrName
-mkRdrFunBind fun@(L loc fun_rdr) matches = L loc (mkFunBind fun matches')
+-- | Produces a function binding. When there are no equations, it generates
+-- a binding with the given arity that produces an error based on the name of
+-- the type of the last argument.
+mkRdrFunBindSE :: Arity -> Located RdrName ->
+                    [LMatch GhcPs (LHsExpr GhcPs)] -> LHsBind GhcPs
+mkRdrFunBindSE arity
+                 fun@(L loc fun_rdr) matches = L loc (mkFunBind fun matches')
  where
    -- Catch-all eqn looks like
-   --     fmap = error "Void fmap"
+   --     compare _ _ = error "Void compare"
    -- It's needed if there no data cons at all,
    -- which can happen with -XEmptyDataDecls
    -- See Trac #4302
    matches' = if null matches
-              then [mkMatch [] (error_Expr str) emptyLocalBinds]
+              then [mkMatch (mkPrefixFunRhs fun)
+                            (replicate arity nlWildPat)
+                            (error_Expr str) (noLoc emptyLocalBinds)]
               else matches
    str = "Void " ++ occNameString (rdrNameOcc fun_rdr)
 
+
 box ::         String           -- The class involved
             -> TyCon            -- The tycon involved
-            -> LHsExpr RdrName  -- The argument
+            -> LHsExpr GhcPs    -- The argument
             -> Type             -- The argument type
-            -> LHsExpr RdrName  -- Boxed version of the arg
+            -> LHsExpr GhcPs    -- Boxed version of the arg
 -- See Note [Deriving and unboxed types] in TcDeriv
 box cls_str tycon arg arg_ty = nlHsApp (nlHsVar box_con) arg
   where
@@ -2126,6 +1927,20 @@ primOrdOps :: String    -- The class involved
 -- See Note [Deriving and unboxed types] in TcDeriv
 primOrdOps str tycon ty = assoc_ty_id str tycon ordOpTbl ty
 
+primLitOps :: String -- The class involved
+           -> TyCon  -- The tycon involved
+           -> Type   -- The type
+           -> ( LHsExpr GhcPs -> LHsExpr GhcPs -- Constructs a Q Exp value
+              , LHsExpr GhcPs -> LHsExpr GhcPs -- Constructs a boxed value
+              )
+primLitOps str tycon ty = ( assoc_ty_id str tycon litConTbl ty
+                          , \v -> nlHsVar boxRDR `nlHsApp` v
+                          )
+  where
+    boxRDR
+      | ty `eqType` addrPrimTy = unpackCString_RDR
+      | otherwise = assoc_ty_id str tycon boxConTbl ty
+
 ordOpTbl :: [(Type, (RdrName, RdrName, RdrName, RdrName, RdrName))]
 ordOpTbl
  =  [(charPrimTy  , (ltChar_RDR  , leChar_RDR  , eqChar_RDR  , geChar_RDR  , gtChar_RDR  ))
@@ -2154,6 +1969,26 @@ postfixModTbl
     ,(doublePrimTy, "##")
     ]
 
+litConTbl :: [(Type, LHsExpr GhcPs -> LHsExpr GhcPs)]
+litConTbl
+  = [(charPrimTy  , nlHsApp (nlHsVar charPrimL_RDR))
+    ,(intPrimTy   , nlHsApp (nlHsVar intPrimL_RDR)
+                      . nlHsApp (nlHsVar toInteger_RDR))
+    ,(wordPrimTy  , nlHsApp (nlHsVar wordPrimL_RDR)
+                      . nlHsApp (nlHsVar toInteger_RDR))
+    ,(addrPrimTy  , nlHsApp (nlHsVar stringPrimL_RDR)
+                      . nlHsApp (nlHsApp
+                          (nlHsVar map_RDR)
+                          (compose_RDR `nlHsApps`
+                            [ nlHsVar fromIntegral_RDR
+                            , nlHsVar fromEnum_RDR
+                            ])))
+    ,(floatPrimTy , nlHsApp (nlHsVar floatPrimL_RDR)
+                      . nlHsApp (nlHsVar toRational_RDR))
+    ,(doublePrimTy, nlHsApp (nlHsVar doublePrimL_RDR)
+                      . nlHsApp (nlHsVar toRational_RDR))
+    ]
+
 -- | Lookup `Type` in an association list.
 assoc_ty_id :: String           -- The class involved
             -> TyCon            -- The tycon involved
@@ -2169,41 +2004,43 @@ assoc_ty_id cls_str _ tbl ty
 
 -----------------------------------------------------------------------
 
-and_Expr :: LHsExpr RdrName -> LHsExpr RdrName -> LHsExpr RdrName
+and_Expr :: LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
 and_Expr a b = genOpApp a and_RDR    b
 
 -----------------------------------------------------------------------
 
-eq_Expr :: TyCon -> Type -> LHsExpr RdrName -> LHsExpr RdrName -> LHsExpr RdrName
+eq_Expr :: TyCon -> Type -> LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
 eq_Expr tycon ty a b
-    | not (isUnLiftedType ty) = genOpApp a eq_RDR b
+    | not (isUnliftedType ty) = genOpApp a eq_RDR b
     | otherwise               = genPrimOpApp a prim_eq b
  where
    (_, _, prim_eq, _, _) = primOrdOps "Eq" tycon ty
 
-untag_Expr :: TyCon -> [( RdrName,  RdrName)] -> LHsExpr RdrName -> LHsExpr RdrName
-untag_Expr _ [] expr = expr
-untag_Expr tycon ((untag_this, put_tag_here) : more) expr
-  = nlHsCase (nlHsPar (nlHsVarApps (con2tag_RDR tycon) [untag_this])) {-of-}
-      [mkSimpleHsAlt (nlVarPat put_tag_here) (untag_Expr tycon more expr)]
+untag_Expr :: DynFlags -> TyCon -> [( RdrName,  RdrName)]
+              -> LHsExpr GhcPs -> LHsExpr GhcPs
+untag_Expr _ _ [] expr = expr
+untag_Expr dflags tycon ((untag_this, put_tag_here) : more) expr
+  = nlHsCase (nlHsPar (nlHsVarApps (con2tag_RDR dflags tycon)
+                                   [untag_this])) {-of-}
+      [mkHsCaseAlt (nlVarPat put_tag_here) (untag_Expr dflags tycon more expr)]
 
 enum_from_to_Expr
-        :: LHsExpr RdrName -> LHsExpr RdrName
-        -> LHsExpr RdrName
+        :: LHsExpr GhcPs -> LHsExpr GhcPs
+        -> LHsExpr GhcPs
 enum_from_then_to_Expr
-        :: LHsExpr RdrName -> LHsExpr RdrName -> LHsExpr RdrName
-        -> LHsExpr RdrName
+        :: LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
+        -> LHsExpr GhcPs
 
 enum_from_to_Expr      f   t2 = nlHsApp (nlHsApp (nlHsVar enumFromTo_RDR) f) t2
 enum_from_then_to_Expr f t t2 = nlHsApp (nlHsApp (nlHsApp (nlHsVar enumFromThenTo_RDR) f) t) t2
 
 showParen_Expr
-        :: LHsExpr RdrName -> LHsExpr RdrName
-        -> LHsExpr RdrName
+        :: LHsExpr GhcPs -> LHsExpr GhcPs
+        -> LHsExpr GhcPs
 
 showParen_Expr e1 e2 = nlHsApp (nlHsApp (nlHsVar showParen_RDR) e1) e2
 
-nested_compose_Expr :: [LHsExpr RdrName] -> LHsExpr RdrName
+nested_compose_Expr :: [LHsExpr GhcPs] -> LHsExpr GhcPs
 
 nested_compose_Expr []  = panic "nested_compose_expr"   -- Arg is always non-empty
 nested_compose_Expr [e] = parenify e
@@ -2212,18 +2049,18 @@ nested_compose_Expr (e:es)
 
 -- impossible_Expr is used in case RHSs that should never happen.
 -- We generate these to keep the desugarer from complaining that they *might* happen!
-error_Expr :: String -> LHsExpr RdrName
+error_Expr :: String -> LHsExpr GhcPs
 error_Expr string = nlHsApp (nlHsVar error_RDR) (nlHsLit (mkHsString string))
 
 -- illegal_Expr is used when signalling error conditions in the RHS of a derived
 -- method. It is currently only used by Enum.{succ,pred}
-illegal_Expr :: String -> String -> String -> LHsExpr RdrName
+illegal_Expr :: String -> String -> String -> LHsExpr GhcPs
 illegal_Expr meth tp msg =
    nlHsApp (nlHsVar error_RDR) (nlHsLit (mkHsString (meth ++ '{':tp ++ "}: " ++ msg)))
 
 -- illegal_toEnum_tag is an extended version of illegal_Expr, which also allows you
 -- to include the value of a_RDR in the error string.
-illegal_toEnum_tag :: String -> RdrName -> LHsExpr RdrName
+illegal_toEnum_tag :: String -> RdrName -> LHsExpr GhcPs
 illegal_toEnum_tag tp maxtag =
    nlHsApp (nlHsVar error_RDR)
            (nlHsApp (nlHsApp (nlHsVar append_RDR)
@@ -2241,16 +2078,16 @@ illegal_toEnum_tag tp maxtag =
                                         (nlHsVar maxtag))
                                         (nlHsLit (mkHsString ")"))))))
 
-parenify :: LHsExpr RdrName -> LHsExpr RdrName
+parenify :: LHsExpr GhcPs -> LHsExpr GhcPs
 parenify e@(L _ (HsVar _)) = e
 parenify e                 = mkHsPar e
 
 -- genOpApp wraps brackets round the operator application, so that the
 -- renamer won't subsequently try to re-associate it.
-genOpApp :: LHsExpr RdrName -> RdrName -> LHsExpr RdrName -> LHsExpr RdrName
+genOpApp :: LHsExpr GhcPs -> RdrName -> LHsExpr GhcPs -> LHsExpr GhcPs
 genOpApp e1 op e2 = nlHsPar (nlHsOpApp e1 op e2)
 
-genPrimOpApp :: LHsExpr RdrName -> RdrName -> LHsExpr RdrName -> LHsExpr RdrName
+genPrimOpApp :: LHsExpr GhcPs -> RdrName -> LHsExpr GhcPs -> LHsExpr GhcPs
 genPrimOpApp e1 op e2 = nlHsPar (nlHsApp (nlHsVar tagToEnum_RDR) (nlHsOpApp e1 op e2))
 
 a_RDR, b_RDR, c_RDR, d_RDR, f_RDR, k_RDR, z_RDR, ah_RDR, bh_RDR, ch_RDR, dh_RDR
@@ -2272,63 +2109,58 @@ 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, c_Expr, f_Expr, z_Expr, ltTag_Expr, eqTag_Expr, gtTag_Expr,
-    false_Expr, true_Expr, fmap_Expr, pure_Expr, mempty_Expr, foldMap_Expr, traverse_Expr :: LHsExpr RdrName
+a_Expr, b_Expr, c_Expr, z_Expr, ltTag_Expr, eqTag_Expr, gtTag_Expr, false_Expr,
+    true_Expr :: LHsExpr GhcPs
 a_Expr          = nlHsVar a_RDR
--- b_Expr       = nlHsVar b_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 GhcPs
 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
 
-minusInt_RDR, tagToEnum_RDR, error_RDR :: RdrName
+minusInt_RDR, tagToEnum_RDR :: RdrName
 minusInt_RDR  = getRdrName (primOpId IntSubOp   )
 tagToEnum_RDR = getRdrName (primOpId TagToEnumOp)
-error_RDR     = getRdrName eRROR_ID
 
-con2tag_RDR, tag2con_RDR, maxtag_RDR :: TyCon -> RdrName
+con2tag_RDR, tag2con_RDR, maxtag_RDR :: DynFlags -> TyCon -> RdrName
 -- Generates Orig s RdrName, for the binding positions
-con2tag_RDR tycon = mk_tc_deriv_name tycon mkCon2TagOcc
-tag2con_RDR tycon = mk_tc_deriv_name tycon mkTag2ConOcc
-maxtag_RDR  tycon = mk_tc_deriv_name tycon mkMaxTagOcc
+con2tag_RDR dflags tycon = mk_tc_deriv_name dflags tycon mkCon2TagOcc
+tag2con_RDR dflags tycon = mk_tc_deriv_name dflags tycon mkTag2ConOcc
+maxtag_RDR  dflags tycon = mk_tc_deriv_name dflags tycon mkMaxTagOcc
 
-mk_tc_deriv_name :: TyCon -> (OccName -> OccName) -> RdrName
-mk_tc_deriv_name tycon occ_fun = mkAuxBinderName (tyConName tycon) occ_fun
+mk_tc_deriv_name :: DynFlags -> TyCon -> (OccName -> OccName) -> RdrName
+mk_tc_deriv_name dflags tycon occ_fun =
+   mkAuxBinderName dflags (tyConName tycon) occ_fun
 
-mkAuxBinderName :: Name -> (OccName -> OccName) -> RdrName
+mkAuxBinderName :: DynFlags -> Name -> (OccName -> OccName) -> RdrName
 -- ^ Make a top-level binder name for an auxiliary binding for a parent name
 -- See Note [Auxiliary binders]
-mkAuxBinderName parent occ_fun
-  = mkRdrUnqual (occ_fun uniq_parent_occ)
+mkAuxBinderName dflags parent occ_fun
+  = mkRdrUnqual (occ_fun stable_parent_occ)
   where
-    uniq_parent_occ = mkOccName (occNameSpace parent_occ) uniq_string
-
-    uniq_string
-      | opt_PprStyle_Debug = showSDocSimple (ppr parent_occ <> underscore <> ppr parent_uniq)
-      | otherwise          = show parent_uniq
-      -- The debug thing is just to generate longer, but perhaps more perspicuous, names
-
-    parent_uniq = nameUnique parent
+    stable_parent_occ = mkOccName (occNameSpace parent_occ) stable_string
+    stable_string
+      | hasPprDebug dflags = parent_stable
+      | otherwise          = parent_stable_hash
+    parent_stable = nameStableString parent
+    parent_stable_hash =
+      let Fingerprint high low = fingerprintString parent_stable
+      in toBase62 high ++ toBase62Padded low
+      -- See Note [Base 62 encoding 128-bit integers] in Encoding
     parent_occ  = nameOccName parent
 
+
 {-
 Note [Auxiliary binders]
 ~~~~~~~~~~~~~~~~~~~~~~~~
@@ -2345,10 +2177,10 @@ generating RdrNames here.  We can't just use the TyCon or DataCon to distinguish
 because with standalone deriving two imported TyCons might both be called T!
 (See Trac #7947.)
 
-So we use the *unique* from the parent name (T in this example) as part of the
-OccName we generate for the new binding.
+So we use package name, module name and the name of the parent
+(T in this example) as part of the OccName we generate for the new binding.
+To make the symbol names short we take a base62 hash of the full name.
 
-In the past we used mkDerivedRdrName name occ_fun, which made an original name
-But:  (a) that does not work well for standalone-deriving either
-      (b) an unqualified name is just fine, provided it can't clash with user code
+In the past we used the *unique* from the parent, but that's not stable across
+recompilations as uniques are nondeterministic.
 -}