+dsDo do_or_lc stmts return_id then_id fail_id result_ty
+ = let
+ (_, b_ty) = splitAppTy result_ty -- result_ty must be of the form (m b)
+
+ go [ReturnStmt expr]
+ = dsExpr expr `thenDs` \ expr2 ->
+ returnDs (mkApps (Var return_id) [Type b_ty, expr2])
+
+ go (GuardStmt expr locn : stmts)
+ = do_expr expr locn `thenDs` \ expr2 ->
+ go stmts `thenDs` \ rest ->
+ let msg = ASSERT( isNotUsgTy b_ty )
+ "Pattern match failure in do expression, " ++ showSDoc (ppr locn) in
+ returnDs (mkIfThenElse expr2
+ rest
+ (App (App (Var fail_id)
+ (Type b_ty))
+ (mkLit (mkStrLit msg stringTy))))
+
+ go (ExprStmt expr locn : stmts)
+ = do_expr expr locn `thenDs` \ expr2 ->
+ let
+ (_, a_ty) = splitAppTy (coreExprType expr2) -- Must be of form (m a)
+ in
+ if null stmts then
+ returnDs expr2
+ else
+ go stmts `thenDs` \ rest ->
+ newSysLocalDs a_ty `thenDs` \ ignored_result_id ->
+ returnDs (mkApps (Var then_id) [Type a_ty, Type b_ty, expr2,
+ Lam ignored_result_id rest])
+
+ go (LetStmt binds : stmts )
+ = go stmts `thenDs` \ rest ->
+ dsLet binds rest
+
+ go (BindStmt pat expr locn : stmts)
+ = putSrcLocDs locn $
+ dsExpr expr `thenDs` \ expr2 ->
+ let
+ (_, a_ty) = splitAppTy (coreExprType expr2) -- Must be of form (m a)
+ fail_expr = HsApp (TyApp (HsVar fail_id) [b_ty])
+ (HsLitOut (HsString (_PK_ msg)) stringTy)
+ msg = ASSERT2( isNotUsgTy a_ty, ppr a_ty )
+ ASSERT2( isNotUsgTy b_ty, ppr b_ty )
+ "Pattern match failure in do expression, " ++ showSDoc (ppr locn)
+ main_match = mkSimpleMatch [pat]
+ (HsDoOut do_or_lc stmts return_id then_id
+ fail_id result_ty locn)
+ (Just result_ty) locn
+ the_matches
+ | failureFreePat pat = [main_match]
+ | otherwise =
+ [ main_match
+ , mkSimpleMatch [WildPat a_ty] fail_expr (Just result_ty) locn
+ ]
+ in
+ matchWrapper DoBindMatch the_matches match_msg
+ `thenDs` \ (binders, matching_code) ->
+ returnDs (mkApps (Var then_id) [Type a_ty, Type b_ty, expr2,
+ mkLams binders matching_code])
+ in
+ go stmts