[commit: ghc] wip/generics-propeq-conservative: get roles right and fix a FIXME (cc618e6)

[git at git.haskell.org]

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

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

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

commit cc618e6de25fda149b7153141895ca942e5f8935
Author: Gabor Greif <ggreif at gmail.com>
Date:   Tue Sep 16 07:22:52 2014 +0200

    get roles right and fix a FIXME


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

cc618e6de25fda149b7153141895ca942e5f8935
 compiler/typecheck/TcGenGenerics.lhs | 33 +++++++++++++++++----------------
 1 file changed, 17 insertions(+), 16 deletions(-)

diff --git a/compiler/typecheck/TcGenGenerics.lhs b/compiler/typecheck/TcGenGenerics.lhs
index 158a1e7..1d0739e 100644
--- a/compiler/typecheck/TcGenGenerics.lhs
+++ b/compiler/typecheck/TcGenGenerics.lhs
@@ -17,6 +17,7 @@ module TcGenGenerics (canDoGenerics, canDoGenerics1,
 import DynFlags
 import HsSyn
 import Type
+import TypeRep          ( Type( TyConApp ) )
 import Kind             ( isKind )
 import TcType
 import TcGenDeriv
@@ -83,12 +84,13 @@ genGenericMetaTyCons tc mod =
         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
+        mkTyCon tyvars name = ASSERT( isExternalName name )
+                              buildAlgTyCon name tyvars roles Nothing [] distinctAbstractTyConRhs
                                           NonRecursive
                                           False          -- Not promotable
                                           False          -- Not GADT syntax
                                           NoParentTyCon
+                                  where roles = map (const Nominal) tyvars
 
       d_name  <- newGlobalBinder mod d_occ loc
       c_names <- forM (zip [0..] tc_cons) $ \(m,_) ->
@@ -96,13 +98,12 @@ 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 metaDTyCon  = mkTyCon d_name
-          metaCTyCons = map mkTyCon c_names
-          metaSTyCons = map (map mkTyCon) s_names
+      let metaDTyCon  = mkTyCon [] d_name
+          metaCTyCons = map (\c_name -> mkTyConApp (mkTyCon [] c_name) [mkTyConTy metaDTyCon]) 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
@@ -111,7 +112,7 @@ metaTyConsToDerivStuff tc metaDts =
   do  loc <- getSrcSpanM
       dflags <- getDynFlags
       dClas <- tcLookupClass datatypeClassName
-      let new_dfun_name clas tycon = newDFunName clas [mkTyConApp tycon []] loc
+      let new_dfun_name clas tycon = newDFunName clas [mkTyConTy tycon] loc
       d_dfun_name <- new_dfun_name dClas tc
       cClas <- tcLookupClass constructorClassName
       c_dfun_names <- sequence [ new_dfun_name cClas tc | _ <- metaC metaDts ]
@@ -123,13 +124,12 @@ metaTyConsToDerivStuff tc metaDts =
 
       let
         (dBinds,cBinds,sBinds) = mkBindsMetaD fix_env tc
-        mk_inst clas tc dfun_name
-          = mkLocalInstance (mkDictFunId dfun_name [] [] clas tys)
+        mk_inst' clas ty dfun_name
+          = mkLocalInstance (mkDictFunId dfun_name [] [] clas [ty])
                             OverlapFlag { overlapMode   = NoOverlap
                                         , isSafeOverlap = safeLanguageOn dflags }
-                            [] clas tys
-          where
-            tys = [mkTyConTy tc]
+                            [] clas [ty]
+        mk_inst clas tc dfun_name = mk_inst' clas (mkTyConTy tc) dfun_name
 
         -- Datatype
         d_metaTycon = metaD metaDts
@@ -142,7 +142,7 @@ metaTyConsToDerivStuff tc metaDts =
 
         -- Constructor
         c_metaTycons = metaC metaDts
-        c_insts = [ mk_inst cClas 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 = []
@@ -644,7 +644,7 @@ tc_mkRepTy gk_ tycon metaDts =
 
 
         metaDTyCon  = mkTyConTy (metaD metaDts)
-        metaCTyCons = map mkTyConTy (metaC metaDts)
+        metaCTyCons = metaC metaDts
         metaSTyCons = map (map mkTyConTy) (metaS metaDts)
 
     return (mkD tycon)
@@ -656,7 +656,7 @@ tc_mkRepTy gk_ tycon metaDts =
 data MetaTyCons = MetaTyCons { -- One meta datatype per datatype
                                metaD :: TyCon
                                -- One meta datatype per constructor
-                             , metaC :: [TyCon]
+                             , metaC :: [Type]
                                -- One meta datatype per selector per constructor
                              , metaS :: [[TyCon]] }
 
@@ -664,7 +664,8 @@ 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)
+metaTyCons2TyCons (MetaTyCons d cty s) = listToBag (d : c ++ concat s)
+  where c = map (\(TyConApp c []) -> c) cty
 
 
 -- Bindings for Datatype, Constructor, and Selector instances