TH: make `Lift` and `TExp` levity-polymorphic
[ghc.git] / compiler / typecheck / TcGenDeriv.hs
index d9166e5..b02494b 100644 (file)
@@ -54,15 +54,14 @@ 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 TcValidity ( checkValidCoAxBranch )
+import CoAxiom    ( coAxiomSingleBranch )
 import TysPrim
 import TysWiredIn
 import Type
@@ -77,7 +76,7 @@ import FastString
 import Pair
 import Bag
 
-import Data.List  ( partition, intersperse )
+import Data.List  ( find, partition, intersperse )
 
 type BagDerivStuff = Bag DerivStuff
 
@@ -214,9 +213,11 @@ gen_Eq_binds loc tycon = do
       where
         nested_eq_expr []  [] [] = true_Expr
         nested_eq_expr tys as bs
-          = foldl1 and_Expr (zipWith3Equal "nested_eq" nested_eq tys as bs)
+          = foldr1 and_Expr (zipWith3Equal "nested_eq" nested_eq tys as bs)
+          -- Using 'foldr1' here ensures that the derived code is correctly
+          -- associated. See #10859.
           where
-            nested_eq ty a b = nlHsPar (eq_Expr tycon ty (nlHsVar a) (nlHsVar b))
+            nested_eq ty a b = nlHsPar (eq_Expr ty (nlHsVar a) (nlHsVar b))
 
 {-
 ************************************************************************
@@ -275,7 +276,7 @@ Several special cases:
 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
+comparisons on top of it; see #2130, #4019.  Reason: we don't
 want to laboriously make a three-way comparison, only to extract a
 binary result, something like this:
      (>) (I# x) (I# y) = case <# x y of
@@ -447,14 +448,14 @@ gen_Ord_binds loc tycon = do
                                  , mkHsCaseAlt nlWildPat (gtResult op) ]
       where
         tag     = get_tag data_con
-        tag_lit = noLoc (HsLit (HsIntPrim NoSourceText (toInteger tag)))
+        tag_lit = noLoc (HsLit noExt (HsIntPrim NoSourceText (toInteger tag)))
 
     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
       = mkHsCaseAlt (nlConVarPat data_con_RDR bs_needed) $
-        mkCompareFields tycon op (dataConOrigArgTys data_con)
+        mkCompareFields op (dataConOrigArgTys data_con)
       where
         data_con_RDR = getRdrName data_con
         bs_needed    = take (dataConSourceArity data_con) bs_RDRs
@@ -464,17 +465,17 @@ gen_Ord_binds loc tycon = do
     -- 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
+        unliftedOrdOp intPrimTy op ah_RDR bh_RDR
 
-mkCompareFields :: TyCon -> OrdOp -> [Type] -> LHsExpr GhcPs
+mkCompareFields :: 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
+mkCompareFields op tys
   = go tys as_RDRs bs_RDRs
   where
     go []   _      _          = eqResult op
     go [ty] (a:_)  (b:_)
-      | isUnliftedType ty     = unliftedOrdOp tycon ty op a b
+      | isUnliftedType ty     = unliftedOrdOp 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)
@@ -496,10 +497,10 @@ mkCompareFields tycon op tys
       where
         a_expr = nlHsVar a
         b_expr = nlHsVar b
-        (lt_op, _, eq_op, _, _) = primOrdOps "Ord" tycon ty
+        (lt_op, _, eq_op, _, _) = primOrdOps "Ord" ty
 
-unliftedOrdOp :: TyCon -> Type -> OrdOp -> RdrName -> RdrName -> LHsExpr GhcPs
-unliftedOrdOp tycon ty op a b
+unliftedOrdOp :: Type -> OrdOp -> RdrName -> RdrName -> LHsExpr GhcPs
+unliftedOrdOp ty op a b
   = case op of
        OrdCompare -> unliftedCompare lt_op eq_op a_expr b_expr
                                      ltTag_Expr eqTag_Expr gtTag_Expr
@@ -508,7 +509,7 @@ unliftedOrdOp tycon ty op a b
        OrdGE      -> wrap ge_op
        OrdGT      -> wrap gt_op
   where
-   (lt_op, le_op, eq_op, ge_op, gt_op) = primOrdOps "Ord" tycon ty
+   (lt_op, le_op, eq_op, ge_op, gt_op) = primOrdOps "Ord" ty
    wrap prim_op = genPrimOpApp a_expr prim_op b_expr
    a_expr = nlHsVar a
    b_expr = nlHsVar b
@@ -614,7 +615,8 @@ gen_Enum_binds loc tycon = do
              (nlHsApp (nlHsVar (tag2con_RDR dflags tycon))
                       (nlHsApps plus_RDR
                             [ nlHsVarApps intDataCon_RDR [ah_RDR]
-                            , nlHsLit (HsInt def (mkIntegralLit (-1 :: Int)))]))
+                            , nlHsLit (HsInt noExt
+                                                (mkIntegralLit (-1 :: Int)))]))
 
     to_enum dflags
       = mk_easy_FunBind loc toEnum_RDR [a_Pat] $
@@ -683,9 +685,9 @@ gen_Bounded_binds loc tycon
     arity          = dataConSourceArity data_con_1
 
     min_bound_1con = mkHsVarBind loc minBound_RDR $
-                     nlHsVarApps data_con_1_RDR (nOfThem arity minBound_RDR)
+                     nlHsVarApps data_con_1_RDR (replicate arity minBound_RDR)
     max_bound_1con = mkHsVarBind loc maxBound_RDR $
