X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcGenDeriv.lhs;h=525f0950b0b08d3e2aed107fde38b1d4c25bf843;hp=35dbf199e670e9266d9caca5a48f686dfd85c347;hb=1a9245caefb80a3c4c5965aaacdf9a607e792e1c;hpb=a8407757462804dfd51708d6cfdda0417a91bf8e

diff --git a/compiler/typecheck/TcGenDeriv.lhs b/compiler/typecheck/TcGenDeriv.lhs
index 35dbf19..525f095 100644
--- a/compiler/typecheck/TcGenDeriv.lhs
+++ b/compiler/typecheck/TcGenDeriv.lhs
@@ -1288,7 +1288,8 @@ kind2 = liftedTypeKind `mkArrowKind` kind1
 
 gfoldl_RDR, gunfold_RDR, toConstr_RDR, dataTypeOf_RDR, mkConstr_RDR,
     mkDataType_RDR, conIndex_RDR, prefix_RDR, infix_RDR,
-    dataCast1_RDR, dataCast2_RDR, gcast1_RDR, gcast2_RDR :: RdrName
+    dataCast1_RDR, dataCast2_RDR, gcast1_RDR, gcast2_RDR,
+    constr_RDR, dataType_RDR :: RdrName
 gfoldl_RDR     = varQual_RDR  gENERICS (fsLit "gfoldl")
 gunfold_RDR    = varQual_RDR  gENERICS (fsLit "gunfold")
 toConstr_RDR   = varQual_RDR  gENERICS (fsLit "toConstr")
@@ -1661,12 +1662,13 @@ fiddling around.
 genAuxBind :: SrcSpan -> DerivAuxBind -> (LHsBind RdrName, LSig RdrName)
 genAuxBind loc (GenCon2Tag tycon)
   = (mk_FunBind loc rdr_name eqns, 
-     L loc (TypeSig (L loc rdr_name) sig_ty))
+     L loc (TypeSig (L loc rdr_name) (L loc sig_ty)))
   where
     rdr_name = con2tag_RDR tycon
 
-    sig_ty = genForAllTy loc tycon $ \hs_tc_app ->
-             hs_tc_app `nlHsFunTy` nlHsTyVar (getRdrName intPrimTyCon)
+    sig_ty = HsCoreTy $ 
+             mkForAllTys (tyConTyVars tycon) $
+             mkParentType tycon `mkFunTy` intPrimTy
 
     lots_of_constructors = tyConFamilySize tycon > 8
                         -- was: mAX_FAMILY_SIZE_FOR_VEC_RETURNS
@@ -1686,19 +1688,18 @@ genAuxBind loc (GenTag2Con tycon)
     (mk_FunBind loc rdr_name 
 	[([nlConVarPat intDataCon_RDR [a_RDR]], 
 	   nlHsApp (nlHsVar tagToEnum_RDR) a_Expr)],
-     L loc (TypeSig (L loc rdr_name) sig_ty))
+     L loc (TypeSig (L loc rdr_name) (L loc sig_ty)))
   where
-    sig_ty = nlHsTyVar (getRdrName intPrimTyCon) 
-             `nlHsFunTy` (nlHsTyVar (getRdrName tycon))
+    sig_ty = HsCoreTy $ intTy `mkFunTy` mkParentType tycon
 
     rdr_name = tag2con_RDR tycon
 
 genAuxBind loc (GenMaxTag tycon)
   = (mkHsVarBind loc rdr_name rhs,
-     L loc (TypeSig (L loc rdr_name) sig_ty))
+     L loc (TypeSig (L loc rdr_name) (L loc sig_ty)))
   where
     rdr_name = maxtag_RDR tycon
-    sig_ty = nlHsTyVar (getRdrName intPrimTyCon) 
+    sig_ty = HsCoreTy intTy
     rhs = nlHsApp (nlHsVar intDataCon_RDR) (nlHsLit (HsIntPrim max_tag))
     max_tag =  case (tyConDataCons tycon) of
 		 data_cons -> toInteger ((length data_cons) - fIRST_TAG)
@@ -1742,17 +1743,13 @@ mk_data_type_name tycon = mkAuxBinderName (tyConName tycon) mkDataTOcc
 mk_constr_name :: DataCon -> RdrName	-- "$cC"
 mk_constr_name con = mkAuxBinderName (dataConName con) mkDataCOcc
 
-genForAllTy :: SrcSpan -> TyCon
-            -> (LHsType RdrName -> LHsType RdrName)
-            -> LHsType RdrName
--- Wrap a forall type for the variables of the TyCOn
-genForAllTy loc tc thing_inside
-  = L loc $ mkExplicitHsForAllTy (userHsTyVarBndrs (map (L loc) tvs)) (L loc []) $
-    thing_inside (nlHsTyConApp (getRdrName tc) (map nlHsTyVar tvs))
-  where
-    tvs = map (mkRdrUnqual . getOccName) (tyConTyVars tc)
-	-- We can't use getRdrName because that makes an Exact RdrName
-	-- and we can't put them in the LocalRdrEnv
+mkParentType :: TyCon -> Type
+-- Turn the representation tycon of a family into
+-- a use of its family constructor
+mkParentType tc
+  = case tyConFamInst_maybe tc of
+       Nothing  -> mkTyConApp tc (mkTyVarTys (tyConTyVars tc))
+       Just (fam_tc,tys) -> mkTyConApp fam_tc tys
 \end{code}
 
 %************************************************************************