2eca842eb009d6429e14bea7044e6ac7e2385754
[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 {-# OPTIONS -fno-warn-incomplete-patterns #-}
10 -- The above warning supression flag is a temporary kludge.
11 -- While working on this module you are encouraged to remove it and fix
12 -- any warnings in the module. See
13 --     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
14 -- for details
15
16 module DsExpr ( dsExpr, dsLExpr, dsLocalBinds, dsValBinds, dsLit ) where
17
18 #include "HsVersions.h"
19
20 import Match
21 import MatchLit
22 import DsBinds
23 import DsGRHSs
24 import DsListComp
25 import DsUtils
26 import DsArrows
27 import DsMonad
28 import Name
29 import NameEnv
30
31 #ifdef GHCI
32         -- Template Haskell stuff iff bootstrapped
33 import DsMeta
34 #endif
35
36 import HsSyn
37 import TcHsSyn
38
39 -- NB: The desugarer, which straddles the source and Core worlds, sometimes
40 --     needs to see source types
41 import TcType
42 import Type
43 import Coercion
44 import CoreSyn
45 import CoreUtils
46 import MkCore
47
48 import DynFlags
49 import StaticFlags
50 import CostCentre
51 import Id
52 import PrelInfo
53 import DataCon
54 import TysWiredIn
55 import BasicTypes
56 import PrelNames
57 import Maybes
58 import SrcLoc
59 import Util
60 import Bag
61 import Outputable
62 import FastString
63
64 import Control.Monad
65 \end{code}
66
67
68 %************************************************************************
69 %*                                                                      *
70                 dsLocalBinds, dsValBinds
71 %*                                                                      *
72 %************************************************************************
73
74 \begin{code}
75 dsLocalBinds :: HsLocalBinds Id -> CoreExpr -> DsM CoreExpr
76 dsLocalBinds EmptyLocalBinds    body = return body
77 dsLocalBinds (HsValBinds binds) body = dsValBinds binds body
78 dsLocalBinds (HsIPBinds binds)  body = dsIPBinds  binds body
79
80 -------------------------
81 dsValBinds :: HsValBinds Id -> CoreExpr -> DsM CoreExpr
82 dsValBinds (ValBindsOut binds _) body = foldrM ds_val_bind body binds
83
84 -------------------------
85 dsIPBinds :: HsIPBinds Id -> CoreExpr -> DsM CoreExpr
86 dsIPBinds (IPBinds ip_binds dict_binds) body
87   = do  { prs <- dsLHsBinds dict_binds
88         ; let inner = Let (Rec prs) body
89                 -- The dict bindings may not be in 
90                 -- dependency order; hence Rec
91         ; foldrM ds_ip_bind inner ip_binds }
92   where
93     ds_ip_bind (L _ (IPBind n e)) body
94       = do e' <- dsLExpr e
95            return (Let (NonRec (ipNameName n) e') body)
96
97 -------------------------
98 ds_val_bind :: (RecFlag, LHsBinds Id) -> CoreExpr -> DsM CoreExpr
99 -- Special case for bindings which bind unlifted variables
100 -- We need to do a case right away, rather than building
101 -- a tuple and doing selections.
102 -- Silently ignore INLINE and SPECIALISE pragmas...
103 ds_val_bind (NonRecursive, hsbinds) body
104   | [L _ (AbsBinds [] [] exports binds)] <- bagToList hsbinds,
105     (L loc bind : null_binds) <- bagToList binds,
106     isBangHsBind bind
107     || isUnboxedTupleBind bind
108     || or [isUnLiftedType (idType g) | (_, g, _, _) <- exports]
109   = let
110       body_w_exports                  = foldr bind_export body exports
111       bind_export (tvs, g, l, _) body = ASSERT( null tvs )
112                                         bindNonRec g (Var l) body
113     in
114     ASSERT (null null_binds)
115         -- Non-recursive, non-overloaded bindings only come in ones
116         -- ToDo: in some bizarre case it's conceivable that there
117         --       could be dict binds in the 'binds'.  (See the notes
118         --       below.  Then pattern-match would fail.  Urk.)
119     putSrcSpanDs loc    $
120     case bind of
121       FunBind { fun_id = L _ fun, fun_matches = matches, fun_co_fn = co_fn, 
122                 fun_tick = tick, fun_infix = inf }
123         -> do (args, rhs) <- matchWrapper (FunRhs (idName fun ) inf) matches
124               MASSERT( null args ) -- Functions aren't lifted
125               MASSERT( isIdHsWrapper co_fn )
126               rhs' <- mkOptTickBox tick rhs
127               return (bindNonRec fun rhs' body_w_exports)
128
129       PatBind {pat_lhs = pat, pat_rhs = grhss, pat_rhs_ty = ty }
130         ->      -- let C x# y# = rhs in body
131                 -- ==> case rhs of C x# y# -> body
132            putSrcSpanDs loc                     $
133            do { rhs <- dsGuarded grhss ty
134               ; let upat = unLoc pat
135                     eqn = EqnInfo { eqn_pats = [upat], 
136                                     eqn_rhs = cantFailMatchResult body_w_exports }
137               ; var    <- selectMatchVar upat
138               ; result <- matchEquations PatBindRhs [var] [eqn] (exprType body)
139               ; return (scrungleMatch var rhs result) }
140
141       _ -> pprPanic "dsLet: unlifted" (pprLHsBinds hsbinds $$ ppr body)
142
143
144 -- Ordinary case for bindings; none should be unlifted
145 ds_val_bind (_is_rec, binds) body
146   = do  { prs <- dsLHsBinds binds
147         ; ASSERT( not (any (isUnLiftedType . idType . fst) prs) )
148           case prs of
149             [] -> return body
150             _  -> return (Let (Rec prs) body) }
151         -- Use a Rec regardless of is_rec. 
152         -- Why? Because it allows the binds to be all
153         -- mixed up, which is what happens in one rare case
154         -- Namely, for an AbsBind with no tyvars and no dicts,
155         --         but which does have dictionary bindings.
156         -- See notes with TcSimplify.inferLoop [NO TYVARS]
157         -- It turned out that wrapping a Rec here was the easiest solution
158         --
159         -- NB The previous case dealt with unlifted bindings, so we
160         --    only have to deal with lifted ones now; so Rec is ok
161
162 isUnboxedTupleBind :: HsBind Id -> Bool
163 isUnboxedTupleBind (PatBind { pat_rhs_ty = ty }) = isUnboxedTupleType ty
164 isUnboxedTupleBind _                             = False
165
166 scrungleMatch :: Id -> CoreExpr -> CoreExpr -> CoreExpr
167 -- Returns something like (let var = scrut in body)
168 -- but if var is an unboxed-tuple type, it inlines it in a fragile way
169 -- Special case to handle unboxed tuple patterns; they can't appear nested
170 -- The idea is that 
171 --      case e of (# p1, p2 #) -> rhs
172 -- should desugar to
173 --      case e of (# x1, x2 #) -> ... match p1, p2 ...
174 -- NOT
175 --      let x = e in case x of ....
176 --
177 -- But there may be a big 
178 --      let fail = ... in case e of ...
179 -- wrapping the whole case, which complicates matters slightly
180 -- It all seems a bit fragile.  Test is dsrun013.
181
182 scrungleMatch var scrut body
183   | isUnboxedTupleType (idType var) = scrungle body
184   | otherwise                       = bindNonRec var scrut body
185   where
186     scrungle (Case (Var x) bndr ty alts)
187                     | x == var = Case scrut bndr ty alts
188     scrungle (Let binds body)  = Let binds (scrungle body)
189     scrungle other = panic ("scrungleMatch: tuple pattern:\n" ++ showSDoc (ppr other))
190
191 \end{code}
192
193 %************************************************************************
194 %*                                                                      *
195 \subsection[DsExpr-vars-and-cons]{Variables, constructors, literals}
196 %*                                                                      *
197 %************************************************************************
198
199 \begin{code}
200 dsLExpr :: LHsExpr Id -> DsM CoreExpr
201
202 dsLExpr (L loc e) = putSrcSpanDs loc $ dsExpr e
203
204 dsExpr :: HsExpr Id -> DsM CoreExpr
205 dsExpr (HsPar e)              = dsLExpr e
206 dsExpr (ExprWithTySigOut e _) = dsLExpr e
207 dsExpr (HsVar var)            = return (Var var)
208 dsExpr (HsIPVar ip)           = return (Var (ipNameName ip))
209 dsExpr (HsLit lit)            = dsLit lit
210 dsExpr (HsOverLit lit)        = dsOverLit lit
211 dsExpr (HsWrap co_fn e)       = dsCoercion co_fn (dsExpr e)
212
213 dsExpr (NegApp expr neg_expr) 
214   = App <$> dsExpr neg_expr <*> dsLExpr expr
215
216 dsExpr (HsLam a_Match)
217   = uncurry mkLams <$> matchWrapper LambdaExpr a_Match
218
219 dsExpr (HsApp fun arg)
220   = mkCoreAppDs <$> dsLExpr fun <*>  dsLExpr arg
221 \end{code}
222
223 Operator sections.  At first it looks as if we can convert
224 \begin{verbatim}
225         (expr op)
226 \end{verbatim}
227 to
228 \begin{verbatim}
229         \x -> op expr x
230 \end{verbatim}
231
232 But no!  expr might be a redex, and we can lose laziness badly this
233 way.  Consider
234 \begin{verbatim}
235         map (expr op) xs
236 \end{verbatim}
237 for example.  So we convert instead to
238 \begin{verbatim}
239         let y = expr in \x -> op y x
240 \end{verbatim}
241 If \tr{expr} is actually just a variable, say, then the simplifier
242 will sort it out.
243
244 \begin{code}
245 dsExpr (OpApp e1 op _ e2)
246   = -- for the type of y, we need the type of op's 2nd argument
247     mkCoreAppsDs <$> dsLExpr op <*> mapM dsLExpr [e1, e2]
248     
249 dsExpr (SectionL expr op)       -- Desugar (e !) to ((!) e)
250   = mkCoreAppDs <$> dsLExpr op <*> dsLExpr expr
251
252 -- dsLExpr (SectionR op expr)   -- \ x -> op x expr
253 dsExpr (SectionR op expr) = do
254     core_op <- dsLExpr op
255     -- for the type of x, we need the type of op's 2nd argument
256     let (x_ty:y_ty:_, _) = splitFunTys (exprType core_op)
257         -- See comment with SectionL
258     y_core <- dsLExpr expr
259     x_id <- newSysLocalDs x_ty
260     y_id <- newSysLocalDs y_ty
261     return (bindNonRec y_id y_core $
262             Lam x_id (mkCoreAppsDs core_op [Var x_id, Var y_id]))
263
264 dsExpr (HsSCC cc expr) = do
265     mod_name <- getModuleDs
266     Note (SCC (mkUserCC cc mod_name)) <$> dsLExpr expr
267
268
269 -- hdaume: core annotation
270
271 dsExpr (HsCoreAnn fs expr)
272   = Note (CoreNote $ unpackFS fs) <$> dsLExpr expr
273
274 dsExpr (HsCase discrim matches@(MatchGroup _ rhs_ty)) 
275   | isEmptyMatchGroup matches   -- A Core 'case' is always non-empty
276   =                             -- So desugar empty HsCase to error call
277     mkErrorAppDs pAT_ERROR_ID (funResultTy rhs_ty) (ptext (sLit "case"))
278
279   | otherwise
280   = do { core_discrim <- dsLExpr discrim
281        ; ([discrim_var], matching_code) <- matchWrapper CaseAlt matches
282        ; return (scrungleMatch discrim_var core_discrim matching_code) }
283
284 -- Pepe: The binds are in scope in the body but NOT in the binding group
285 --       This is to avoid silliness in breakpoints
286 dsExpr (HsLet binds body) = do
287     body' <- dsLExpr body
288     dsLocalBinds binds body'
289
290 -- We need the `ListComp' form to use `deListComp' (rather than the "do" form)
291 -- because the interpretation of `stmts' depends on what sort of thing it is.
292 --
293 dsExpr (HsDo ListComp stmts body result_ty)
294   =     -- Special case for list comprehensions
295     dsListComp stmts body elt_ty
296   where
297     [elt_ty] = tcTyConAppArgs result_ty
298
299 dsExpr (HsDo DoExpr stmts body result_ty)
300   = dsDo stmts body result_ty
301
302 dsExpr (HsDo (MDoExpr tbl) stmts body result_ty)
303   = dsMDo tbl stmts body result_ty
304
305 dsExpr (HsDo PArrComp stmts body result_ty)
306   =     -- Special case for array comprehensions
307     dsPArrComp (map unLoc stmts) body elt_ty
308   where
309     [elt_ty] = tcTyConAppArgs result_ty
310
311 dsExpr (HsIf guard_expr then_expr else_expr)
312   = mkIfThenElse <$> dsLExpr guard_expr <*> dsLExpr then_expr <*> dsLExpr else_expr
313 \end{code}
314
315
316 \noindent
317 \underline{\bf Various data construction things}
318 %              ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
319 \begin{code}
320 dsExpr (ExplicitList elt_ty xs) 
321   = dsExplicitList elt_ty xs
322
323 -- We desugar [:x1, ..., xn:] as
324 --   singletonP x1 +:+ ... +:+ singletonP xn
325 --
326 dsExpr (ExplicitPArr ty []) = do
327     emptyP <- dsLookupGlobalId emptyPName
328     return (Var emptyP `App` Type ty)
329 dsExpr (ExplicitPArr ty xs) = do
330     singletonP <- dsLookupGlobalId singletonPName
331     appP       <- dsLookupGlobalId appPName
332     xs'        <- mapM dsLExpr xs
333     return . foldr1 (binary appP) $ map (unary singletonP) xs'
334   where
335     unary  fn x   = mkApps (Var fn) [Type ty, x]
336     binary fn x y = mkApps (Var fn) [Type ty, x, y]
337
338 dsExpr (ExplicitTuple expr_list boxity) = do
339     core_exprs <- mapM dsLExpr expr_list
340     return (mkConApp (tupleCon boxity (length expr_list))
341                   (map (Type .  exprType) core_exprs ++ core_exprs))
342
343 dsExpr (ArithSeq expr (From from))
344   = App <$> dsExpr expr <*> dsLExpr from
345
346 dsExpr (ArithSeq expr (FromTo from to))
347   = mkApps <$> dsExpr expr <*> mapM dsLExpr [from, to]
348
349 dsExpr (ArithSeq expr (FromThen from thn))
350   = mkApps <$> dsExpr expr <*> mapM dsLExpr [from, thn]
351
352 dsExpr (ArithSeq expr (FromThenTo from thn to))
353   = mkApps <$> dsExpr expr <*> mapM dsLExpr [from, thn, to]
354
355 dsExpr (PArrSeq expr (FromTo from to))
356   = mkApps <$> dsExpr expr <*> mapM dsLExpr [from, to]
357
358 dsExpr (PArrSeq expr (FromThenTo from thn to))
359   = mkApps <$> dsExpr expr <*> mapM dsLExpr [from, thn, to]
360
361 dsExpr (PArrSeq _ _)
362   = panic "DsExpr.dsExpr: Infinite parallel array!"
363     -- the parser shouldn't have generated it and the renamer and typechecker
364     -- shouldn't have let it through
365 \end{code}
366
367 \noindent
368 \underline{\bf Record construction and update}
369 %              ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
370 For record construction we do this (assuming T has three arguments)
371 \begin{verbatim}
372         T { op2 = e }
373 ==>
374         let err = /\a -> recConErr a 
375         T (recConErr t1 "M.lhs/230/op1") 
376           e 
377           (recConErr t1 "M.lhs/230/op3")
378 \end{verbatim}
379 @recConErr@ then converts its arugment string into a proper message
380 before printing it as
381 \begin{verbatim}
382         M.lhs, line 230: missing field op1 was evaluated
383 \end{verbatim}
384
385 We also handle @C{}@ as valid construction syntax for an unlabelled
386 constructor @C@, setting all of @C@'s fields to bottom.
387
388 \begin{code}
389 dsExpr (RecordCon (L _ data_con_id) con_expr rbinds) = do
390     con_expr' <- dsExpr con_expr
391     let
392         (arg_tys, _) = tcSplitFunTys (exprType con_expr')
393         -- A newtype in the corner should be opaque; 
394         -- hence TcType.tcSplitFunTys
395
396         mk_arg (arg_ty, lbl)    -- Selector id has the field label as its name
397           = case findField (rec_flds rbinds) lbl of
398               (rhs:rhss) -> ASSERT( null rhss )
399                             dsLExpr rhs
400               []         -> mkErrorAppDs rEC_CON_ERROR_ID arg_ty (ppr lbl)
401         unlabelled_bottom arg_ty = mkErrorAppDs rEC_CON_ERROR_ID arg_ty empty
402
403         labels = dataConFieldLabels (idDataCon data_con_id)
404         -- The data_con_id is guaranteed to be the wrapper id of the constructor
405     
406     con_args <- if null labels
407                 then mapM unlabelled_bottom arg_tys
408                 else mapM mk_arg (zipEqual "dsExpr:RecordCon" arg_tys labels)
409     
410     return (mkApps con_expr' con_args)
411 \end{code}
412
413 Record update is a little harder. Suppose we have the decl:
414 \begin{verbatim}
415         data T = T1 {op1, op2, op3 :: Int}
416                | T2 {op4, op2 :: Int}
417                | T3
418 \end{verbatim}
419 Then we translate as follows:
420 \begin{verbatim}
421         r { op2 = e }
422 ===>
423         let op2 = e in
424         case r of
425           T1 op1 _ op3 -> T1 op1 op2 op3
426           T2 op4 _     -> T2 op4 op2
427           other        -> recUpdError "M.lhs/230"
428 \end{verbatim}
429 It's important that we use the constructor Ids for @T1@, @T2@ etc on the
430 RHSs, and do not generate a Core constructor application directly, because the constructor
431 might do some argument-evaluation first; and may have to throw away some
432 dictionaries.
433
434 Note [Update for GADTs]
435 ~~~~~~~~~~~~~~~~~~~~~~~
436 Consider 
437    data T a b where
438      T1 { f1 :: a } :: T a Int
439
440 Then the wrapper function for T1 has type 
441    $WT1 :: a -> T a Int
442 But if x::T a b, then
443    x { f1 = v } :: T a b   (not T a Int!)
444 So we need to cast (T a Int) to (T a b).  Sigh.
445
446 \begin{code}
447 dsExpr expr@(RecordUpd record_expr (HsRecFields { rec_flds = fields })
448                        cons_to_upd in_inst_tys out_inst_tys)
449   | null fields
450   = dsLExpr record_expr
451   | otherwise
452   = ASSERT2( notNull cons_to_upd, ppr expr )
453
454     do  { record_expr' <- dsLExpr record_expr
455         ; field_binds' <- mapM ds_field fields
456         ; let upd_fld_env :: NameEnv Id -- Maps field name to the LocalId of the field binding
457               upd_fld_env = mkNameEnv [(f,l) | (f,l,_) <- field_binds']
458
459         -- It's important to generate the match with matchWrapper,
460         -- and the right hand sides with applications of the wrapper Id
461         -- so that everything works when we are doing fancy unboxing on the
462         -- constructor aguments.
463         ; alts <- mapM (mk_alt upd_fld_env) cons_to_upd
464         ; ([discrim_var], matching_code) 
465                 <- matchWrapper RecUpd (MatchGroup alts in_out_ty)
466
467         ; return (add_field_binds field_binds' $
468                   bindNonRec discrim_var record_expr' matching_code) }
469   where
470     ds_field :: HsRecField Id (LHsExpr Id) -> DsM (Name, Id, CoreExpr)
471       -- Clone the Id in the HsRecField, because its Name is that
472       -- of the record selector, and we must not make that a lcoal binder
473       -- else we shadow other uses of the record selector
474       -- Hence 'lcl_id'.  Cf Trac #2735
475     ds_field rec_field = do { rhs <- dsLExpr (hsRecFieldArg rec_field)
476                             ; let fld_id = unLoc (hsRecFieldId rec_field)
477                             ; lcl_id <- newSysLocalDs (idType fld_id)
478                             ; return (idName fld_id, lcl_id, rhs) }
479
480     add_field_binds [] expr = expr
481     add_field_binds ((_,b,r):bs) expr = bindNonRec b r (add_field_binds bs expr)
482
483         -- Awkwardly, for families, the match goes 
484         -- from instance type to family type
485     tycon     = dataConTyCon (head cons_to_upd)
486     in_ty     = mkTyConApp tycon in_inst_tys
487     in_out_ty = mkFunTy in_ty (mkFamilyTyConApp tycon out_inst_tys)
488
489     mk_alt upd_fld_env con
490       = do { let (univ_tvs, ex_tvs, eq_spec, 
491                   eq_theta, dict_theta, arg_tys, _) = dataConFullSig con
492                  subst = mkTopTvSubst (univ_tvs `zip` in_inst_tys)
493
494                 -- I'm not bothering to clone the ex_tvs
495            ; eqs_vars   <- mapM newPredVarDs (substTheta subst (eqSpecPreds eq_spec))
496            ; theta_vars <- mapM newPredVarDs (substTheta subst (eq_theta ++ dict_theta))
497            ; arg_ids    <- newSysLocalsDs (substTys subst arg_tys)
498            ; let val_args = zipWithEqual "dsExpr:RecordUpd" mk_val_arg
499                                          (dataConFieldLabels con) arg_ids
500                  mk_val_arg field_name pat_arg_id 
501                      = nlHsVar (lookupNameEnv upd_fld_env field_name `orElse` pat_arg_id)
502                  inst_con = noLoc $ HsWrap wrap (HsVar (dataConWrapId con))
503                         -- Reconstruct with the WrapId so that unpacking happens
504                  wrap = mkWpApps theta_vars `WpCompose` 
505                         mkWpTyApps (mkTyVarTys ex_tvs) `WpCompose`
506                         mkWpTyApps [ty | (tv, ty) <- univ_tvs `zip` out_inst_tys
507                                        , isNothing (lookupTyVar wrap_subst tv) ]
508                  rhs = foldl (\a b -> nlHsApp a b) inst_con val_args
509
510                         -- Tediously wrap the application in a cast
511                         -- Note [Update for GADTs]
512                  wrapped_rhs | null eq_spec = rhs
513                              | otherwise    = mkLHsWrap (WpCast wrap_co) rhs
514                  wrap_co = mkTyConApp tycon [ lookup tv ty 
515                                             | (tv,ty) <- univ_tvs `zip` out_inst_tys]
516                  lookup univ_tv ty = case lookupTyVar wrap_subst univ_tv of
517                                         Just ty' -> ty'
518                                         Nothing  -> ty
519                  wrap_subst = mkTopTvSubst [ (tv,mkSymCoercion (mkTyVarTy co_var))
520                                            | ((tv,_),co_var) <- eq_spec `zip` eqs_vars ]
521                  
522                  pat = noLoc $ ConPatOut { pat_con = noLoc con, pat_tvs = ex_tvs
523                                          , pat_dicts = eqs_vars ++ theta_vars
524                                          , pat_binds = emptyLHsBinds 
525                                          , pat_args = PrefixCon $ map nlVarPat arg_ids
526                                          , pat_ty = in_ty }
527            ; return (mkSimpleMatch [pat] wrapped_rhs) }
528
529 \end{code}
530
531 Here is where we desugar the Template Haskell brackets and escapes
532
533 \begin{code}
534 -- Template Haskell stuff
535
536 #ifdef GHCI     /* Only if bootstrapping */
537 dsExpr (HsBracketOut x ps) = dsBracket x ps
538 dsExpr (HsSpliceE s)       = pprPanic "dsExpr:splice" (ppr s)
539 #endif
540
541 -- Arrow notation extension
542 dsExpr (HsProc pat cmd) = dsProcExpr pat cmd
543 \end{code}
544
545 Hpc Support 
546
547 \begin{code}
548 dsExpr (HsTick ix vars e) = do
549   e' <- dsLExpr e
550   mkTickBox ix vars e'
551
552 -- There is a problem here. The then and else branches
553 -- have no free variables, so they are open to lifting.
554 -- We need someway of stopping this.
555 -- This will make no difference to binary coverage
556 -- (did you go here: YES or NO), but will effect accurate
557 -- tick counting.
558
559 dsExpr (HsBinTick ixT ixF e) = do
560   e2 <- dsLExpr e
561   do { ASSERT(exprType e2 `coreEqType` boolTy)
562        mkBinaryTickBox ixT ixF e2
563      }
564 \end{code}
565
566 \begin{code}
567
568 -- HsSyn constructs that just shouldn't be here:
569 dsExpr (ExprWithTySig _ _)  = panic "dsExpr:ExprWithTySig"
570
571
572 findField :: [HsRecField Id arg] -> Name -> [arg]
573 findField rbinds lbl 
574   = [rhs | HsRecField { hsRecFieldId = id, hsRecFieldArg = rhs } <- rbinds 
575          , lbl == idName (unLoc id) ]
576 \end{code}
577
578 %--------------------------------------------------------------------
579
580 Note [Desugaring explicit lists]
581 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
582 Explicit lists are desugared in a cleverer way to prevent some
583 fruitless allocations.  Essentially, whenever we see a list literal
584 [x_1, ..., x_n] we:
585
586 1. Find the tail of the list that can be allocated statically (say
587    [x_k, ..., x_n]) by later stages and ensure we desugar that
588    normally: this makes sure that we don't cause a code size increase
589    by having the cons in that expression fused (see later) and hence
590    being unable to statically allocate any more
591
592 2. For the prefix of the list which cannot be allocated statically,
593    say [x_1, ..., x_(k-1)], we turn it into an expression involving
594    build so that if we find any foldrs over it it will fuse away
595    entirely!
596    
597    So in this example we will desugar to:
598    build (\c n -> x_1 `c` x_2 `c` .... `c` foldr c n [x_k, ..., x_n]
599    
600    If fusion fails to occur then build will get inlined and (since we
601    defined a RULE for foldr (:) []) we will get back exactly the
602    normal desugaring for an explicit list.
603
604 This optimisation can be worth a lot: up to 25% of the total
605 allocation in some nofib programs. Specifically
606
607         Program           Size    Allocs   Runtime  CompTime
608         rewrite          +0.0%    -26.3%      0.02     -1.8%
609            ansi          -0.3%    -13.8%      0.00     +0.0%
610            lift          +0.0%     -8.7%      0.00     -2.3%
611
612 Of course, if rules aren't turned on then there is pretty much no
613 point doing this fancy stuff, and it may even be harmful.
614
615 =======>  Note by SLPJ Dec 08.
616
617 I'm unconvinced that we should *ever* generate a build for an explicit
618 list.  See the comments in GHC.Base about the foldr/cons rule, which 
619 points out that (foldr k z [a,b,c]) may generate *much* less code than
620 (a `k` b `k` c `k` z).
621
622 Furthermore generating builds messes up the LHS of RULES. 
623 Example: the foldr/single rule in GHC.Base
624    foldr k z [x] = ...
625 We do not want to generate a build invocation on the LHS of this RULE!
626
627 To test this I've added a (static) flag -fsimple-list-literals, which
628 makes all list literals be generated via the simple route.  
629
630
631 \begin{code}
632
633 dsExplicitList :: PostTcType -> [LHsExpr Id] -> DsM CoreExpr
634 -- See Note [Desugaring explicit lists]
635 dsExplicitList elt_ty xs = do
636     dflags <- getDOptsDs
637     xs' <- mapM dsLExpr xs
638     if  opt_SimpleListLiterals || not (dopt Opt_EnableRewriteRules dflags)
639         then return $ mkListExpr elt_ty xs'
640         else mkBuildExpr elt_ty (mkSplitExplicitList (thisPackage dflags) xs')
641   where
642     mkSplitExplicitList this_package xs' (c, _) (n, n_ty) = do
643         let (dynamic_prefix, static_suffix) = spanTail (rhsIsStatic this_package) xs'
644             static_suffix' = mkListExpr elt_ty static_suffix
645         
646         folded_static_suffix <- mkFoldrExpr elt_ty n_ty (Var c) (Var n) static_suffix'
647         let build_body = foldr (App . App (Var c)) folded_static_suffix dynamic_prefix
648         return build_body
649
650 spanTail :: (a -> Bool) -> [a] -> ([a], [a])
651 spanTail f xs = (reverse rejected, reverse satisfying)
652     where (satisfying, rejected) = span f $ reverse xs
653 \end{code}
654
655 Desugar 'do' and 'mdo' expressions (NOT list comprehensions, they're
656 handled in DsListComp).  Basically does the translation given in the
657 Haskell 98 report:
658
659 \begin{code}
660 dsDo    :: [LStmt Id]
661         -> LHsExpr Id
662         -> Type                 -- Type of the whole expression
663         -> DsM CoreExpr
664
665 dsDo stmts body _result_ty
666   = goL stmts
667   where
668     goL [] = dsLExpr body
669     goL ((L loc stmt):lstmts) = putSrcSpanDs loc (go stmt lstmts)
670   
671     go (ExprStmt rhs then_expr _) stmts
672       = do { rhs2 <- dsLExpr rhs
673            ; case tcSplitAppTy_maybe (exprType rhs2) of
674                 Just (container_ty, returning_ty) -> warnDiscardedDoBindings rhs container_ty returning_ty
675                 _                                 -> return ()
676            ; then_expr2 <- dsExpr then_expr
677            ; rest <- goL stmts
678            ; return (mkApps then_expr2 [rhs2, rest]) }
679     
680     go (LetStmt binds) stmts
681       = do { rest <- goL stmts
682            ; dsLocalBinds binds rest }
683
684     go (BindStmt pat rhs bind_op fail_op) stmts
685       = 
686        do  { body     <- goL stmts
687            ; rhs'     <- dsLExpr rhs
688            ; bind_op' <- dsExpr bind_op
689            ; var   <- selectSimpleMatchVarL pat
690            ; let bind_ty = exprType bind_op'    -- rhs -> (pat -> res1) -> res2
691                  res1_ty = funResultTy (funArgTy (funResultTy bind_ty))
692            ; match <- matchSinglePat (Var var) (StmtCtxt DoExpr) pat
693                                      res1_ty (cantFailMatchResult body)
694            ; match_code <- handle_failure pat match fail_op
695            ; return (mkApps bind_op' [rhs', Lam var match_code]) }
696     
697     -- In a do expression, pattern-match failure just calls
698     -- the monadic 'fail' rather than throwing an exception
699     handle_failure pat match fail_op
700       | matchCanFail match
701       = do { fail_op' <- dsExpr fail_op
702            ; fail_msg <- mkStringExpr (mk_fail_msg pat)
703            ; extractMatchResult match (App fail_op' fail_msg) }
704       | otherwise
705       = extractMatchResult match (error "It can't fail") 
706
707 mk_fail_msg :: Located e -> String
708 mk_fail_msg pat = "Pattern match failure in do expression at " ++ 
709                   showSDoc (ppr (getLoc pat))
710 \end{code}
711
712 Translation for RecStmt's: 
713 -----------------------------
714 We turn (RecStmt [v1,..vn] stmts) into:
715   
716   (v1,..,vn) <- mfix (\~(v1,..vn). do stmts
717                                       return (v1,..vn))
718
719 \begin{code}
720 dsMDo   :: PostTcTable
721         -> [LStmt Id]
722         -> LHsExpr Id
723         -> Type                 -- Type of the whole expression
724         -> DsM CoreExpr
725
726 dsMDo tbl stmts body result_ty
727   = goL stmts
728   where
729     goL [] = dsLExpr body
730     goL ((L loc stmt):lstmts) = putSrcSpanDs loc (go loc stmt lstmts)
731   
732     (m_ty, b_ty) = tcSplitAppTy result_ty       -- result_ty must be of the form (m b)
733     mfix_id   = lookupEvidence tbl mfixName
734     return_id = lookupEvidence tbl returnMName
735     bind_id   = lookupEvidence tbl bindMName
736     then_id   = lookupEvidence tbl thenMName
737     fail_id   = lookupEvidence tbl failMName
738     ctxt      = MDoExpr tbl
739
740     go _ (LetStmt binds) stmts
741       = do { rest <- goL stmts
742            ; dsLocalBinds binds rest }
743
744     go _ (ExprStmt rhs _ rhs_ty) stmts
745       = do { rhs2 <- dsLExpr rhs
746            ; warnDiscardedDoBindings rhs m_ty rhs_ty
747            ; rest <- goL stmts
748            ; return (mkApps (Var then_id) [Type rhs_ty, Type b_ty, rhs2, rest]) }
749     
750     go _ (BindStmt pat rhs _ _) stmts
751       = do { body  <- goL stmts
752            ; var   <- selectSimpleMatchVarL pat
753            ; match <- matchSinglePat (Var var) (StmtCtxt ctxt) pat
754                                   result_ty (cantFailMatchResult body)
755            ; fail_msg   <- mkStringExpr (mk_fail_msg pat)
756            ; let fail_expr = mkApps (Var fail_id) [Type b_ty, fail_msg]
757            ; match_code <- extractMatchResult match fail_expr
758
759            ; rhs'       <- dsLExpr rhs
760            ; return (mkApps (Var bind_id) [Type (hsLPatType pat), Type b_ty, 
761                                              rhs', Lam var match_code]) }
762     
763     go loc (RecStmt rec_stmts later_ids rec_ids rec_rets binds) stmts
764       = ASSERT( length rec_ids > 0 )
765         ASSERT( length rec_ids == length rec_rets )
766         goL (new_bind_stmt : let_stmt : stmts)
767       where
768         new_bind_stmt = L loc $ mkBindStmt (mk_tup_pat later_pats) mfix_app
769         let_stmt = L loc $ LetStmt (HsValBinds (ValBindsOut [(Recursive, binds)] []))
770
771         
772                 -- Remove the later_ids that appear (without fancy coercions) 
773                 -- in rec_rets, because there's no need to knot-tie them separately
774                 -- See Note [RecStmt] in HsExpr
775         later_ids'   = filter (`notElem` mono_rec_ids) later_ids
776         mono_rec_ids = [ id | HsVar id <- rec_rets ]
777     
778         mfix_app = nlHsApp (nlHsTyApp mfix_id [tup_ty]) mfix_arg
779         mfix_arg = noLoc $ HsLam (MatchGroup [mkSimpleMatch [mfix_pat] body]
780                                              (mkFunTy tup_ty body_ty))
781
782         -- The rec_tup_pat must bind the rec_ids only; remember that the 
783         --      trimmed_laters may share the same Names
784         -- Meanwhile, the later_pats must bind the later_vars
785         rec_tup_pats = map mk_wild_pat later_ids' ++ map nlVarPat rec_ids
786         later_pats   = map nlVarPat    later_ids' ++ map mk_later_pat rec_ids
787         rets         = map nlHsVar     later_ids' ++ map noLoc rec_rets
788
789         mfix_pat = noLoc $ LazyPat $ mk_tup_pat rec_tup_pats
790         body     = noLoc $ HsDo ctxt rec_stmts return_app body_ty
791         body_ty = mkAppTy m_ty tup_ty
792         tup_ty  = mkCoreTupTy (map idType (later_ids' ++ rec_ids))
793                   -- mkCoreTupTy deals with singleton case
794
795         return_app  = nlHsApp (nlHsTyApp return_id [tup_ty]) 
796                               (mk_ret_tup rets)
797
798         mk_wild_pat :: Id -> LPat Id 
799         mk_wild_pat v = noLoc $ WildPat $ idType v
800
801         mk_later_pat :: Id -> LPat Id
802         mk_later_pat v | v `elem` later_ids' = mk_wild_pat v
803                        | otherwise           = nlVarPat v
804
805         mk_tup_pat :: [LPat Id] -> LPat Id
806         mk_tup_pat [p] = p
807         mk_tup_pat ps  = noLoc $ mkVanillaTuplePat ps Boxed
808
809         mk_ret_tup :: [LHsExpr Id] -> LHsExpr Id
810         mk_ret_tup [r] = r
811         mk_ret_tup rs  = noLoc $ ExplicitTuple rs Boxed
812 \end{code}
813
814
815 %************************************************************************
816 %*                                                                      *
817 \subsection{Errors and contexts}
818 %*                                                                      *
819 %************************************************************************
820
821 \begin{code}
822 -- Warn about certain types of values discarded in monadic bindings (#3263)
823 warnDiscardedDoBindings :: LHsExpr Id -> Type -> Type -> DsM ()
824 warnDiscardedDoBindings rhs container_ty returning_ty = do {
825           -- Warn about discarding non-() things in 'monadic' binding
826         ; warn_unused <- doptDs Opt_WarnUnusedDoBind
827         ; if warn_unused && not (returning_ty `tcEqType` unitTy)
828            then warnDs (unusedMonadBind rhs returning_ty)
829            else do {
830           -- Warn about discarding m a things in 'monadic' binding of the same type,
831           -- but only if we didn't already warn due to Opt_WarnUnusedDoBind
832         ; warn_wrong <- doptDs Opt_WarnWrongDoBind
833         ; case tcSplitAppTy_maybe returning_ty of
834                   Just (returning_container_ty, _) -> when (warn_wrong && container_ty `tcEqType` returning_container_ty) $
835                                                             warnDs (wrongMonadBind rhs returning_ty)
836                   _ -> return () } }
837
838 unusedMonadBind :: LHsExpr Id -> Type -> SDoc
839 unusedMonadBind rhs returning_ty
840   = ptext (sLit "A do-notation statement discarded a result of type") <+> ppr returning_ty <> dot $$
841     ptext (sLit "Suppress this warning by saying \"_ <- ") <> ppr rhs <> ptext (sLit "\",") $$
842     ptext (sLit "or by using the flag -fno-warn-unused-do-bind")
843
844 wrongMonadBind :: LHsExpr Id -> Type -> SDoc
845 wrongMonadBind rhs returning_ty
846   = ptext (sLit "A do-notation statement discarded a result of type") <+> ppr returning_ty <> dot $$
847     ptext (sLit "Suppress this warning by saying \"_ <- ") <> ppr rhs <> ptext (sLit "\",") $$
848     ptext (sLit "or by using the flag -fno-warn-wrong-do-bind")
849 \end{code}