X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcExpr.lhs;h=4151e0d1f2366a1f70e65aee41b5b52bb123cf9d;hb=cd2c71bb9bfe5dd3582263468712c29192c7340e;hp=0ac873ef04357e75ad641c9d8793cce602163a10;hpb=84923cc7de2a93c22a2f72daf9ac863959efae13;p=ghc-hetmet.git

diff --git a/compiler/typecheck/TcExpr.lhs b/compiler/typecheck/TcExpr.lhs
index 0ac873e..4151e0d 100644
--- a/compiler/typecheck/TcExpr.lhs
+++ b/compiler/typecheck/TcExpr.lhs
@@ -294,10 +294,19 @@ tcExpr in_expr@(ExplicitPArr _ exprs) res_ty	-- maybe empty
   where
     tc_elt elt_ty expr = tcPolyExpr expr elt_ty
 
+-- For tuples, take care to preserve rigidity
+-- E.g. 	case (x,y) of ....
+-- 	   The scrutinee should have a rigid type if x,y do
+-- The general scheme is the same as in tcIdApp
 tcExpr (ExplicitTuple exprs boxity) res_ty
-  = do	{ arg_tys <- boxySplitTyConApp (tupleTyCon boxity (length exprs)) res_ty
-	; exprs' <-  tcPolyExprs exprs arg_tys
-	; return (ExplicitTuple exprs' boxity) }
+  = do	{ tvs <- newBoxyTyVars [argTypeKind | e <- exprs]
+	; let tup_tc     = tupleTyCon boxity (length exprs)
+	      tup_res_ty = mkTyConApp tup_tc (mkTyVarTys tvs)
+	; arg_tys   <- preSubType tvs (mkVarSet tvs) tup_res_ty res_ty
+	; exprs'    <-  tcPolyExprs exprs arg_tys
+	; arg_tys' <- mapM refineBox arg_tys
+	; co_fn <- tcFunResTy (tyConName tup_tc) (mkTyConApp tup_tc arg_tys') res_ty
+	; return (mkHsWrap co_fn (ExplicitTuple exprs' boxity)) }
 
 tcExpr (HsProc pat cmd) res_ty
   = do	{ (pat', cmd') <- tcProc pat cmd res_ty
@@ -373,7 +382,7 @@ tcExpr expr@(RecordCon (L loc con_name) _ rbinds) res_ty
 -- don't know how to do the update otherwise.
 
 
-tcExpr expr@(RecordUpd record_expr rbinds _ _) res_ty
+tcExpr expr@(RecordUpd record_expr hrbinds@(HsRecordBinds rbinds) _ _) res_ty
   = 	-- STEP 0
 	-- Check that the field names are really field names
     ASSERT( notNull rbinds )
@@ -395,7 +404,7 @@ tcExpr expr@(RecordUpd record_expr rbinds _ _) res_ty
 	-- Figure out the tycon and data cons from the first field name
     let
 		-- It's OK to use the non-tc splitters here (for a selector)
-	upd_field_lbls  = recBindFields rbinds
+	upd_field_lbls  = recBindFields hrbinds
 	sel_id : _   	= sel_ids
 	(tycon, _)   	= recordSelectorFieldLabel sel_id	-- We've failed already if
 	data_cons    	= tyConDataCons tycon		-- it's not a field label
@@ -407,7 +416,7 @@ tcExpr expr@(RecordUpd record_expr rbinds _ _) res_ty
 	-- Check that at least one constructor has all the named fields
 	-- i.e. has an empty set of bad fields returned by badFields
     checkTc (not (null relevant_cons))
-	    (badFieldsUpd rbinds)	`thenM_`
+	    (badFieldsUpd hrbinds)	`thenM_`
 
 	-- Check that all relevant data cons are vanilla.  Doing record updates on 
 	-- GADTs and/or existentials is more than my tiny brain can cope with today
@@ -448,7 +457,7 @@ tcExpr expr@(RecordUpd record_expr rbinds _ _) res_ty
 	con1_arg_tys'    = map (substTy inst_env) con1_arg_tys
     in
     tcSubExp result_record_ty res_ty		`thenM` \ co_fn ->
-    tcRecordBinds con1 con1_arg_tys' rbinds	`thenM` \ rbinds' ->
+    tcRecordBinds con1 con1_arg_tys' hrbinds	`thenM` \ rbinds' ->
 
 	-- STEP 5
 	-- Typecheck the expression to be updated
@@ -912,7 +921,7 @@ tagToEnumError tys
 
 %************************************************************************
 %*									*
-\subsection{@tcId@ typchecks an identifier occurrence}
+\subsection{@tcId@ typechecks an identifier occurrence}
 %*									*
 %************************************************************************
 
@@ -1040,9 +1049,9 @@ tcRecordBinds
 	-> HsRecordBinds Name
 	-> TcM (HsRecordBinds TcId)
 
-tcRecordBinds data_con arg_tys rbinds
+tcRecordBinds data_con arg_tys (HsRecordBinds rbinds)
   = do	{ mb_binds <- mappM do_bind rbinds
-	; return (catMaybes mb_binds) }
+	; return (HsRecordBinds (catMaybes mb_binds)) }
   where
     flds_w_tys = zipEqual "tcRecordBinds" (dataConFieldLabels data_con) arg_tys
     do_bind (L loc field_lbl, rhs)