Use TypeLits in the meta-data encoding of GHC.Generics

Test Plan: Validate.

Reviewers: simonpj, goldfire, hvr, dreixel, kosmikus, austin, bgamari

Reviewed By: kosmikus, austin, bgamari

Subscribers: RyanGlScott, Fuuzetsu, bgamari, thomie, carter, dreixel

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

GHC Trac Issues: #9766

4 files changed, 146 insertions, 316 deletions

diff --git a/compiler/prelude/PrelNames.hs b/compiler/prelude/PrelNames.hs
index 11d7d191ff..057e96dbd4 100644
--- a/compiler/prelude/PrelNames.hs
+++ b/compiler/prelude/PrelNames.hs
@@ -380,12 +380,16 @@ genericTyConNames :: [Name]
 genericTyConNames = [
     v1TyConName, u1TyConName, par1TyConName, rec1TyConName,
     k1TyConName, m1TyConName, sumTyConName, prodTyConName,
-    compTyConName, rTyConName, pTyConName, dTyConName,
-    cTyConName, sTyConName, rec0TyConName, par0TyConName,
+    compTyConName, rTyConName, dTyConName,
+    cTyConName, sTyConName, rec0TyConName,
     d1TyConName, c1TyConName, s1TyConName, noSelTyConName,
     repTyConName, rep1TyConName, uRecTyConName,
     uAddrTyConName, uCharTyConName, uDoubleTyConName,
-    uFloatTyConName, uIntTyConName, uWordTyConName
+    uFloatTyConName, uIntTyConName, uWordTyConName,
+    prefixIDataConName, infixIDataConName, leftAssociativeDataConName,
+    rightAssociativeDataConName, notAssociativeDataConName,
+    metaDataDataConName, metaConsDataConName,
+    metaSelDataConName, metaNoSelDataConName
   ]
 
 {-
@@ -702,8 +706,7 @@ u1DataCon_RDR, par1DataCon_RDR, rec1DataCon_RDR,
   unPar1_RDR, unRec1_RDR, unK1_RDR, unComp1_RDR,
   from_RDR, from1_RDR, to_RDR, to1_RDR,
   datatypeName_RDR, moduleName_RDR, packageName_RDR, isNewtypeName_RDR,
-  conName_RDR, conFixity_RDR, conIsRecord_RDR,
-  noArityDataCon_RDR, arityDataCon_RDR, selName_RDR,
+  conName_RDR, conFixity_RDR, conIsRecord_RDR, selName_RDR,
   prefixDataCon_RDR, infixDataCon_RDR, leftAssocDataCon_RDR,
   rightAssocDataCon_RDR, notAssocDataCon_RDR,
   uAddrDataCon_RDR, uCharDataCon_RDR, uDoubleDataCon_RDR,
@@ -742,8 +745,6 @@ conName_RDR       = varQual_RDR gHC_GENERICS (fsLit "conName")
 conFixity_RDR     = varQual_RDR gHC_GENERICS (fsLit "conFixity")
 conIsRecord_RDR   = varQual_RDR gHC_GENERICS (fsLit "conIsRecord")
 
-noArityDataCon_RDR    = dataQual_RDR gHC_GENERICS (fsLit "NoArity")
-arityDataCon_RDR      = dataQual_RDR gHC_GENERICS (fsLit "Arity")
 prefixDataCon_RDR     = dataQual_RDR gHC_GENERICS (fsLit "Prefix")
 infixDataCon_RDR      = dataQual_RDR gHC_GENERICS (fsLit "Infix")
 leftAssocDataCon_RDR  = dataQual_RDR gHC_GENERICS (fsLit "LeftAssociative")
@@ -854,12 +855,16 @@ rightDataConName  = dcQual dATA_EITHER (fsLit "Right")  rightDataConKey
 -- Generics (types)
 v1TyConName, u1TyConName, par1TyConName, rec1TyConName,
   k1TyConName, m1TyConName, sumTyConName, prodTyConName,
-  compTyConName, rTyConName, pTyConName, dTyConName,
-  cTyConName, sTyConName, rec0TyConName, par0TyConName,
+  compTyConName, rTyConName, dTyConName,
+  cTyConName, sTyConName, rec0TyConName,
   d1TyConName, c1TyConName, s1TyConName, noSelTyConName,
   repTyConName, rep1TyConName, uRecTyConName,
   uAddrTyConName, uCharTyConName, uDoubleTyConName,
-  uFloatTyConName, uIntTyConName, uWordTyConName :: Name
+  uFloatTyConName, uIntTyConName, uWordTyConName,
+  prefixIDataConName, infixIDataConName, leftAssociativeDataConName,
+  rightAssociativeDataConName, notAssociativeDataConName,
+  metaDataDataConName, metaConsDataConName,
+  metaSelDataConName, metaNoSelDataConName :: Name
 
 v1TyConName  = tcQual gHC_GENERICS (fsLit "V1") v1TyConKey
 u1TyConName  = tcQual gHC_GENERICS (fsLit "U1") u1TyConKey
@@ -873,13 +878,11 @@ prodTyConName   = tcQual gHC_GENERICS (fsLit ":*:") prodTyConKey
 compTyConName   = tcQual gHC_GENERICS (fsLit ":.:") compTyConKey
 
 rTyConName  = tcQual gHC_GENERICS (fsLit "R") rTyConKey
-pTyConName  = tcQual gHC_GENERICS (fsLit "P") pTyConKey
 dTyConName  = tcQual gHC_GENERICS (fsLit "D") dTyConKey
 cTyConName  = tcQual gHC_GENERICS (fsLit "C") cTyConKey
 sTyConName  = tcQual gHC_GENERICS (fsLit "S") sTyConKey
 
 rec0TyConName  = tcQual gHC_GENERICS (fsLit "Rec0") rec0TyConKey
-par0TyConName  = tcQual gHC_GENERICS (fsLit "Par0") par0TyConKey
 d1TyConName  = tcQual gHC_GENERICS (fsLit "D1") d1TyConKey
 c1TyConName  = tcQual gHC_GENERICS (fsLit "C1") c1TyConKey
 s1TyConName  = tcQual gHC_GENERICS (fsLit "S1") s1TyConKey
@@ -896,6 +899,17 @@ uFloatTyConName    = tcQual gHC_GENERICS (fsLit "UFloat") uFloatTyConKey
 uIntTyConName      = tcQual gHC_GENERICS (fsLit "UInt") uIntTyConKey
 uWordTyConName     = tcQual gHC_GENERICS (fsLit "UWord") uWordTyConKey
 
+prefixIDataConName = dcQual gHC_GENERICS (fsLit "PrefixI")  prefixIDataConKey
+infixIDataConName  = dcQual gHC_GENERICS (fsLit "InfixI")   infixIDataConKey
+leftAssociativeDataConName  = dcQual gHC_GENERICS (fsLit "LeftAssociative")   leftAssociativeDataConKey
+rightAssociativeDataConName = dcQual gHC_GENERICS (fsLit "RightAssociative")  rightAssociativeDataConKey
+notAssociativeDataConName   = dcQual gHC_GENERICS (fsLit "NotAssociative")    notAssociativeDataConKey
+
+metaDataDataConName  = dcQual gHC_GENERICS (fsLit "MetaData")  metaDataDataConKey
+metaConsDataConName  = dcQual gHC_GENERICS (fsLit "MetaCons")  metaConsDataConKey
+metaSelDataConName   = dcQual gHC_GENERICS (fsLit "MetaSel")   metaSelDataConKey
+metaNoSelDataConName = dcQual gHC_GENERICS (fsLit "MetaNoSel") metaNoSelDataConKey
+
 -- Base strings Strings
 unpackCStringName, unpackCStringFoldrName,
     unpackCStringUtf8Name, eqStringName :: Name
@@ -1607,8 +1621,8 @@ opaqueTyConKey                          = mkPreludeTyConUnique 133
 -- Generics (Unique keys)
 v1TyConKey, u1TyConKey, par1TyConKey, rec1TyConKey,
   k1TyConKey, m1TyConKey, sumTyConKey, prodTyConKey,
-  compTyConKey, rTyConKey, pTyConKey, dTyConKey,
-  cTyConKey, sTyConKey, rec0TyConKey, par0TyConKey,
+  compTyConKey, rTyConKey, dTyConKey,
+  cTyConKey, sTyConKey, rec0TyConKey,
   d1TyConKey, c1TyConKey, s1TyConKey, noSelTyConKey,
   repTyConKey, rep1TyConKey, uRecTyConKey,
   uAddrTyConKey, uCharTyConKey, uDoubleTyConKey,
@@ -1626,13 +1640,11 @@ prodTyConKey  = mkPreludeTyConUnique 142
 compTyConKey  = mkPreludeTyConUnique 143
 
 rTyConKey = mkPreludeTyConUnique 144
-pTyConKey = mkPreludeTyConUnique 145
 dTyConKey = mkPreludeTyConUnique 146
 cTyConKey = mkPreludeTyConUnique 147
 sTyConKey = mkPreludeTyConUnique 148
 
 rec0TyConKey  = mkPreludeTyConUnique 149
-par0TyConKey  = mkPreludeTyConUnique 150
 d1TyConKey    = mkPreludeTyConUnique 151
 c1TyConKey    = mkPreludeTyConUnique 152
 s1TyConKey    = mkPreludeTyConUnique 153
@@ -1729,6 +1741,7 @@ charDataConKey, consDataConKey, doubleDataConKey, falseDataConKey,
     ratioDataConKey, stableNameDataConKey, trueDataConKey, wordDataConKey,
     word8DataConKey, ioDataConKey, integerDataConKey, eqBoxDataConKey,
     coercibleDataConKey, nothingDataConKey, justDataConKey :: Unique
+
 charDataConKey                          = mkPreludeDataConUnique  1
 consDataConKey                          = mkPreludeDataConUnique  2
 doubleDataConKey                        = mkPreludeDataConUnique  3
@@ -1801,6 +1814,20 @@ typeErrorAppendDataConKey               = mkPreludeDataConUnique 51
 typeErrorVAppendDataConKey              = mkPreludeDataConUnique 52
 typeErrorShowTypeDataConKey             = mkPreludeDataConUnique 53
 
+prefixIDataConKey, infixIDataConKey, leftAssociativeDataConKey,
+    rightAssociativeDataConKey, notAssociativeDataConKey,
+    metaDataDataConKey, metaConsDataConKey,
+    metaSelDataConKey, metaNoSelDataConKey :: Unique
+prefixIDataConKey                       = mkPreludeDataConUnique 54
+infixIDataConKey                        = mkPreludeDataConUnique 55
+leftAssociativeDataConKey               = mkPreludeDataConUnique 56
+rightAssociativeDataConKey              = mkPreludeDataConUnique 57
+notAssociativeDataConKey                = mkPreludeDataConUnique 58
+metaDataDataConKey                      = mkPreludeDataConUnique 59
+metaConsDataConKey                      = mkPreludeDataConUnique 60
+metaSelDataConKey                       = mkPreludeDataConUnique 61
+metaNoSelDataConKey                     = mkPreludeDataConUnique 62
+
 ---------------- Template Haskell -------------------
 --      THNames.hs: USES DataUniques 100-150
 -----------------------------------------------------
diff --git a/compiler/typecheck/TcDeriv.hs b/compiler/typecheck/TcDeriv.hs
index 9944831b4c..44e8564fe1 100644
--- a/compiler/typecheck/TcDeriv.hs
+++ b/compiler/typecheck/TcDeriv.hs
@@ -47,7 +47,6 @@ import DataCon
 import Maybes
 import RdrName
 import Name
-import NameEnv
 import NameSet
 import TyCon
 import TcType
@@ -147,10 +146,6 @@ data EarlyDerivSpec = InferTheta (DerivSpec ThetaOrigin)
         -- GivenTheta ds => the exact context for the instance is supplied
         --                  by the programmer; it is ds_theta
 
-forgetTheta :: EarlyDerivSpec -> DerivSpec ()
-forgetTheta (InferTheta spec) = spec { ds_theta = () }
-forgetTheta (GivenTheta spec) = spec { ds_theta = () }
-
 earlyDSLoc :: EarlyDerivSpec -> SrcSpan
 earlyDSLoc (InferTheta spec) = ds_loc spec
 earlyDSLoc (GivenTheta spec) = ds_loc spec
@@ -381,25 +376,20 @@ tcDeriving deriv_infos deriv_decls
         ; early_specs <- makeDerivSpecs is_boot deriv_infos deriv_decls
         ; traceTc "tcDeriving 1" (ppr early_specs)
 
-        -- for each type, determine the auxliary declarations that are common
-        -- to multiple derivations involving that type (e.g. Generic and
-        -- Generic1 should use the same TcGenGenerics.MetaTyCons)
-        ; (commonAuxs, auxDerivStuff) <- commonAuxiliaries $ map forgetTheta early_specs
-
         ; let (infer_specs, given_specs) = splitEarlyDerivSpec early_specs
-        ; insts1 <- mapM (genInst commonAuxs) given_specs
+        ; insts1 <- mapM genInst given_specs
 
         -- the stand-alone derived instances (@insts1@) are used when inferring
         -- the contexts for "deriving" clauses' instances (@infer_specs@)
         ; final_specs <- extendLocalInstEnv (map (iSpec . fstOf3) insts1) $
                          inferInstanceContexts infer_specs
 
-        ; insts2 <- mapM (genInst commonAuxs) final_specs
+        ; insts2 <- mapM genInst final_specs
 
         ; let (inst_infos, deriv_stuff, maybe_fvs) = unzip3 (insts1 ++ insts2)
         ; loc <- getSrcSpanM
-        ; let (binds, newTyCons, famInsts, extraInstances) =
-                genAuxBinds loc (unionManyBags (auxDerivStuff : deriv_stuff))
+        ; let (binds, famInsts, extraInstances) =
+                genAuxBinds loc (unionManyBags deriv_stuff)
 
         ; dflags <- getDynFlags
 
@@ -408,29 +398,22 @@ tcDeriving deriv_infos deriv_decls
 
         ; unless (isEmptyBag inst_info) $
              liftIO (dumpIfSet_dyn dflags Opt_D_dump_deriv "Derived instances"
-                        (ddump_deriving inst_info rn_binds newTyCons famInsts))
+                        (ddump_deriving inst_info rn_binds famInsts))
 