-                     nlHsVarApps data_con_1_RDR (nOfThem arity maxBound_RDR)
+                     nlHsVarApps data_con_1_RDR (replicate arity maxBound_RDR)
 
 {-
 ************************************************************************
@@ -774,7 +776,7 @@ gen_Ix_binds loc tycon = do
 
     enum_index dflags
       = mk_easy_FunBind loc unsafeIndex_RDR
-                [noLoc (AsPat (noLoc c_RDR)
+                [noLoc (AsPat noExt (noLoc c_RDR)
                            (nlTuplePat [a_Pat, nlWildPat] Boxed)),
                                 d_Pat] (
            untag_Expr dflags tycon [(a_RDR, ah_RDR)] (
@@ -866,7 +868,7 @@ gen_Ix_binds loc tycon = do
                  con_pat cs_needed] $
           if con_arity == 0
              -- If the product type has no fields, inRange is trivially true
-             -- (see Trac #12853).
+             -- (see #12853).
              then true_Expr
              else foldl1 and_Expr (zipWith3Equal "single_con_inRange" in_range
                     as_needed bs_needed cs_needed)
@@ -923,12 +925,12 @@ rather than
    Ident "T1" <- lexP
 The latter desugares to inline code for matching the Ident and the
 string, and this can be very voluminous. The former is much more
-compact.  Cf Trac #7258, although that also concerned non-linearity in
+compact.  Cf #7258, although that also concerned non-linearity in
 the occurrence analyser, a separate issue.
 
 Note [Read for empty data types]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-What should we get for this?  (Trac #7931)
+What should we get for this?  (#7931)
    data Emp deriving( Read )   -- No data constructors
 
 Here we want
@@ -1056,7 +1058,7 @@ gen_Read_binds get_fixity loc tycon
 
     -- For constructors and field labels ending in '#', we hackily
     -- let the lexer generate two tokens, and look for both in sequence
-    -- Thus [Ident "I"; Symbol "#"].  See Trac #5041
+    -- Thus [Ident "I"; Symbol "#"].  See #5041
     ident_h_pat s | Just (ss, '#') <- snocView s = [ ident_pat ss, symbol_pat "#" ]
                   | otherwise                    = [ ident_pat s ]
 
@@ -1080,19 +1082,23 @@ gen_Read_binds get_fixity loc tycon
         [noLoc
           (mkBindStmt
             (nlVarPat a)
-            (nlHsApps
+            (nlHsApp
               read_field
-              [ nlHsLit (mkHsString lbl_str)
-              , nlHsVarApps reset_RDR [readPrec_RDR]
-              ]
+              (nlHsVarApps reset_RDR [readPrec_RDR])
             )
           )
         ]
         where
           lbl_str = unpackFS lbl
+          mk_read_field read_field_rdr lbl
+              = nlHsApps read_field_rdr [nlHsLit (mkHsString lbl)]
           read_field
-              | isSym lbl_str = readSymField_RDR
-              | otherwise = readField_RDR
+              | isSym lbl_str
+              = mk_read_field readSymField_RDR lbl_str
+              | Just (ss, '#') <- snocView lbl_str -- #14918
+              = mk_read_field readFieldHash_RDR ss
+              | otherwise
+              = mk_read_field readField_RDR lbl_str
 
 {-
 ************************************************************************
@@ -1132,7 +1138,7 @@ gen_Show_binds get_fixity loc tycon
   = (unitBag shows_prec, emptyBag)
   where
     data_cons = tyConDataCons tycon
-    shows_prec = mkFunBindEC 1 loc showsPrec_RDR id (map pats_etc data_cons)
+    shows_prec = mkFunBindEC 2 loc showsPrec_RDR id (map pats_etc data_cons)
     comma_space = nlHsVar showCommaSpace_RDR
 
     pats_etc data_con
@@ -1142,7 +1148,7 @@ gen_Show_binds get_fixity loc tycon
       | otherwise   =
          ([a_Pat, con_pat],
           showParen_Expr (genOpApp a_Expr ge_RDR (nlHsLit
-                                 (HsInt def (mkIntegralLit con_prec_plus_one))))
+                         (HsInt noExt (mkIntegralLit con_prec_plus_one))))
                          (nlHsPar (nested_compose_Expr show_thingies)))
         where
              data_con_RDR  = getRdrName data_con
@@ -1190,16 +1196,25 @@ gen_Show_binds get_fixity loc tycon
 
              show_arg :: RdrName -> Type -> LHsExpr GhcPs
              show_arg b 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]
-               | otherwise
-               = mk_showsPrec_app arg_prec arg
-                 where
-                   arg        = nlHsVar b
-                   boxed_arg  = box "Show" tycon arg arg_ty
-                   postfixMod = assoc_ty_id "Show" tycon postfixModTbl arg_ty
+                 | isUnliftedType arg_ty
+                 -- See Note [Deriving and unboxed types] in TcDerivInfer
+                 = with_conv $
+                    nlHsApps compose_RDR
+                        [mk_shows_app boxed_arg, mk_showString_app postfixMod]
+                 | otherwise
+                 = mk_showsPrec_app arg_prec arg
+               where
+                 arg        = nlHsVar b
+                 boxed_arg  = box "Show" arg arg_ty
+                 postfixMod = assoc_ty_id "Show" postfixModTbl arg_ty
+                 with_conv expr
+                    | (Just conv) <- assoc_ty_id_maybe primConvTbl arg_ty =
+                        nested_compose_Expr
+                            [ mk_showString_app ("(" ++ conv ++ " ")
+                            , expr
+                            , mk_showString_app ")"
+                            ]
+                    | otherwise = expr
 
                 -- Fixity stuff
              is_infix = dataConIsInfix data_con
@@ -1226,7 +1241,7 @@ mk_showString_app str = nlHsApp (nlHsVar showString_RDR) (nlHsLit (mkHsString st
 -- | showsPrec :: Show a => Int -> a -> ShowS
 mk_showsPrec_app :: Integer -> LHsExpr GhcPs -> LHsExpr GhcPs
 mk_showsPrec_app p x
-  = nlHsApps showsPrec_RDR [nlHsLit (HsInt def (mkIntegralLit p)), x]
+  = nlHsApps showsPrec_RDR [nlHsLit (HsInt noExt (mkIntegralLit p)), x]
 
 -- | shows :: Show a => a -> ShowS
 mk_shows_app :: LHsExpr GhcPs -> LHsExpr GhcPs
@@ -1296,7 +1311,7 @@ gen_Data_binds loc rep_tc
 
        -- 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.
+       -- but that might not be unique: see #12245.
        ; dt_occ  <- chooseUniqueOccTc (mkDataTOcc (getOccName rep_tc))
        ; dc_occs <- mapM (chooseUniqueOccTc . mkDataCOcc . getOccName)
                          (tyConDataCons rep_tc)
@@ -1323,7 +1338,7 @@ gen_data dflags data_type_name constr_names loc rep_tc
     genDataTyCon :: DerivStuff
     genDataTyCon        --  $dT
       = DerivHsBind (mkHsVarBind loc data_type_name rhs,
-                     L loc (TypeSig [L loc data_type_name] sig_ty))
+                     L loc (TypeSig noExt [L loc data_type_name] sig_ty))
 
     sig_ty = mkLHsSigWcType (nlHsTyVar dataType_RDR)
     rhs    = nlHsVar mkDataType_RDR
@@ -1333,7 +1348,7 @@ gen_data dflags data_type_name constr_names loc rep_tc
     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))
+                     L loc (TypeSig noExt [L loc constr_name] sig_ty))
       where
         sig_ty   = mkLHsSigWcType (nlHsTyVar constr_RDR)
         rhs      = nlHsApps mkConstr_RDR constr_args
@@ -1357,7 +1372,7 @@ gen_data dflags data_type_name constr_names loc rep_tc
 
     gfoldl_eqn con
       = ([nlVarPat k_RDR, z_Pat, nlConVarPat con_name as_needed],
-                   foldl mk_k_app (z_Expr `nlHsApp` nlHsVar con_name) as_needed)
+                   foldl' mk_k_app (z_Expr `nlHsApp` nlHsVar con_name) as_needed)
                    where
                      con_name ::  RdrName
                      con_name = getRdrName con
@@ -1413,7 +1428,7 @@ gen_data dflags data_type_name constr_names loc rep_tc
         -- because D :: * -> *
         -- even though rep_tc has kind * -> * -> * -> *
         -- Hence looking for the kind of fam_tc not rep_tc
-        -- See Trac #4896
+        -- See #4896
     tycon_kind = case tyConFamInst_maybe rep_tc of
                     Just (fam_tc, _) -> tyConKind fam_tc
                     Nothing          -> tyConKind rep_tc
@@ -1426,8 +1441,8 @@ gen_data dflags data_type_name constr_names loc rep_tc
 
 
 kind1, kind2 :: Kind
-kind1 = liftedTypeKind `mkFunTy` liftedTypeKind
-kind2 = liftedTypeKind `mkFunTy` kind1
+kind1 = liftedTypeKind `mkVisFunTy` liftedTypeKind
+kind2 = liftedTypeKind `mkVisFunTy` kind1
 
 gfoldl_RDR, gunfold_RDR, toConstr_RDR, dataTypeOf_RDR, mkConstr_RDR,
     mkDataType_RDR, conIndex_RDR, prefix_RDR, infix_RDR,
@@ -1435,10 +1450,16 @@ gfoldl_RDR, gunfold_RDR, toConstr_RDR, dataTypeOf_RDR, mkConstr_RDR,
     constr_RDR, dataType_RDR,
     eqChar_RDR  , ltChar_RDR  , geChar_RDR  , gtChar_RDR  , leChar_RDR  ,
     eqInt_RDR   , ltInt_RDR   , geInt_RDR   , gtInt_RDR   , leInt_RDR   ,
+    eqInt8_RDR  , ltInt8_RDR  , geInt8_RDR  , gtInt8_RDR  , leInt8_RDR  ,
+    eqInt16_RDR , ltInt16_RDR , geInt16_RDR , gtInt16_RDR , leInt16_RDR ,
     eqWord_RDR  , ltWord_RDR  , geWord_RDR  , gtWord_RDR  , leWord_RDR  ,
+    eqWord8_RDR , ltWord8_RDR , geWord8_RDR , gtWord8_RDR , leWord8_RDR ,
+    eqWord16_RDR, ltWord16_RDR, geWord16_RDR, gtWord16_RDR, leWord16_RDR,
     eqAddr_RDR  , ltAddr_RDR  , geAddr_RDR  , gtAddr_RDR  , leAddr_RDR  ,
     eqFloat_RDR , ltFloat_RDR , geFloat_RDR , gtFloat_RDR , leFloat_RDR ,
-    eqDouble_RDR, ltDouble_RDR, geDouble_RDR, gtDouble_RDR, leDouble_RDR :: RdrName
+    eqDouble_RDR, ltDouble_RDR, geDouble_RDR, gtDouble_RDR, leDouble_RDR,
+    extendWord8_RDR, extendInt8_RDR,
+    extendWord16_RDR, extendInt16_RDR :: RdrName
 gfoldl_RDR     = varQual_RDR  gENERICS (fsLit "gfoldl")
 gunfold_RDR    = varQual_RDR  gENERICS (fsLit "gunfold")
 toConstr_RDR   = varQual_RDR  gENERICS (fsLit "toConstr")
@@ -1467,12 +1488,36 @@ leInt_RDR      = varQual_RDR  gHC_PRIM (fsLit "<=#")
 gtInt_RDR      = varQual_RDR  gHC_PRIM (fsLit ">#" )
 geInt_RDR      = varQual_RDR  gHC_PRIM (fsLit ">=#")
 
+eqInt8_RDR     = varQual_RDR  gHC_PRIM (fsLit "eqInt8#")
+ltInt8_RDR     = varQual_RDR  gHC_PRIM (fsLit "ltInt8#" )
+leInt8_RDR     = varQual_RDR  gHC_PRIM (fsLit "leInt8#")
+gtInt8_RDR     = varQual_RDR  gHC_PRIM (fsLit "gtInt8#" )
+geInt8_RDR     = varQual_RDR  gHC_PRIM (fsLit "geInt8#")
+
+eqInt16_RDR    = varQual_RDR  gHC_PRIM (fsLit "eqInt16#")
+ltInt16_RDR    = varQual_RDR  gHC_PRIM (fsLit "ltInt16#" )
+leInt16_RDR    = varQual_RDR  gHC_PRIM (fsLit "leInt16#")
+gtInt16_RDR    = varQual_RDR  gHC_PRIM (fsLit "gtInt16#" )
+geInt16_RDR    = varQual_RDR  gHC_PRIM (fsLit "geInt16#")
+
 eqWord_RDR     = varQual_RDR  gHC_PRIM (fsLit "eqWord#")
 ltWord_RDR     = varQual_RDR  gHC_PRIM (fsLit "ltWord#")
 leWord_RDR     = varQual_RDR  gHC_PRIM (fsLit "leWord#")
 gtWord_RDR     = varQual_RDR  gHC_PRIM (fsLit "gtWord#")
 geWord_RDR     = varQual_RDR  gHC_PRIM (fsLit "geWord#")
 
+eqWord8_RDR    = varQual_RDR  gHC_PRIM (fsLit "eqWord8#")
+ltWord8_RDR    = varQual_RDR  gHC_PRIM (fsLit "ltWord8#" )
+leWord8_RDR    = varQual_RDR  gHC_PRIM (fsLit "leWord8#")
+gtWord8_RDR    = varQual_RDR  gHC_PRIM (fsLit "gtWord8#" )
+geWord8_RDR    = varQual_RDR  gHC_PRIM (fsLit "geWord8#")
+
+eqWord16_RDR   = varQual_RDR  gHC_PRIM (fsLit "eqWord16#")
+ltWord16_RDR   = varQual_RDR  gHC_PRIM (fsLit "ltWord16#" )
+leWord16_RDR   = varQual_RDR  gHC_PRIM (fsLit "leWord16#")
+gtWord16_RDR   = varQual_RDR  gHC_PRIM (fsLit "gtWord16#" )
+geWord16_RDR   = varQual_RDR  gHC_PRIM (fsLit "geWord16#")
+
 eqAddr_RDR     = varQual_RDR  gHC_PRIM (fsLit "eqAddr#")
 ltAddr_RDR     = varQual_RDR  gHC_PRIM (fsLit "ltAddr#")
 leAddr_RDR     = varQual_RDR  gHC_PRIM (fsLit "leAddr#")
@@ -1491,6 +1536,13 @@ leDouble_RDR   = varQual_RDR  gHC_PRIM (fsLit "<=##")
 gtDouble_RDR   = varQual_RDR  gHC_PRIM (fsLit ">##" )
 geDouble_RDR   = varQual_RDR  gHC_PRIM (fsLit ">=##")
 
+extendWord8_RDR = varQual_RDR  gHC_PRIM (fsLit "extendWord8#")
+extendInt8_RDR  = varQual_RDR  gHC_PRIM (fsLit "extendInt8#")
+
+extendWord16_RDR = varQual_RDR  gHC_PRIM (fsLit "extendWord16#")
+extendInt16_RDR  = varQual_RDR  gHC_PRIM (fsLit "extendInt16#")
+
+
 {-
 ************************************************************************
 *                                                                      *
@@ -1505,68 +1557,36 @@ Example:
     ==>
 
     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.
+        lift (Foo a) = [| Foo a |]
+        lift ((:^:) u v) = [| (:^:) u v |]
+
+        liftTyped (Foo a) = [|| Foo a ||]
+        liftTyped ((:^:) u v) = [|| (:^:) u v ||]
 -}
 
+
 gen_Lift_binds :: SrcSpan -> TyCon -> (LHsBinds GhcPs, BagDerivStuff)
-gen_Lift_binds loc tycon = (unitBag lift_bind, emptyBag)
+gen_Lift_binds loc tycon = (listToBag [lift_bind, liftTyped_bind], emptyBag)
   where
-    lift_bind = mkFunBindEC 1 loc lift_RDR (nlHsApp pure_Expr)
-                            (map pats_etc data_cons)
+    lift_bind      = mkFunBindEC 1 loc lift_RDR (nlHsApp pure_Expr)
+                                 (map (pats_etc mk_exp) data_cons)
+    liftTyped_bind = mkFunBindEC 1 loc liftTyped_RDR (nlHsApp pure_Expr)
+                                 (map (pats_etc mk_texp) data_cons)
+
+    mk_exp = ExpBr NoExt
+    mk_texp = TExpBr NoExt
     data_cons = tyConDataCons tycon
 
-    pats_etc data_con
+    pats_etc mk_bracket data_con
       = ([con_pat], lift_Expr)
        where
             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]
+            lift_Expr    = noLoc (HsBracket NoExt (mk_bracket br_body))
+            br_body      = nlHsApps (Exact (dataConName data_con))
+                                    (map nlHsVar as_needed)
 
 {-
 ************************************************************************
@@ -1578,43 +1598,59 @@ mk_appE_app a b = nlHsApps appE_RDR [a, b]
 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
+into the derived instance. We need type applications 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
+    op :: forall c. a -> [b] -> c -> Int
 
   newtype T x = MkT <rep-ty>
 
   instance C a <rep-ty> => C a (T x) where
-    op = coerce @ (a -> [<rep-ty>] -> Int)
-                @ (a -> [T x]      -> Int)
-                op
+    op = coerce @ (a -> [<rep-ty>] -> c -> Int)
+                @ (a -> [T x]      -> c -> Int)
+                op :: forall c. a -> [T x] -> c -> Int
+
+In addition to the type applications, we also have an explicit
+type signature on the entire RHS. This brings the method-bound variable
+`c` into scope over the two type applications.
+See Note [GND and QuantifiedConstraints] for more information on why this
+is important.
 
-Notice that we give the 'coerce' two explicitly-visible type arguments
-to say how it should be instantiated.  Recall
+Giving 'coerce' two explicitly-visible type arguments grants us finer control
+over how it should be instantiated. Recall
 
-  coerce :: Coeercible a b => a -> b
+  coerce :: Coercible a b => a -> b
 
 By giving it explicit type arguments we deal with the case where
 'op' has a higher rank type, and so we must instantiate 'coerce' with
 a polytype.  E.g.
-   class C a where op :: forall b. a -> b -> b
+
+   class C a where op :: a -> forall b. 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
+     op = coerce @ (<rep-ty> -> forall b. b -> b)
+                 @ (T x      -> forall b. b -> b)
+                op :: T x -> forall b. b -> b
+
+The use of type applications is crucial here. If we had tried using only
+explicit type signatures, like so:
 
-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.
+   instance C <rep-ty> => C (T x) where
+     op = coerce (op :: <rep-ty> -> forall b. b -> b)
+                     :: T x      -> forall b. b -> b
 
-See #8503 for more discussion.
+Then GHC will attempt to deeply skolemize the two type signatures, which will
+wreak havoc with the Coercible solver. Therefore, we instead use type
+applications, which do not deeply skolemize and thus avoid this issue.
+The downside is that we currently require -XImpredicativeTypes to permit this
+polymorphic type instantiation, so we have to switch that flag on locally in
+TcDeriv.genInst. See #8503 for more discussion.
 
 Note [Newtype-deriving trickiness]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Consider (Trac #12768):
+Consider (#12768):
   class C a where { op :: D a => a -> a }
 
   instance C a  => C [a] where { op = opList }
@@ -1631,13 +1667,125 @@ coercing opList, thus:
   instance C a => C (N a) where { op = opN }
 
   opN :: (C a, D (N a)) => N a -> N a
-  opN = coerce @(D [a]   => [a] -> [a])
-               @(D (N a) => [N a] -> [N a]
-               opList
+  opN = coerce @([a]   -> [a])
+               @([N a] -> [N a]
+               opList :: D (N a) => [N a] -> [N a]
 
 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.
+
+Note [GND and QuantifiedConstraints]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider the following example from #15290:
+
+  class C m where
+    join :: m (m a) -> m a
+
+  newtype T m a = MkT (m a)
+
+  deriving instance
+    (C m, forall p q. Coercible p q => Coercible (m p) (m q)) =>
+    C (T m)
+
+The code that GHC used to generate for this was:
+
+  instance (C m, forall p q. Coercible p q => Coercible (m p) (m q)) =>
+      C (T m) where
+    join = coerce @(forall a.   m   (m a) ->   m a)
+                  @(forall a. T m (T m a) -> T m a)
+                  join
+
+This instantiates `coerce` at a polymorphic type, a form of impredicative
+polymorphism, so we're already on thin ice. And in fact the ice breaks,
+as we'll explain:
+
+The call to `coerce` gives rise to:
+
+  Coercible (forall a.   m   (m a) ->   m a)
+            (forall a. T m (T m a) -> T m a)
+
+And that simplified to the following implication constraint:
+
+  forall a <no-ev>. m (T m a) ~R# m (m a)
+
+But because this constraint is under a `forall`, inside a type, we have to
+prove it *without computing any term evidence* (hence the <no-ev>). Alas, we
+*must* generate a term-level evidence binding in order to instantiate the
+quantified constraint! In response, GHC currently chooses not to use such
+a quantified constraint.
+See Note [Instances in no-evidence implications] in TcInteract.
+
+But this isn't the death knell for combining QuantifiedConstraints with GND.
+On the contrary, if we generate GND bindings in a slightly different way, then
+we can avoid this situation altogether. Instead of applying `coerce` to two
+polymorphic types, we instead let an explicit type signature do the polymorphic
+instantiation, and omit the `forall`s in the type applications.
+More concretely, we generate the following code instead:
+
+  instance (C m, forall p q. Coercible p q => Coercible (m p) (m q)) =>
+      C (T m) where
+    join = coerce @(  m   (m a) ->   m a)
+                  @(T m (T m a) -> T m a)
+                  join :: forall a. T m (T m a) -> T m a
+
+Now the visible type arguments are both monotypes, so we need do any of this
+funny quantified constraint instantiation business.
+
+You might think that that second @(T m (T m a) -> T m a) argument is redundant
+in the presence of the explicit `:: forall a. T m (T m a) -> T m a` type
+signature, but in fact leaving it off will break this example (from the
+T15290d test case):
+
+  class C a where
+    c :: Int -> forall b. b -> a
+
+  instance C Int
+
+  instance C Age where
+    c = coerce @(Int -> forall b. b -> Int)
+               c :: Int -> forall b. b -> Age
+
+That is because the explicit type signature deeply skolemizes the forall-bound
+`b`, which wreaks havoc with the `Coercible` solver. An additional visible type
+argument of @(Int -> forall b. b -> Age) is enough to prevent this.
+
+Be aware that the use of an explicit type signature doesn't /solve/ this
+problem; it just makes it less likely to occur. For example, if a class has
+a truly higher-rank type like so:
+
+  class CProblem m where
+    op :: (forall b. ... (m b) ...) -> Int
+
+Then the same situation will arise again. But at least it won't arise for the
+common case of methods with ordinary, prenex-quantified types.
+
+Note [GND and ambiguity]
+~~~~~~~~~~~~~~~~~~~~~~~~
+We make an effort to make the code generated through GND be robust w.r.t.
+ambiguous type variables. As one example, consider the following example
+(from #15637):
+
+  class C a where f :: String
+  instance C () where f = "foo"
+  newtype T = T () deriving C
+
+A na├»ve attempt and generating a C T instance would be:
+
+  instance C T where
+    f = coerce @String @String f
+          :: String
+
+This isn't going to typecheck, however, since GHC doesn't know what to
+instantiate the type variable `a` with in the call to `f` in the method body.
+(Note that `f :: forall a. String`!) To compensate for the possibility of
+ambiguity here, we explicitly instantiate `a` like so:
+
+  instance C T where
+    f = coerce @String @String (f @())
+          :: String
+
+All better now.
 -}
 
 gen_Newtype_binds :: SrcSpan
@@ -1663,30 +1811,40 @@ gen_Newtype_binds loc cls inst_tvs inst_tys rhs_ty
                                           [] rhs_expr]
       where
         Pair from_ty to_ty = mkCoerceClassMethEqn cls inst_tvs inst_tys rhs_ty meth_id
+        (_, _, from_tau) = tcSplitSigmaTy from_ty
+        (_, _, to_tau)   = tcSplitSigmaTy to_ty
 
         meth_RDR = getRdrName meth_id
 
         rhs_expr = nlHsVar (getRdrName coerceId)
-                                      `nlHsAppType` from_ty
-                                      `nlHsAppType` to_ty
-                                      `nlHsApp`     nlHsVar meth_RDR
+                                      `nlHsAppType`     from_tau
+                                      `nlHsAppType`     to_tau
+                                      `nlHsApp`         meth_app
+                                      `nlExprWithTySig` to_ty
+
+        -- The class method, applied to all of the class instance types
+        -- (including the representation type) to avoid potential ambiguity.
+        -- See Note [GND and ambiguity]
+        meth_app = foldl' nlHsAppType (nlHsVar meth_RDR) $
+                   filterOutInferredTypes (classTyCon cls) underlying_inst_tys
+                     -- Filter out any inferred arguments, since they can't be
+                     -- applied with visible type application.
 
     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'
+        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
+        checkValidCoAxBranch fam_tc (coAxiomSingleBranch axiom)
         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_env     = zipTyEnv cls_tvs underlying_inst_tys
         rhs_subst   = mkTvSubst in_scope rhs_env
         fam_tvs     = tyConTyVars fam_tc
         rep_lhs_tys = substTyVars lhs_subst fam_tvs
@@ -1694,17 +1852,21 @@ gen_Newtype_binds loc cls inst_tvs inst_tys rhs_ty
         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)
+        rep_tvs'    = scopedSort rep_tvs
+        rep_cvs'    = scopedSort rep_cvs
+
+    -- Same as inst_tys, but with the last argument type replaced by the
+    -- representation type.
+    underlying_inst_tys :: [Type]
+    underlying_inst_tys = changeLast inst_tys rhs_ty
 
 nlHsAppType :: LHsExpr GhcPs -> Type -> LHsExpr GhcPs
-nlHsAppType e s = noLoc (e `HsAppType` hs_ty)
+nlHsAppType e s = noLoc (HsAppType noExt e hs_ty)
   where
-    hs_ty = mkHsWildCardBndrs $ nlHsParTy (typeToLHsType s)
+    hs_ty = mkHsWildCardBndrs $ parenthesizeHsType appPrec (typeToLHsType s)
 
 nlExprWithTySig :: LHsExpr GhcPs -> Type -> LHsExpr GhcPs
-nlExprWithTySig e s = noLoc (e `ExprWithTySig` hs_ty)
+nlExprWithTySig e s = noLoc $ ExprWithTySig noExt (parenthesizeHsExpr sigPrec e) hs_ty
   where
     hs_ty = mkLHsSigWcType (typeToLHsType s)
 
@@ -1719,7 +1881,7 @@ mkCoerceClassMethEqn :: Class   -- the class being derived
 -- 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
+-- the type of the method we are trying to get
 mkCoerceClassMethEqn cls inst_tvs inst_tys rhs_ty id
   = Pair (substTy rhs_subst user_meth_ty)
          (substTy lhs_subst user_meth_ty)
@@ -1754,13 +1916,13 @@ 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))
+     L loc (TypeSig noExt [L loc rdr_name] sig_ty))
   where
     rdr_name = con2tag_RDR dflags tycon
 
-    sig_ty = mkLHsSigWcType $ L loc $ HsCoreTy $
+    sig_ty = mkLHsSigWcType $ L loc $ XHsType $ NHsCoreTy $
              mkSpecSigmaTy (tyConTyVars tycon) (tyConStupidTheta tycon) $
-             mkParentType tycon `mkFunTy` intPrimTy
+             mkParentType tycon `mkVisFunTy` intPrimTy
 
     lots_of_constructors = tyConFamilySize tycon > 8
                         -- was: mAX_FAMILY_SIZE_FOR_VEC_RETURNS
@@ -1780,20 +1942,20 @@ 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] sig_ty))
+     L loc (TypeSig noExt [L loc rdr_name] sig_ty))
   where
     sig_ty = mkLHsSigWcType $ L loc $
