X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcHsSyn.lhs;h=299d70fa7835247134e1eb2aca43a19e16fa697c;hb=ca8d50e001ffa64cefac0231f1cdbdff19b47e8c;hp=7e15770270b07dcdc633c0f9b4ab11602b15a40b;hpb=1add6282808b5ae98e72ef7034634036c9b91b04;p=ghc-hetmet.git

diff --git a/compiler/typecheck/TcHsSyn.lhs b/compiler/typecheck/TcHsSyn.lhs
index 7e15770..299d70f 100644
--- a/compiler/typecheck/TcHsSyn.lhs
+++ b/compiler/typecheck/TcHsSyn.lhs
@@ -13,7 +13,7 @@ module TcHsSyn (
 	mkHsConApp, mkHsDictLet, mkHsApp,
 	hsLitType, hsLPatType, hsPatType, 
 	mkHsAppTy, mkSimpleHsAlt,
-	nlHsIntLit, mkVanillaTuplePat, 
+	nlHsIntLit, 
 	shortCutLit, hsOverLitName,
 	
 	mkArbitraryType,	-- Put this elsewhere?
@@ -35,7 +35,6 @@ import Id
 
 import TcRnMonad
 import PrelNames
-import Type
 import TcType
 import TcMType
 import TysPrim
@@ -49,7 +48,6 @@ import VarEnv
 import Literal
 import BasicTypes
 import Maybes
-import Unique
 import SrcLoc
 import Util
 import Bag
@@ -82,11 +80,6 @@ mappM = mapM
 Note: If @hsLPatType@ doesn't bear a strong resemblance to @exprType@,
 then something is wrong.
 \begin{code}
-mkVanillaTuplePat :: [OutPat Id] -> Boxity -> Pat Id
--- A vanilla tuple pattern simply gets its type from its sub-patterns
-mkVanillaTuplePat pats box 
-  = TuplePat pats box (mkTupleTy box (length pats) (map hsLPatType pats))
-
 hsLPatType :: OutPat Id -> Type
 hsLPatType (L _ pat) = hsPatType pat
 
@@ -492,6 +485,13 @@ zonkExpr env (SectionR op expr)
     zonkLExpr env expr		`thenM` \ new_expr ->
     returnM (SectionR new_op new_expr)
 
+zonkExpr env (ExplicitTuple tup_args boxed)
+  = do { new_tup_args <- mapM zonk_tup_arg tup_args
+       ; return (ExplicitTuple new_tup_args boxed) }
+  where
+    zonk_tup_arg (Present e) = do { e' <- zonkLExpr env e; return (Present e') }
+    zonk_tup_arg (Missing t) = do { t' <- zonkTcTypeToType env t; return (Missing t') }
+
 zonkExpr env (HsCase expr ms)
   = zonkLExpr env expr    	`thenM` \ new_expr ->
     zonkMatchGroup env ms	`thenM` \ new_ms ->
@@ -525,10 +525,6 @@ zonkExpr env (ExplicitPArr ty exprs)
     zonkLExprs env exprs	`thenM` \ new_exprs ->
     returnM (ExplicitPArr new_ty new_exprs)
 
-zonkExpr env (ExplicitTuple exprs boxed)
-  = zonkLExprs env exprs  	`thenM` \ new_exprs ->
-    returnM (ExplicitTuple new_exprs boxed)
-
 zonkExpr env (RecordCon data_con con_expr rbinds)
   = do	{ new_con_expr <- zonkExpr env con_expr
 	; new_rbinds   <- zonkRecFields env rbinds
@@ -766,9 +762,9 @@ zonkRecFields env (HsRecFields flds dd)
 	; return (HsRecFields flds' dd) }
   where
     zonk_rbind fld
-      = do { new_expr <- zonkLExpr env (hsRecFieldArg fld)
-	   ; return (fld { hsRecFieldArg = new_expr }) }
-	-- Field selectors have declared types; hence no zonking
+      = do { new_id   <- wrapLocM (zonkIdBndr env) (hsRecFieldId fld)
+	   ; new_expr <- zonkLExpr env (hsRecFieldArg fld)
+	   ; return (fld { hsRecFieldId = new_id, hsRecFieldArg = new_expr }) }
 
 -------------------------------------------------------------------------
 mapIPNameTc :: (a -> TcM b) -> IPName a -> TcM (IPName b)
@@ -823,7 +819,8 @@ zonk_pat env (AsPat (L loc v) pat)
 zonk_pat env (ViewPat expr pat ty)
   = do	{ expr' <- zonkLExpr env expr
 	; (env', pat') <- zonkPat env pat
- 	; return (env', ViewPat expr' pat' ty) }
+ 	; ty' <- zonkTcTypeToType env ty
+	; return (env', ViewPat expr' pat' ty') }
 
 zonk_pat env (ListPat pats ty)
   = do	{ ty' <- zonkTcTypeToType env ty
@@ -1071,7 +1068,7 @@ mkArbitraryType warn tv
   , isLiftedTypeKind res			--    Horrible hack to make less use 
   = return (mkTyConApp tup_tc [])		--    of mkAnyPrimTyCon
   | otherwise
-  = do	{ warn (getSrcSpan tv) msg
+  = do	{ _ <- warn (getSrcSpan tv) msg
 	; return (mkTyConApp (mkAnyPrimTyCon (getUnique tv) kind) []) }
 		-- Same name as the tyvar, apart from making it start with a colon (sigh)
 		-- I dread to think what will happen if this gets out into an