X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fiface%2FTcIface.lhs;h=90bedd92cfb4bef1fd3bf0449b20a6f71a0a86db;hb=71cad0e1783707f325973a537b3b0a74300bd866;hp=813467680bbd521d02d95cc47ae3c37759f644bb;hpb=2cab0d72186713bc2be393b3ee2c39b46a453783;p=ghc-hetmet.git

diff --git a/compiler/iface/TcIface.lhs b/compiler/iface/TcIface.lhs
index 8134676..90bedd9 100644
--- a/compiler/iface/TcIface.lhs
+++ b/compiler/iface/TcIface.lhs
@@ -35,7 +35,7 @@ import HscTypes		( ExternalPackageState(..),
 			  emptyModDetails, lookupTypeEnv, lookupType, typeEnvIds )
 import InstEnv		( Instance(..), mkImportedInstance )
 import CoreSyn
-import CoreUtils	( exprType )
+import CoreUtils	( exprType, dataConRepFSInstPat )
 import CoreUnfold
 import CoreLint		( lintUnfolding )
 import WorkWrap		( mkWrapper )
@@ -53,11 +53,11 @@ import Var		( TyVar, mkTyVar, tyVarKind )
 import Name		( Name, nameModule, nameIsLocalOrFrom, isWiredInName,
  			  nameOccName, wiredInNameTyThing_maybe )
 import NameEnv
-import OccName		( OccName, mkVarOccFS, mkTyVarOccoccNameSpace, pprNameSpace  )
+import OccName		( OccName, mkVarOccFS, mkTyVarOccoccNameSpace, pprNameSpace, occNameFS  )
 import FastString       ( FastString )
 import Module		( Module, moduleName )
 import UniqFM		( lookupUFM )
-import UniqSupply	( initUs_ )
+import UniqSupply	( initUs_, uniqsFromSupply )
 import Outputable	
 import ErrUtils		( Message )
 import Maybes		( MaybeErr(..) )
@@ -354,7 +354,7 @@ tcIfaceDecl (IfaceData {ifName = occ_name,
 			ifTyVars = tv_bndrs, 
 			ifCtxt = ctxt, ifGadtSyntax = gadt_syn,
 			ifCons = rdr_cons, 
-			ifVrcs = arg_vrcs, ifRec = is_rec, 
+			ifRec = is_rec, 
 			ifGeneric = want_generic })
   = do	{ tc_name <- lookupIfaceTop occ_name
 	; bindIfaceTyVars tv_bndrs $ \ tyvars -> do
@@ -363,23 +363,23 @@ tcIfaceDecl (IfaceData {ifName = occ_name,
 	    { stupid_theta <- tcIfaceCtxt ctxt
 	    ; cons  <- tcIfaceDataCons tc_name tycon tyvars rdr_cons
 	    ; buildAlgTyCon tc_name tyvars stupid_theta
-			    cons arg_vrcs is_rec want_generic gadt_syn
+			    cons is_rec want_generic gadt_syn
 	    })
         ; traceIf (text "tcIfaceDecl4" <+> ppr tycon)
 	; return (ATyCon tycon)
     }}
 
 tcIfaceDecl (IfaceSyn {ifName = occ_name, ifTyVars = tv_bndrs, 
-		       ifSynRhs = rdr_rhs_ty, ifVrcs = arg_vrcs})
+		       ifSynRhs = rdr_rhs_ty})
    = bindIfaceTyVars tv_bndrs $ \ tyvars -> do
      { tc_name <- lookupIfaceTop occ_name
      ; rhs_ty <- tcIfaceType rdr_rhs_ty
-     ; return (ATyCon (buildSynTyCon tc_name tyvars rhs_ty arg_vrcs))
+     ; return (ATyCon (buildSynTyCon tc_name tyvars rhs_ty))
      }
 
 tcIfaceDecl (IfaceClass {ifCtxt = rdr_ctxt, ifName = occ_name, ifTyVars = tv_bndrs, 
 			 ifFDs = rdr_fds, ifSigs = rdr_sigs, 
-			 ifVrcs = tc_vrcs, ifRec = tc_isrec })
+			 ifRec = tc_isrec })
 -- ToDo: in hs-boot files we should really treat abstract classes specially,
 --	 as we do abstract tycons
   = bindIfaceTyVars tv_bndrs $ \ tyvars -> do
@@ -387,7 +387,7 @@ tcIfaceDecl (IfaceClass {ifCtxt = rdr_ctxt, ifName = occ_name, ifTyVars = tv_bnd
     ; ctxt <- tcIfaceCtxt rdr_ctxt
     ; sigs <- mappM tc_sig rdr_sigs
     ; fds  <- mappM tc_fd rdr_fds
-    ; cls  <- buildClass cls_name tyvars ctxt fds sigs tc_isrec tc_vrcs
+    ; cls  <- buildClass cls_name tyvars ctxt fds sigs tc_isrec
     ; return (AClass cls) }
   where
    tc_sig (IfaceClassOp occ dm rdr_ty)
@@ -407,7 +407,7 @@ tcIfaceDecl (IfaceClass {ifCtxt = rdr_ctxt, ifName = occ_name, ifTyVars = tv_bnd
 tcIfaceDecl (IfaceForeign {ifName = rdr_name, ifExtName = ext_name})
   = do	{ name <- lookupIfaceTop rdr_name
 	; return (ATyCon (mkForeignTyCon name ext_name 
-					 liftedTypeKind 0 [])) }
+					 liftedTypeKind 0)) }
 
 tcIfaceDataCons tycon_name tycon tc_tyvars if_cons
   = case if_cons of
@@ -678,18 +678,12 @@ tcIfaceAlt (tycon, inst_tys) (IfaceTupleAlt boxity, arg_occs, rhs)
 	; tcIfaceDataAlt data_con inst_tys arg_occs rhs }
 
 tcIfaceDataAlt con inst_tys arg_strs rhs
-  = do	{ arg_names <- newIfaceNames (map mkVarOccFS arg_strs)
-        ; let (tyvar_strs, id_strs) = splitAtList (dataConTyVars con) arg_strs
-        ; tyvar_names <- mapM (newIfaceName . mkTyVarOcc) tyvar_strs
-        ; id_names    <- mapM (newIfaceName . mkVarOccFS) id_strs
-	; let	ex_tvs  = [ mkTyVar name (tyVarKind tv) 
-			   | (name,tv) <- tyvar_names `zip` dataConExTyVars con ]
-		arg_tys	 = dataConInstArgTys con (inst_tys ++ mkTyVarTys ex_tvs)
-		arg_ids  = ASSERT2( equalLength id_names arg_tys,
-				    ppr (con, tyvar_names++id_names, rhs) $$ ppr ex_tvs $$ ppr arg_tys )
-			   zipWith mkLocalId id_names arg_tys
-		
-	; rhs' <- extendIfaceTyVarEnv ex_tvs	$
+  = do	{ us <- newUniqueSupply
+	; let uniqs = uniqsFromSupply us
+	; let	(ex_tvs, co_tvs, arg_ids) = dataConRepFSInstPat (map occNameFS arg_strs) uniqs con inst_tys
+                all_tvs                   = ex_tvs ++ co_tvs
+
+	; rhs' <- extendIfaceTyVarEnv all_tvs	$
 		  extendIfaceIdEnv arg_ids	$
 		  tcIfaceExpr rhs
 	; return (DataAlt con, ex_tvs ++ arg_ids, rhs') }