-             HsCoreTy $ mkSpecForAllTys (tyConTyVars tycon) $
-             intTy `mkFunTy` mkParentType tycon
+             XHsType $ NHsCoreTy $ mkSpecForAllTys (tyConTyVars tycon) $
+             intTy `mkVisFunTy` mkParentType tycon
 
     rdr_name = tag2con_RDR dflags tycon
 
 genAuxBindSpec dflags loc (DerivMaxTag tycon)
   = (mkHsVarBind loc rdr_name rhs,
-     L loc (TypeSig [L loc rdr_name] sig_ty))
+     L loc (TypeSig noExt [L loc rdr_name] sig_ty))
   where
     rdr_name = maxtag_RDR dflags tycon
-    sig_ty = mkLHsSigWcType (L loc (HsCoreTy intTy))
+    sig_ty = mkLHsSigWcType (L loc (XHsType (NHsCoreTy intTy)))
     rhs = nlHsApp (nlHsVar intDataCon_RDR)
                   (nlHsLit (HsIntPrim NoSourceText max_tag))
     max_tag =  case (tyConDataCons tycon) of
@@ -1849,7 +2011,8 @@ mkFunBindSE :: Arity -> SrcSpan -> RdrName
 mkFunBindSE arity loc fun pats_and_exprs
   = mkRdrFunBindSE arity (L loc fun) matches
   where
