[commit: ghc] wip/generics-propeq: actually create the indexed Constr descriptions (711503c)

[git at git.haskell.org]

Repository : ssh://git@git.haskell.org/ghc

On branch  : wip/generics-propeq
Link       : http://ghc.haskell.org/trac/ghc/changeset/711503c6dada380db2ce549281785267a632345d/ghc

>---------------------------------------------------------------

commit 711503c6dada380db2ce549281785267a632345d
Author: Gabor Greif <ggreif at gmail.com>
Date:   Sun Jun 29 13:29:15 2014 +0200

    actually create the indexed Constr descriptions


>---------------------------------------------------------------

711503c6dada380db2ce549281785267a632345d
 compiler/prelude/PrelNames.lhs       | 10 +++++++---
 compiler/typecheck/TcGenGenerics.lhs | 17 +++++++++--------
 2 files changed, 16 insertions(+), 11 deletions(-)

diff --git a/compiler/prelude/PrelNames.lhs b/compiler/prelude/PrelNames.lhs
index 81cba3c..e7408a1 100644
--- a/compiler/prelude/PrelNames.lhs
+++ b/compiler/prelude/PrelNames.lhs
@@ -353,7 +353,7 @@ genericTyConNames = [
     compTyConName, rTyConName, pTyConName, dTyConName,
     cTyConName, sTyConName, rec0TyConName, par0TyConName,
     d1TyConName, c1TyConName, s1TyConName, noSelTyConName,
-    repTyConName, rep1TyConName, datTyConName
+    repTyConName, rep1TyConName, datTyConName, constrTyConName
   ]
 \end{code}
 
@@ -775,7 +775,8 @@ v1TyConName, u1TyConName, par1TyConName, rec1TyConName,
   compTyConName, rTyConName, pTyConName, dTyConName,
   cTyConName, sTyConName, rec0TyConName, par0TyConName,
   d1TyConName, c1TyConName, s1TyConName, noSelTyConName,
-  repTyConName, rep1TyConName, datTyConName :: Name
+  repTyConName, rep1TyConName, datTyConName,
+  constrTyConName :: Name
 
 v1TyConName  = tcQual gHC_GENERICS (fsLit "V1") v1TyConKey
 u1TyConName  = tcQual gHC_GENERICS (fsLit "U1") u1TyConKey
@@ -795,6 +796,7 @@ cTyConName  = tcQual gHC_GENERICS (fsLit "C") cTyConKey
 sTyConName  = tcQual gHC_GENERICS (fsLit "S") sTyConKey
 
 datTyConName  = tcQual gHC_GENERICS (fsLit "Dat") datTyConKey
+constrTyConName  = tcQual gHC_GENERICS (fsLit "Constr") constrTyConKey
 
 rec0TyConName  = tcQual gHC_GENERICS (fsLit "Rec0") rec0TyConKey
 par0TyConName  = tcQual gHC_GENERICS (fsLit "Par0") par0TyConKey
@@ -1458,7 +1460,8 @@ v1TyConKey, u1TyConKey, par1TyConKey, rec1TyConKey,
   compTyConKey, rTyConKey, pTyConKey, dTyConKey,
   cTyConKey, sTyConKey, rec0TyConKey, par0TyConKey,
   d1TyConKey, c1TyConKey, s1TyConKey, noSelTyConKey,
-  repTyConKey, rep1TyConKey, datTyConKey :: Unique
+  repTyConKey, rep1TyConKey, datTyConKey,
+  constrTyConKey :: Unique
 
 v1TyConKey    = mkPreludeTyConUnique 135
 u1TyConKey    = mkPreludeTyConUnique 136
@@ -1487,6 +1490,7 @@ noSelTyConKey = mkPreludeTyConUnique 154
 repTyConKey  = mkPreludeTyConUnique 155
 rep1TyConKey = mkPreludeTyConUnique 156
 datTyConKey = mkPreludeTyConUnique 157
+constrTyConKey = mkPreludeTyConUnique 158
 
 -- Type-level naturals
 typeNatKindConNameKey, typeSymbolKindConNameKey,
diff --git a/compiler/typecheck/TcGenGenerics.lhs b/compiler/typecheck/TcGenGenerics.lhs
index 809434d..1e4d42b 100644
--- a/compiler/typecheck/TcGenGenerics.lhs
+++ b/compiler/typecheck/TcGenGenerics.lhs
@@ -97,10 +97,11 @@ genGenericMetaTyCons tc mod =
       s_names <- forM (zip [0..] tc_arits) $ \(m,a) -> forM [0..a-1] $ \n ->
                     newGlobalBinder mod (s_occ m n) loc
 
-      let metaCTyCons = map (mkTyCon []) c_names
+      c_tycon  <- tcLookupTyCon constrTyConName
+      let metaCTys = map (\name -> mkTyConApp c_tycon [d_type, LitTy . StrTyLit . occNameFS . nameOccName $ name]) c_names
           metaSTyCons = map (map (mkTyCon [])) s_names
 
-          metaDts = MetaTyCons d_type metaCTyCons metaSTyCons
+          metaDts = MetaTyCons d_type metaCTys metaSTyCons
 
       -- pprTrace "rep0" (ppr rep0_tycon) $
       (,) metaDts `fmap` metaTyConsToDerivStuff tc metaDts
@@ -141,7 +142,7 @@ metaTyConsToDerivStuff tc metaDts =
 
         -- Constructor
         c_metaTycons = metaC metaDts
-        c_insts = [ mk_inst cClas (mkTyConTy c) ds
+        c_insts = [ mk_inst cClas c ds
                   | (c, ds) <- myZip1 c_metaTycons c_dfun_names ]
         c_binds = [ InstBindings { ib_binds = c
                                  , ib_pragmas = []
@@ -612,9 +613,9 @@ tc_mkRepTy gk_ tycon metaDts =
 
         -- Sums and products are done in the same way for both Rep and Rep1
         sumP [] = mkTyConTy v1
-        sumP l  = ASSERT(length metaCTyCons == length l)
+        sumP l  = ASSERT(length metaCTys == length l)
                     foldBal mkSum' [ mkC i d a
-                                   | (d,(a,i)) <- zip metaCTyCons (zip l [0..])]
+                                   | (d,(a,i)) <- zip metaCTys (zip l [0..])]
         -- The Bool is True if this constructor has labelled fields
         prod :: Int -> [Type] -> Bool -> Type
         prod i [] _ = ASSERT(length metaSTyCons > i)
@@ -641,7 +642,7 @@ tc_mkRepTy gk_ tycon metaDts =
                ata_rec1 = mkRec1, ata_comp = mkComp}
 
         metaDTy     = metaD metaDts
-        metaCTyCons = map mkTyConTy (metaC metaDts)
+        metaCTys    = metaC metaDts
         metaSTyCons = map (map mkTyConTy) (metaS metaDts)
 
     return (mkD tycon)
@@ -653,7 +654,7 @@ tc_mkRepTy gk_ tycon metaDts =
 data MetaTyCons = MetaTyCons { -- One meta datatype per dataype
                                metaD :: Type
                                -- One meta datatype per constructor
-                             , metaC :: [TyCon]
+                             , metaC :: [Type]
                                -- One meta datatype per selector per constructor
                              , metaS :: [[TyCon]] }
 
@@ -661,7 +662,7 @@ 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 _ c s) = listToBag (c ++ concat s)
+metaTyCons2TyCons (MetaTyCons _ _ s) = listToBag (concat s)
 
 
 -- Bindings for Datatype, Constructor, and Selector instances