X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FbasicTypes%2FMkId.lhs;h=3e548135a1c13313d63ae6c47a0236d955a45a28;hb=8053aac536c96dabdc06e9f068852f5481474a29;hp=fda676368aceffcfa8c8c039c318b8eadbd09892;hpb=27897431cf24d4bde04b15947440c7205f2d703c;p=ghc-hetmet.git

diff --git a/compiler/basicTypes/MkId.lhs b/compiler/basicTypes/MkId.lhs
index fda6763..3e54813 100644
--- a/compiler/basicTypes/MkId.lhs
+++ b/compiler/basicTypes/MkId.lhs
@@ -47,7 +47,8 @@ import TysPrim		( openAlphaTyVars, alphaTyVar, alphaTy,
 import TysWiredIn	( charTy, mkListTy )
 import PrelRules	( primOpRules )
 import Type		( TyThing(..), mkForAllTy, tyVarsOfTypes, 
- 			  newTyConInstRhs, mkTopTvSubst, substTyVar, substTy )
+ 			  newTyConInstRhs, mkTopTvSubst, substTyVar, substTy,
+ 			  substTys, zipTopTvSubst )
 import TcGadt           ( gadtRefine, refineType, emptyRefinement )
 import HsBinds          ( ExprCoFn(..), isIdCoercion )
 import Coercion         ( mkSymCoercion, mkUnsafeCoercion, isEqPred )
@@ -60,11 +61,12 @@ 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,
-                          newTyConCo )
+                          newTyConCo_maybe )
 import Class		( Class, classTyCon, classSelIds )
 import Var		( Id, TyVar, Var, setIdType )
 import VarSet		( isEmptyVarSet, subVarSet, varSetElems )
@@ -220,14 +222,14 @@ This coercion is conditionally applied by wrapFamInstBody.
 mkDataConIds :: Name -> Name -> DataCon -> DataConIds
 mkDataConIds wrap_name wkr_name data_con
   | isNewTyCon tycon
-  = DCIds Nothing nt_work_id                    -- Newtype, only has a worker
+  = DCIds Nothing nt_work_id                 -- Newtype, only has a worker
 
-  | any isMarkedStrict all_strict_marks		-- Algebraic, needs wrapper
-    || not (null eq_spec)
-    || isFamInstTyCon tycon
+  | any isMarkedStrict all_strict_marks	     -- Algebraic, needs wrapper
+    || not (null eq_spec)		     -- NB: LoadIface.ifaceDeclSubBndrs
+    || isFamInstTyCon tycon		     --     depends on this test
   = DCIds (Just alg_wrap_id) wrk_id
 
-  | otherwise					-- Algebraic, no wrapper
+  | otherwise				     -- Algebraic, no wrapper
   = DCIds Nothing wrk_id
   where
     (univ_tvs, ex_tvs, eq_spec, 
@@ -240,6 +242,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 +256,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 
@@ -860,7 +870,7 @@ wrapNewTypeBody tycon args result_expr
   = wrapFamInstBody tycon args inner
   where
     inner
-      | Just co_con <- newTyConCo tycon
+      | Just co_con <- newTyConCo_maybe tycon
       = mkCoerce (mkSymCoercion (mkTyConApp co_con args)) result_expr
       | otherwise
       = result_expr
@@ -872,7 +882,7 @@ wrapNewTypeBody tycon args result_expr
 --
 unwrapNewTypeBody :: TyCon -> [Type] -> CoreExpr -> CoreExpr
 unwrapNewTypeBody tycon args result_expr
-  | Just co_con <- newTyConCo tycon
+  | Just co_con <- newTyConCo_maybe tycon
   = mkCoerce (mkTyConApp co_con args) result_expr
   | otherwise
   = result_expr