[commit: ghc] wip/generics-propeq: clean up (9dc1547)

[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/9dc15479c8ba185218d989ff4715252930c607fb/ghc

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

commit 9dc15479c8ba185218d989ff4715252930c607fb
Author: Gabor Greif <ggreif at gmail.com>
Date:   Sat Jun 28 14:10:06 2014 +0200

    clean up


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

9dc15479c8ba185218d989ff4715252930c607fb
 compiler/typecheck/TcGenGenerics.lhs | 29 +++++++++--------------------
 1 file changed, 9 insertions(+), 20 deletions(-)

diff --git a/compiler/typecheck/TcGenGenerics.lhs b/compiler/typecheck/TcGenGenerics.lhs
index d242218..59bbcad 100644
--- a/compiler/typecheck/TcGenGenerics.lhs
+++ b/compiler/typecheck/TcGenGenerics.lhs
@@ -79,7 +79,6 @@ genGenericMetaTyCons tc mod =
         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
 
@@ -90,20 +89,17 @@ genGenericMetaTyCons tc mod =
                                           False          -- Not GADT syntax
                                           NoParentTyCon
 
-      --d_name  <- newGlobalBinder mod d_occ loc
-      --d_tycon  <- tcLookupTyCon datTyConName -- "Dat"
-      --let d_type = mkTyConApp d_tycon [LitTy . StrTyLit . fsLit $ "HEY!"] -- HEYtcLookupTyCon datTyConName -- "Dat"
-      let d_type d_tycon = mkTyConApp d_tycon [LitTy . StrTyLit $ occNameFS (nameOccName tc_name)] -- HEYtcLookupTyCon datTyConName -- "Dat"
+      d_tycon  <- tcLookupTyCon datTyConName
+      let d_type = mkTyConApp d_tycon [LitTy . StrTyLit $ occNameFS (nameOccName tc_name)]
       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  = d_tycon -- mkTyCon [] d_name
-          metaCTyCons = map (mkTyCon []) c_names
+      let metaCTyCons = map (mkTyCon []) c_names
           metaSTyCons = map (map (mkTyCon [])) s_names
 
-          metaDts = MetaTyCons {-metaDTyCon-}d_type metaCTyCons metaSTyCons
+          metaDts = MetaTyCons d_type metaCTyCons metaSTyCons
 
       -- pprTrace "rep0" (ppr rep0_tycon) $
       (,) metaDts `fmap` metaTyConsToDerivStuff tc metaDts
@@ -113,7 +109,6 @@ metaTyConsToDerivStuff :: TyCon -> MetaTyCons -> TcM BagDerivStuff
 metaTyConsToDerivStuff tc metaDts =
   do  loc <- getSrcSpanM
       dflags <- getDynFlags
-      dat   <- tcLookupTyCon datTyConName -- HERE not good, wrong context!
       dClas <- tcLookupClass datatypeClassName
       let new_dfun_name clas tycon = newDFunName clas [mkTyConApp tycon []] loc
       d_dfun_name <- new_dfun_name dClas tc
@@ -142,9 +137,7 @@ metaTyConsToDerivStuff tc metaDts =
             tys = [ty]
 
         -- Datatype
-        --d_metaTycon = undefined --metaD metaDts
-        --d_inst   = mk_inst dClas d_metaTycon d_dfun_name
-        d_inst   = mk_inst_ty dClas (metaD metaDts dat) d_dfun_name
+        d_inst   = mk_inst_ty dClas (metaD metaDts) d_dfun_name
         d_binds  = InstBindings { ib_binds = dBinds
                                 , ib_pragmas = []
                                 , ib_extensions = []
@@ -607,7 +600,6 @@ tc_mkRepTy gk_ tycon metaDts =
     plus  <- tcLookupTyCon sumTyConName
     times <- tcLookupTyCon prodTyConName
     comp  <- tcLookupTyCon compTyConName
-    dat   <- tcLookupTyCon datTyConName
 
     let mkSum' a b = mkTyConApp plus  [a,b]
         mkProd a b = mkTyConApp times [a,b]
@@ -615,7 +607,7 @@ tc_mkRepTy gk_ tycon metaDts =
         mkRec0 a   = mkTyConApp rec0  [a]
         mkRec1 a   = mkTyConApp rec1  [a]
         mkPar1     = mkTyConTy  par1
-        mkD    a   = mkTyConApp d1    [metaDTyCon dat, sumP (tyConDataCons a)]
+        mkD    a   = mkTyConApp d1    [metaDTy, 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
@@ -653,10 +645,7 @@ tc_mkRepTy gk_ tycon metaDts =
               {ata_rec0 = mkRec0, ata_par1 = mkPar1,
                ata_rec1 = mkRec1, ata_comp = mkComp}
 
-
-        --metaDTyCon  = mkTyConTy (metaD metaDts)
-        --metaDTyCon  = TyConApp (metaD metaDts) [LitTy . StrTyLit . fsLit $ "HEY!"]
-        metaDTyCon  = metaD metaDts --mkTyConApp (metaD metaDts) [LitTy . StrTyLit . fsLit $ "HEY!"]
+        metaDTy     = metaD metaDts
         metaCTyCons = map mkTyConTy (metaC metaDts)
         metaSTyCons = map (map mkTyConTy) (metaS metaDts)
 
@@ -667,14 +656,14 @@ tc_mkRepTy gk_ tycon metaDts =
 --------------------------------------------------------------------------------
 
 data MetaTyCons = MetaTyCons { -- One meta datatype per dataype
-                               metaD :: TyCon -> Type --TyCon
+                               metaD :: Type
                                -- 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))
+  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)