Deriving for phantom and empty types
[ghc.git] / compiler / typecheck / TcGenGenerics.hs
index 2c90c17..51451a6 100644 (file)
@@ -6,46 +6,46 @@ The deriving code for the Generic class
 (equivalent to the code in TcGenDeriv, for other classes)
 -}
 
-{-# LANGUAGE CPP, ScopedTypeVariables #-}
+{-# LANGUAGE CPP, ScopedTypeVariables, TupleSections #-}
 {-# LANGUAGE FlexibleContexts #-}
 
 module TcGenGenerics (canDoGenerics, canDoGenerics1,
                       GenericKind(..),
-                      MetaTyCons, genGenericMetaTyCons,
                       gen_Generic_binds, get_gen1_constrained_tys) where
 
-import DynFlags
 import HsSyn
 import Type
-import Kind             ( isKind )
 import TcType
 import TcGenDeriv
+import TcGenFunctor
 import DataCon
 import TyCon
 import FamInstEnv       ( FamInst, FamFlavor(..), mkSingleCoAxiom )
 import FamInst
-import Module           ( Module, moduleName, moduleNameString )
+import Module           ( moduleName, moduleNameFS
+                        , moduleUnitId, unitIdFS, getModule )
 import IfaceEnv         ( newGlobalBinder )
 import Name      hiding ( varName )
 import RdrName
 import BasicTypes
+import TysPrim
 import TysWiredIn
 import PrelNames
-import InstEnv
 import TcEnv
-import MkId
 import TcRnMonad
 import HscTypes
 import ErrUtils( Validity(..), andValid )
-import BuildTyCl
 import SrcLoc
 import Bag
+import VarEnv
 import VarSet (elemVarSet)
 import Outputable
 import FastString
 import Util
 
-import Control.Monad (mplus,forM)
+import Control.Monad (mplus)
+import Data.List (zip4, partition)
+import Data.Maybe (isJust)
 
 #include "HsVersions.h"
 
@@ -64,121 +64,12 @@ For the generic representation we need to generate:
 \end{itemize}
 -}
 
-gen_Generic_binds :: GenericKind -> TyCon -> MetaTyCons -> Module
+gen_Generic_binds :: GenericKind -> TyCon -> [Type]
                  -> TcM (LHsBinds RdrName, FamInst)
-gen_Generic_binds gk tc metaTyCons mod = do
-  repTyInsts <- tc_mkRepFamInsts gk tc metaTyCons mod
+gen_Generic_binds gk tc inst_tys = do
+  repTyInsts <- tc_mkRepFamInsts gk tc inst_tys
   return (mkBindsRep gk tc, repTyInsts)
 
-genGenericMetaTyCons :: TyCon -> Module -> TcM (MetaTyCons, BagDerivStuff)
-genGenericMetaTyCons tc mod =
-  do  loc <- getSrcSpanM
-      let
-        tc_name   = tyConName tc
-        tc_cons   = tyConDataCons tc
-        tc_arits  = map dataConSourceArity tc_cons
-
-        tc_occ    = nameOccName tc_name
-        d_occ     = mkGenD tc_occ
-        c_occ m   = mkGenC tc_occ m
-        s_occ m n = mkGenS tc_occ m n
-
-        mkTyCon name = ASSERT( isExternalName name )
-                       buildAlgTyCon name [] [] Nothing [] distinctAbstractTyConRhs
-                                          NonRecursive
-                                          False          -- Not promotable
-                                          False          -- Not GADT syntax
-                                          NoParentTyCon
-
-      d_name  <- newGlobalBinder mod d_occ loc
-      c_names <- forM (zip [0..] tc_cons) $ \(m,_) ->
-                    newGlobalBinder mod (c_occ m) loc
-      s_names <- forM (zip [0..] tc_arits) $ \(m,a) -> forM [0..a-1] $ \n ->
-                    newGlobalBinder mod (s_occ m n) loc
-
-      let metaDTyCon  = mkTyCon d_name
-          metaCTyCons = map mkTyCon c_names
-          metaSTyCons = map (map mkTyCon) s_names
-
-          metaDts = MetaTyCons metaDTyCon metaCTyCons metaSTyCons
-
-      -- pprTrace "rep0" (ppr rep0_tycon) $
-      (,) metaDts `fmap` metaTyConsToDerivStuff tc metaDts
-
--- both the tycon declarations and related instances
-metaTyConsToDerivStuff :: TyCon -> MetaTyCons -> TcM BagDerivStuff
-metaTyConsToDerivStuff tc metaDts =
-  do  loc <- getSrcSpanM
-      dflags <- getDynFlags
-      dClas <- tcLookupClass datatypeClassName
-      let new_dfun_name clas tycon = newDFunName clas [mkTyConApp tycon []] loc
-      d_dfun_name <- new_dfun_name dClas tc
-      cClas <- tcLookupClass constructorClassName
-      c_dfun_names <- sequence [ new_dfun_name cClas tc | _ <- metaC metaDts ]
-      sClas <- tcLookupClass selectorClassName
-      s_dfun_names <- sequence (map sequence [ [ new_dfun_name sClas tc
-                                               | _ <- x ]
-                                             | x <- metaS metaDts ])
-      fix_env <- getFixityEnv
-
-      let
-        (dBinds,cBinds,sBinds) = mkBindsMetaD fix_env tc
-        mk_inst clas tc dfun_name
-          = mkLocalInstance (mkDictFunId dfun_name [] [] clas tys)
-                            OverlapFlag { overlapMode   = (NoOverlap "")
-                                        , isSafeOverlap = safeLanguageOn dflags }
-                            [] clas tys
-          where
-            tys = [mkTyConTy tc]
-
-        -- Datatype
-        d_metaTycon = metaD metaDts
-        d_inst   = mk_inst dClas d_metaTycon d_dfun_name
-        d_binds  = InstBindings { ib_binds = dBinds
-                                , ib_tyvars = []
-                                , ib_pragmas = []
-                                , ib_extensions = []
-                                , ib_derived = True }
-        d_mkInst = DerivInst (InstInfo { iSpec = d_inst, iBinds = d_binds })
-
-        -- Constructor
-        c_metaTycons = metaC metaDts
-        c_insts = [ mk_inst cClas c ds
-                  | (c, ds) <- myZip1 c_metaTycons c_dfun_names ]
-        c_binds = [ InstBindings { ib_binds = c
-                                 , ib_tyvars = []
-                                 , ib_pragmas = []
-                                 , ib_extensions = []
-                                 , ib_derived = True }
-                  | c <- cBinds ]
-        c_mkInst = [ DerivInst (InstInfo { iSpec = is, iBinds = bs })
-                   | (is,bs) <- myZip1 c_insts c_binds ]
-
-        -- Selector
-        s_metaTycons = metaS metaDts
-        s_insts = map (map (\(s,ds) -> mk_inst sClas s ds))
-                      (myZip2 s_metaTycons s_dfun_names)
-        s_binds = [ [ InstBindings { ib_binds = s
-                                   , ib_tyvars = []
-                                   , ib_pragmas = []
-                                   , ib_extensions = []
-                                   , ib_derived = True }
-                    | s <- ss ] | ss <- sBinds ]
-        s_mkInst = map (map (\(is,bs) -> DerivInst (InstInfo { iSpec  = is
-                                                             , iBinds = bs})))
-                       (myZip2 s_insts s_binds)
-
-        myZip1 :: [a] -> [b] -> [(a,b)]
-        myZip1 l1 l2 = ASSERT(length l1 == length l2) zip l1 l2
-
-        myZip2 :: [[a]] -> [[b]] -> [[(a,b)]]
-        myZip2 l1 l2 =
-          ASSERT(and (zipWith (>=) (map length l1) (map length l2)))
-            [ zip x1 x2 | (x1,x2) <- zip l1 l2 ]
-
-      return $ mapBag DerivTyCon (metaTyCons2TyCons metaDts)
-               `unionBags` listToBag (d_mkInst : c_mkInst ++ concat s_mkInst)
-
 {-
 ************************************************************************
 *                                                                      *
@@ -206,31 +97,31 @@ expressions.
 (Generic T) and (Rep T) are derivable for some type expression T if the
 following constraints are satisfied.
 
-  (a) T = (D v1 ... vn) with free variables v1, v2, ..., vn where n >= 0 v1
-      ... vn are distinct type variables. Cf #5939.
-
-  (b) D is a type constructor *value*. In other words, D is either a type
+  (a) D is a type constructor *value*. In other words, D is either a type
       constructor or it is equivalent to the head of a data family instance (up to
       alpha-renaming).
 
-  (c) D cannot have a "stupid context".
+  (b) D cannot have a "stupid context".
 
-  (d) The right-hand side of D cannot include unboxed types, existential types,
-      or universally quantified types.
+  (c) The right-hand side of D cannot include existential types, universally
+      quantified types, or "exotic" unlifted types. An exotic unlifted type
+      is one which is not listed in the definition of allowedUnliftedTy
+      (i.e., one for which we have no representation type).
+      See Note [Generics and unlifted types]
 
-  (e) T :: *.
+  (d) T :: *.
 
 (Generic1 T) and (Rep1 T) are derivable for some type expression T if the
 following constraints are satisfied.
 
-  (a),(b),(c),(d) As above.
+  (a),(b),(c) As above.
 
-  (f) T must expect arguments, and its last parameter must have kind *.
+  (d) T must expect arguments, and its last parameter must have kind *.
 
       We use `a' to denote the parameter of D that corresponds to the last
       parameter of T.
 
-  (g) For any type-level application (Tfun Targ) in the right-hand side of D
+  (e) For any type-level application (Tfun Targ) in the right-hand side of D
       where the head of Tfun is not a tuple constructor:
 
       (b1) `a' must not occur in Tfun.
@@ -239,54 +130,53 @@ following constraints are satisfied.
 
 -}
 
-canDoGenerics :: TyCon -> [Type] -> Validity
--- canDoGenerics rep_tc tc_args determines if Generic/Rep can be derived for a
--- type expression (rep_tc tc_arg0 tc_arg1 ... tc_argn).
+canDoGenerics :: TyCon -> Validity
+-- canDoGenerics determines if Generic/Rep can be derived.
 --
--- Check (b) from Note [Requirements for deriving Generic and Rep] is taken
+-- Check (a) from Note [Requirements for deriving Generic and Rep] is taken
 -- care of because canDoGenerics is applied to rep tycons.
 --
--- It returns Nothing if deriving is possible. It returns (Just reason) if not.
-canDoGenerics tc tc_args
+-- It returns IsValid if deriving is possible. It returns (NotValid reason)
+-- if not.
+canDoGenerics tc
   = mergeErrors (
-          -- Check (c) from Note [Requirements for deriving Generic and Rep].
+          -- Check (b) from Note [Requirements for deriving Generic and Rep].
               (if (not (null (tyConStupidTheta tc)))
                 then (NotValid (tc_name <+> text "must not have a datatype context"))
-                else IsValid) :
-          -- Check (a) from Note [Requirements for deriving Generic and Rep].
-          --
-          -- Data family indices can be instantiated; the `tc_args` here are
-          -- the representation tycon args
-              (if (all isTyVarTy (filterOut isKind tc_args))
-                then IsValid
-                else NotValid (tc_name <+> text "must not be instantiated;" <+>
-                               text "try deriving `" <> tc_name <+> tc_tys <>
-                               text "' instead"))
+                else IsValid)
           -- See comment below
             : (map bad_con (tyConDataCons tc)))
   where
     -- The tc can be a representation tycon. When we want to display it to the
     -- user (in an error message) we should print its parent
-    (tc_name, tc_tys) = case tyConParent tc of
-        FamInstTyCon _ ptc tys -> (ppr ptc, hsep (map ppr
-                                            (tys ++ drop (length tys) tc_args)))
-        _                      -> (ppr tc, hsep (map ppr (tyConTyVars tc)))
+    tc_name = ppr $ case tyConFamInst_maybe tc of
+        Just (ptc, _) -> ptc
+        _             -> tc
 
-        -- Check (d) from Note [Requirements for deriving Generic and Rep].
+        -- Check (c) from Note [Requirements for deriving Generic and Rep].
         --
-        -- If any of the constructors has an unboxed type as argument,
+        -- If any of the constructors has an exotic unlifted type as argument,
         -- then we can't build the embedding-projection pair, because
         -- it relies on instantiating *polymorphic* sum and product types
         -- at the argument types of the constructors
     bad_con dc = if (any bad_arg_type (dataConOrigArgTys dc))
-                  then (NotValid (ppr dc <+> text "must not have unlifted or polymorphic arguments"))
+                  then (NotValid (ppr dc <+> text
+                    "must not have exotic unlifted or polymorphic arguments"))
                   else (if (not (isVanillaDataCon dc))
                           then (NotValid (ppr dc <+> text "must be a vanilla data constructor"))
                           else IsValid)
 
         -- Nor can we do the job if it's an existential data constructor,
         -- Nor if the args are polymorphic types (I don't think)
-    bad_arg_type ty = isUnLiftedType ty || not (isTauTy ty)
+    bad_arg_type ty = (isUnliftedType ty && not (allowedUnliftedTy ty))
+                      || not (isTauTy ty)
+
+-- Returns True the Type argument is an unlifted type which has a
+-- corresponding generic representation type. For example,
+-- (allowedUnliftedTy Int#) would return True since there is the UInt
+-- representation type.
+allowedUnliftedTy :: Type -> Bool
+allowedUnliftedTy = isJust . unboxedRepRDRs
 
 mergeErrors :: [Validity] -> Validity
 mergeErrors []             = IsValid
@@ -328,22 +218,22 @@ explicitly, even though foldDataConArgs is also doing this internally.
 
 -}
 
--- canDoGenerics1 rep_tc tc_args determines if a Generic1/Rep1 can be derived
--- for a type expression (rep_tc tc_arg0 tc_arg1 ... tc_argn).
+-- canDoGenerics1 determines if a Generic1/Rep1 can be derived.
 --
--- Checks (a) through (d) from Note [Requirements for deriving Generic and Rep]
+-- Checks (a) through (c) from Note [Requirements for deriving Generic and Rep]
 -- are taken care of by the call to canDoGenerics.
 --
--- It returns Nothing if deriving is possible. It returns (Just reason) if not.
-canDoGenerics1 :: TyCon -> [Type] -> Validity
-canDoGenerics1 rep_tc tc_args =
-  canDoGenerics rep_tc tc_args `andValid` additionalChecks
+-- It returns IsValid if deriving is possible. It returns (NotValid reason)
+-- if not.
+canDoGenerics1 :: TyCon -> Validity
+canDoGenerics1 rep_tc =
+  canDoGenerics rep_tc `andValid` additionalChecks
   where
     additionalChecks
-        -- check (f) from Note [Requirements for deriving Generic and Rep]
+        -- check (d) from Note [Requirements for deriving Generic and Rep]
       | null (tyConTyVars rep_tc) = NotValid $
-          ptext (sLit "Data type") <+> quotes (ppr rep_tc)
-      <+> ptext (sLit "must have some type parameters")
+          text "Data type" <+> quotes (ppr rep_tc)
+      <+> text "must have some type parameters"
 
       | otherwise = mergeErrors $ concatMap check_con data_cons
 
@@ -353,7 +243,7 @@ canDoGenerics1 rep_tc tc_args =
       IsValid -> _ccdg1_errors `map` foldDataConArgs (ft_check con) con
 
     bad :: DataCon -> SDoc -> SDoc
-    bad con msg = ptext (sLit "Constructor") <+> quotes (ppr con) <+> msg
+    bad con msg = text "Constructor" <+> quotes (ppr con) <+> msg
 
     check_vanilla :: DataCon -> Validity
     check_vanilla con | isVanillaDataCon con = IsValid
@@ -363,7 +253,8 @@ canDoGenerics1 rep_tc tc_args =
     bmbad con s = CCDG1 True $ NotValid $ bad con s
     bmplus (CCDG1 b1 m1) (CCDG1 b2 m2) = CCDG1 (b1 || b2) (m1 `andValid` m2)
 
-    -- check (g) from Note [degenerate use of FFoldType]
+    -- check (e) from Note [Requirements for deriving Generic and Rep]
+    -- See also Note [degenerate use of FFoldType]
     ft_check :: DataCon -> FFoldType Check_for_CanDoGenerics1
     ft_check con = FT
       { ft_triv = bmzero
@@ -428,16 +319,23 @@ gk2gkDC Gen0_   _ = Gen0_DC
 gk2gkDC Gen1_{} d = Gen1_DC $ last $ dataConUnivTyVars d
 
 
-
 -- Bindings for the Generic instance
 mkBindsRep :: GenericKind -> TyCon -> LHsBinds RdrName
 mkBindsRep gk tycon =
-    unitBag (mkRdrFunBind (L loc from01_RDR) from_matches)
+    unitBag (mkRdrFunBind (L loc from01_RDR) [from_eqn])
   `unionBags`
-    unitBag (mkRdrFunBind (L loc to01_RDR) to_matches)
+    unitBag (mkRdrFunBind (L loc to01_RDR) [to_eqn])
       where
-        from_matches  = [mkSimpleHsAlt pat rhs | (pat,rhs) <- from_alts]
-        to_matches    = [mkSimpleHsAlt pat rhs | (pat,rhs) <- to_alts  ]
+        -- The topmost M1 (the datatype metadata) has the exact same type
+        -- across all cases of a from/to definition, and can be factored out
+        -- to save some allocations during typechecking.
+        -- See Note [Generics compilation speed tricks]
+        from_eqn = mkHsCaseAlt x_Pat $ mkM1_E
+                                       $ nlHsPar $ nlHsCase x_Expr from_matches
+        to_eqn   = mkHsCaseAlt (mkM1_P x_Pat) $ nlHsCase x_Expr to_matches
+
+        from_matches  = [mkHsCaseAlt pat rhs | (pat,rhs) <- from_alts]
+        to_matches    = [mkHsCaseAlt pat rhs | (pat,rhs) <- to_alts  ]
         loc           = srcLocSpan (getSrcLoc tycon)
         datacons      = tyConDataCons tycon
 
@@ -447,7 +345,7 @@ mkBindsRep gk tycon =
 
         -- Recurse over the sum first
         from_alts, to_alts :: [Alt]
-        (from_alts, to_alts) = mkSum gk_ (1 :: US) tycon datacons
+        (from_alts, to_alts) = mkSum gk_ (1 :: US) datacons
           where gk_ = case gk of
                   Gen0 -> Gen0_
                   Gen1 -> ASSERT(length tyvars >= 1)
@@ -460,12 +358,12 @@ mkBindsRep gk tycon =
 --       type Rep_D a b = ...representation type for D ...
 --------------------------------------------------------------------------------
 
-tc_mkRepFamInsts :: GenericKind     -- Gen0 or Gen1
-               -> TyCon           -- The type to generate representation for
-               -> MetaTyCons      -- Metadata datatypes to refer to
-               -> Module          -- Used as the location of the new RepTy
-               -> TcM (FamInst)   -- Generated representation0 coercion
-tc_mkRepFamInsts gk tycon metaDts mod =
+tc_mkRepFamInsts :: GenericKind   -- Gen0 or Gen1
+                 -> TyCon         -- The type to generate representation for
+                 -> [Type]        -- The type(s) to which Generic(1) is applied
+                                  -- in the generated instance
+                 -> TcM FamInst   -- Generated representation0 coercion
+tc_mkRepFamInsts gk tycon inst_tys =
        -- Consider the example input tycon `D`, where data D a b = D_ a
        -- Also consider `R:DInt`, where { data family D x y :: * -> *
        --                               ; data instance D Int a b = D_ a }
@@ -474,6 +372,30 @@ tc_mkRepFamInsts gk tycon metaDts mod =
          Gen0 -> tcLookupTyCon repTyConName
          Gen1 -> tcLookupTyCon rep1TyConName
 
+     ; fam_envs <- tcGetFamInstEnvs
+
+     ; let -- If the derived instance is
+           --   instance Generic (Foo x)
+           -- then:
+           --   `arg_ki` = *, `inst_ty` = Foo x :: *
+           --
+           -- If the derived instance is
+           --   instance Generic1 (Bar x :: k -> *)
+           -- then:
+           --   `arg_k` = k, `inst_ty` = Bar x :: k -> *
+           (arg_ki, inst_ty) = case (gk, inst_tys) of
+             (Gen0, [inst_t])        -> (liftedTypeKind, inst_t)
+             (Gen1, [arg_k, inst_t]) -> (arg_k,          inst_t)
+             _ -> pprPanic "tc_mkRepFamInsts" (ppr inst_tys)
+
+     ; let mbFamInst         = tyConFamInst_maybe tycon
+           -- If we're examining a data family instance, we grab the parent
+           -- TyCon (ptc) and use it to determine the type arguments
+           -- (inst_args) for the data family *instance*'s type variables.
+           ptc               = maybe tycon fst mbFamInst
+           (_, inst_args, _) = tcLookupDataFamInst fam_envs ptc $ snd
+                                 $ tcSplitTyConApp inst_ty
+
      ; let -- `tyvars` = [a,b]
            (tyvars, gk_) = case gk of
              Gen0 -> (all_tyvars, Gen0_)
@@ -481,31 +403,31 @@ tc_mkRepFamInsts gk tycon metaDts mod =
                      (init all_tyvars, Gen1_ $ last all_tyvars)
              where all_tyvars = tyConTyVars tycon
 
-           tyvar_args = mkTyVarTys tyvars
-
-           appT :: [Type]
-           appT = case tyConFamInst_maybe tycon of
-                     -- `appT` = D Int a b (data families case)
-                     Just (famtycon, apps) ->
-                       -- `fam` = D
-                       -- `apps` = [Int, a, b]
-                       let allApps = case gk of
-                                       Gen0 -> apps
-                                       Gen1 -> ASSERT(not $ null apps)
-                                               init apps
-                       in [mkTyConApp famtycon allApps]
-                     -- `appT` = D a b (normal case)
-                     Nothing -> [mkTyConApp tycon tyvar_args]
-
        -- `repTy` = D1 ... (C1 ... (S1 ... (Rec0 a))) :: * -> *
-     ; repTy <- tc_mkRepTy gk_ tycon metaDts
+     ; repTy <- tc_mkRepTy gk_ tycon arg_ki
 
        -- `rep_name` is a name we generate for the synonym
-     ; rep_name <- let mkGen = case gk of Gen0 -> mkGenR; Gen1 -> mkGen1R
-                   in newGlobalBinder mod (mkGen (nameOccName (tyConName tycon)))
-                        (nameSrcSpan (tyConName tycon))
+     ; mod <- getModule
+     ; loc <- getSrcSpanM
+     ; let tc_occ  = nameOccName (tyConName tycon)
+           rep_occ = case gk of Gen0 -> mkGenR tc_occ; Gen1 -> mkGen1R tc_occ
+     ; rep_name <- newGlobalBinder mod rep_occ loc
+
+       -- We make sure to substitute the tyvars with their user-supplied
+       -- type arguments before generating the Rep/Rep1 instance, since some
+       -- of the tyvars might have been instantiated when deriving.
+       -- See Note [Generating a correctly typed Rep instance].
+     ; let env        = zipTyEnv tyvars inst_args
+           in_scope   = mkInScopeSet (tyCoVarsOfTypes inst_tys)
+           subst      = mkTvSubst in_scope env
+           repTy'     = substTy  subst repTy
+           tcv'       = tyCoVarsOfTypeList inst_ty
+           (tv', cv') = partition isTyVar tcv'
+           tvs'       = toposortTyVars tv'
+           cvs'       = toposortTyVars cv'
+           axiom      = mkSingleCoAxiom Nominal rep_name tvs' cvs'
+                                        fam_tc inst_tys repTy'
 
-     ; let axiom = mkSingleCoAxiom rep_name tyvars fam_tc appT repTy
      ; newFamInst SynFamilyInst axiom  }
 
 --------------------------------------------------------------------------------
@@ -568,7 +490,7 @@ argTyFold argVar (ArgTyAlg {ata_rec0 = mkRec0,
     isApp = do -- handles applications
       (phi, beta) <- tcSplitAppTy_maybe t
 
-      let interesting = argVar `elemVarSet` exactTyVarsOfType beta
+      let interesting = argVar `elemVarSet` exactTyCoVarsOfType beta
 
       -- Does it have no interesting structure to represent?
       if not interesting then Nothing
@@ -581,56 +503,83 @@ tc_mkRepTy ::  -- Gen0_ or Gen1_, for Rep or Rep1
                GenericKind_
               -- The type to generate representation for
             -> TyCon
-               -- Metadata datatypes to refer to
-            -> MetaTyCons
+              -- The kind of the representation type's argument
+              -- See Note [Handling kinds in a Rep instance]
+            -> Kind
                -- Generated representation0 type
             -> TcM Type
-tc_mkRepTy gk_ tycon metaDts =
+tc_mkRepTy gk_ tycon k =
   do
-    d1    <- tcLookupTyCon d1TyConName
-    c1    <- tcLookupTyCon c1TyConName
-    s1    <- tcLookupTyCon s1TyConName
-    nS1   <- tcLookupTyCon noSelTyConName
-    rec0  <- tcLookupTyCon rec0TyConName
-    rec1  <- tcLookupTyCon rec1TyConName
-    par1  <- tcLookupTyCon par1TyConName
-    u1    <- tcLookupTyCon u1TyConName
-    v1    <- tcLookupTyCon v1TyConName
-    plus  <- tcLookupTyCon sumTyConName
-    times <- tcLookupTyCon prodTyConName
-    comp  <- tcLookupTyCon compTyConName
-
-    let mkSum' a b = mkTyConApp plus  [a,b]
-        mkProd a b = mkTyConApp times [a,b]
-        mkComp a b = mkTyConApp comp  [a,b]
-        mkRec0 a   = mkTyConApp rec0  [a]
-        mkRec1 a   = mkTyConApp rec1  [a]
+    d1      <- tcLookupTyCon d1TyConName
+    c1      <- tcLookupTyCon c1TyConName
+    s1      <- tcLookupTyCon s1TyConName
+    rec0    <- tcLookupTyCon rec0TyConName
+    rec1    <- tcLookupTyCon rec1TyConName
+    par1    <- tcLookupTyCon par1TyConName
+    u1      <- tcLookupTyCon u1TyConName
+    v1      <- tcLookupTyCon v1TyConName
+    plus    <- tcLookupTyCon sumTyConName
+    times   <- tcLookupTyCon prodTyConName
+    comp    <- tcLookupTyCon compTyConName
+    uAddr   <- tcLookupTyCon uAddrTyConName
+    uChar   <- tcLookupTyCon uCharTyConName
+    uDouble <- tcLookupTyCon uDoubleTyConName
+    uFloat  <- tcLookupTyCon uFloatTyConName
+    uInt    <- tcLookupTyCon uIntTyConName
+    uWord   <- tcLookupTyCon uWordTyConName
+
+    let tcLookupPromDataCon = fmap promoteDataCon . tcLookupDataCon
+
+    md         <- tcLookupPromDataCon metaDataDataConName
+    mc         <- tcLookupPromDataCon metaConsDataConName
+    ms         <- tcLookupPromDataCon metaSelDataConName
+    pPrefix    <- tcLookupPromDataCon prefixIDataConName
+    pInfix     <- tcLookupPromDataCon infixIDataConName
+    pLA        <- tcLookupPromDataCon leftAssociativeDataConName
+    pRA        <- tcLookupPromDataCon rightAssociativeDataConName
+    pNA        <- tcLookupPromDataCon notAssociativeDataConName
+    pSUpk      <- tcLookupPromDataCon sourceUnpackDataConName
+    pSNUpk     <- tcLookupPromDataCon sourceNoUnpackDataConName
+    pNSUpkness <- tcLookupPromDataCon noSourceUnpackednessDataConName
+    pSLzy      <- tcLookupPromDataCon sourceLazyDataConName
+    pSStr      <- tcLookupPromDataCon sourceStrictDataConName
+    pNSStrness <- tcLookupPromDataCon noSourceStrictnessDataConName
+    pDLzy      <- tcLookupPromDataCon decidedLazyDataConName
+    pDStr      <- tcLookupPromDataCon decidedStrictDataConName
+    pDUpk      <- tcLookupPromDataCon decidedUnpackDataConName
+
+    fix_env <- getFixityEnv
+
+    let mkSum' a b = mkTyConApp plus  [k,a,b]
+        mkProd a b = mkTyConApp times [k,a,b]
+        mkRec0 a   = mkBoxTy uAddr uChar uDouble uFloat uInt uWord rec0 k a
+        mkRec1 a   = mkTyConApp rec1  [k,a]
         mkPar1     = mkTyConTy  par1
-        mkD    a   = mkTyConApp d1    [metaDTyCon, sumP (tyConDataCons a)]
-        mkC  i d a = mkTyConApp c1    [d, prod i (dataConInstOrigArgTys a $ mkTyVarTys $ tyConTyVars tycon)
-                                                 (null (dataConFieldLabels a))]
-        -- This field has no label
-        mkS True  _ a = mkTyConApp s1 [mkTyConTy nS1, a]
-        -- This field has a  label
-        mkS False d a = mkTyConApp s1 [d, a]
+        mkD    a   = mkTyConApp d1 [ k, metaDataTy, sumP (tyConDataCons a) ]
+        mkC      a = mkTyConApp c1 [ k
+                                   , metaConsTy a
+                                   , prod (dataConInstOrigArgTys a
+                                            . mkTyVarTys . tyConTyVars $ tycon)
+                                          (dataConSrcBangs    a)
+                                          (dataConImplBangs   a)
+                                          (dataConFieldLabels a)]
+        mkS mlbl su ss ib a = mkTyConApp s1 [k, metaSelTy mlbl su ss ib, a]
 
         -- Sums and products are done in the same way for both Rep and Rep1
-        sumP [] = mkTyConTy v1
-        sumP l  = ASSERT(length metaCTyCons == length l)
-                    foldBal mkSum' [ mkC i d a
-                                   | (d,(a,i)) <- zip metaCTyCons (zip l [0..])]
+        sumP [] = mkTyConApp v1 [k]
+        sumP l  = foldBal mkSum' . map mkC  $ l
         -- The Bool is True if this constructor has labelled fields
-        prod :: Int -> [Type] -> Bool -> Type
-        prod i [] _ = ASSERT(length metaSTyCons > i)
-                        ASSERT(length (metaSTyCons !! i) == 0)
-                          mkTyConTy u1
-        prod i l b  = ASSERT(length metaSTyCons > i)
-                        ASSERT(length l == length (metaSTyCons !! i))
-                          foldBal mkProd [ arg d t b
-                                         | (d,t) <- zip (metaSTyCons !! i) l ]
-
-        arg :: Type -> Type -> Bool -> Type
-        arg d t b = mkS b d $ case gk_ of
+        prod :: [Type] -> [HsSrcBang] -> [HsImplBang] -> [FieldLabel] -> Type
+        prod [] _  _  _  = mkTyConApp u1 [k]
+        prod l  sb ib fl = foldBal mkProd
+                                   [ ASSERT(null fl || length fl > j)
+                                     arg t sb' ib' (if null fl
+                                                       then Nothing
+                                                       else Just (fl !! j))
+                                   | (t,sb',ib',j) <- zip4 l sb ib [0..] ]
+
+        arg :: Type -> HsSrcBang -> HsImplBang -> Maybe FieldLabel -> Type
+        arg t (HsSrcBang _ su ss) ib fl = mkS fl su ss ib $ case gk_ of
             -- Here we previously used Par0 if t was a type variable, but we
             -- realized that we can't always guarantee that we are wrapping-up
             -- all type variables in Par0. So we decided to stop using Par0
@@ -638,93 +587,105 @@ tc_mkRepTy gk_ tycon metaDts =
                       Gen0_        -> mkRec0 t
                       Gen1_ argVar -> argPar argVar t
           where
-            -- Builds argument represention for Rep1 (more complicated due to
+            -- Builds argument representation for Rep1 (more complicated due to
             -- the presence of composition).
             argPar argVar = argTyFold argVar $ ArgTyAlg
               {ata_rec0 = mkRec0, ata_par1 = mkPar1,
-               ata_rec1 = mkRec1, ata_comp = mkComp}
-
-
-        metaDTyCon  = mkTyConTy (metaD metaDts)
-        metaCTyCons = map mkTyConTy (metaC metaDts)
-        metaSTyCons = map (map mkTyConTy) (metaS metaDts)
-
-    return (mkD tycon)
-
---------------------------------------------------------------------------------
--- Meta-information
---------------------------------------------------------------------------------
-
-data MetaTyCons = MetaTyCons { -- One meta datatype per datatype
-                               metaD :: TyCon
-                               -- One meta datatype per constructor
-                             , metaC :: [TyCon]
-                               -- One meta datatype per selector per constructor
-                             , metaS :: [[TyCon]] }
-
-instance Outputable MetaTyCons where
-  ppr (MetaTyCons d c s) = ppr d $$ vcat (map ppr c) $$ vcat (map ppr (concat s))
-
-metaTyCons2TyCons :: MetaTyCons -> Bag TyCon
-metaTyCons2TyCons (MetaTyCons d c s) = listToBag (d : c ++ concat s)
-
-
--- Bindings for Datatype, Constructor, and Selector instances
-mkBindsMetaD :: FixityEnv -> TyCon
-             -> ( LHsBinds RdrName      -- Datatype instance
-                , [LHsBinds RdrName]    -- Constructor instances
-                , [[LHsBinds RdrName]]) -- Selector instances
-mkBindsMetaD fix_env tycon = (dtBinds, allConBinds, allSelBinds)
-      where
-        mkBag l = foldr1 unionBags
-                    [ unitBag (mkRdrFunBind (L loc name) matches)
-                        | (name, matches) <- l ]
-        dtBinds       = mkBag ( [ (datatypeName_RDR, dtName_matches)
-                                , (moduleName_RDR, moduleName_matches)]
-                              ++ ifElseEmpty (isNewTyCon tycon)
-                                [ (isNewtypeName_RDR, isNewtype_matches) ] )
-
-        allConBinds   = map conBinds datacons
-        conBinds c    = mkBag ( [ (conName_RDR, conName_matches c)]
-                              ++ ifElseEmpty (dataConIsInfix c)
-                                   [ (conFixity_RDR, conFixity_matches c) ]
-                              ++ ifElseEmpty (length (dataConFieldLabels c) > 0)
-                                   [ (conIsRecord_RDR, conIsRecord_matches c) ]
-                              )
-
-        ifElseEmpty p x = if p then x else []
-        fixity c      = case lookupFixity fix_env (dataConName c) of
-                          Fixity n InfixL -> buildFix n leftAssocDataCon_RDR
-                          Fixity n InfixR -> buildFix n rightAssocDataCon_RDR
-                          Fixity n InfixN -> buildFix n notAssocDataCon_RDR
-        buildFix n assoc = nlHsApps infixDataCon_RDR [nlHsVar assoc
-                                                     , nlHsIntLit (toInteger n)]
-
-        allSelBinds   = map (map selBinds) datasels
-        selBinds s    = mkBag [(selName_RDR, selName_matches s)]
-
-        loc           = srcLocSpan (getSrcLoc tycon)
-        mkStringLHS s = [mkSimpleHsAlt nlWildPat (nlHsLit (mkHsString s))]
-        datacons      = tyConDataCons tycon
-        datasels      = map dataConFieldLabels datacons
+               ata_rec1 = mkRec1, ata_comp = mkComp comp k}
 
         tyConName_user = case tyConFamInst_maybe tycon of
                            Just (ptycon, _) -> tyConName ptycon
                            Nothing          -> tyConName tycon
 
-        dtName_matches     = mkStringLHS . occNameString . nameOccName
-                           $ tyConName_user
-        moduleName_matches = mkStringLHS . moduleNameString . moduleName
-                           . nameModule . tyConName $ tycon
-        isNewtype_matches  = [mkSimpleHsAlt nlWildPat (nlHsVar true_RDR)]
+        dtName  = mkStrLitTy . occNameFS . nameOccName $ tyConName_user
+        mdName  = mkStrLitTy . moduleNameFS . moduleName
+                . nameModule . tyConName $ tycon
+        pkgName = mkStrLitTy . unitIdFS . moduleUnitId
+                . nameModule . tyConName $ tycon
+        isNT    = mkTyConTy $ if isNewTyCon tycon
+                              then promotedTrueDataCon
+                              else promotedFalseDataCon
+
+        ctName = mkStrLitTy . occNameFS . nameOccName . dataConName
+        ctFix c
+            | dataConIsInfix c
+            = case lookupFixity fix_env (dataConName c) of
+                   Fixity _ n InfixL -> buildFix n pLA
+                   Fixity _ n InfixR -> buildFix n pRA
+                   Fixity _ n InfixN -> buildFix n pNA
+            | otherwise = mkTyConTy pPrefix
+        buildFix n assoc = mkTyConApp pInfix [ mkTyConTy assoc
+                                             , mkNumLitTy (fromIntegral n)]
+
+        isRec c = mkTyConTy $ if length (dataConFieldLabels c) > 0
+                              then promotedTrueDataCon
+                              else promotedFalseDataCon
+
+        selName = mkStrLitTy . flLabel
+
+        mbSel Nothing  = mkTyConApp promotedNothingDataCon [typeSymbolKind]
+        mbSel (Just s) = mkTyConApp promotedJustDataCon
+                                    [typeSymbolKind, selName s]
+
+        metaDataTy   = mkTyConApp md [dtName, mdName, pkgName, isNT]
+        metaConsTy c = mkTyConApp mc [ctName c, ctFix c, isRec c]
+        metaSelTy mlbl su ss ib =
+            mkTyConApp ms [mbSel mlbl, pSUpkness, pSStrness, pDStrness]
+          where
+            pSUpkness = mkTyConTy $ case su of
+                                         SrcUnpack   -> pSUpk
+                                         SrcNoUnpack -> pSNUpk
+                                         NoSrcUnpack -> pNSUpkness
+
+            pSStrness = mkTyConTy $ case ss of
+                                         SrcLazy     -> pSLzy
+                                         SrcStrict   -> pSStr
+                                         NoSrcStrict -> pNSStrness
 
-        conName_matches     c = mkStringLHS . occNameString . nameOccName
-                              . dataConName $ c
-        conFixity_matches   c = [mkSimpleHsAlt nlWildPat (fixity c)]
-        conIsRecord_matches _ = [mkSimpleHsAlt nlWildPat (nlHsVar true_RDR)]
+            pDStrness = mkTyConTy $ case ib of
+                                         HsLazy      -> pDLzy
+                                         HsStrict    -> pDStr
+                                         HsUnpack{}  -> pDUpk
 
-        selName_matches     s = mkStringLHS (occNameString (nameOccName s))
+    return (mkD tycon)
 
+mkComp :: TyCon -> Kind -> Type -> Type -> Type
+mkComp comp k f g
+  | k1_first  = mkTyConApp comp  [k,liftedTypeKind,f,g]
+  | otherwise = mkTyConApp comp  [liftedTypeKind,k,f,g]
+  where
+    -- Which of these is the case?
+    --     newtype (:.:) {k1} {k2} (f :: k2->*) (g :: k1->k2) (p :: k1) = ...
+    -- or  newtype (:.:) {k2} {k1} (f :: k2->*) (g :: k1->k2) (p :: k1) = ...
+    -- We want to instantiate with k1=k, and k2=*
+    --    Reason for k2=*: see Note [Handling kinds in a Rep instance]
+    -- But we need to know which way round!
+    k1_first = k_first == p_kind_var
+    [k_first,_,_,_,p] = tyConTyVars comp
+    Just p_kind_var = getTyVar_maybe (tyVarKind p)
+
+-- Given the TyCons for each URec-related type synonym, check to see if the
+-- given type is an unlifted type that generics understands. If so, return
+-- its representation type. Otherwise, return Rec0.
+-- See Note [Generics and unlifted types]
+mkBoxTy :: TyCon -- UAddr
+        -> TyCon -- UChar
+        -> TyCon -- UDouble
+        -> TyCon -- UFloat
+        -> TyCon -- UInt
+        -> TyCon -- UWord
+        -> TyCon -- Rec0
+        -> Kind  -- What to instantiate Rec0's kind variable with
+        -> Type
+        -> Type
+mkBoxTy uAddr uChar uDouble uFloat uInt uWord rec0 k ty
+  | ty `eqType` addrPrimTy   = mkTyConApp uAddr   [k]
+  | ty `eqType` charPrimTy   = mkTyConApp uChar   [k]
+  | ty `eqType` doublePrimTy = mkTyConApp uDouble [k]
+  | ty `eqType` floatPrimTy  = mkTyConApp uFloat  [k]
+  | ty `eqType` intPrimTy    = mkTyConApp uInt    [k]
+  | ty `eqType` wordPrimTy   = mkTyConApp uWord   [k]
+  | otherwise                = mkTyConApp rec0    [k,ty]
 
 --------------------------------------------------------------------------------
 -- Dealing with sums
@@ -732,24 +693,19 @@ mkBindsMetaD fix_env tycon = (dtBinds, allConBinds, allSelBinds)
 
 mkSum :: GenericKind_ -- Generic or Generic1?
       -> US          -- Base for generating unique names
-      -> TyCon       -- The type constructor
       -> [DataCon]   -- The data constructors
       -> ([Alt],     -- Alternatives for the T->Trep "from" function
           [Alt])     -- Alternatives for the Trep->T "to" function
 
 -- Datatype without any constructors
-mkSum _ _ tycon [] = ([from_alt], [to_alt])
+mkSum _ _ [] = ([from_alt], [to_alt])
   where
-    from_alt = (nlWildPat, mkM1_E (makeError errMsgFrom))
-    to_alt   = (mkM1_P nlWildPat, makeError errMsgTo)
+    from_alt = (x_Pat, nlHsCase x_Expr [])
+    to_alt   = (x_Pat, nlHsCase x_Expr [])
                -- These M1s are meta-information for the datatype
-    makeError s = nlHsApp (nlHsVar error_RDR) (nlHsLit (mkHsString s))
-    tyConStr   = occNameString (nameOccName (tyConName tycon))
-    errMsgFrom = "No generic representation for empty datatype " ++ tyConStr
-    errMsgTo   = "No values for empty datatype " ++ tyConStr
 
 -- Datatype with at least one constructor
-mkSum gk_ us datacons =
+mkSum gk_ us datacons =
   -- switch the payload of gk_ to be datacon-centric instead of tycon-centric
  unzip [ mk1Sum (gk2gkDC gk_ d) us i (length datacons) d
            | (d,i) <- zip datacons [1..] ]
@@ -777,31 +733,31 @@ mk1Sum gk_ us i n datacon = (from_alt, to_alt)
     datacon_rdr  = getRdrName datacon
 
     from_alt     = (nlConVarPat datacon_rdr datacon_vars, from_alt_rhs)
-    from_alt_rhs = mkM1_E (genLR_E i n (mkProd_E gk_ us' datacon_varTys))
+    from_alt_rhs = genLR_E i n (mkProd_E gk_ us' datacon_varTys)
 
-    to_alt     = (mkM1_P (genLR_P i n (mkProd_P gk us' datacon_vars)), to_alt_rhs)
-                 -- These M1s are meta-information for the datatype
+    to_alt     = ( genLR_P i n (mkProd_P gk us' datacon_varTys)
+                 , to_alt_rhs
+                 ) -- These M1s are meta-information for the datatype
     to_alt_rhs = case gk_ of
       Gen0_DC        -> nlHsVarApps datacon_rdr datacon_vars
       Gen1_DC argVar -> nlHsApps datacon_rdr $ map argTo datacon_varTys
         where
           argTo (var, ty) = converter ty `nlHsApp` nlHsVar var where
             converter = argTyFold argVar $ ArgTyAlg
-              {ata_rec0 = const $ nlHsVar unK1_RDR,
+              {ata_rec0 = nlHsVar . unboxRepRDR,
                ata_par1 = nlHsVar unPar1_RDR,
                ata_rec1 = const $ nlHsVar unRec1_RDR,
                ata_comp = \_ cnv -> (nlHsVar fmap_RDR `nlHsApp` cnv)
                                     `nlHsCompose` nlHsVar unComp1_RDR}
 
 
-
 -- Generates the L1/R1 sum pattern
 genLR_P :: Int -> Int -> LPat RdrName -> LPat RdrName
 genLR_P i n p
   | n == 0       = error "impossible"
   | n == 1       = p
-  | i <= div n 2 = nlConPat l1DataCon_RDR [genLR_P i     (div n 2) p]
-  | otherwise    = nlConPat r1DataCon_RDR [genLR_P (i-m) (n-m)     p]
+  | i <= div n 2 = nlParPat $ nlConPat l1DataCon_RDR [genLR_P i     (div n 2) p]
+  | otherwise    = nlParPat $ nlConPat r1DataCon_RDR [genLR_P (i-m) (n-m)     p]
                      where m = div n 2
 
 -- Generates the L1/R1 sum expression
@@ -809,8 +765,10 @@ genLR_E :: Int -> Int -> LHsExpr RdrName -> LHsExpr RdrName
 genLR_E i n e
   | n == 0       = error "impossible"
   | n == 1       = e
-  | i <= div n 2 = nlHsVar l1DataCon_RDR `nlHsApp` genLR_E i     (div n 2) e
-  | otherwise    = nlHsVar r1DataCon_RDR `nlHsApp` genLR_E (i-m) (n-m)     e
+  | i <= div n 2 = nlHsVar l1DataCon_RDR `nlHsApp`
+                                            nlHsPar (genLR_E i     (div n 2) e)
+  | otherwise    = nlHsVar r1DataCon_RDR `nlHsApp`
+                                            nlHsPar (genLR_E (i-m) (n-m)     e)
                      where m = div n 2
 
 --------------------------------------------------------------------------------
@@ -818,10 +776,10 @@ genLR_E i n e
 --------------------------------------------------------------------------------
 
 -- Build a product expression
-mkProd_E :: GenericKind_DC      -- Generic or Generic1?
-         -> US              -- Base for unique names
+mkProd_E :: GenericKind_DC    -- Generic or Generic1?
+         -> US                -- Base for unique names
          -> [(RdrName, Type)] -- List of variables matched on the lhs and their types
-         -> LHsExpr RdrName -- Resulting product expression
+         -> LHsExpr RdrName   -- Resulting product expression
 mkProd_E _   _ []     = mkM1_E (nlHsVar u1DataCon_RDR)
 mkProd_E gk_ _ varTys = mkM1_E (foldBal prod appVars)
                      -- These M1s are meta-information for the constructor
@@ -830,44 +788,72 @@ mkProd_E gk_ _ varTys = mkM1_E (foldBal prod appVars)
     prod a b = prodDataCon_RDR `nlHsApps` [a,b]
 
 wrapArg_E :: GenericKind_DC -> (RdrName, Type) -> LHsExpr RdrName
-wrapArg_E Gen0_DC          (var, _)  = mkM1_E (k1DataCon_RDR `nlHsVarApps` [var])
+wrapArg_E Gen0_DC          (var, ty) = mkM1_E $
+                            boxRepRDR ty `nlHsVarApps` [var]
                          -- This M1 is meta-information for the selector
-wrapArg_E (Gen1_DC argVar) (var, ty) = mkM1_E $ converter ty `nlHsApp` nlHsVar var
+wrapArg_E (Gen1_DC argVar) (var, ty) = mkM1_E $
+                            converter ty `nlHsApp` nlHsVar var
                          -- This M1 is meta-information for the selector
   where converter = argTyFold argVar $ ArgTyAlg
-          {ata_rec0 = const $ nlHsVar k1DataCon_RDR,
+          {ata_rec0 = nlHsVar . boxRepRDR,
            ata_par1 = nlHsVar par1DataCon_RDR,
            ata_rec1 = const $ nlHsVar rec1DataCon_RDR,
            ata_comp = \_ cnv -> nlHsVar comp1DataCon_RDR `nlHsCompose`
                                   (nlHsVar fmap_RDR `nlHsApp` cnv)}
 
+boxRepRDR :: Type -> RdrName
+boxRepRDR = maybe k1DataCon_RDR fst . unboxedRepRDRs
 
+unboxRepRDR :: Type -> RdrName
+unboxRepRDR = maybe unK1_RDR snd . unboxedRepRDRs
+
+-- Retrieve the RDRs associated with each URec data family instance
+-- constructor. See Note [Generics and unlifted types]
+unboxedRepRDRs :: Type -> Maybe (RdrName, RdrName)
+unboxedRepRDRs ty
+  | ty `eqType` addrPrimTy   = Just (uAddrDataCon_RDR,   uAddrHash_RDR)
+  | ty `eqType` charPrimTy   = Just (uCharDataCon_RDR,   uCharHash_RDR)
+  | ty `eqType` doublePrimTy = Just (uDoubleDataCon_RDR, uDoubleHash_RDR)
+  | ty `eqType` floatPrimTy  = Just (uFloatDataCon_RDR,  uFloatHash_RDR)
+  | ty `eqType` intPrimTy    = Just (uIntDataCon_RDR,    uIntHash_RDR)
+  | ty `eqType` wordPrimTy   = Just (uWordDataCon_RDR,   uWordHash_RDR)
+  | otherwise          = Nothing
 
 -- Build a product pattern
-mkProd_P :: GenericKind   -- Gen0 or Gen1
-         -> US                  -- Base for unique names
-               -> [RdrName]     -- List of variables to match
-               -> LPat RdrName  -- Resulting product pattern
-mkProd_P _  _ []   = mkM1_P (nlNullaryConPat u1DataCon_RDR)
-mkProd_P gk _ vars = mkM1_P (foldBal prod appVars)
+mkProd_P :: GenericKind       -- Gen0 or Gen1
+         -> US                -- Base for unique names
+         -> [(RdrName, Type)] -- List of variables to match,
+                              --   along with their types
+         -> LPat RdrName      -- Resulting product pattern
+mkProd_P _  _ []     = mkM1_P (nlNullaryConPat u1DataCon_RDR)
+mkProd_P gk _ varTys = mkM1_P (foldBal prod appVars)
                      -- These M1s are meta-information for the constructor
   where
-    appVars = map (wrapArg_P gk) vars
-    prod a b = prodDataCon_RDR `nlConPat` [a,b]
+    appVars = unzipWith (wrapArg_P gk) varTys
+    prod a b = nlParPat $ prodDataCon_RDR `nlConPat` [a,b]
 
-wrapArg_P :: GenericKind -> RdrName -> LPat RdrName
-wrapArg_P Gen0 v = mkM1_P (k1DataCon_RDR `nlConVarPat` [v])
+wrapArg_P :: GenericKind -> RdrName -> Type -> LPat RdrName
+wrapArg_P Gen0 v ty = mkM1_P (nlParPat $ boxRepRDR ty `nlConVarPat` [v])
                    -- This M1 is meta-information for the selector
-wrapArg_P Gen1 v = m1DataCon_RDR `nlConVarPat` [v]
+wrapArg_P Gen1 v _  = nlParPat $ m1DataCon_RDR `nlConVarPat` [v]
 
 mkGenericLocal :: US -> RdrName
 mkGenericLocal u = mkVarUnqual (mkFastString ("g" ++ show u))
 
+x_RDR :: RdrName
+x_RDR = mkVarUnqual (fsLit "x")
+
+x_Expr :: LHsExpr RdrName
+x_Expr = nlHsVar x_RDR
+
+x_Pat :: LPat RdrName
+x_Pat = nlVarPat x_RDR
+
 mkM1_E :: LHsExpr RdrName -> LHsExpr RdrName
 mkM1_E e = nlHsVar m1DataCon_RDR `nlHsApp` e
 
 mkM1_P :: LPat RdrName -> LPat RdrName
-mkM1_P p = m1DataCon_RDR `nlConPat` [p]
+mkM1_P p = nlParPat $ m1DataCon_RDR `nlConPat` [p]
 
 nlHsCompose :: LHsExpr RdrName -> LHsExpr RdrName -> LHsExpr RdrName
 nlHsCompose x y = compose_RDR `nlHsApps` [x, y]
@@ -881,3 +867,139 @@ foldBal' _  x []  = x
 foldBal' _  _ [y] = y
 foldBal' op x l   = let (a,b) = splitAt (length l `div` 2) l
                     in foldBal' op x a `op` foldBal' op x b
+
+{-
+Note [Generics and unlifted types]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Normally, all constants are marked with K1/Rec0. The exception to this rule is
+when a data constructor has an unlifted argument (e.g., Int#, Char#, etc.). In
+that case, we must use a data family instance of URec (from GHC.Generics) to
+mark it. As a result, before we can generate K1 or unK1, we must first check
+to see if the type is actually one of the unlifted types for which URec has a
+data family instance; if so, we generate that instead.
+
+See wiki:Commentary/Compiler/GenericDeriving#Handlingunliftedtypes for more
+details on why URec is implemented the way it is.
+
+Note [Generating a correctly typed Rep instance]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+tc_mkRepTy derives the RHS of the Rep(1) type family instance when deriving
+Generic(1). That is, it derives the ellipsis in the following:
+
+    instance Generic Foo where
+      type Rep Foo = ...
+
+However, tc_mkRepTy only has knowledge of the *TyCon* of the type for which
+a Generic(1) instance is being derived, not the fully instantiated type. As a
+result, tc_mkRepTy builds the most generalized Rep(1) instance possible using
+the type variables it learns from the TyCon (i.e., it uses tyConTyVars). This
+can cause problems when the instance has instantiated type variables
+(see Trac #11732). As an example:
+
+    data T a = MkT a
+    deriving instance Generic (T Int)
+    ==>
+    instance Generic (T Int) where
+      type Rep (T Int) = (... (Rec0 a)) -- wrong!
+
+-XStandaloneDeriving is one way for the type variables to become instantiated.
+Another way is when Generic1 is being derived for a datatype with a visible
+kind binder, e.g.,
+
+   data P k (a :: k) = MkP k deriving Generic1
+   ==>
+   instance Generic1 (P *) where
+     type Rep1 (P *) = (... (Rec0 k)) -- wrong!
+
+See Note [Unify kinds in deriving] in TcDeriv.
+
+In any such scenario, we must prevent a discrepancy between the LHS and RHS of
+a Rep(1) instance. To do so, we create a type variable substitution that maps
+the tyConTyVars of the TyCon to their counterparts in the fully instantiated
+type. (For example, using T above as example, you'd map a :-> Int.) We then
+apply the substitution to the RHS before generating the instance.
+
+Note [Handling kinds in a Rep instance]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Because Generic1 is poly-kinded, the representation types were generalized to
+be kind-polymorphic as well. As a result, tc_mkRepTy must explicitly apply
+the kind of the instance being derived to all the representation type
+constructors. For instance, if you have
+
+    data Empty (a :: k) = Empty deriving Generic1
+
+Then the generated code is now approximately (with -fprint-explicit-kinds
+syntax):
+
+    instance Generic1 k (Empty k) where
+      type Rep1 k (Empty k) = U1 k
+
+Most representation types have only one kind variable, making them easy to deal
+with. The only non-trivial case is (:.:), which is only used in Generic1
+instances:
+
+    newtype (:.:) (f :: k2 -> *) (g :: k1 -> k2) (p :: k1) =
+        Comp1 { unComp1 :: f (g p) }
+
+Here, we do something a bit counter-intuitive: we make k1 be the kind of the
+instance being derived, and we always make k2 be *. Why *? It's because
+the code that GHC generates using (:.:) is always of the form x :.: Rec1 y
+for some types x and y. In other words, the second type to which (:.:) is
+applied always has kind k -> *, for some kind k, so k2 cannot possibly be
+anything other than * in a generated Generic1 instance.
+
+Note [Generics compilation speed tricks]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Deriving Generic(1) is known to have a large constant factor during
+compilation, which contributes to noticeable compilation slowdowns when
+deriving Generic(1) for large datatypes (see Trac #5642).
+
+To ease the pain, there is a trick one can play when generating definitions for
+to(1) and from(1). If you have a datatype like:
+
+  data Letter = A | B | C | D
+
+then a na├»ve Generic instance for Letter would be:
+
+  instance Generic Letter where
+    type Rep Letter = D1 ('MetaData ...) ...
+
+    to (M1 (L1 (L1 (M1 U1)))) = A
+    to (M1 (L1 (R1 (M1 U1)))) = B
+    to (M1 (R1 (L1 (M1 U1)))) = C
+    to (M1 (R1 (R1 (M1 U1)))) = D
+
+    from A = M1 (L1 (L1 (M1 U1)))
+    from B = M1 (L1 (R1 (M1 U1)))
+    from C = M1 (R1 (L1 (M1 U1)))
+    from D = M1 (R1 (R1 (M1 U1)))
+
+Notice that in every LHS pattern-match of the 'to' definition, and in every RHS
+expression in the 'from' definition, the topmost constructor is M1. This
+corresponds to the datatype-specific metadata (the D1 in the Rep Letter
+instance). But this is wasteful from a typechecking perspective, since this
+definition requires GHC to typecheck an application of M1 in every single case,
+leading to an O(n) increase in the number of coercions the typechecker has to
+solve, which in turn increases allocations and degrades compilation speed.
+
+Luckily, since the topmost M1 has the exact same type across every case, we can
+factor it out reduce the typechecker's burden:
+
+  instance Generic Letter where
+    type Rep Letter = D1 ('MetaData ...) ...
+
+    to (M1 x) = case x of
+      L1 (L1 (M1 U1)) -> A
+      L1 (R1 (M1 U1)) -> B
+      R1 (L1 (M1 U1)) -> C
+      R1 (R1 (M1 U1)) -> D
+
+    from x = M1 (case x of
+      A -> L1 (L1 (M1 U1))
+      B -> L1 (R1 (M1 U1))
+      C -> R1 (L1 (M1 U1))
+      D -> R1 (R1 (M1 U1)))
+
+A simple change, but one that pays off, since it goes turns an O(n) amount of
+coercions to an O(1) amount.
+-}