-        ; let all_tycons = bagToList newTyCons
-        ; gbl_env <- tcExtendTyConEnv all_tycons $
-                     tcExtendGlobalEnvImplicit (concatMap implicitTyConThings all_tycons) $
-                     tcExtendLocalFamInstEnv (bagToList famInsts) $
+        ; gbl_env <- tcExtendLocalFamInstEnv (bagToList famInsts) $
                      tcExtendLocalInstEnv (map iSpec (bagToList inst_info)) getGblEnv
         ; let all_dus = rn_dus `plusDU` usesOnly (mkFVs $ catMaybes maybe_fvs)
         ; return (addTcgDUs gbl_env all_dus, inst_info, rn_binds) }
   where
     ddump_deriving :: Bag (InstInfo Name) -> HsValBinds Name
-                   -> Bag TyCon               -- ^ Empty data constructors
                    -> Bag FamInst             -- ^ Rep type family instances
                    -> SDoc
-    ddump_deriving inst_infos extra_binds repMetaTys repFamInsts
+    ddump_deriving inst_infos extra_binds repFamInsts
       =    hang (ptext (sLit "Derived instances:"))
               2 (vcat (map (\i -> pprInstInfoDetails i $$ text "") (bagToList inst_infos))
                  $$ ppr extra_binds)
