-dsDo do_or_lc stmts ids result_ty
- = dsReboundNames ids `thenDs` \ (meth_binds, ds_meths) ->
- let
- return_id = lookupReboundName ds_meths returnMName
- fail_id = lookupReboundName ds_meths failMName
- bind_id = lookupReboundName ds_meths bindMName
- then_id = lookupReboundName ds_meths thenMName
-
- (m_ty, b_ty) = tcSplitAppTy result_ty -- result_ty must be of the form (m b)
-
- -- For ExprStmt, see the comments near HsExpr.Stmt about
- -- exactly what ExprStmts mean!
- --
- -- In dsDo we can only see DoStmt and ListComp (no guards)
-
- go [ResultStmt expr] = dsLExpr expr
-
-
- go (ExprStmt expr a_ty : stmts)
- = dsLExpr expr `thenDs` \ expr2 ->
- go stmts `thenDs` \ rest ->
- returnDs (mkApps then_id [Type a_ty, Type b_ty, expr2, rest])
-
- go (LetStmt binds : stmts)
- = go stmts `thenDs` \ rest ->
- dsLet binds rest
-
- go (BindStmt pat expr : stmts)
- = go stmts `thenDs` \ body ->
- dsLExpr expr `thenDs` \ rhs ->
- mkStringLit (mk_msg (getLoc pat)) `thenDs` \ core_msg ->
- let
- -- In a do expression, pattern-match failure just calls
- -- the monadic 'fail' rather than throwing an exception
- fail_expr = mkApps fail_id [Type b_ty, core_msg]
- a_ty = hsPatType pat
- in
- selectMatchVarL pat `thenDs` \ var ->
- matchSimply (Var var) (StmtCtxt do_or_lc) pat
- body fail_expr `thenDs` \ match_code ->
- returnDs (mkApps bind_id [Type a_ty, Type b_ty, rhs, Lam var match_code])
-
- go (RecStmt rec_stmts later_vars rec_vars rec_rets : stmts)
- = go (bind_stmt : stmts)
- where
- bind_stmt = dsRecStmt m_ty ds_meths rec_stmts later_vars rec_vars rec_rets
-
- in
- go (map unLoc stmts) `thenDs` \ stmts_code ->
- returnDs (foldr Let stmts_code meth_binds)
-