+dsMDo tbl stmts body result_ty
+ = go (map unLoc stmts)
+ where
+ (m_ty, b_ty) = tcSplitAppTy result_ty -- result_ty must be of the form (m b)
+ mfix_id = lookupEvidence tbl mfixName
+ return_id = lookupEvidence tbl returnMName
+ bind_id = lookupEvidence tbl bindMName
+ then_id = lookupEvidence tbl thenMName
+ fail_id = lookupEvidence tbl failMName
+ ctxt = MDoExpr tbl
+
+ go [] = dsLExpr body
+
+ go (LetStmt binds : stmts)
+ = do { rest <- go stmts
+ ; dsLocalBinds binds rest }
+
+ go (ExprStmt rhs _ rhs_ty : stmts)
+ = do { rhs2 <- dsLExpr rhs
+ ; rest <- go stmts
+ ; returnDs (mkApps (Var then_id) [Type rhs_ty, Type b_ty, rhs2, rest]) }
+
+ go (BindStmt pat rhs _ _ : stmts)
+ = do { body <- go stmts
+ ; var <- selectSimpleMatchVarL pat
+ ; match <- matchSinglePat (Var var) (StmtCtxt ctxt) pat
+ result_ty (cantFailMatchResult body)
+ ; fail_msg <- mkStringExpr (mk_fail_msg pat)
+ ; let fail_expr = mkApps (Var fail_id) [Type b_ty, fail_msg]
+ ; match_code <- extractMatchResult match fail_expr
+
+ ; rhs' <- dsLExpr rhs
+ ; returnDs (mkApps (Var bind_id) [Type (hsPatType pat), Type b_ty,
+ rhs', Lam var match_code]) }
+
+ go (RecStmt rec_stmts later_ids rec_ids rec_rets binds : stmts)
+ = ASSERT( length rec_ids > 0 )
+ ASSERT( length rec_ids == length rec_rets )
+ go (new_bind_stmt : let_stmt : stmts)
+ where
+ new_bind_stmt = mkBindStmt (mk_tup_pat later_pats) mfix_app
+ let_stmt = LetStmt (HsValBinds (ValBindsOut [(Recursive, binds)] []))