-        $$ hangP "Generic representation:" (
-              hangP "Generated datatypes for meta-information:"
-               (vcat (map ppr (bagToList repMetaTys)))
-           $$ hangP "Representation types:"
-                (vcat (map pprRepTy (bagToList repFamInsts))))
+        $$ hangP "GHC.Generics representation types:"
+             (vcat (map pprRepTy (bagToList repFamInsts)))
 
     hangP s x = text "" $$ hang (ptext (sLit s)) 2 x
 
@@ -441,27 +424,6 @@ pprRepTy fi@(FamInst { fi_tys = lhs })
       equals <+> ppr rhs
   where rhs = famInstRHS fi
 
--- As of 24 April 2012, this only shares MetaTyCons between derivations of
--- Generic and Generic1; thus the types and logic are quite simple.
-type CommonAuxiliary = MetaTyCons
-type CommonAuxiliaries = NameEnv CommonAuxiliary
-
-commonAuxiliaries :: [DerivSpec ()] -> TcM (CommonAuxiliaries, BagDerivStuff)
-commonAuxiliaries = foldM snoc (emptyNameEnv, emptyBag) where
-  snoc :: (CommonAuxiliaries, BagDerivStuff)
-       -> DerivSpec () -> TcM (CommonAuxiliaries, BagDerivStuff)
-  snoc acc@(cas, stuff) (DS {ds_cls = cls, ds_tc = rep_tycon})
-    | getUnique cls `elem` [genClassKey, gen1ClassKey] =
-      extendComAux $ genGenericMetaTyCons rep_tycon
-    | otherwise = return acc
-   where extendComAux :: TcM (MetaTyCons, BagDerivStuff)
-                      -> TcM (CommonAuxiliaries, BagDerivStuff)
-         extendComAux m -- don't run m if its already in the accumulator
-           | elemNameEnv (tyConName rep_tycon) cas = return acc
-           | otherwise = do (ca, new_stuff) <- m
-                            return ( extendNameEnv cas (tyConName rep_tycon) ca
-                                   , stuff `unionBags` new_stuff)
-
 renameDeriv :: Bool
             -> [InstInfo RdrName]
             -> Bag (LHsBind RdrName, LSig RdrName)
