-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)
-
- -- For ExprStmt, see the comments near HsExpr.HsStmt about
- -- exactly what ExprStmts mean!
- --
- -- In dsDo we can only see DoStmt and ListComp (no gaurds)
-
- go [ResultStmt expr locn]
- | isDoExpr do_or_lc = do_expr expr locn
- | otherwise = do_expr expr locn `thenDs` \ expr2 ->
- returnDs (mkApps (Var return_id) [Type b_ty, expr2])
-
- go (ExprStmt expr locn : stmts)
- | isDoExpr do_or_lc
- = do_expr expr locn `thenDs` \ expr2 ->
- go stmts `thenDs` \ rest ->
- let
- (_, a_ty) = splitAppTy (exprType expr2) -- Must be of form (m a)
- in
- newSysLocalDs a_ty `thenDs` \ ignored_result_id ->
- returnDs (mkApps (Var then_id) [Type a_ty, Type b_ty, expr2,
- Lam ignored_result_id rest])
-
- | otherwise -- List comprehension
- = do_expr expr locn `thenDs` \ expr2 ->
- go stmts `thenDs` \ rest ->
- let
- msg = "Pattern match failure in do expression, " ++ showSDoc (ppr locn)
- in
- mkStringLit msg `thenDs` \ core_msg ->
- returnDs (mkIfThenElse expr2 rest
- (App (App (Var fail_id) (Type b_ty)) core_msg))
-
- 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 (exprType expr2) -- Must be of form (m a)
- fail_expr = HsApp (TyApp (HsVar fail_id) [b_ty])
- (HsLit (HsString (_PK_ msg)))
- msg = "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 DoExpr 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
-