projects
/
ghc-hetmet.git
/ blobdiff
commit
grep
author
committer
pickaxe
?
search:
re
summary
|
shortlog
|
log
|
commit
|
commitdiff
|
tree
raw
|
inline
| side by side
Make do-notation a bit more flexible (Trac #1537)
[ghc-hetmet.git]
/
compiler
/
deSugar
/
DsExpr.lhs
diff --git
a/compiler/deSugar/DsExpr.lhs
b/compiler/deSugar/DsExpr.lhs
index
5191afe
..
f4f2c56
100644
(file)
--- 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)
=
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
; 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
; match <- matchSinglePat (Var var) (StmtCtxt DoExpr) pat
- result_ty (cantFailMatchResult body)
+ res1_ty (cantFailMatchResult body)
; match_code <- handle_failure pat match fail_op
; 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
; return (mkApps bind_op' [rhs', Lam var match_code]) }
-- In a do expression, pattern-match failure just calls