@@ -1955,11 +1917,9 @@ the renamer.  What a great hack!
 -- Representation tycons differ from the tycon in the instance signature in
 -- case of instances for indexed families.
 --
-genInst :: CommonAuxiliaries
-        -> DerivSpec ThetaType
+genInst :: DerivSpec ThetaType
         -> TcM (InstInfo RdrName, BagDerivStuff, Maybe Name)
-genInst comauxs
-        spec@(DS { ds_tvs = tvs, ds_tc = rep_tycon, ds_tc_args = rep_tc_args
+genInst spec@(DS { ds_tvs = tvs, ds_tc = rep_tycon, ds_tc_args = rep_tc_args
                  , ds_theta = theta, ds_newtype = is_newtype, ds_tys = tys
                  , ds_name = dfun_name, ds_cls = clas, ds_loc = loc })
   | is_newtype   -- See Note [Bindings for Generalised Newtype Deriving]
@@ -1982,8 +1942,6 @@ genInst comauxs
   = do { (meth_binds, deriv_stuff) <- genDerivStuff loc clas
                                         dfun_name rep_tycon
                                         tys tvs
-                                        (lookupNameEnv comauxs
-                                                       (tyConName rep_tycon))
        ; inst_spec <- newDerivClsInst theta spec
        ; traceTc "newder" (ppr inst_spec)
        ; let inst_info = InstInfo { iSpec   = inst_spec
@@ -2000,17 +1958,15 @@ genInst comauxs
 -- Generate the bindings needed for a derived class that isn't handled by
 -- -XGeneralizedNewtypeDeriving.
 genDerivStuff :: SrcSpan -> Class -> Name -> TyCon -> [Type] -> [TyVar]
-              -> Maybe CommonAuxiliary
               -> TcM (LHsBinds RdrName, BagDerivStuff)
-genDerivStuff loc clas dfun_name tycon inst_tys tyvars comaux_maybe
+genDerivStuff loc clas dfun_name tycon inst_tys tyvars
   -- Special case for DeriveGeneric
   | let ck = classKey clas
-  ,
-    Just gk <- lookup ck [(genClassKey, Gen0), (gen1ClassKey, Gen1)]
-  = let -- TODO NSF: correctly identify when we're building Both instead of One
-        Just metaTyCons = comaux_maybe -- well-guarded by commonAuxiliaries and genInst
+  , ck `elem` [genClassKey, gen1ClassKey]
+  = let gk = if ck == genClassKey then Gen0 else Gen1
+        -- TODO NSF: correctly identify when we're building Both instead of One
     in do
-      (binds, faminst) <- gen_Generic_binds gk tycon metaTyCons (nameModule dfun_name)
+      (binds, faminst) <- gen_Generic_binds gk tycon (nameModule dfun_name)
       return (binds, unitBag (DerivFamInst faminst))
 
   -- Not deriving Generic(1), so we first check if the compiler has built-in
diff --git a/compiler/typecheck/TcGenDeriv.hs b/compiler/typecheck/TcGenDeriv.hs
index bba0abac3b..88c48300d0 100644
--- a/compiler/typecheck/TcGenDeriv.hs
+++ b/compiler/typecheck/TcGenDeriv.hs
@@ -89,7 +89,6 @@ data DerivStuff     -- Please add this auxiliary stuff
   = DerivAuxBind AuxBindSpec
 
   -- Generics
-  | DerivTyCon TyCon                   -- New data types
   | DerivFamInst FamInst               -- New type family instances
 
   -- New top-level auxiliary bindings
@@ -2103,7 +2102,6 @@ genAuxBindSpec loc (DerivMaxTag tycon)
 type SeparateBagsDerivStuff = -- AuxBinds and SYB bindings
                               ( Bag (LHsBind RdrName, LSig RdrName)
                                 -- Extra bindings (used by Generic only)
-                              , Bag TyCon   -- Extra top-level datatypes
                               , Bag (FamInst)           -- Extra family instances
                               , Bag (InstInfo RdrName)) -- Extra instances
 
@@ -2118,18 +2116,16 @@ genAuxBinds loc b = genAuxBinds' b2 where
 
   genAuxBinds' :: BagDerivStuff -> SeparateBagsDerivStuff
   genAuxBinds' = foldrBag f ( mapBag (genAuxBindSpec loc) (rm_dups b1)
-                            , emptyBag, emptyBag, emptyBag)
+                            , emptyBag, emptyBag)
   f :: DerivStuff -> SeparateBagsDerivStuff -> SeparateBagsDerivStuff
   f (DerivAuxBind _) = panic "genAuxBinds'" -- We have removed these before
   f (DerivHsBind  b) = add1 b
-  f (DerivTyCon   t) = add2 t
-  f (DerivFamInst t) = add3 t
-  f (DerivInst    i) = add4 i
-
-  add1 x (a,b,c,d) = (x `consBag` a,b,c,d)
-  add2 x (a,b,c,d) = (a,x `consBag` b,c,d)
-  add3 x (a,b,c,d) = (a,b,x `consBag` c,d)
-  add4 x (a,b,c,d) = (a,b,c,x `consBag` d)
+  f (DerivFamInst t) = add2 t
+  f (DerivInst    i) = add3 i
+
+  add1 x (a,b,c) = (x `consBag` a,b,c)
+  add2 x (a,b,c) = (a,x `consBag` b,c)
+  add3 x (a,b,c) = (a,b,x `consBag` c)
 
 mk_data_type_name :: TyCon -> RdrName   -- "$tT"
 mk_data_type_name tycon = mkAuxBinderName (tyConName tycon) mkDataTOcc
diff --git a/compiler/typecheck/TcGenGenerics.hs b/compiler/typecheck/TcGenGenerics.hs
index acb39de9e1..2c5b80ef03 100644
--- a/compiler/typecheck/TcGenGenerics.hs
+++ b/compiler/typecheck/TcGenGenerics.hs
@@ -11,7 +11,6 @@ The deriving code for the Generic class
 
 module TcGenGenerics (canDoGenerics, canDoGenerics1,
                       GenericKind(..),
-                      MetaTyCons, genGenericMetaTyCons,
                       gen_Generic_binds, get_gen1_constrained_tys) where
 
 import HsSyn
@@ -23,10 +22,11 @@ import DataCon
 import TyCon
 import FamInstEnv       ( FamInst, FamFlavor(..), mkSingleCoAxiom )
 import FamInst
-import Module           ( Module, moduleName, moduleNameString
-                        , moduleUnitId, unitIdString, getModule )
+import Module           ( Module, moduleName, moduleNameFS
+                        , moduleUnitId, unitIdFS )
 import IfaceEnv         ( newGlobalBinder )
 import Name      hiding ( varName )
+import NameEnv ( lookupNameEnv )
 import RdrName
 import BasicTypes
 import TysPrim
@@ -36,16 +36,14 @@ import TcEnv
 import TcRnMonad
 import HscTypes
 import ErrUtils( Validity(..), andValid )
-import BuildTyCl
 import SrcLoc
 import Bag
-import Inst
 import VarSet (elemVarSet)
 import Outputable
 import FastString
 import Util
 
-import Control.Monad (mplus,forM)
+import Control.Monad (mplus)
 import Data.Maybe (isJust)
 
 #include "HsVersions.h"
@@ -65,118 +63,12 @@ For the generic representation we need to generate:
 \end{itemize}
 -}
 
-gen_Generic_binds :: GenericKind -> TyCon -> MetaTyCons -> Module
+gen_Generic_binds :: GenericKind -> TyCon -> Module
                  -> TcM (LHsBinds RdrName, FamInst)
-gen_Generic_binds gk tc metaTyCons mod = do
-  repTyInsts <- tc_mkRepFamInsts gk tc metaTyCons mod
+gen_Generic_binds gk tc mod = do
+  repTyInsts <- tc_mkRepFamInsts gk tc mod
   return (mkBindsRep gk tc, repTyInsts)
 
-genGenericMetaTyCons :: TyCon -> TcM (MetaTyCons, BagDerivStuff)
-genGenericMetaTyCons tc =
-  do  let tc_name   = tyConName tc
-      ty_rep_name <- newTyConRepName tc_name
-      let mod       = nameModule tc_name
-          tc_cons   = tyConDataCons tc
-          tc_arits  = map dataConSourceArity tc_cons
-
-          tc_occ    = nameOccName tc_name
-          d_occ     = mkGenD mod tc_occ
-          c_occ m   = mkGenC mod tc_occ m
-          s_occ m n = mkGenS mod tc_occ m n
-
-          mkTyCon name = ASSERT( isExternalName name )
-                         buildAlgTyCon name [] [] Nothing [] distinctAbstractTyConRhs
-                                            NonRecursive
-                                            False          -- Not promotable
-                                            False          -- Not GADT syntax
-                                            (VanillaAlgTyCon ty_rep_name)
-
-      loc <- getSrcSpanM
-      -- we generate new names in current module
-      currentMod <- getModule
-      d_name  <- newGlobalBinder currentMod d_occ loc
-      c_names <- forM (zip [0..] tc_cons) $ \(m,_) ->
-                    newGlobalBinder currentMod (c_occ m) loc
-      s_names <- forM (zip [0..] tc_arits) $ \(m,a) -> forM [0..a-1] $ \n ->
-                    newGlobalBinder currentMod (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
-
-      (,) metaDts `fmap` metaTyConsToDerivStuff tc metaDts
-
--- both the tycon declarations and related instances
-metaTyConsToDerivStuff :: TyCon -> MetaTyCons -> TcM BagDerivStuff
-metaTyConsToDerivStuff tc metaDts =
-  do  dClas <- tcLookupClass datatypeClassName
-      d_dfun_name <- newDFunName' dClas tc
-      cClas <- tcLookupClass constructorClassName
-      c_dfun_names <- sequence [ (conTy,) <$> newDFunName' cClas tc
-                               | conTy <- metaC metaDts ]
-      sClas <- tcLookupClass selectorClassName
-      s_dfun_names <-
-        sequence (map sequence [ [ (selector,) <$> newDFunName' sClas tc
-                                 | selector <- selectors ]
-                               | selectors <- metaS metaDts ])
-      fix_env <- getFixityEnv
-
-      let
-        (dBinds,cBinds,sBinds) = mkBindsMetaD fix_env tc
-        mk_inst clas tc dfun_name
-          = newClsInst (Just (NoOverlap "")) dfun_name [] [] clas tys
-          where
-            tys = [mkTyConTy tc]
-
-
-      let d_metaTycon = metaD metaDts
-      d_inst <- mk_inst dClas d_metaTycon d_dfun_name
-      c_insts <- sequence [ mk_inst cClas c ds | (c, ds) <- c_dfun_names ]
-      s_insts <- mapM (mapM (\(s,ds) -> mk_inst sClas s ds)) s_dfun_names
-
-      let
-        -- Datatype
-        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_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_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)
-
 {-
 ************************************************************************
 *                                                                      *
@@ -430,7 +322,6 @@ 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 =
@@ -464,10 +355,9 @@ mkBindsRep gk tycon =
 
 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 gk tycon mod =
        -- 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 }
@@ -500,7 +390,7 @@ tc_mkRepFamInsts gk tycon metaDts mod =
                      Nothing -> [mkTyConApp tycon tyvar_args]
 
        -- `repTy` = D1 ... (C1 ... (S1 ... (Rec0 a))) :: * -> *
-     ; repTy <- tc_mkRepTy gk_ tycon metaDts
+     ; repTy <- tc_mkRepTy gk_ tycon
 
        -- `rep_name` is a name we generate for the synonym
      ; rep_name <- let mkGen = case gk of Gen0 -> mkGenR; Gen1 -> mkGen1R
@@ -583,16 +473,13 @@ tc_mkRepTy ::  -- Gen0_ or Gen1_, for Rep or Rep1
                GenericKind_
               -- The type to generate representation for
             -> TyCon
-               -- Metadata datatypes to refer to
-            -> MetaTyCons
                -- Generated representation0 type
             -> TcM Type
-tc_mkRepTy gk_ tycon metaDts =
+tc_mkRepTy gk_ tycon =
   do
     d1      <- tcLookupTyCon d1TyConName
     c1      <- tcLookupTyCon c1TyConName
     s1      <- tcLookupTyCon s1TyConName
-    nS1     <- tcLookupTyCon noSelTyConName
     rec0    <- tcLookupTyCon rec0TyConName
     rec1    <- tcLookupTyCon rec1TyConName
     par1    <- tcLookupTyCon par1TyConName
@@ -608,37 +495,46 @@ tc_mkRepTy gk_ tycon metaDts =
     uInt    <- tcLookupTyCon uIntTyConName
     uWord   <- tcLookupTyCon uWordTyConName
 
+    let tcLookupPromDataCon = fmap promoteDataCon . tcLookupDataCon
+
+    md      <- tcLookupPromDataCon metaDataDataConName
+    mc      <- tcLookupPromDataCon metaConsDataConName
+    ms      <- tcLookupPromDataCon metaSelDataConName
+    mns     <- tcLookupPromDataCon metaNoSelDataConName
+    pPrefix <- tcLookupPromDataCon prefixIDataConName
+    pInfix  <- tcLookupPromDataCon infixIDataConName
+    pLA     <- tcLookupPromDataCon leftAssociativeDataConName
+    pRA     <- tcLookupPromDataCon rightAssociativeDataConName
+    pNA     <- tcLookupPromDataCon notAssociativeDataConName
+
+    fix_env <- getFixityEnv
+
     let mkSum' a b = mkTyConApp plus  [a,b]
         mkProd a b = mkTyConApp times [a,b]
         mkComp a b = mkTyConApp comp  [a,b]
         mkRec0 a   = mkBoxTy uAddr uChar uDouble uFloat uInt uWord rec0 a
         mkRec1 a   = mkTyConApp rec1  [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 [ metaDataTy, sumP (tyConDataCons a) ]
+        mkC      a = mkTyConApp c1 [ metaConsTy a
+                                   , prod (dataConInstOrigArgTys a
+                                            . mkTyVarTys . tyConTyVars $ tycon)
+                                          (dataConFieldLabels a)]
+        mkS mlbl a = mkTyConApp s1 [metaSelTy mlbl, 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 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] -> [FieldLabel] -> Type
+        prod [] _ = mkTyConTy u1
+        prod l fl = foldBal mkProd [ ASSERT(null fl || length fl > j)
+                                     arg t (if null fl then Nothing
+                                                       else Just (fl !! j))
+                                   | (t,j) <- zip l [0..] ]
+
+        arg :: Type -> Maybe FieldLabel -> Type
+        arg t fl = mkS fl $ 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
@@ -646,16 +542,49 @@ 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}
 
+        tyConName_user = case tyConFamInst_maybe tycon of
+                           Just (ptycon, _) -> tyConName ptycon
+                           Nothing          -> tyConName tycon
 
-        metaDTyCon  = mkTyConTy (metaD metaDts)
-        metaCTyCons = map mkTyConTy (metaC metaDts)
-        metaSTyCons = map (map mkTyConTy) (metaS metaDts)
+        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 = case myLookupFixity fix_env (dataConName c) of
+                    Just (Fixity n InfixL) -> buildFix n pLA
+                    Just (Fixity n InfixR) -> buildFix n pRA
+                    Just (Fixity n InfixN) -> buildFix n pNA
+                    Nothing                -> mkTyConTy pPrefix
+        buildFix n assoc = mkTyConApp pInfix [ mkTyConTy assoc
+                                             , mkNumLitTy (fromIntegral n)]
+
+        myLookupFixity :: FixityEnv -> Name -> Maybe Fixity
+        myLookupFixity env n = case lookupNameEnv env n of
+                                 Just (FixItem _ fix) -> Just fix
+                                 Nothing              -> Nothing
+
+        isRec c = mkTyConTy $ if length (dataConFieldLabels c) > 0
+                              then promotedTrueDataCon
+                              else promotedFalseDataCon
+
+        selName = mkStrLitTy . flLabel
+
+        metaDataTy   = mkTyConApp md [dtName, mdName, pkgName, isNT]
+        metaConsTy c = mkTyConApp mc [ctName c, ctFix c, isRec c]
+        metaSelTy Nothing  = mkTyConTy mns
+        metaSelTy (Just s) = mkTyConApp ms [selName s]
 
     return (mkD tycon)
 
@@ -682,84 +611,6 @@ mkBoxTy uAddr uChar uDouble uFloat uInt uWord rec0 ty
   | otherwise          = mkTyConApp rec0 [ty]
 
 --------------------------------------------------------------------------------
--- 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)
-                                , (packageName_RDR, pkgName_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
-
-        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
-        pkgName_matches    = mkStringLHS . unitIdString . moduleUnitId
-                           . nameModule . tyConName $ tycon
-        isNewtype_matches  = [mkSimpleHsAlt nlWildPat (nlHsVar true_RDR)]
-
-        conName_matches     c = mkStringLHS . occNameString . nameOccName
-                              . dataConName $ c
-        conFixity_matches   c = [mkSimpleHsAlt nlWildPat (fixity c)]
-        conIsRecord_matches _ = [mkSimpleHsAlt nlWildPat (nlHsVar true_RDR)]
-
-        selName_matches    fl = mkStringLHS (unpackFS (flLabel fl))
-
-
---------------------------------------------------------------------------------
 -- Dealing with sums
 --------------------------------------------------------------------------------
 
@@ -851,10 +702,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