Breakpoint code instrumentation
[ghc.git] / compiler / deSugar / DsExpr.lhs
1 %
2 % (c) The University of Glasgow 2006
3 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
4 %
5
6 Desugaring exporessions.
7
8 \begin{code}
9 module DsExpr ( dsExpr, dsLExpr, dsLocalBinds, dsValBinds, dsLit ) where
10
11 #include "HsVersions.h"
12
13
14 import Match
15 import MatchLit
16 import DsBinds
17 import DsGRHSs
18 import DsListComp
19 import DsUtils
20 import DsArrows
21 import DsMonad
22
23 #ifdef GHCI
24 import PrelNames
25 import DsBreakpoint
26         -- Template Haskell stuff iff bootstrapped
27 import DsMeta
28 #else
29 import DsBreakpoint
30 #endif
31
32 import HsSyn
33 import TcHsSyn
34
35 -- NB: The desugarer, which straddles the source and Core worlds, sometimes
36 --     needs to see source types
37 import TcType
38 import Type
39 import CoreSyn
40 import CoreUtils
41
42 import CostCentre
43 import Id
44 import PrelInfo
45 import DataCon
46 import TyCon
47 import TysWiredIn
48 import BasicTypes
49 import PrelNames
50 import SrcLoc
51 import Util
52 import Bag
53 import Outputable
54 import FastString
55 \end{code}
56
57
58 %************************************************************************
59 %*                                                                      *
60                 dsLocalBinds, dsValBinds
61 %*                                                                      *
62 %************************************************************************
63
64 \begin{code}
65 dsLocalBinds :: HsLocalBinds Id -> CoreExpr -> DsM CoreExpr
66 dsLocalBinds EmptyLocalBinds    body = return body
67 dsLocalBinds (HsValBinds binds) body = dsValBinds binds body
68 dsLocalBinds (HsIPBinds binds)  body = dsIPBinds  binds body
69
70 -------------------------
71 dsValBinds :: HsValBinds Id -> CoreExpr -> DsM CoreExpr
72 dsValBinds (ValBindsOut binds _) body = foldrDs ds_val_bind body binds
73
74 -------------------------
75 dsIPBinds (IPBinds ip_binds dict_binds) body
76   = do  { prs <- dsLHsBinds dict_binds
77         ; let inner = Let (Rec prs) body
78                 -- The dict bindings may not be in 
79                 -- dependency order; hence Rec
80         ; foldrDs ds_ip_bind inner ip_binds }
81   where
82     ds_ip_bind (L _ (IPBind n e)) body
83       = dsLExpr e       `thenDs` \ e' ->
84         returnDs (Let (NonRec (ipNameName n) e') body)
85
86 -------------------------
87 ds_val_bind :: (RecFlag, LHsBinds Id) -> CoreExpr -> DsM CoreExpr
88 -- Special case for bindings which bind unlifted variables
89 -- We need to do a case right away, rather than building
90 -- a tuple and doing selections.
91 -- Silently ignore INLINE and SPECIALISE pragmas...
92 ds_val_bind (NonRecursive, hsbinds) body
93   | [L _ (AbsBinds [] [] exports binds)] <- bagToList hsbinds,
94     (L loc bind : null_binds) <- bagToList binds,
95     isBangHsBind bind
96     || isUnboxedTupleBind bind
97     || or [isUnLiftedType (idType g) | (_, g, _, _) <- exports]
98   = let
99       body_w_exports                  = foldr bind_export body exports
100       bind_export (tvs, g, l, _) body = ASSERT( null tvs )
101                                         bindNonRec g (Var l) body
102     in
103     ASSERT (null null_binds)
104         -- Non-recursive, non-overloaded bindings only come in ones
105         -- ToDo: in some bizarre case it's conceivable that there
106         --       could be dict binds in the 'binds'.  (See the notes
107         --       below.  Then pattern-match would fail.  Urk.)
108     putSrcSpanDs loc    $
109     case bind of
110       FunBind { fun_id = L _ fun, fun_matches = matches, fun_co_fn = co_fn, fun_tick = tick }
111         -> matchWrapper (FunRhs (idName fun)) matches           `thenDs` \ (args, rhs) ->
112            ASSERT( null args )  -- Functions aren't lifted
113            ASSERT( isIdHsWrapper co_fn )
114            mkOptTickBox tick rhs                                `thenDs` \ rhs' ->
115            returnDs (bindNonRec fun rhs' body_w_exports)
116
117       PatBind {pat_lhs = pat, pat_rhs = grhss, pat_rhs_ty = ty }
118         ->      -- let C x# y# = rhs in body
119                 -- ==> case rhs of C x# y# -> body
120            putSrcSpanDs loc                     $
121            do { rhs <- dsGuarded grhss ty
122               ; let upat = unLoc pat
123                     eqn = EqnInfo { eqn_pats = [upat], 
124                                     eqn_rhs = cantFailMatchResult body_w_exports }
125               ; var    <- selectMatchVar upat
126               ; result <- matchEquations PatBindRhs [var] [eqn] (exprType body)
127               ; return (scrungleMatch var rhs result) }
128
129       other -> pprPanic "dsLet: unlifted" (pprLHsBinds hsbinds $$ ppr body)
130
131
132 -- Ordinary case for bindings; none should be unlifted
133 ds_val_bind (is_rec, binds) body
134   = do  { prs <- dsLHsBinds binds
135         ; ASSERT( not (any (isUnLiftedType . idType . fst) prs) )
136           case prs of
137             []    -> return body
138             other -> return (Let (Rec prs) body) }
139         -- Use a Rec regardless of is_rec. 
140         -- Why? Because it allows the binds to be all
141         -- mixed up, which is what happens in one rare case
142         -- Namely, for an AbsBind with no tyvars and no dicts,
143         --         but which does have dictionary bindings.
144         -- See notes with TcSimplify.inferLoop [NO TYVARS]
145         -- It turned out that wrapping a Rec here was the easiest solution
146         --
147         -- NB The previous case dealt with unlifted bindings, so we
148         --    only have to deal with lifted ones now; so Rec is ok
149
150 isUnboxedTupleBind :: HsBind Id -> Bool
151 isUnboxedTupleBind (PatBind { pat_rhs_ty = ty }) = isUnboxedTupleType ty
152 isUnboxedTupleBind other                         = False
153
154 scrungleMatch :: Id -> CoreExpr -> CoreExpr -> CoreExpr
155 -- Returns something like (let var = scrut in body)
156 -- but if var is an unboxed-tuple type, it inlines it in a fragile way
157 -- Special case to handle unboxed tuple patterns; they can't appear nested
158 -- The idea is that 
159 --      case e of (# p1, p2 #) -> rhs
160 -- should desugar to
161 --      case e of (# x1, x2 #) -> ... match p1, p2 ...
162 -- NOT
163 --      let x = e in case x of ....
164 --
165 -- But there may be a big 
166 --      let fail = ... in case e of ...
167 -- wrapping the whole case, which complicates matters slightly
168 -- It all seems a bit fragile.  Test is dsrun013.
169
170 scrungleMatch var scrut body
171   | isUnboxedTupleType (idType var) = scrungle body
172   | otherwise                       = bindNonRec var scrut body
173   where
174     scrungle (Case (Var x) bndr ty alts)
175                     | x == var = Case scrut bndr ty alts
176     scrungle (Let binds body)  = Let binds (scrungle body)
177     scrungle other = panic ("scrungleMatch: tuple pattern:\n" ++ showSDoc (ppr other))
178
179 \end{code}      
180
181 %************************************************************************
182 %*                                                                      *
183 \subsection[DsExpr-vars-and-cons]{Variables, constructors, literals}
184 %*                                                                      *
185 %************************************************************************
186
187 \begin{code}
188 dsLExpr :: LHsExpr Id -> DsM CoreExpr
189
190 #if defined(GHCI)
191 dsLExpr (L loc expr@(HsWrap w (HsVar v)))
192     | idName v `elem` [breakpointName, breakpointCondName, breakpointAutoName]
193     = do areBreakpointsEnabled <- breakpoints_enabled
194          if areBreakpointsEnabled
195            then do
196               L _ breakpointExpr <- mkBreakpointExpr loc v
197               dsLExpr (L loc $ HsWrap w breakpointExpr)
198            else putSrcSpanDs loc $ dsExpr expr
199 #endif
200
201 dsLExpr (L loc e) = putSrcSpanDs loc $ dsExpr e
202
203 dsExpr :: HsExpr Id -> DsM CoreExpr
204 dsExpr (HsPar e)              = dsLExpr e
205 dsExpr (ExprWithTySigOut e _) = dsLExpr e
206 dsExpr (HsVar var)            = returnDs (Var var)
207 dsExpr (HsIPVar ip)           = returnDs (Var (ipNameName ip))
208 dsExpr (HsLit lit)            = dsLit lit
209 dsExpr (HsOverLit lit)        = dsOverLit lit
210 dsExpr (HsWrap co_fn e)     = dsCoercion co_fn (dsExpr e)
211
212 dsExpr (NegApp expr neg_expr) 
213   = do  { core_expr <- dsLExpr expr
214         ; core_neg  <- dsExpr neg_expr
215         ; return (core_neg `App` core_expr) }
216
217 dsExpr expr@(HsLam a_Match)
218   = matchWrapper LambdaExpr a_Match     `thenDs` \ (binders, matching_code) ->
219     returnDs (mkLams binders matching_code)
220
221 dsExpr expr@(HsApp fun arg)      
222   = dsLExpr fun         `thenDs` \ core_fun ->
223     dsLExpr arg         `thenDs` \ core_arg ->
224     returnDs (core_fun `App` core_arg)
225 \end{code}
226
227 Operator sections.  At first it looks as if we can convert
228 \begin{verbatim}
229         (expr op)
230 \end{verbatim}
231 to
232 \begin{verbatim}
233         \x -> op expr x
234 \end{verbatim}
235
236 But no!  expr might be a redex, and we can lose laziness badly this
237 way.  Consider
238 \begin{verbatim}
239         map (expr op) xs
240 \end{verbatim}
241 for example.  So we convert instead to
242 \begin{verbatim}
243         let y = expr in \x -> op y x
244 \end{verbatim}
245 If \tr{expr} is actually just a variable, say, then the simplifier
246 will sort it out.
247
248 \begin{code}
249 dsExpr (OpApp e1 op _ e2)
250   = dsLExpr op                                          `thenDs` \ core_op ->
251     -- for the type of y, we need the type of op's 2nd argument
252     dsLExpr e1                          `thenDs` \ x_core ->
253     dsLExpr e2                          `thenDs` \ y_core ->
254     returnDs (mkApps core_op [x_core, y_core])
255     
256 dsExpr (SectionL expr op)       -- Desugar (e !) to ((!) e)
257   = dsLExpr op                          `thenDs` \ core_op ->
258     dsLExpr expr                        `thenDs` \ x_core ->
259     returnDs (App core_op x_core)
260
261 -- dsLExpr (SectionR op expr)   -- \ x -> op x expr
262 dsExpr (SectionR op expr)
263   = dsLExpr op                  `thenDs` \ core_op ->
264     -- for the type of x, we need the type of op's 2nd argument
265     let
266         (x_ty:y_ty:_, _) = splitFunTys (exprType core_op)
267         -- See comment with SectionL
268     in
269     dsLExpr expr                                `thenDs` \ y_core ->
270     newSysLocalDs x_ty                  `thenDs` \ x_id ->
271     newSysLocalDs y_ty                  `thenDs` \ y_id ->
272
273     returnDs (bindNonRec y_id y_core $
274               Lam x_id (mkApps core_op [Var x_id, Var y_id]))
275
276 dsExpr (HsSCC cc expr)
277   = dsLExpr expr                        `thenDs` \ core_expr ->
278     getModuleDs                 `thenDs` \ mod_name ->
279     returnDs (Note (SCC (mkUserCC cc mod_name)) core_expr)
280
281
282 -- hdaume: core annotation
283
284 dsExpr (HsCoreAnn fs expr)
285   = dsLExpr expr        `thenDs` \ core_expr ->
286     returnDs (Note (CoreNote $ unpackFS fs) core_expr)
287
288 dsExpr (HsCase discrim matches)
289   = dsLExpr discrim                     `thenDs` \ core_discrim ->
290     matchWrapper CaseAlt matches        `thenDs` \ ([discrim_var], matching_code) ->
291     returnDs (scrungleMatch discrim_var core_discrim matching_code)
292
293 dsExpr (HsLet binds body)
294   = dsAndThenMaybeInsertBreakpoint body `thenDs` \ body' ->
295     dsLocalBinds binds body'
296
297 -- We need the `ListComp' form to use `deListComp' (rather than the "do" form)
298 -- because the interpretation of `stmts' depends on what sort of thing it is.
299 --
300 dsExpr (HsDo ListComp stmts body result_ty)
301   =     -- Special case for list comprehensions
302     dsListComp stmts body elt_ty
303   where
304     [elt_ty] = tcTyConAppArgs result_ty
305
306 dsExpr (HsDo DoExpr stmts body result_ty)
307   = dsDo stmts body result_ty
308
309 dsExpr (HsDo (MDoExpr tbl) stmts body result_ty)
310   = dsMDo tbl stmts body result_ty
311
312 dsExpr (HsDo PArrComp stmts body result_ty)
313   =     -- Special case for array comprehensions
314     dsPArrComp (map unLoc stmts) body elt_ty
315   where
316     [elt_ty] = tcTyConAppArgs result_ty
317
318 dsExpr (HsIf guard_expr then_expr else_expr)
319   = dsLExpr guard_expr  `thenDs` \ core_guard ->
320     dsLExpr then_expr   `thenDs` \ core_then ->
321     dsLExpr else_expr   `thenDs` \ core_else ->
322     returnDs (mkIfThenElse core_guard core_then core_else)
323 \end{code}
324
325
326 \noindent
327 \underline{\bf Various data construction things}
328 %              ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
329 \begin{code}
330 dsExpr (ExplicitList ty xs)
331   = go xs
332   where
333     go []     = returnDs (mkNilExpr ty)
334     go (x:xs) = dsLExpr x                               `thenDs` \ core_x ->
335                 go xs                                   `thenDs` \ core_xs ->
336                 returnDs (mkConsExpr ty core_x core_xs)
337
338 -- we create a list from the array elements and convert them into a list using
339 -- `PrelPArr.toP'
340 --
341 --  * the main disadvantage to this scheme is that `toP' traverses the list
342 --   twice: once to determine the length and a second time to put to elements
343 --   into the array; this inefficiency could be avoided by exposing some of
344 --   the innards of `PrelPArr' to the compiler (ie, have a `PrelPArrBase') so
345 --   that we can exploit the fact that we already know the length of the array
346 --   here at compile time
347 --
348 dsExpr (ExplicitPArr ty xs)
349   = dsLookupGlobalId toPName                            `thenDs` \toP      ->
350     dsExpr (ExplicitList ty xs)                         `thenDs` \coreList ->
351     returnDs (mkApps (Var toP) [Type ty, coreList])
352
353 dsExpr (ExplicitTuple expr_list boxity)
354   = mappM dsLExpr expr_list       `thenDs` \ core_exprs  ->
355     returnDs (mkConApp (tupleCon boxity (length expr_list))
356                        (map (Type .  exprType) core_exprs ++ core_exprs))
357
358 dsExpr (ArithSeq expr (From from))
359   = dsExpr expr           `thenDs` \ expr2 ->
360     dsLExpr from          `thenDs` \ from2 ->
361     returnDs (App expr2 from2)
362
363 dsExpr (ArithSeq expr (FromTo from two))
364   = dsExpr expr           `thenDs` \ expr2 ->
365     dsLExpr from          `thenDs` \ from2 ->
366     dsLExpr two           `thenDs` \ two2 ->
367     returnDs (mkApps expr2 [from2, two2])
368
369 dsExpr (ArithSeq expr (FromThen from thn))
370   = dsExpr expr           `thenDs` \ expr2 ->
371     dsLExpr from          `thenDs` \ from2 ->
372     dsLExpr thn           `thenDs` \ thn2 ->
373     returnDs (mkApps expr2 [from2, thn2])
374
375 dsExpr (ArithSeq expr (FromThenTo from thn two))
376   = dsExpr expr           `thenDs` \ expr2 ->
377     dsLExpr from          `thenDs` \ from2 ->
378     dsLExpr thn           `thenDs` \ thn2 ->
379     dsLExpr two           `thenDs` \ two2 ->
380     returnDs (mkApps expr2 [from2, thn2, two2])
381
382 dsExpr (PArrSeq expr (FromTo from two))
383   = dsExpr expr           `thenDs` \ expr2 ->
384     dsLExpr from          `thenDs` \ from2 ->
385     dsLExpr two           `thenDs` \ two2 ->
386     returnDs (mkApps expr2 [from2, two2])
387
388 dsExpr (PArrSeq expr (FromThenTo from thn two))
389   = dsExpr expr           `thenDs` \ expr2 ->
390     dsLExpr from          `thenDs` \ from2 ->
391     dsLExpr thn           `thenDs` \ thn2 ->
392     dsLExpr two           `thenDs` \ two2 ->
393     returnDs (mkApps expr2 [from2, thn2, two2])
394
395 dsExpr (PArrSeq expr _)
396   = panic "DsExpr.dsExpr: Infinite parallel array!"
397     -- the parser shouldn't have generated it and the renamer and typechecker
398     -- shouldn't have let it through
399 \end{code}
400
401 \noindent
402 \underline{\bf Record construction and update}
403 %              ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
404 For record construction we do this (assuming T has three arguments)
405 \begin{verbatim}
406         T { op2 = e }
407 ==>
408         let err = /\a -> recConErr a 
409         T (recConErr t1 "M.lhs/230/op1") 
410           e 
411           (recConErr t1 "M.lhs/230/op3")
412 \end{verbatim}
413 @recConErr@ then converts its arugment string into a proper message
414 before printing it as
415 \begin{verbatim}
416         M.lhs, line 230: missing field op1 was evaluated
417 \end{verbatim}
418
419 We also handle @C{}@ as valid construction syntax for an unlabelled
420 constructor @C@, setting all of @C@'s fields to bottom.
421
422 \begin{code}
423 dsExpr (RecordCon (L _ data_con_id) con_expr rbinds)
424   = dsExpr con_expr     `thenDs` \ con_expr' ->
425     let
426         (arg_tys, _) = tcSplitFunTys (exprType con_expr')
427         -- A newtype in the corner should be opaque; 
428         -- hence TcType.tcSplitFunTys
429
430         mk_arg (arg_ty, lbl)    -- Selector id has the field label as its name
431           = case [rhs | (L _ sel_id, rhs) <- rbinds, lbl == idName sel_id] of
432               (rhs:rhss) -> ASSERT( null rhss )
433                             dsLExpr rhs
434               []         -> mkErrorAppDs rEC_CON_ERROR_ID arg_ty (showSDoc (ppr lbl))
435         unlabelled_bottom arg_ty = mkErrorAppDs rEC_CON_ERROR_ID arg_ty ""
436
437         labels = dataConFieldLabels (idDataCon data_con_id)
438         -- The data_con_id is guaranteed to be the wrapper id of the constructor
439     in
440
441     (if null labels
442         then mappM unlabelled_bottom arg_tys
443         else mappM mk_arg (zipEqual "dsExpr:RecordCon" arg_tys labels))
444         `thenDs` \ con_args ->
445
446     returnDs (mkApps con_expr' con_args)
447 \end{code}
448
449 Record update is a little harder. Suppose we have the decl:
450 \begin{verbatim}
451         data T = T1 {op1, op2, op3 :: Int}
452                | T2 {op4, op2 :: Int}
453                | T3
454 \end{verbatim}
455 Then we translate as follows:
456 \begin{verbatim}
457         r { op2 = e }
458 ===>
459         let op2 = e in
460         case r of
461           T1 op1 _ op3 -> T1 op1 op2 op3
462           T2 op4 _     -> T2 op4 op2
463           other        -> recUpdError "M.lhs/230"
464 \end{verbatim}
465 It's important that we use the constructor Ids for @T1@, @T2@ etc on the
466 RHSs, and do not generate a Core constructor application directly, because the constructor
467 might do some argument-evaluation first; and may have to throw away some
468 dictionaries.
469
470 \begin{code}
471 dsExpr (RecordUpd record_expr [] record_in_ty record_out_ty)
472   = dsLExpr record_expr
473
474 dsExpr expr@(RecordUpd record_expr rbinds record_in_ty record_out_ty)
475   = dsLExpr record_expr         `thenDs` \ record_expr' ->
476
477         -- Desugar the rbinds, and generate let-bindings if
478         -- necessary so that we don't lose sharing
479
480     let
481         in_inst_tys  = tcTyConAppArgs record_in_ty      -- Newtype opaque
482         out_inst_tys = tcTyConAppArgs record_out_ty     -- Newtype opaque
483         in_out_ty    = mkFunTy record_in_ty record_out_ty
484
485         mk_val_arg field old_arg_id 
486           = case [rhs | (L _ sel_id, rhs) <- rbinds, field == idName sel_id] of
487               (rhs:rest) -> ASSERT(null rest) rhs
488               []         -> nlHsVar old_arg_id
489
490         mk_alt con
491           = ASSERT( isVanillaDataCon con )
492             newSysLocalsDs (dataConInstOrigArgTys con in_inst_tys) `thenDs` \ arg_ids ->
493                 -- This call to dataConInstOrigArgTys won't work for existentials
494                 -- but existentials don't have record types anyway
495             let 
496                 val_args = zipWithEqual "dsExpr:RecordUpd" mk_val_arg
497                                         (dataConFieldLabels con) arg_ids
498                 rhs = foldl (\a b -> nlHsApp a b)
499                             (nlHsTyApp (dataConWrapId con) out_inst_tys)
500                             val_args
501             in
502             returnDs (mkSimpleMatch [mkPrefixConPat con (map nlVarPat arg_ids) record_in_ty] rhs)
503     in
504         -- Record stuff doesn't work for existentials
505         -- The type checker checks for this, but we need 
506         -- worry only about the constructors that are to be updated
507     ASSERT2( all isVanillaDataCon cons_to_upd, ppr expr )
508
509         -- It's important to generate the match with matchWrapper,
510         -- and the right hand sides with applications of the wrapper Id
511         -- so that everything works when we are doing fancy unboxing on the
512         -- constructor aguments.
513     mappM mk_alt cons_to_upd                            `thenDs` \ alts ->
514     matchWrapper RecUpd (MatchGroup alts in_out_ty)     `thenDs` \ ([discrim_var], matching_code) ->
515
516     returnDs (bindNonRec discrim_var record_expr' matching_code)
517
518   where
519     updated_fields :: [FieldLabel]
520     updated_fields = [ idName sel_id | (L _ sel_id,_) <- rbinds]
521
522         -- Get the type constructor from the record_in_ty
523         -- so that we are sure it'll have all its DataCons
524         -- (In GHCI, it's possible that some TyCons may not have all
525         --  their constructors, in a module-loop situation.)
526     tycon       = tcTyConAppTyCon record_in_ty
527     data_cons   = tyConDataCons tycon
528     cons_to_upd = filter has_all_fields data_cons
529
530     has_all_fields :: DataCon -> Bool
531     has_all_fields con_id 
532       = all (`elem` con_fields) updated_fields
533       where
534         con_fields = dataConFieldLabels con_id
535 \end{code}
536
537 Here is where we desugar the Template Haskell brackets and escapes
538
539 \begin{code}
540 -- Template Haskell stuff
541
542 #ifdef GHCI     /* Only if bootstrapping */
543 dsExpr (HsBracketOut x ps) = dsBracket x ps
544 dsExpr (HsSpliceE s)       = pprPanic "dsExpr:splice" (ppr s)
545 #endif
546
547 -- Arrow notation extension
548 dsExpr (HsProc pat cmd) = dsProcExpr pat cmd
549 \end{code}
550
551 Hpc Support 
552
553 \begin{code}
554 dsExpr (HsTick ix e) = do
555   e' <- dsLExpr e
556   mkTickBox ix e'
557
558 -- There is a problem here. The then and else branches
559 -- have no free variables, so they are open to lifting.
560 -- We need someway of stopping this.
561 -- This will make no difference to binary coverage
562 -- (did you go here: YES or NO), but will effect accurate
563 -- tick counting.
564
565 dsExpr (HsBinTick ixT ixF e) = do
566   e2 <- dsLExpr e
567   do { ASSERT(exprType e2 `coreEqType` boolTy)
568        mkBinaryTickBox ixT ixF e2
569      }
570 \end{code}
571
572 \begin{code}
573
574 #ifdef DEBUG
575 -- HsSyn constructs that just shouldn't be here:
576 dsExpr (ExprWithTySig _ _)  = panic "dsExpr:ExprWithTySig"
577 #endif
578
579 \end{code}
580
581 %--------------------------------------------------------------------
582
583 Desugar 'do' and 'mdo' expressions (NOT list comprehensions, they're
584 handled in DsListComp).  Basically does the translation given in the
585 Haskell 98 report:
586
587 \begin{code}
588 dsDo    :: [LStmt Id]
589         -> LHsExpr Id
590         -> Type                 -- Type of the whole expression
591         -> DsM CoreExpr
592
593 dsDo stmts body result_ty
594   = go (map unLoc stmts)
595   where
596     go [] = dsAndThenMaybeInsertBreakpoint body
597     
598     go (ExprStmt rhs then_expr _ : stmts)
599       = do { rhs2 <- dsAndThenMaybeInsertBreakpoint rhs
600            ; then_expr2 <- dsExpr then_expr
601            ; rest <- go stmts
602            ; returnDs (mkApps then_expr2 [rhs2, rest]) }
603     
604     go (LetStmt binds : stmts)
605       = do { rest <- go stmts
606            ; dsLocalBinds binds rest }
607         
608     go (BindStmt pat rhs bind_op fail_op : stmts)
609       = do { body  <- go stmts
610            ; var   <- selectSimpleMatchVarL pat
611            ; match <- matchSinglePat (Var var) (StmtCtxt DoExpr) pat
612                                   result_ty (cantFailMatchResult body)
613            ; match_code <- handle_failure pat match fail_op
614            ; rhs'       <- dsAndThenMaybeInsertBreakpoint rhs
615            ; bind_op'   <- dsExpr bind_op
616            ; returnDs (mkApps bind_op' [rhs', Lam var match_code]) }
617     
618     -- In a do expression, pattern-match failure just calls
619     -- the monadic 'fail' rather than throwing an exception
620     handle_failure pat match fail_op
621       | matchCanFail match
622       = do { fail_op' <- dsExpr fail_op
623            ; fail_msg <- mkStringExpr (mk_fail_msg pat)
624            ; extractMatchResult match (App fail_op' fail_msg) }
625       | otherwise
626       = extractMatchResult match (error "It can't fail") 
627
628 mk_fail_msg pat = "Pattern match failure in do expression at " ++ 
629                   showSDoc (ppr (getLoc pat))
630 \end{code}
631
632 Translation for RecStmt's: 
633 -----------------------------
634 We turn (RecStmt [v1,..vn] stmts) into:
635   
636   (v1,..,vn) <- mfix (\~(v1,..vn). do stmts
637                                       return (v1,..vn))
638
639 \begin{code}
640 dsMDo   :: PostTcTable
641         -> [LStmt Id]
642         -> LHsExpr Id
643         -> Type                 -- Type of the whole expression
644         -> DsM CoreExpr
645
646 dsMDo tbl stmts body result_ty
647   = go (map unLoc stmts)
648   where
649     (m_ty, b_ty) = tcSplitAppTy result_ty       -- result_ty must be of the form (m b)
650     mfix_id   = lookupEvidence tbl mfixName
651     return_id = lookupEvidence tbl returnMName
652     bind_id   = lookupEvidence tbl bindMName
653     then_id   = lookupEvidence tbl thenMName
654     fail_id   = lookupEvidence tbl failMName
655     ctxt      = MDoExpr tbl
656
657     go [] = dsLExpr body
658     
659     go (LetStmt binds : stmts)
660       = do { rest <- go stmts
661            ; dsLocalBinds binds rest }
662
663     go (ExprStmt rhs _ rhs_ty : stmts)
664       = do { rhs2 <- dsAndThenMaybeInsertBreakpoint rhs
665            ; rest <- go stmts
666            ; returnDs (mkApps (Var then_id) [Type rhs_ty, Type b_ty, rhs2, rest]) }
667     
668     go (BindStmt pat rhs _ _ : stmts)
669       = do { body  <- go stmts
670            ; var   <- selectSimpleMatchVarL pat
671            ; match <- matchSinglePat (Var var) (StmtCtxt ctxt) pat
672                                   result_ty (cantFailMatchResult body)
673            ; fail_msg   <- mkStringExpr (mk_fail_msg pat)
674            ; let fail_expr = mkApps (Var fail_id) [Type b_ty, fail_msg]
675            ; match_code <- extractMatchResult match fail_expr
676
677            ; rhs'       <- dsAndThenMaybeInsertBreakpoint rhs
678            ; returnDs (mkApps (Var bind_id) [Type (hsLPatType pat), Type b_ty, 
679                                              rhs', Lam var match_code]) }
680     
681     go (RecStmt rec_stmts later_ids rec_ids rec_rets binds : stmts)
682       = ASSERT( length rec_ids > 0 )
683         ASSERT( length rec_ids == length rec_rets )
684         go (new_bind_stmt : let_stmt : stmts)
685       where
686         new_bind_stmt = mkBindStmt (mk_tup_pat later_pats) mfix_app
687         let_stmt = LetStmt (HsValBinds (ValBindsOut [(Recursive, binds)] []))
688
689         
690                 -- Remove the later_ids that appear (without fancy coercions) 
691                 -- in rec_rets, because there's no need to knot-tie them separately
692                 -- See Note [RecStmt] in HsExpr
693         later_ids'   = filter (`notElem` mono_rec_ids) later_ids
694         mono_rec_ids = [ id | HsVar id <- rec_rets ]
695     
696         mfix_app = nlHsApp (nlHsTyApp mfix_id [tup_ty]) mfix_arg
697         mfix_arg = noLoc $ HsLam (MatchGroup [mkSimpleMatch [mfix_pat] body]
698                                              (mkFunTy tup_ty body_ty))
699
700         -- The rec_tup_pat must bind the rec_ids only; remember that the 
701         --      trimmed_laters may share the same Names
702         -- Meanwhile, the later_pats must bind the later_vars
703         rec_tup_pats = map mk_wild_pat later_ids' ++ map nlVarPat rec_ids
704         later_pats   = map nlVarPat    later_ids' ++ map mk_later_pat rec_ids
705         rets         = map nlHsVar     later_ids' ++ map noLoc rec_rets
706
707         mfix_pat = noLoc $ LazyPat $ mk_tup_pat rec_tup_pats
708         body     = noLoc $ HsDo ctxt rec_stmts return_app body_ty
709         body_ty = mkAppTy m_ty tup_ty
710         tup_ty  = mkCoreTupTy (map idType (later_ids' ++ rec_ids))
711                   -- mkCoreTupTy deals with singleton case
712
713         return_app  = nlHsApp (nlHsTyApp return_id [tup_ty]) 
714                               (mk_ret_tup rets)
715
716         mk_wild_pat :: Id -> LPat Id 
717         mk_wild_pat v = noLoc $ WildPat $ idType v
718
719         mk_later_pat :: Id -> LPat Id
720         mk_later_pat v | v `elem` later_ids' = mk_wild_pat v
721                        | otherwise           = nlVarPat v
722
723         mk_tup_pat :: [LPat Id] -> LPat Id
724         mk_tup_pat [p] = p
725         mk_tup_pat ps  = noLoc $ mkVanillaTuplePat ps Boxed
726
727         mk_ret_tup :: [LHsExpr Id] -> LHsExpr Id
728         mk_ret_tup [r] = r
729         mk_ret_tup rs  = noLoc $ ExplicitTuple rs Boxed
730 \end{code}