X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FdeSugar%2FDsExpr.lhs;h=f4f2c56cf2a4e6f27441510fd5523611f38eb1df;hp=5191afe4110ba14725ec3f1b654889d5d6d7aa5a;hb=bddd4b23e32532091a64bdb1c432dfbc8ca84645;hpb=df61ac588d1e7132acea67596ca3d735a308eafb

diff --git a/compiler/deSugar/DsExpr.lhs b/compiler/deSugar/DsExpr.lhs
index 5191afe..f4f2c56 100644
--- a/compiler/deSugar/DsExpr.lhs
+++ b/compiler/deSugar/DsExpr.lhs
@@ -548,13 +548,15 @@ dsDo stmts body result_ty
 
     go (BindStmt pat rhs bind_op fail_op : stmts)
       = 
-       do { body  <- go stmts
+       do  { body     <- go stmts
+           ; rhs'     <- dsLExpr rhs
+	   ; bind_op' <- dsExpr bind_op
 	   ; var   <- selectSimpleMatchVarL pat
+	   ; let bind_ty = exprType bind_op' 	-- rhs -> (pat -> res1) -> res2
+		 res1_ty = funResultTy (funArgTy (funResultTy bind_ty))
 	   ; match <- matchSinglePat (Var var) (StmtCtxt DoExpr) pat
-    				  result_ty (cantFailMatchResult body)
+    				     res1_ty (cantFailMatchResult body)
 	   ; match_code <- handle_failure pat match fail_op
-           ; rhs'       <- dsLExpr rhs
-	   ; bind_op'   <- dsExpr bind_op
 	   ; return (mkApps bind_op' [rhs', Lam var match_code]) }
     
     -- In a do expression, pattern-match failure just calls