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)
 
-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 ->
+    zonkExpr new_env return_op  `thenM` \ new_return ->
     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 ->
@@ -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)
-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
-    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)
@@ -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 }) }
 
-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 ->
+    zonkExpr env guard_op      `thenM` \ new_guard ->
     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
-    ; 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
+    ; 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')
-    ; 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
@@ -1112,4 +1122,4 @@ zonkTypeZapping 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}