X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FbasicTypes%2FMkId.lhs;h=d927e16a71aa5699c3c82b41301474ff39376034;hb=ed51bb0f84523769612c9c05807f879e1985c59b;hp=54bbae9ea47d9a34c1bdadbaf5c71ac48ec66d7e;hpb=d76c18e05f6366c23144624b696a02fbaa6d26e8;p=ghc-hetmet.git

diff --git a/compiler/basicTypes/MkId.lhs b/compiler/basicTypes/MkId.lhs
index 54bbae9..d927e16 100644
--- a/compiler/basicTypes/MkId.lhs
+++ b/compiler/basicTypes/MkId.lhs
@@ -47,9 +47,10 @@ import TysPrim		( openAlphaTyVars, alphaTyVar, alphaTy,
 import TysWiredIn	( charTy, mkListTy )
 import PrelRules	( primOpRules )
 import Type		( TyThing(..), mkForAllTy, tyVarsOfTypes, 
- 			  newTyConInstRhs, mkTopTvSubst, substTyVar, substTy )
+ 			  newTyConInstRhs, mkTopTvSubst, substTyVar, 
+ 			  substTys, zipTopTvSubst )
 import TcGadt           ( gadtRefine, refineType, emptyRefinement )
-import HsBinds          ( ExprCoFn(..), isIdCoercion )
+import HsBinds          ( HsWrapper(..), isIdHsWrapper )
 import Coercion         ( mkSymCoercion, mkUnsafeCoercion, isEqPred )
 import TcType		( Type, ThetaType, mkDictTy, mkPredTys, mkPredTy, 
 			  mkTyConApp, mkTyVarTys, mkClassPred, isPredTy,
@@ -60,7 +61,8 @@ import TcType		( Type, ThetaType, mkDictTy, mkPredTys, mkPredTy,
 import CoreUtils	( exprType, dataConOrigInstPat, mkCoerce )
 import CoreUnfold 	( mkTopUnfolding, mkCompulsoryUnfolding )
 import Literal		( nullAddrLit, mkStringLit )
-import TyCon		( TyCon, isNewTyCon, tyConDataCons, FieldLabel,
+import TyCon		( TyCon, isNewTyCon, tyConTyVars, tyConDataCons,
+			  FieldLabel,
                           tyConStupidTheta, isProductTyCon, isDataTyCon,
                           isRecursiveTyCon, isFamInstTyCon,
                           tyConFamInst_maybe, tyConFamilyCoercion_maybe,
@@ -95,7 +97,6 @@ import NewDemand	( mkStrictSig, DmdResult(..),
 import DmdAnal		( dmdAnalTopRhs )
 import CoreSyn
 import Unique		( mkBuiltinUnique, mkPrimOpIdUnique )
-import Maybe		( fromJust )
 import Maybes
 import PrelNames
 import Util             ( dropList, isSingleton )
@@ -240,6 +241,12 @@ mkDataConIds wrap_name wkr_name data_con
 	-- extra constraints where necessary.
     wrap_tvs = (univ_tvs `minusList` map fst eq_spec) ++ ex_tvs
     subst	   = mkTopTvSubst eq_spec
+    famSubst	   = ASSERT( length (tyConTyVars tycon  ) ==  
+			     length (mkTyVarTys univ_tvs)   )
+		     zipTopTvSubst (tyConTyVars tycon) (mkTyVarTys univ_tvs)
+		     -- substitution mapping the type constructor's type
+		     -- arguments to the universals of the data constructor
+		     -- (crucial when type checking interfaces)
     dict_tys       = mkPredTys theta
     result_ty_args = map (substTyVar subst) univ_tvs
     result_ty      = case tyConFamInst_maybe tycon of
@@ -248,7 +255,9 @@ mkDataConIds wrap_name wkr_name data_con
 		         -- family instance constructor
 		       Just (familyTyCon, 
 			     instTys)     -> 
-		         mkTyConApp familyTyCon (map (substTy subst) instTys)
+		         mkTyConApp familyTyCon ( substTys subst 
+						. substTys famSubst 
+						$ instTys)
     wrap_ty        = mkForAllTys wrap_tvs $ mkFunTys dict_tys $
 	             mkFunTys orig_arg_tys $ result_ty
 	-- NB: watch out here if you allow user-written equality 
@@ -393,16 +402,6 @@ wrapFamInstBody tycon args result_expr
   = mkCoerce (mkSymCoercion (mkTyConApp co_con args)) result_expr
   | otherwise
   = result_expr
-
--- Apply the coercion in the opposite direction.
---
-unwrapFamInstBody :: TyCon -> [Type] -> CoreExpr -> CoreExpr
-unwrapFamInstBody tycon args result_expr
-  | Just co_con <- tyConFamilyCoercion_maybe tycon
-  = mkCoerce (mkTyConApp co_con args) result_expr
-  | otherwise
-  = result_expr
-
 \end{code}
 
 
@@ -630,8 +629,8 @@ mkRecordSelId tycon field_label
 		-- and apply to (Maybe b'), to get (Maybe b)
 
         rhs = case co_fn of
-		ExprCoFn co -> Cast (Var the_arg_id) co
-		id_co	    -> ASSERT(isIdCoercion id_co) Var the_arg_id
+		WpCo co -> Cast (Var the_arg_id) co
+		id_co	    -> ASSERT(isIdHsWrapper id_co) Var the_arg_id
 
 	field_vs    = filter (not . isPredTy . idType) arg_vs 
     	the_arg_id  = assoc "mkRecordSelId:mk_alt" (field_lbls `zip` field_vs) field_label