2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
4 \section[DsExpr]{Matching expressions (Exprs)}
7 #include "HsVersions.h"
9 module DsExpr ( dsExpr ) where
12 IMPORT_DELOOPER(DsLoop) -- partly to get dsBinds, partly to chk dsExpr
14 import HsSyn ( failureFreePat,
15 HsExpr(..), OutPat(..), HsLit(..), ArithSeqInfo(..),
16 Stmt(..), Match(..), Qualifier, HsBinds, PolyType,
19 import TcHsSyn ( SYN_IE(TypecheckedHsExpr), SYN_IE(TypecheckedHsBinds),
20 SYN_IE(TypecheckedRecordBinds), SYN_IE(TypecheckedPat),
21 SYN_IE(TypecheckedStmt)
26 import DsCCall ( dsCCall )
27 import DsHsSyn ( outPatType )
28 import DsListComp ( dsListComp )
29 import DsUtils ( mkAppDs, mkConDs, mkPrimDs, dsExprToAtom,
30 mkErrorAppDs, showForErr, EquationInfo,
31 MatchResult, SYN_IE(DsCoreArg)
33 import Match ( matchWrapper )
35 import CoreUnfold ( UnfoldingDetails(..), UnfoldingGuidance(..),
37 import CoreUtils ( coreExprType, substCoreExpr, argToExpr,
38 mkCoreIfThenElse, unTagBinders )
39 import CostCentre ( mkUserCC )
40 import FieldLabel ( fieldLabelType, FieldLabel )
41 import Id ( mkTupleCon, idType, nullIdEnv, addOneToIdEnv,
42 getIdUnfolding, dataConArgTys, dataConFieldLabels,
43 recordSelectorFieldLabel
45 import Literal ( mkMachInt, Literal(..) )
46 import MagicUFs ( MagicUnfoldingFun )
47 import Name ( Name{--O only-} )
48 import PprStyle ( PprStyle(..) )
49 import PprType ( GenType )
50 import PrelVals ( rEC_CON_ERROR_ID, rEC_UPD_ERROR_ID, voidId )
51 import Pretty ( ppShow, ppBesides, ppPStr, ppStr )
52 import TyCon ( isDataTyCon, isNewTyCon )
53 import Type ( splitSigmaTy, splitFunTy, typePrimRep,
54 getAppDataTyConExpandingDicts, getAppTyCon, applyTy,
57 import TysPrim ( voidTy )
58 import TysWiredIn ( mkTupleTy, nilDataCon, consDataCon,
61 import TyVar ( nullTyVarEnv, addOneToTyVarEnv, GenTyVar{-instance Eq-} )
62 import Usage ( SYN_IE(UVar) )
63 import Util ( zipEqual, pprError, panic, assertPanic )
65 mk_nil_con ty = mkCon nilDataCon [] [ty] [] -- micro utility...
68 The funny business to do with variables is that we look them up in the
69 Id-to-Id and Id-to-Id maps that the monadery is carrying
70 around; if we get hits, we use the value accordingly.
72 %************************************************************************
74 \subsection[DsExpr-vars-and-cons]{Variables and constructors}
76 %************************************************************************
79 dsExpr :: TypecheckedHsExpr -> DsM CoreExpr
81 dsExpr (HsVar var) = dsApp (HsVar var) []
84 %************************************************************************
86 \subsection[DsExpr-literals]{Literals}
88 %************************************************************************
90 We give int/float literals type Integer and Rational, respectively.
91 The typechecker will (presumably) have put \tr{from{Integer,Rational}s}
94 ToDo: put in range checks for when converting "i"
95 (or should that be in the typechecker?)
97 For numeric literals, we try to detect there use at a standard type
98 (Int, Float, etc.) are directly put in the right constructor.
99 [NB: down with the @App@ conversion.]
100 Otherwise, we punt, putting in a "NoRep" Core literal (where the
101 representation decisions are delayed)...
103 See also below where we look for @DictApps@ for \tr{plusInt}, etc.
106 dsExpr (HsLitOut (HsString s) _)
108 = returnDs (mk_nil_con charTy)
112 the_char = mkCon charDataCon [] [] [LitArg (MachChar (_HEAD_ s))]
113 the_nil = mk_nil_con charTy
115 mkConDs consDataCon [TyArg charTy, VarArg the_char, VarArg the_nil]
117 -- "_" => build (\ c n -> c 'c' n) -- LATER
119 -- "str" ==> build (\ c n -> foldr charTy T c n "str")
122 dsExpr (HsLitOut (HsString str) _)
123 = newTyVarsDs [alphaTyVar] `thenDs` \ [new_tyvar] ->
125 new_ty = mkTyVarTy new_tyvar
128 charTy `mkFunTy` (new_ty `mkFunTy` new_ty),
130 mkForallTy [alphaTyVar]
131 ((charTy `mkFunTy` (alphaTy `mkFunTy` alphaTy))
132 `mkFunTy` (alphaTy `mkFunTy` alphaTy))
133 ] `thenDs` \ [c,n,g] ->
134 returnDs (mkBuild charTy new_tyvar c n g (
136 (CoTyApp (CoTyApp (Var foldrId) charTy) new_ty) *** ensure non-prim type ***
137 [VarArg c,VarArg n,LitArg (NoRepStr str)]))
140 -- otherwise, leave it as a NoRepStr;
141 -- the Core-to-STG pass will wrap it in an application of "unpackCStringId".
143 dsExpr (HsLitOut (HsString str) _)
144 = returnDs (Lit (NoRepStr str))
146 dsExpr (HsLitOut (HsLitLit s) ty)
147 = returnDs ( mkCon data_con [] [] [LitArg (MachLitLit s kind)] )
150 = case (maybeBoxedPrimType ty) of
151 Just (boxing_data_con, prim_ty)
152 -> (boxing_data_con, typePrimRep prim_ty)
154 -> pprError "ERROR: ``literal-literal'' not a single-constructor type: "
155 (ppBesides [ppPStr s, ppStr "; type: ", ppr PprDebug ty])
157 dsExpr (HsLitOut (HsInt i) ty)
158 = returnDs (Lit (NoRepInteger i ty))
160 dsExpr (HsLitOut (HsFrac r) ty)
161 = returnDs (Lit (NoRepRational r ty))
163 -- others where we know what to do:
165 dsExpr (HsLitOut (HsIntPrim i) _)
166 = if (i >= toInteger minInt && i <= toInteger maxInt) then
167 returnDs (Lit (mkMachInt i))
169 error ("ERROR: Int constant " ++ show i ++ out_of_range_msg)
171 dsExpr (HsLitOut (HsFloatPrim f) _)
172 = returnDs (Lit (MachFloat f))
173 -- ToDo: range checking needed!
175 dsExpr (HsLitOut (HsDoublePrim d) _)
176 = returnDs (Lit (MachDouble d))
177 -- ToDo: range checking needed!
179 dsExpr (HsLitOut (HsChar c) _)
180 = returnDs ( mkCon charDataCon [] [] [LitArg (MachChar c)] )
182 dsExpr (HsLitOut (HsCharPrim c) _)
183 = returnDs (Lit (MachChar c))
185 dsExpr (HsLitOut (HsStringPrim s) _)
186 = returnDs (Lit (MachStr s))
188 -- end of literals magic. --
190 dsExpr expr@(HsLam a_Match)
191 = matchWrapper LambdaMatch [a_Match] "lambda" `thenDs` \ (binders, matching_code) ->
192 returnDs ( mkValLam binders matching_code )
194 dsExpr expr@(HsApp e1 e2) = dsApp expr []
195 dsExpr expr@(OpApp e1 op e2) = dsApp expr []
198 Operator sections. At first it looks as if we can convert
207 But no! expr might be a redex, and we can lose laziness badly this
212 for example. So we convert instead to
214 let y = expr in \x -> op y x
216 If \tr{expr} is actually just a variable, say, then the simplifier
220 dsExpr (SectionL expr op)
221 = dsExpr op `thenDs` \ core_op ->
222 dsExpr expr `thenDs` \ core_expr ->
223 dsExprToAtom (VarArg core_expr) $ \ y_atom ->
225 -- for the type of x, we need the type of op's 2nd argument
227 x_ty = case (splitSigmaTy (coreExprType core_op)) of { (_, _, tau_ty) ->
228 case (splitFunTy tau_ty) of {
229 ((_:arg2_ty:_), _) -> arg2_ty;
230 _ -> panic "dsExpr:SectionL:arg 2 ty" }}
232 newSysLocalDs x_ty `thenDs` \ x_id ->
233 returnDs (mkValLam [x_id] (core_op `App` y_atom `App` VarArg x_id))
235 -- dsExpr (SectionR op expr) -- \ x -> op x expr
236 dsExpr (SectionR op expr)
237 = dsExpr op `thenDs` \ core_op ->
238 dsExpr expr `thenDs` \ core_expr ->
239 dsExprToAtom (VarArg core_expr) $ \ y_atom ->
241 -- for the type of x, we need the type of op's 1st argument
243 x_ty = case (splitSigmaTy (coreExprType core_op)) of { (_, _, tau_ty) ->
244 case (splitFunTy tau_ty) of {
245 ((arg1_ty:_), _) -> arg1_ty;
246 _ -> panic "dsExpr:SectionR:arg 1 ty" }}
248 newSysLocalDs x_ty `thenDs` \ x_id ->
249 returnDs (mkValLam [x_id] (core_op `App` VarArg x_id `App` y_atom))
251 dsExpr (CCall label args may_gc is_asm result_ty)
252 = mapDs dsExpr args `thenDs` \ core_args ->
253 dsCCall label core_args may_gc is_asm result_ty
254 -- dsCCall does all the unboxification, etc.
256 dsExpr (HsSCC cc expr)
257 = dsExpr expr `thenDs` \ core_expr ->
258 getModuleAndGroupDs `thenDs` \ (mod_name, group_name) ->
259 returnDs ( SCC (mkUserCC cc mod_name group_name) core_expr)
261 dsExpr expr@(HsCase discrim matches src_loc)
262 = putSrcLocDs src_loc $
263 dsExpr discrim `thenDs` \ core_discrim ->
264 matchWrapper CaseMatch matches "case" `thenDs` \ ([discrim_var], matching_code) ->
265 returnDs ( mkCoLetAny (NonRec discrim_var core_discrim) matching_code )
267 dsExpr (ListComp expr quals)
268 = dsExpr expr `thenDs` \ core_expr ->
269 dsListComp core_expr quals
271 dsExpr (HsLet binds expr)
272 = dsBinds False binds `thenDs` \ core_binds ->
273 dsExpr expr `thenDs` \ core_expr ->
274 returnDs ( mkCoLetsAny core_binds core_expr )
276 dsExpr (HsDoOut stmts then_id zero_id src_loc)
277 = putSrcLocDs src_loc $
278 dsDo then_id zero_id stmts
280 dsExpr (HsIf guard_expr then_expr else_expr src_loc)
281 = putSrcLocDs src_loc $
282 dsExpr guard_expr `thenDs` \ core_guard ->
283 dsExpr then_expr `thenDs` \ core_then ->
284 dsExpr else_expr `thenDs` \ core_else ->
285 returnDs (mkCoreIfThenElse core_guard core_then core_else)
289 Type lambda and application
290 ~~~~~~~~~~~~~~~~~~~~~~~~~~~
292 dsExpr (TyLam tyvars expr)
293 = dsExpr expr `thenDs` \ core_expr ->
294 returnDs (mkTyLam tyvars core_expr)
296 dsExpr expr@(TyApp e tys) = dsApp expr []
300 Various data construction things
301 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
303 dsExpr (ExplicitListOut ty xs)
305 [] -> returnDs (mk_nil_con ty)
307 dsExpr y `thenDs` \ core_hd ->
308 dsExpr (ExplicitListOut ty ys) `thenDs` \ core_tl ->
309 mkConDs consDataCon [TyArg ty, VarArg core_hd, VarArg core_tl]
311 dsExpr (ExplicitTuple expr_list)
312 = mapDs dsExpr expr_list `thenDs` \ core_exprs ->
313 mkConDs (mkTupleCon (length expr_list))
314 (map (TyArg . coreExprType) core_exprs ++ map VarArg core_exprs)
316 -- Two cases, one for ordinary constructors and one for newtype constructors
317 dsExpr (HsCon con tys args)
318 | isDataTyCon tycon -- The usual datatype case
319 = mapDs dsExpr args `thenDs` \ args_exprs ->
320 mkConDs con (map TyArg tys ++ map VarArg args_exprs)
322 | otherwise -- The newtype case
323 = ASSERT( isNewTyCon tycon )
324 ASSERT( null rest_args )
325 dsExpr first_arg `thenDs` \ arg_expr ->
326 returnDs (Coerce (CoerceIn con) result_ty arg_expr)
329 (first_arg:rest_args) = args
330 (args_tys, result_ty) = splitFunTy (foldl applyTy (idType con) tys)
331 (tycon,_) = getAppTyCon result_ty
333 dsExpr (ArithSeqOut expr (From from))
334 = dsExpr expr `thenDs` \ expr2 ->
335 dsExpr from `thenDs` \ from2 ->
336 mkAppDs expr2 [VarArg from2]
338 dsExpr (ArithSeqOut expr (FromTo from two))
339 = dsExpr expr `thenDs` \ expr2 ->
340 dsExpr from `thenDs` \ from2 ->
341 dsExpr two `thenDs` \ two2 ->
342 mkAppDs expr2 [VarArg from2, VarArg two2]
344 dsExpr (ArithSeqOut expr (FromThen from thn))
345 = dsExpr expr `thenDs` \ expr2 ->
346 dsExpr from `thenDs` \ from2 ->
347 dsExpr thn `thenDs` \ thn2 ->
348 mkAppDs expr2 [VarArg from2, VarArg thn2]
350 dsExpr (ArithSeqOut expr (FromThenTo from thn two))
351 = dsExpr expr `thenDs` \ expr2 ->
352 dsExpr from `thenDs` \ from2 ->
353 dsExpr thn `thenDs` \ thn2 ->
354 dsExpr two `thenDs` \ two2 ->
355 mkAppDs expr2 [VarArg from2, VarArg thn2, VarArg two2]
358 Record construction and update
359 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
360 For record construction we do this (assuming T has three arguments)
364 let err = /\a -> recConErr a
365 T (recConErr t1 "M.lhs/230/op1")
367 (recConErr t1 "M.lhs/230/op3")
369 recConErr then converts its arugment string into a proper message
370 before printing it as
372 M.lhs, line 230: missing field op1 was evaluated
376 dsExpr (RecordCon con_expr rbinds)
377 = dsExpr con_expr `thenDs` \ con_expr' ->
379 con_id = get_con con_expr'
380 (arg_tys, _) = splitFunTy (coreExprType con_expr')
383 = case [rhs | (sel_id,rhs,_) <- rbinds,
384 lbl == recordSelectorFieldLabel sel_id] of
385 (rhs:rhss) -> ASSERT( null rhss )
387 [] -> mkErrorAppDs rEC_CON_ERROR_ID arg_ty (showForErr lbl)
389 mapDs mk_arg (zipEqual "dsExpr:RecordCon" arg_tys (dataConFieldLabels con_id)) `thenDs` \ con_args ->
390 mkAppDs con_expr' (map VarArg con_args)
392 -- "con_expr'" is simply an application of the constructor Id
393 -- to types and (perhaps) dictionaries. This gets the constructor...
394 get_con (Var con) = con
395 get_con (App fun _) = get_con fun
398 Record update is a little harder. Suppose we have the decl:
400 data T = T1 {op1, op2, op3 :: Int}
401 | T2 {op4, op2 :: Int}
404 Then we translate as follows:
410 T1 op1 _ op3 -> T1 op1 op2 op3
411 T2 op4 _ -> T2 op4 op2
412 other -> recUpdError "M.lhs/230"
414 It's important that we use the constructor Ids for T1, T2 etc on the
415 RHSs, and do not generate a Core Con directly, because the constructor
416 might do some argument-evaluation first; and may have to throw away some
420 dsExpr (RecordUpdOut record_expr dicts rbinds)
421 = dsExpr record_expr `thenDs` \ record_expr' ->
423 -- Desugar the rbinds, and generate let-bindings if
424 -- necessary so that we don't lose sharing
425 dsRbinds rbinds $ \ rbinds' ->
427 record_ty = coreExprType record_expr'
428 (tycon, inst_tys, cons) = trace "DsExpr.getAppDataTyConExpandingDicts" $
429 getAppDataTyConExpandingDicts record_ty
430 cons_to_upd = filter has_all_fields cons
432 -- initial_args are passed to every constructor
433 initial_args = map TyArg inst_tys ++ map VarArg dicts
435 mk_val_arg (field, arg_id)
436 = case [arg | (f, arg) <- rbinds',
437 field == recordSelectorFieldLabel f] of
438 (arg:args) -> ASSERT(null args)
443 = newSysLocalsDs (dataConArgTys con inst_tys) `thenDs` \ arg_ids ->
445 val_args = map mk_val_arg (zipEqual "dsExpr:RecordUpd" (dataConFieldLabels con) arg_ids)
447 returnDs (con, arg_ids, mkGenApp (mkGenApp (Var con) initial_args) val_args)
450 | length cons_to_upd == length cons
453 = newSysLocalDs record_ty `thenDs` \ deflt_id ->
454 mkErrorAppDs rEC_UPD_ERROR_ID record_ty "" `thenDs` \ err ->
455 returnDs (BindDefault deflt_id err)
457 mapDs mk_alt cons_to_upd `thenDs` \ alts ->
458 mk_default `thenDs` \ deflt ->
460 returnDs (Case record_expr' (AlgAlts alts deflt))
463 has_all_fields :: Id -> Bool
464 has_all_fields con_id
467 con_fields = dataConFieldLabels con_id
468 ok (sel_id, _, _) = recordSelectorFieldLabel sel_id `elem` con_fields
471 Dictionary lambda and application
472 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
473 @DictLam@ and @DictApp@ turn into the regular old things.
474 (OLD:) @DictFunApp@ also becomes a curried application, albeit slightly more
475 complicated; reminiscent of fully-applied constructors.
477 dsExpr (DictLam dictvars expr)
478 = dsExpr expr `thenDs` \ core_expr ->
479 returnDs( mkValLam dictvars core_expr )
483 dsExpr expr@(DictApp e dicts) -- becomes a curried application
487 @SingleDicts@ become @Locals@; @Dicts@ turn into tuples, unless
489 @ClassDictLam dictvars methods expr@ is ``the opposite'':
491 \ x -> case x of ( dictvars-and-methods-tuple ) -> expr
494 dsExpr (SingleDict dict) -- just a local
495 = lookupEnvWithDefaultDs dict (Var dict)
497 dsExpr (Dictionary dicts methods)
498 = -- hey, these things may have been substituted away...
499 zipWithDs lookupEnvWithDefaultDs
500 dicts_and_methods dicts_and_methods_exprs
501 `thenDs` \ core_d_and_ms ->
503 (case num_of_d_and_ms of
504 0 -> returnDs (Var voidId)
506 1 -> returnDs (head core_d_and_ms) -- just a single Id
509 mkConDs (mkTupleCon num_of_d_and_ms)
510 (map (TyArg . coreExprType) core_d_and_ms ++ map VarArg core_d_and_ms)
513 dicts_and_methods = dicts ++ methods
514 dicts_and_methods_exprs = map Var dicts_and_methods
515 num_of_d_and_ms = length dicts_and_methods
517 dsExpr (ClassDictLam dicts methods expr)
518 = dsExpr expr `thenDs` \ core_expr ->
519 case num_of_d_and_ms of
520 0 -> newSysLocalDs voidTy `thenDs` \ new_x ->
521 returnDs (mkValLam [new_x] core_expr)
524 returnDs (mkValLam dicts_and_methods core_expr)
527 newSysLocalDs tuple_ty `thenDs` \ new_x ->
529 Lam (ValBinder new_x)
532 [(tuple_con, dicts_and_methods, core_expr)]
535 num_of_d_and_ms = length dicts + length methods
536 dicts_and_methods = dicts ++ methods
537 tuple_ty = mkTupleTy num_of_d_and_ms (map idType dicts_and_methods)
538 tuple_con = mkTupleCon num_of_d_and_ms
541 -- HsSyn constructs that just shouldn't be here:
542 dsExpr (HsDo _ _) = panic "dsExpr:HsDo"
543 dsExpr (ExplicitList _) = panic "dsExpr:ExplicitList"
544 dsExpr (ExprWithTySig _ _) = panic "dsExpr:ExprWithTySig"
545 dsExpr (ArithSeqIn _) = panic "dsExpr:ArithSeqIn"
548 out_of_range_msg -- ditto
549 = " out of range: [" ++ show minInt ++ ", " ++ show maxInt ++ "]\n"
552 %--------------------------------------------------------------------
554 @(dsApp e [t_1,..,t_n, e_1,..,e_n])@ returns something with the same
557 e t_1 ... t_n e_1 .. e_n
560 We're doing all this so we can saturate constructors (as painlessly as
564 dsApp :: TypecheckedHsExpr -- expr to desugar
565 -> [DsCoreArg] -- accumulated ty/val args: NB:
566 -> DsM CoreExpr -- final result
568 dsApp (HsApp e1 e2) args
569 = dsExpr e2 `thenDs` \ core_e2 ->
570 dsApp e1 (VarArg core_e2 : args)
572 dsApp (OpApp e1 op e2) args
573 = dsExpr e1 `thenDs` \ core_e1 ->
574 dsExpr e2 `thenDs` \ core_e2 ->
575 dsApp op (VarArg core_e1 : VarArg core_e2 : args)
577 dsApp (DictApp expr dicts) args
578 = -- now, those dicts may have been substituted away...
579 zipWithDs lookupEnvWithDefaultDs dicts (map Var dicts)
580 `thenDs` \ core_dicts ->
581 dsApp expr (map VarArg core_dicts ++ args)
583 dsApp (TyApp expr tys) args
584 = dsApp expr (map TyArg tys ++ args)
586 -- we might should look out for SectionLs, etc., here, but we don't
589 = lookupEnvDs v `thenDs` \ maybe_expr ->
591 Just expr -> mkAppDs expr args
593 Nothing -> -- we're only saturating constructors and PrimOps
594 case getIdUnfolding v of
595 GenForm _ the_unfolding EssentialUnfolding
596 -> do_unfold nullTyVarEnv nullIdEnv (unTagBinders the_unfolding) args
598 _ -> mkAppDs (Var v) args
601 dsApp anything_else args
602 = dsExpr anything_else `thenDs` \ core_expr ->
603 mkAppDs core_expr args
607 dsRbinds :: TypecheckedRecordBinds -- The field bindings supplied
608 -> ([(Id, CoreArg)] -> DsM CoreExpr) -- A continuation taking the field
609 -- bindings with atomic rhss
610 -> DsM CoreExpr -- The result of the continuation,
611 -- wrapped in suitable Lets
613 dsRbinds [] continue_with
616 dsRbinds ((sel_id, rhs, pun_flag) : rbinds) continue_with
617 = dsExpr rhs `thenDs` \ rhs' ->
618 dsExprToAtom (VarArg rhs') $ \ rhs_atom ->
619 dsRbinds rbinds $ \ rbinds' ->
620 continue_with ((sel_id, rhs_atom) : rbinds')
624 do_unfold ty_env val_env (Lam (TyBinder tyvar) body) (TyArg ty : args)
625 = do_unfold (addOneToTyVarEnv ty_env tyvar ty) val_env body args
627 do_unfold ty_env val_env (Lam (ValBinder binder) body) (arg@(VarArg expr) : args)
628 = dsExprToAtom arg $ \ arg_atom ->
630 (addOneToIdEnv val_env binder (argToExpr arg_atom))
633 do_unfold ty_env val_env body args
634 = -- Clone the remaining part of the template
635 uniqSMtoDsM (substCoreExpr val_env ty_env body) `thenDs` \ body' ->
637 -- Apply result to remaining arguments
641 Basically does the translation given in the Haskell~1.3 report:
643 dsDo :: Id -- id for: (>>=) m
644 -> Id -- id for: zero m
648 dsDo then_id zero_id (stmt:stmts)
650 ExprStmt expr locn -> ASSERT( null stmts ) do_expr expr locn
652 ExprStmtOut expr locn a b ->
653 do_expr expr locn `thenDs` \ expr2 ->
654 ds_rest `thenDs` \ rest ->
655 newSysLocalDs a `thenDs` \ ignored_result_id ->
656 dsApp (HsVar then_id) [TyArg a, TyArg b, VarArg expr2,
657 VarArg (mkValLam [ignored_result_id] rest)]
660 dsBinds False binds `thenDs` \ binds2 ->
661 ds_rest `thenDs` \ rest ->
662 returnDs (mkCoLetsAny binds2 rest)
664 BindStmtOut pat expr locn a b ->
665 do_expr expr locn `thenDs` \ expr2 ->
667 zero_expr = TyApp (HsVar zero_id) [b]
669 = PatMatch pat (SimpleMatch (HsDoOut stmts then_id zero_id locn))
671 = if failureFreePat pat
673 else [main_match, PatMatch (WildPat a) (SimpleMatch zero_expr)]
675 matchWrapper DoBindMatch the_matches "`do' statement"
676 `thenDs` \ (binders, matching_code) ->
677 dsApp (HsVar then_id) [TyArg a, TyArg b,
678 VarArg expr2, VarArg (mkValLam binders matching_code)]
680 ds_rest = dsDo then_id zero_id stmts
681 do_expr expr locn = putSrcLocDs locn (dsExpr expr)
684 dsDo then_expr zero_expr [] = panic "dsDo:[]"