X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcMatches.lhs;h=452bae792d2c8521f4a91ad1b925cc4d0e7f74e0;hp=e07e6dad767b024e7e5b3e57aece7687f8629b2e;hb=58de6cb725982dd1f57803cc838f233d5fd9c42c;hpb=67cb409159fa9136dff942b8baaec25909416022

diff --git a/compiler/typecheck/TcMatches.lhs b/compiler/typecheck/TcMatches.lhs
index e07e6da..452bae7 100644
--- a/compiler/typecheck/TcMatches.lhs
+++ b/compiler/typecheck/TcMatches.lhs
@@ -44,7 +44,7 @@ import Outputable
 import Util
 import SrcLoc
 
-import Control.Monad( liftM )
+import Control.Monad
 \end{code}
 
 %************************************************************************
@@ -197,9 +197,9 @@ tcGRHSs :: TcMatchCtxt -> GRHSs Name -> (Refinement, BoxyRhoType)
 
 tcGRHSs ctxt (GRHSs grhss binds) res_ty
   = do	{ (binds', grhss') <- tcLocalBinds binds $
-			      mappM (wrapLocM (tcGRHS ctxt res_ty)) grhss
+			      mapM (wrapLocM (tcGRHS ctxt res_ty)) grhss
 
-	; returnM (GRHSs grhss' binds') }
+	; return (GRHSs grhss' binds') }
 
 -------------
 tcGRHS :: TcMatchCtxt -> (Refinement, BoxyRhoType) -> GRHS Name -> TcM (GRHS TcId)
@@ -467,7 +467,7 @@ tcLcStmt m_tc ctxt stmt elt_ty thing_inside
 
 tcDoStmt :: TcStmtChecker
 
-tcDoStmt ctxt (BindStmt pat rhs bind_op fail_op) reft_res_ty@(_,res_ty) thing_inside
+tcDoStmt ctxt (BindStmt pat rhs bind_op fail_op) (reft,res_ty) thing_inside
   = do	{ (rhs', rhs_ty) <- tcInferRho rhs
 		-- We should use type *inference* for the RHS computations, becuase of GADTs. 
 		-- 	do { pat <- rhs; <rest> }
@@ -476,33 +476,44 @@ tcDoStmt ctxt (BindStmt pat rhs bind_op fail_op) reft_res_ty@(_,res_ty) thing_in
 		-- We do inference on rhs, so that information about its type can be refined
 		-- when type-checking the pattern. 
 
-	-- Deal with rebindable syntax; (>>=) :: rhs_ty -> (a -> res_ty) -> res_ty
-	; (bind_op', pat_ty) <- 
+	-- Deal with rebindable syntax:
+	--	 (>>=) :: rhs_ty -> (pat_ty -> new_res_ty) -> res_ty
+	-- This level of generality is needed for using do-notation
+	-- in full generality; see Trac #1537
+	; ((bind_op', new_res_ty), pat_ty) <- 
 	     withBox liftedTypeKind $ \ pat_ty ->
+	     withBox liftedTypeKind $ \ new_res_ty ->
 	     tcSyntaxOp DoOrigin bind_op 
-			(mkFunTys [rhs_ty, mkFunTy pat_ty res_ty] res_ty)
+			(mkFunTys [rhs_ty, mkFunTy pat_ty new_res_ty] res_ty)
 
 		-- If (but only if) the pattern can fail, 
 		-- typecheck the 'fail' operator
 	; fail_op' <- if isIrrefutableHsPat pat 
 		      then return noSyntaxExpr
-		      else tcSyntaxOp DoOrigin fail_op (mkFunTy stringTy res_ty)
+		      else tcSyntaxOp DoOrigin fail_op (mkFunTy stringTy new_res_ty)
 
-	; (pat', thing) <- tcLamPat pat pat_ty reft_res_ty thing_inside
+	; (pat', thing) <- tcLamPat pat pat_ty (reft, new_res_ty) thing_inside
 
 	; return (BindStmt pat' rhs' bind_op' fail_op', thing) }
 
 
-tcDoStmt ctxt (ExprStmt rhs then_op _) reft_res_ty@(_,res_ty) thing_inside
+tcDoStmt ctxt (ExprStmt rhs then_op _) (reft,res_ty) thing_inside
   = do	{ (rhs', rhs_ty) <- tcInferRho rhs
 
-  	-- Deal with rebindable syntax; (>>) :: rhs_ty -> res_ty -> res_ty
-	; then_op' <- tcSyntaxOp DoOrigin then_op 
-				 (mkFunTys [rhs_ty, res_ty] res_ty)
+  	-- Deal with rebindable syntax; (>>) :: rhs_ty -> new_res_ty -> res_ty
+	; (then_op', new_res_ty) <-
+		withBox liftedTypeKind $ \ new_res_ty ->
+		tcSyntaxOp DoOrigin then_op 
+			   (mkFunTys [rhs_ty, new_res_ty] res_ty)
 
-	; thing <- thing_inside reft_res_ty
+	; thing <- thing_inside (reft, new_res_ty)
 	; return (ExprStmt rhs' then_op' rhs_ty, thing) }
 
+tcDoStmt ctxt (RecStmt {}) res_ty thing_inside
+  = failWithTc (ptext SLIT("Illegal 'rec' stmt in") <+> pprStmtContext ctxt)
+	-- This case can't be caught in the renamer
+	-- see RnExpr.checkRecStmt
+
 tcDoStmt ctxt stmt res_ty thing_inside
   = pprPanic "tcDoStmt: unexpected Stmt" (ppr stmt)