X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcExpr.lhs;h=2100bba58b88c97003d22b26f4a1ea127c14245f;hb=7e03b5b7cfd72c651444856fe83b429da0734ec2;hp=fa0e419aed2200816f1e08da6456224cf9c40b5c;hpb=a2fcf3aa210edff15c5f4603ac267171f89366f0;p=ghc-hetmet.git

diff --git a/compiler/typecheck/TcExpr.lhs b/compiler/typecheck/TcExpr.lhs
index fa0e419..2100bba 100644
--- a/compiler/typecheck/TcExpr.lhs
+++ b/compiler/typecheck/TcExpr.lhs
@@ -129,6 +129,9 @@ tcExpr (HsPar expr)     res_ty = do { expr' <- tcMonoExpr expr res_ty
 
 tcExpr (HsSCC lbl expr) res_ty = do { expr' <- tcMonoExpr expr res_ty
 				    ; returnM (HsSCC lbl expr') }
+tcExpr (HsTickPragma info expr) res_ty 
+       		     	       = do { expr' <- tcMonoExpr expr res_ty
+				    ; returnM (HsTickPragma info expr') }
 
 tcExpr (HsCoreAnn lbl expr) res_ty 	 -- hdaume: core annotation
   = do	{ expr' <- tcMonoExpr expr res_ty
@@ -291,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
@@ -746,7 +758,7 @@ instFun orig fun subst tv_theta_prs
 	; go True fun ty_theta_prs' }
   where
     subst_pr (tvs, theta) 
-	= (map (substTyVar subst) tvs, substTheta subst theta)
+	= (substTyVars subst tvs, substTheta subst theta)
 
     go _ fun [] = return fun
 
@@ -909,7 +921,7 @@ tagToEnumError tys
 
 %************************************************************************
 %*									*
-\subsection{@tcId@ typchecks an identifier occurrence}
+\subsection{@tcId@ typechecks an identifier occurrence}
 %*									*
 %************************************************************************