-    matches = [mkMatch (mkPrefixFunRhs (L loc fun)) p e
+    matches = [mkMatch (mkPrefixFunRhs (L loc fun))
+                               (map (parenthesizePat appPrec) p) e
                                (noLoc emptyLocalBinds)
               | (p,e) <-pats_and_exprs]
 
@@ -1869,7 +2032,8 @@ mkFunBindEC :: Arity -> SrcSpan -> RdrName
 mkFunBindEC arity loc fun catch_all pats_and_exprs
   = mkRdrFunBindEC arity catch_all (L loc fun) matches
   where
-    matches = [ mkMatch (mkPrefixFunRhs (L loc fun)) p e
+    matches = [ mkMatch (mkPrefixFunRhs (L loc fun))
+                                (map (parenthesizePat appPrec) p) e
                                 (noLoc emptyLocalBinds)
               | (p,e) <- pats_and_exprs ]
 
@@ -1893,7 +2057,7 @@ mkRdrFunBindEC arity catch_all
    --     foldMap _ z = mempty
    -- It's needed if there no data cons at all,
    -- which can happen with -XEmptyDataDecls
-   -- See Trac #4302
+   -- See #4302
    matches' = if null matches
               then [mkMatch (mkPrefixFunRhs fun)
                             (replicate (arity - 1) nlWildPat ++ [z_Pat])
@@ -1913,7 +2077,7 @@ mkRdrFunBindSE arity
    --     compare _ _ = error "Void compare"
    -- It's needed if there no data cons at all,
    -- which can happen with -XEmptyDataDecls
-   -- See Trac #4302
+   -- See #4302
    matches' = if null matches
               then [mkMatch (mkPrefixFunRhs fun)
                             (replicate arity nlWildPat)
@@ -1923,55 +2087,67 @@ mkRdrFunBindSE arity
 
 
 box ::         String           -- The class involved
-            -> TyCon            -- The tycon involved
             -> LHsExpr GhcPs    -- The argument
             -> Type             -- The argument type
             -> 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
-    box_con = assoc_ty_id cls_str tycon boxConTbl arg_ty
+-- See Note [Deriving and unboxed types] in TcDerivInfer
+box cls_str arg arg_ty = assoc_ty_id cls_str boxConTbl arg_ty arg
 
 ---------------------
 primOrdOps :: String    -- The class involved
-           -> TyCon     -- The tycon involved
            -> Type      -- The type
            -> (RdrName, RdrName, RdrName, RdrName, RdrName)  -- (lt,le,eq,ge,gt)
--- 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
+-- See Note [Deriving and unboxed types] in TcDerivInfer
+primOrdOps str ty = assoc_ty_id str ordOpTbl ty
 
 ordOpTbl :: [(Type, (RdrName, RdrName, RdrName, RdrName, RdrName))]
 ordOpTbl
- =  [(charPrimTy  , (ltChar_RDR  , leChar_RDR  , eqChar_RDR  , geChar_RDR  , gtChar_RDR  ))
-    ,(intPrimTy   , (ltInt_RDR   , leInt_RDR   , eqInt_RDR   , geInt_RDR   , gtInt_RDR   ))
-    ,(wordPrimTy  , (ltWord_RDR  , leWord_RDR  , eqWord_RDR  , geWord_RDR  , gtWord_RDR  ))
-    ,(addrPrimTy  , (ltAddr_RDR  , leAddr_RDR  , eqAddr_RDR  , geAddr_RDR  , gtAddr_RDR  ))
-    ,(floatPrimTy , (ltFloat_RDR , leFloat_RDR , eqFloat_RDR , geFloat_RDR , gtFloat_RDR ))
-    ,(doublePrimTy, (ltDouble_RDR, leDouble_RDR, eqDouble_RDR, geDouble_RDR, gtDouble_RDR)) ]
-
-boxConTbl :: [(Type, RdrName)]
-boxConTbl
-  = [(charPrimTy  , getRdrName charDataCon  )
-    ,(intPrimTy   , getRdrName intDataCon   )
-    ,(wordPrimTy  , getRdrName wordDataCon  )
-    ,(floatPrimTy , getRdrName floatDataCon )
-    ,(doublePrimTy, getRdrName doubleDataCon)
+ =  [(charPrimTy  , (ltChar_RDR  , leChar_RDR
+     , eqChar_RDR  , geChar_RDR  , gtChar_RDR  ))
+    ,(intPrimTy   , (ltInt_RDR   , leInt_RDR
+     , eqInt_RDR   , geInt_RDR   , gtInt_RDR   ))
+    ,(int8PrimTy  , (ltInt8_RDR  , leInt8_RDR
+     , eqInt8_RDR  , geInt8_RDR  , gtInt8_RDR   ))
+    ,(int16PrimTy , (ltInt16_RDR , leInt16_RDR
+     , eqInt16_RDR , geInt16_RDR , gtInt16_RDR   ))
+    ,(wordPrimTy  , (ltWord_RDR  , leWord_RDR
+     , eqWord_RDR  , geWord_RDR  , gtWord_RDR  ))
+    ,(word8PrimTy , (ltWord8_RDR , leWord8_RDR
+     , eqWord8_RDR , geWord8_RDR , gtWord8_RDR   ))
+    ,(word16PrimTy, (ltWord16_RDR, leWord16_RDR
+     , eqWord16_RDR, geWord16_RDR, gtWord16_RDR  ))
+    ,(addrPrimTy  , (ltAddr_RDR  , leAddr_RDR
+     , eqAddr_RDR  , geAddr_RDR  , gtAddr_RDR  ))
+    ,(floatPrimTy , (ltFloat_RDR , leFloat_RDR
+     , eqFloat_RDR , geFloat_RDR , gtFloat_RDR ))
+    ,(doublePrimTy, (ltDouble_RDR, leDouble_RDR
+     , eqDouble_RDR, geDouble_RDR, gtDouble_RDR)) ]
+
+-- A mapping from a primitive type to a function that constructs its boxed
+-- version.
+-- NOTE: Int8#/Word8# will become Int/Word.
+boxConTbl :: [(Type, LHsExpr GhcPs -> LHsExpr GhcPs)]
+boxConTbl =
+    [ (charPrimTy  , nlHsApp (nlHsVar $ getRdrName charDataCon))
+    , (intPrimTy   , nlHsApp (nlHsVar $ getRdrName intDataCon))
+    , (wordPrimTy  , nlHsApp (nlHsVar $ getRdrName wordDataCon ))
+    , (floatPrimTy , nlHsApp (nlHsVar $ getRdrName floatDataCon ))
+    , (doublePrimTy, nlHsApp (nlHsVar $ getRdrName doubleDataCon))
+    , (int8PrimTy,
+        nlHsApp (nlHsVar $ getRdrName intDataCon)
+        . nlHsApp (nlHsVar extendInt8_RDR))
+    , (word8PrimTy,
+        nlHsApp (nlHsVar $ getRdrName wordDataCon)
+        .  nlHsApp (nlHsVar extendWord8_RDR))
+    , (int16PrimTy,
+        nlHsApp (nlHsVar $ getRdrName intDataCon)
+        . nlHsApp (nlHsVar extendInt16_RDR))
+    , (word16PrimTy,
+        nlHsApp (nlHsVar $ getRdrName wordDataCon)
+        .  nlHsApp (nlHsVar extendWord16_RDR))
     ]
 
+
 -- | A table of postfix modifiers for unboxed values.
 postfixModTbl :: [(Type, String)]
 postfixModTbl
@@ -1980,6 +2156,18 @@ postfixModTbl
     ,(wordPrimTy  , "##")
     ,(floatPrimTy , "#" )
     ,(doublePrimTy, "##")
+    ,(int8PrimTy, "#")
+    ,(word8PrimTy, "##")
+    ,(int16PrimTy, "#")
+    ,(word16PrimTy, "##")
+    ]
+
+primConvTbl :: [(Type, String)]
+primConvTbl =
+    [ (int8PrimTy, "narrowInt8#")
+    , (word8PrimTy, "narrowWord8#")
+    , (int16PrimTy, "narrowInt16#")
+    , (word16PrimTy, "narrowWord16#")
     ]
 
 litConTbl :: [(Type, LHsExpr GhcPs -> LHsExpr GhcPs)]
@@ -2003,17 +2191,20 @@ litConTbl
     ]
 
 -- | Lookup `Type` in an association list.
-assoc_ty_id :: String           -- The class involved
-            -> TyCon            -- The tycon involved
+assoc_ty_id :: HasCallStack => String           -- The class involved
             -> [(Type,a)]       -- The table
             -> Type             -- The type
             -> a                -- The result of the lookup
-assoc_ty_id cls_str _ tbl ty
-  | null res = pprPanic "Error in deriving:" (text "Can't derive" <+> text cls_str <+>
-                                              text "for primitive type" <+> ppr ty)
-  | otherwise = head res
-  where
-    res = [id | (ty',id) <- tbl, ty `eqType` ty']
+assoc_ty_id cls_str tbl ty
+  | Just a <- assoc_ty_id_maybe tbl ty = a
+  | otherwise =
+      pprPanic "Error in deriving:"
+          (text "Can't derive" <+> text cls_str <+>
+           text "for primitive type" <+> ppr ty)
+
+-- | Lookup `Type` in an association list.
+assoc_ty_id_maybe :: [(Type, a)] -> Type -> Maybe a
+assoc_ty_id_maybe tbl ty = snd <$> find (\(t, _) -> t `eqType` ty) tbl
 
 -----------------------------------------------------------------------
 
@@ -2022,12 +2213,12 @@ and_Expr a b = genOpApp a and_RDR    b
 
 -----------------------------------------------------------------------
 
-eq_Expr :: TyCon -> Type -> LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
-eq_Expr tycon ty a b
+eq_Expr :: Type -> LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
+eq_Expr ty a b
     | not (isUnliftedType ty) = genOpApp a eq_RDR b
     | otherwise               = genPrimOpApp a prim_eq b
  where
-   (_, _, prim_eq, _, _) = primOrdOps "Eq" tycon ty
+   (_, _, prim_eq, _, _) = primOrdOps "Eq" ty
 
 untag_Expr :: DynFlags -> TyCon -> [( RdrName,  RdrName)]
               -> LHsExpr GhcPs -> LHsExpr GhcPs
@@ -2092,8 +2283,8 @@ illegal_toEnum_tag tp maxtag =
                                         (nlHsLit (mkHsString ")"))))))
 
 parenify :: LHsExpr GhcPs -> LHsExpr GhcPs
-parenify e@(L _ (HsVar _)) = e
-parenify e                 = mkHsPar e
+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.
@@ -2189,7 +2380,7 @@ We often want to make a top-level auxiliary binding.  E.g. for comparison we hae
 Of course these top-level bindings should all have distinct name, and we are
 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.)
+(See #7947.)
 
 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.