projects
/
ghc-hetmet.git
/ blobdiff
commit
grep
author
committer
pickaxe
?
search:
re
summary
|
shortlog
|
log
|
commit
|
commitdiff
|
tree
raw
|
inline
| side by side
Preliminary monad-comprehension patch (Trac #4370)
[ghc-hetmet.git]
/
compiler
/
typecheck
/
TcHsSyn.lhs
diff --git
a/compiler/typecheck/TcHsSyn.lhs
b/compiler/typecheck/TcHsSyn.lhs
index
122b743
..
357db73
100644
(file)
--- a/
compiler/typecheck/TcHsSyn.lhs
+++ b/
compiler/typecheck/TcHsSyn.lhs
@@
-578,11
+578,12
@@
zonkExpr env (HsLet binds expr)
zonkLExpr new_env expr `thenM` \ new_expr ->
returnM (HsLet new_binds new_expr)
zonkLExpr new_env expr `thenM` \ new_expr ->
returnM (HsLet new_binds new_expr)
-zonkExpr env (HsDo do_or_lc stmts body ty)
+zonkExpr env (HsDo do_or_lc stmts body return_op ty)
= zonkStmts env stmts `thenM` \ (new_env, new_stmts) ->
zonkLExpr new_env body `thenM` \ new_body ->
= zonkStmts env stmts `thenM` \ (new_env, new_stmts) ->
zonkLExpr new_env body `thenM` \ new_body ->
+ zonkExpr new_env return_op `thenM` \ new_return ->
zonkTcTypeToType env ty `thenM` \ new_ty ->
zonkTcTypeToType env ty `thenM` \ new_ty ->
- returnM (HsDo do_or_lc new_stmts new_body new_ty)
+ returnM (HsDo do_or_lc new_stmts new_body new_return new_ty)
zonkExpr env (ExplicitList ty exprs)
= zonkTcTypeToType env ty `thenM` \ new_ty ->
zonkExpr env (ExplicitList ty exprs)
= zonkTcTypeToType env ty `thenM` \ new_ty ->
@@
-728,13
+729,16
@@
zonkStmts env (s:ss) = do { (env1, s') <- wrapLocSndM (zonkStmt env) s
; return (env2, s' : ss') }
zonkStmt :: ZonkEnv -> Stmt TcId -> TcM (ZonkEnv, Stmt Id)
; return (env2, s' : ss') }
zonkStmt :: ZonkEnv -> Stmt TcId -> TcM (ZonkEnv, Stmt Id)
-zonkStmt env (ParStmt stmts_w_bndrs)
+zonkStmt env (ParStmt stmts_w_bndrs mzip_op bind_op return_op)
= mappM zonk_branch stmts_w_bndrs `thenM` \ new_stmts_w_bndrs ->
let
new_binders = concat (map snd new_stmts_w_bndrs)
env1 = extendZonkEnv env new_binders
in
= mappM zonk_branch stmts_w_bndrs `thenM` \ new_stmts_w_bndrs ->
let
new_binders = concat (map snd new_stmts_w_bndrs)
env1 = extendZonkEnv env new_binders
in
- return (env1, ParStmt new_stmts_w_bndrs)
+ zonkExpr env1 mzip_op `thenM` \ new_mzip ->
+ zonkExpr env1 bind_op `thenM` \ new_bind ->
+ zonkExpr env1 return_op `thenM` \ new_return ->
+ return (env1, ParStmt new_stmts_w_bndrs new_mzip new_bind new_return)
where
zonk_branch (stmts, bndrs) = zonkStmts env stmts `thenM` \ (env1, new_stmts) ->
returnM (new_stmts, zonkIdOccs env1 bndrs)
where
zonk_branch (stmts, bndrs) = zonkStmts env stmts `thenM` \ (env1, new_stmts) ->
returnM (new_stmts, zonkIdOccs env1 bndrs)
@@
-758,26
+762,32
@@
zonkStmt env (RecStmt { recS_stmts = segStmts, recS_later_ids = lvs, recS_rec_id
, recS_mfix_fn = new_mfix_id, recS_bind_fn = new_bind_id
, recS_rec_rets = new_rets }) }
, recS_mfix_fn = new_mfix_id, recS_bind_fn = new_bind_id
, recS_rec_rets = new_rets }) }
-zonkStmt env (ExprStmt expr then_op ty)
+zonkStmt env (ExprStmt expr then_op guard_op ty)
= zonkLExpr env expr `thenM` \ new_expr ->
zonkExpr env then_op `thenM` \ new_then ->
= zonkLExpr env expr `thenM` \ new_expr ->
zonkExpr env then_op `thenM` \ new_then ->
+ zonkExpr env guard_op `thenM` \ new_guard ->
zonkTcTypeToType env ty `thenM` \ new_ty ->
zonkTcTypeToType env ty `thenM` \ new_ty ->
- returnM (env, ExprStmt new_expr new_then new_ty)
+ returnM (env, ExprStmt new_expr new_then new_guard new_ty)
-zonkStmt env (TransformStmt stmts binders usingExpr maybeByExpr)
+zonkStmt env (TransformStmt stmts binders usingExpr maybeByExpr return_op bind_op)
= do { (env', stmts') <- zonkStmts env stmts
; let binders' = zonkIdOccs env' binders
; usingExpr' <- zonkLExpr env' usingExpr
; maybeByExpr' <- zonkMaybeLExpr env' maybeByExpr
= do { (env', stmts') <- zonkStmts env stmts
; let binders' = zonkIdOccs env' binders
; usingExpr' <- zonkLExpr env' usingExpr
; maybeByExpr' <- zonkMaybeLExpr env' maybeByExpr
- ; return (env', TransformStmt stmts' binders' usingExpr' maybeByExpr') }
+ ; return_op' <- zonkExpr env' return_op
+ ; bind_op' <- zonkExpr env' bind_op
+ ; return (env', TransformStmt stmts' binders' usingExpr' maybeByExpr' return_op' bind_op') }
-zonkStmt env (GroupStmt stmts binderMap by using)
+zonkStmt env (GroupStmt stmts binderMap by using return_op bind_op liftM_op)
= do { (env', stmts') <- zonkStmts env stmts
; binderMap' <- mappM (zonkBinderMapEntry env') binderMap
; by' <- fmapMaybeM (zonkLExpr env') by
; using' <- fmapEitherM (zonkLExpr env) (zonkExpr env) using
= do { (env', stmts') <- zonkStmts env stmts
; binderMap' <- mappM (zonkBinderMapEntry env') binderMap
; by' <- fmapMaybeM (zonkLExpr env') by
; using' <- fmapEitherM (zonkLExpr env) (zonkExpr env) using
+ ; return_op' <- zonkExpr env' return_op
+ ; bind_op' <- zonkExpr env' bind_op
+ ; liftM_op' <- zonkExpr env' liftM_op
; let env'' = extendZonkEnv env' (map snd binderMap')
; let env'' = extendZonkEnv env' (map snd binderMap')
- ; return (env'', GroupStmt stmts' binderMap' by' using') }
+ ; return (env'', GroupStmt stmts' binderMap' by' using' return_op' bind_op' liftM_op') }
where
zonkBinderMapEntry env (oldBinder, newBinder) = do
let oldBinder' = zonkIdOcc env oldBinder
where
zonkBinderMapEntry env (oldBinder, newBinder) = do
let oldBinder' = zonkIdOcc env oldBinder
@@
-1112,4
+1122,4
@@
zonkTypeZapping ty
zonk_unbound_tyvar tv = do { let ty = anyTypeOfKind (tyVarKind tv)
; writeMetaTyVar tv ty
; return ty }
zonk_unbound_tyvar tv = do { let ty = anyTypeOfKind (tyVarKind tv)
; writeMetaTyVar tv ty
; return ty }
-\end{code}
\ No newline at end of file
+\end{code}