compiler: de-lhs deSugar/
[ghc.git] / compiler / deSugar / DsExpr.hs
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
9 {-# LANGUAGE CPP #-}
10
11 module DsExpr ( dsExpr, dsLExpr, dsLocalBinds, dsValBinds, dsLit ) where
12
13 #include "HsVersions.h"
14
15 import Match
16 import MatchLit
17 import DsBinds
18 import DsGRHSs
19 import DsListComp
20 import DsUtils
21 import DsArrows
22 import DsMonad
23 import Name
24 import NameEnv
25 import FamInstEnv( topNormaliseType )
26
27 #ifdef GHCI
28 -- Template Haskell stuff iff bootstrapped
29 import DsMeta
30 #endif
31
32 import HsSyn
33
34 -- NB: The desugarer, which straddles the source and Core worlds, sometimes
35 -- needs to see source types
36 import TcType
37 import Coercion ( Role(..) )
38 import TcEvidence
39 import TcRnMonad
40 import Type
41 import CoreSyn
42 import CoreUtils
43 import CoreFVs
44 import MkCore
45
46 import DynFlags
47 import CostCentre
48 import Id
49 import Module
50 import VarSet
51 import VarEnv
52 import ConLike
53 import DataCon
54 import TysWiredIn
55 import BasicTypes
56 import Maybes
57 import SrcLoc
58 import Util
59 import Bag
60 import Outputable
61 import FastString
62
63 import Control.Monad
64
65 {-
66 ************************************************************************
67 * *
68 dsLocalBinds, dsValBinds
69 * *
70 ************************************************************************
71 -}
72
73 dsLocalBinds :: HsLocalBinds Id -> CoreExpr -> DsM CoreExpr
74 dsLocalBinds EmptyLocalBinds body = return body
75 dsLocalBinds (HsValBinds binds) body = dsValBinds binds body
76 dsLocalBinds (HsIPBinds binds) body = dsIPBinds binds body
77
78 -------------------------
79 dsValBinds :: HsValBinds Id -> CoreExpr -> DsM CoreExpr
80 dsValBinds (ValBindsOut binds _) body = foldrM ds_val_bind body binds
81 dsValBinds (ValBindsIn _ _) _ = panic "dsValBinds ValBindsIn"
82
83 -------------------------
84 dsIPBinds :: HsIPBinds Id -> CoreExpr -> DsM CoreExpr
85 dsIPBinds (IPBinds ip_binds ev_binds) body
86 = do { ds_binds <- dsTcEvBinds ev_binds
87 ; let inner = mkCoreLets ds_binds body
88 -- The dict bindings may not be in
89 -- dependency order; hence Rec
90 ; foldrM ds_ip_bind inner ip_binds }
91 where
92 ds_ip_bind (L _ (IPBind ~(Right n) e)) body
93 = do e' <- dsLExpr e
94 return (Let (NonRec n e') body)
95
96 -------------------------
97 ds_val_bind :: (RecFlag, LHsBinds Id) -> CoreExpr -> DsM CoreExpr
98 -- Special case for bindings which bind unlifted variables
99 -- We need to do a case right away, rather than building
100 -- a tuple and doing selections.
101 -- Silently ignore INLINE and SPECIALISE pragmas...
102 ds_val_bind (NonRecursive, hsbinds) body
103 | [L loc bind] <- bagToList hsbinds,
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 strictMatchOnly bind
109 = putSrcSpanDs loc (dsStrictBind bind body)
110
111 -- Ordinary case for bindings; none should be unlifted
112 ds_val_bind (_is_rec, binds) body
113 = do { prs <- dsLHsBinds binds
114 ; ASSERT2( not (any (isUnLiftedType . idType . fst) prs), ppr _is_rec $$ ppr binds )
115 case prs of
116 [] -> return body
117 _ -> return (Let (Rec prs) body) }
118 -- Use a Rec regardless of is_rec.
119 -- Why? Because it allows the binds to be all
120 -- mixed up, which is what happens in one rare case
121 -- Namely, for an AbsBind with no tyvars and no dicts,
122 -- but which does have dictionary bindings.
123 -- See notes with TcSimplify.inferLoop [NO TYVARS]
124 -- It turned out that wrapping a Rec here was the easiest solution
125 --
126 -- NB The previous case dealt with unlifted bindings, so we
127 -- only have to deal with lifted ones now; so Rec is ok
128
129 ------------------
130 dsStrictBind :: HsBind Id -> CoreExpr -> DsM CoreExpr
131 dsStrictBind (AbsBinds { abs_tvs = [], abs_ev_vars = []
132 , abs_exports = exports
133 , abs_ev_binds = ev_binds
134 , abs_binds = lbinds }) body
135 = do { let body1 = foldr bind_export body exports
136 bind_export export b = bindNonRec (abe_poly export) (Var (abe_mono export)) b
137 ; body2 <- foldlBagM (\body lbind -> dsStrictBind (unLoc lbind) body)
138 body1 lbinds
139 ; ds_binds <- dsTcEvBinds ev_binds
140 ; return (mkCoreLets ds_binds body2) }
141
142 dsStrictBind (FunBind { fun_id = L _ fun, fun_matches = matches, fun_co_fn = co_fn
143 , fun_tick = tick, fun_infix = inf }) body
144 -- Can't be a bang pattern (that looks like a PatBind)
145 -- so must be simply unboxed
146 = do { (args, rhs) <- matchWrapper (FunRhs (idName fun ) inf) matches
147 ; MASSERT( null args ) -- Functions aren't lifted
148 ; MASSERT( isIdHsWrapper co_fn )
149 ; let rhs' = mkOptTickBox tick rhs
150 ; return (bindNonRec fun rhs' body) }
151
152 dsStrictBind (PatBind {pat_lhs = pat, pat_rhs = grhss, pat_rhs_ty = ty }) body
153 = -- let C x# y# = rhs in body
154 -- ==> case rhs of C x# y# -> body
155 do { rhs <- dsGuarded grhss ty
156 ; let upat = unLoc pat
157 eqn = EqnInfo { eqn_pats = [upat],
158 eqn_rhs = cantFailMatchResult body }
159 ; var <- selectMatchVar upat
160 ; result <- matchEquations PatBindRhs [var] [eqn] (exprType body)
161 ; return (bindNonRec var rhs result) }
162
163 dsStrictBind bind body = pprPanic "dsLet: unlifted" (ppr bind $$ ppr body)
164
165 ----------------------
166 strictMatchOnly :: HsBind Id -> Bool
167 strictMatchOnly (AbsBinds { abs_binds = lbinds })
168 = anyBag (strictMatchOnly . unLoc) lbinds
169 strictMatchOnly (PatBind { pat_lhs = lpat, pat_rhs_ty = rhs_ty })
170 = isUnLiftedType rhs_ty
171 || isStrictLPat lpat
172 || any (isUnLiftedType . idType) (collectPatBinders lpat)
173 strictMatchOnly (FunBind { fun_id = L _ id })
174 = isUnLiftedType (idType id)
175 strictMatchOnly _ = False -- I hope! Checked immediately by caller in fact
176
177 {-
178 ************************************************************************
179 * *
180 \subsection[DsExpr-vars-and-cons]{Variables, constructors, literals}
181 * *
182 ************************************************************************
183 -}
184
185 dsLExpr :: LHsExpr Id -> DsM CoreExpr
186
187 dsLExpr (L loc e) = putSrcSpanDs loc $ dsExpr e
188
189 dsExpr :: HsExpr Id -> DsM CoreExpr
190 dsExpr (HsPar e) = dsLExpr e
191 dsExpr (ExprWithTySigOut e _) = dsLExpr e
192 dsExpr (HsVar var) = return (varToCoreExpr var) -- See Note [Desugaring vars]
193 dsExpr (HsIPVar _) = panic "dsExpr: HsIPVar"
194 dsExpr (HsLit lit) = dsLit lit
195 dsExpr (HsOverLit lit) = dsOverLit lit
196
197 dsExpr (HsWrap co_fn e)
198 = do { e' <- dsExpr e
199 ; wrapped_e <- dsHsWrapper co_fn e'
200 ; dflags <- getDynFlags
201 ; warnAboutIdentities dflags e' (exprType wrapped_e)
202 ; return wrapped_e }
203
204 dsExpr (NegApp expr neg_expr)
205 = App <$> dsExpr neg_expr <*> dsLExpr expr
206
207 dsExpr (HsLam a_Match)
208 = uncurry mkLams <$> matchWrapper LambdaExpr a_Match
209
210 dsExpr (HsLamCase arg matches)
211 = do { arg_var <- newSysLocalDs arg
212 ; ([discrim_var], matching_code) <- matchWrapper CaseAlt matches
213 ; return $ Lam arg_var $ bindNonRec discrim_var (Var arg_var) matching_code }
214
215 dsExpr (HsApp fun arg)
216 = mkCoreAppDs <$> dsLExpr fun <*> dsLExpr arg
217
218 dsExpr (HsUnboundVar _) = panic "dsExpr: HsUnboundVar"
219
220 {-
221 Note [Desugaring vars]
222 ~~~~~~~~~~~~~~~~~~~~~~
223 In one situation we can get a *coercion* variable in a HsVar, namely
224 the support method for an equality superclass:
225 class (a~b) => C a b where ...
226 instance (blah) => C (T a) (T b) where ..
227 Then we get
228 $dfCT :: forall ab. blah => C (T a) (T b)
229 $dfCT ab blah = MkC ($c$p1C a blah) ($cop a blah)
230
231 $c$p1C :: forall ab. blah => (T a ~ T b)
232 $c$p1C ab blah = let ...; g :: T a ~ T b = ... } in g
233
234 That 'g' in the 'in' part is an evidence variable, and when
235 converting to core it must become a CO.
236
237 Operator sections. At first it looks as if we can convert
238 \begin{verbatim}
239 (expr op)
240 \end{verbatim}
241 to
242 \begin{verbatim}
243 \x -> op expr x
244 \end{verbatim}
245
246 But no! expr might be a redex, and we can lose laziness badly this
247 way. Consider
248 \begin{verbatim}
249 map (expr op) xs
250 \end{verbatim}
251 for example. So we convert instead to
252 \begin{verbatim}
253 let y = expr in \x -> op y x
254 \end{verbatim}
255 If \tr{expr} is actually just a variable, say, then the simplifier
256 will sort it out.
257 -}
258
259 dsExpr (OpApp e1 op _ e2)
260 = -- for the type of y, we need the type of op's 2nd argument
261 mkCoreAppsDs <$> dsLExpr op <*> mapM dsLExpr [e1, e2]
262
263 dsExpr (SectionL expr op) -- Desugar (e !) to ((!) e)
264 = mkCoreAppDs <$> dsLExpr op <*> dsLExpr expr
265
266 -- dsLExpr (SectionR op expr) -- \ x -> op x expr
267 dsExpr (SectionR op expr) = do
268 core_op <- dsLExpr op
269 -- for the type of x, we need the type of op's 2nd argument
270 let (x_ty:y_ty:_, _) = splitFunTys (exprType core_op)
271 -- See comment with SectionL
272 y_core <- dsLExpr expr
273 x_id <- newSysLocalDs x_ty
274 y_id <- newSysLocalDs y_ty
275 return (bindNonRec y_id y_core $
276 Lam x_id (mkCoreAppsDs core_op [Var x_id, Var y_id]))
277
278 dsExpr (ExplicitTuple tup_args boxity)
279 = do { let go (lam_vars, args) (L _ (Missing ty))
280 -- For every missing expression, we need
281 -- another lambda in the desugaring.
282 = do { lam_var <- newSysLocalDs ty
283 ; return (lam_var : lam_vars, Var lam_var : args) }
284 go (lam_vars, args) (L _ (Present expr))
285 -- Expressions that are present don't generate
286 -- lambdas, just arguments.
287 = do { core_expr <- dsLExpr expr
288 ; return (lam_vars, core_expr : args) }
289
290 ; (lam_vars, args) <- foldM go ([], []) (reverse tup_args)
291 -- The reverse is because foldM goes left-to-right
292
293 ; return $ mkCoreLams lam_vars $
294 mkCoreConApps (tupleCon (boxityNormalTupleSort boxity) (length tup_args))
295 (map (Type . exprType) args ++ args) }
296
297 dsExpr (HsSCC cc expr@(L loc _)) = do
298 mod_name <- getModule
299 count <- goptM Opt_ProfCountEntries
300 uniq <- newUnique
301 Tick (ProfNote (mkUserCC cc mod_name loc uniq) count True) <$> dsLExpr expr
302
303 dsExpr (HsCoreAnn _ expr)
304 = dsLExpr expr
305
306 dsExpr (HsCase discrim matches)
307 = do { core_discrim <- dsLExpr discrim
308 ; ([discrim_var], matching_code) <- matchWrapper CaseAlt matches
309 ; return (bindNonRec discrim_var core_discrim matching_code) }
310
311 -- Pepe: The binds are in scope in the body but NOT in the binding group
312 -- This is to avoid silliness in breakpoints
313 dsExpr (HsLet binds body) = do
314 body' <- dsLExpr body
315 dsLocalBinds binds body'
316
317 -- We need the `ListComp' form to use `deListComp' (rather than the "do" form)
318 -- because the interpretation of `stmts' depends on what sort of thing it is.
319 --
320 dsExpr (HsDo ListComp stmts res_ty) = dsListComp stmts res_ty
321 dsExpr (HsDo PArrComp stmts _) = dsPArrComp (map unLoc stmts)
322 dsExpr (HsDo DoExpr stmts _) = dsDo stmts
323 dsExpr (HsDo GhciStmtCtxt stmts _) = dsDo stmts
324 dsExpr (HsDo MDoExpr stmts _) = dsDo stmts
325 dsExpr (HsDo MonadComp stmts _) = dsMonadComp stmts
326
327 dsExpr (HsIf mb_fun guard_expr then_expr else_expr)
328 = do { pred <- dsLExpr guard_expr
329 ; b1 <- dsLExpr then_expr
330 ; b2 <- dsLExpr else_expr
331 ; case mb_fun of
332 Just fun -> do { core_fun <- dsExpr fun
333 ; return (mkCoreApps core_fun [pred,b1,b2]) }
334 Nothing -> return $ mkIfThenElse pred b1 b2 }
335
336 dsExpr (HsMultiIf res_ty alts)
337 | null alts
338 = mkErrorExpr
339
340 | otherwise
341 = do { match_result <- liftM (foldr1 combineMatchResults)
342 (mapM (dsGRHS IfAlt res_ty) alts)
343 ; error_expr <- mkErrorExpr
344 ; extractMatchResult match_result error_expr }
345 where
346 mkErrorExpr = mkErrorAppDs nON_EXHAUSTIVE_GUARDS_ERROR_ID res_ty
347 (ptext (sLit "multi-way if"))
348
349 {-
350 \noindent
351 \underline{\bf Various data construction things}
352 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
353 -}
354
355 dsExpr (ExplicitList elt_ty wit xs)
356 = dsExplicitList elt_ty wit xs
357
358 -- We desugar [:x1, ..., xn:] as
359 -- singletonP x1 +:+ ... +:+ singletonP xn
360 --
361 dsExpr (ExplicitPArr ty []) = do
362 emptyP <- dsDPHBuiltin emptyPVar
363 return (Var emptyP `App` Type ty)
364 dsExpr (ExplicitPArr ty xs) = do
365 singletonP <- dsDPHBuiltin singletonPVar
366 appP <- dsDPHBuiltin appPVar
367 xs' <- mapM dsLExpr xs
368 return . foldr1 (binary appP) $ map (unary singletonP) xs'
369 where
370 unary fn x = mkApps (Var fn) [Type ty, x]
371 binary fn x y = mkApps (Var fn) [Type ty, x, y]
372
373 dsExpr (ArithSeq expr witness seq)
374 = case witness of
375 Nothing -> dsArithSeq expr seq
376 Just fl -> do {
377 ; fl' <- dsExpr fl
378 ; newArithSeq <- dsArithSeq expr seq
379 ; return (App fl' newArithSeq)}
380
381 dsExpr (PArrSeq expr (FromTo from to))
382 = mkApps <$> dsExpr expr <*> mapM dsLExpr [from, to]
383
384 dsExpr (PArrSeq expr (FromThenTo from thn to))
385 = mkApps <$> dsExpr expr <*> mapM dsLExpr [from, thn, to]
386
387 dsExpr (PArrSeq _ _)
388 = panic "DsExpr.dsExpr: Infinite parallel array!"
389 -- the parser shouldn't have generated it and the renamer and typechecker
390 -- shouldn't have let it through
391
392 {-
393 \noindent
394 \underline{\bf Record construction and update}
395 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
396 For record construction we do this (assuming T has three arguments)
397 \begin{verbatim}
398 T { op2 = e }
399 ==>
400 let err = /\a -> recConErr a
401 T (recConErr t1 "M.lhs/230/op1")
402 e
403 (recConErr t1 "M.lhs/230/op3")
404 \end{verbatim}
405 @recConErr@ then converts its arugment string into a proper message
406 before printing it as
407 \begin{verbatim}
408 M.lhs, line 230: missing field op1 was evaluated
409 \end{verbatim}
410
411 We also handle @C{}@ as valid construction syntax for an unlabelled
412 constructor @C@, setting all of @C@'s fields to bottom.
413 -}
414
415 dsExpr (RecordCon (L _ data_con_id) con_expr rbinds) = do
416 con_expr' <- dsExpr con_expr
417 let
418 (arg_tys, _) = tcSplitFunTys (exprType con_expr')
419 -- A newtype in the corner should be opaque;
420 -- hence TcType.tcSplitFunTys
421
422 mk_arg (arg_ty, lbl) -- Selector id has the field label as its name
423 = case findField (rec_flds rbinds) lbl of
424 (rhs:rhss) -> ASSERT( null rhss )
425 dsLExpr rhs
426 [] -> mkErrorAppDs rEC_CON_ERROR_ID arg_ty (ppr lbl)
427 unlabelled_bottom arg_ty = mkErrorAppDs rEC_CON_ERROR_ID arg_ty Outputable.empty
428
429 labels = dataConFieldLabels (idDataCon data_con_id)
430 -- The data_con_id is guaranteed to be the wrapper id of the constructor
431
432 con_args <- if null labels
433 then mapM unlabelled_bottom arg_tys
434 else mapM mk_arg (zipEqual "dsExpr:RecordCon" arg_tys labels)
435
436 return (mkCoreApps con_expr' con_args)
437
438 {-
439 Record update is a little harder. Suppose we have the decl:
440 \begin{verbatim}
441 data T = T1 {op1, op2, op3 :: Int}
442 | T2 {op4, op2 :: Int}
443 | T3
444 \end{verbatim}
445 Then we translate as follows:
446 \begin{verbatim}
447 r { op2 = e }
448 ===>
449 let op2 = e in
450 case r of
451 T1 op1 _ op3 -> T1 op1 op2 op3
452 T2 op4 _ -> T2 op4 op2
453 other -> recUpdError "M.lhs/230"
454 \end{verbatim}
455 It's important that we use the constructor Ids for @T1@, @T2@ etc on the
456 RHSs, and do not generate a Core constructor application directly, because the constructor
457 might do some argument-evaluation first; and may have to throw away some
458 dictionaries.
459
460 Note [Update for GADTs]
461 ~~~~~~~~~~~~~~~~~~~~~~~
462 Consider
463 data T a b where
464 T1 { f1 :: a } :: T a Int
465
466 Then the wrapper function for T1 has type
467 $WT1 :: a -> T a Int
468 But if x::T a b, then
469 x { f1 = v } :: T a b (not T a Int!)
470 So we need to cast (T a Int) to (T a b). Sigh.
471 -}
472
473 dsExpr expr@(RecordUpd record_expr (HsRecFields { rec_flds = fields })
474 cons_to_upd in_inst_tys out_inst_tys)
475 | null fields
476 = dsLExpr record_expr
477 | otherwise
478 = ASSERT2( notNull cons_to_upd, ppr expr )
479
480 do { record_expr' <- dsLExpr record_expr
481 ; field_binds' <- mapM ds_field fields
482 ; let upd_fld_env :: NameEnv Id -- Maps field name to the LocalId of the field binding
483 upd_fld_env = mkNameEnv [(f,l) | (f,l,_) <- field_binds']
484
485 -- It's important to generate the match with matchWrapper,
486 -- and the right hand sides with applications of the wrapper Id
487 -- so that everything works when we are doing fancy unboxing on the
488 -- constructor aguments.
489 ; alts <- mapM (mk_alt upd_fld_env) cons_to_upd
490 ; ([discrim_var], matching_code)
491 <- matchWrapper RecUpd (MG { mg_alts = alts, mg_arg_tys = [in_ty]
492 , mg_res_ty = out_ty, mg_origin = FromSource })
493 -- FromSource is not strictly right, but we
494 -- want incomplete pattern-match warnings
495
496 ; return (add_field_binds field_binds' $
497 bindNonRec discrim_var record_expr' matching_code) }
498 where
499 ds_field :: LHsRecField Id (LHsExpr Id) -> DsM (Name, Id, CoreExpr)
500 -- Clone the Id in the HsRecField, because its Name is that
501 -- of the record selector, and we must not make that a lcoal binder
502 -- else we shadow other uses of the record selector
503 -- Hence 'lcl_id'. Cf Trac #2735
504 ds_field (L _ rec_field) = do { rhs <- dsLExpr (hsRecFieldArg rec_field)
505 ; let fld_id = unLoc (hsRecFieldId rec_field)
506 ; lcl_id <- newSysLocalDs (idType fld_id)
507 ; return (idName fld_id, lcl_id, rhs) }
508
509 add_field_binds [] expr = expr
510 add_field_binds ((_,b,r):bs) expr = bindNonRec b r (add_field_binds bs expr)
511
512 -- Awkwardly, for families, the match goes
513 -- from instance type to family type
514 tycon = dataConTyCon (head cons_to_upd)
515 in_ty = mkTyConApp tycon in_inst_tys
516 out_ty = mkFamilyTyConApp tycon out_inst_tys
517
518 mk_alt upd_fld_env con
519 = do { let (univ_tvs, ex_tvs, eq_spec,
520 theta, arg_tys, _) = dataConFullSig con
521 subst = mkTopTvSubst (univ_tvs `zip` in_inst_tys)
522
523 -- I'm not bothering to clone the ex_tvs
524 ; eqs_vars <- mapM newPredVarDs (substTheta subst (eqSpecPreds eq_spec))
525 ; theta_vars <- mapM newPredVarDs (substTheta subst theta)
526 ; arg_ids <- newSysLocalsDs (substTys subst arg_tys)
527 ; let val_args = zipWithEqual "dsExpr:RecordUpd" mk_val_arg
528 (dataConFieldLabels con) arg_ids
529 mk_val_arg field_name pat_arg_id
530 = nlHsVar (lookupNameEnv upd_fld_env field_name `orElse` pat_arg_id)
531 inst_con = noLoc $ HsWrap wrap (HsVar (dataConWrapId con))
532 -- Reconstruct with the WrapId so that unpacking happens
533 wrap = mkWpEvVarApps theta_vars <.>
534 mkWpTyApps (mkTyVarTys ex_tvs) <.>
535 mkWpTyApps [ty | (tv, ty) <- univ_tvs `zip` out_inst_tys
536 , not (tv `elemVarEnv` wrap_subst) ]
537 rhs = foldl (\a b -> nlHsApp a b) inst_con val_args
538
539 -- Tediously wrap the application in a cast
540 -- Note [Update for GADTs]
541 wrap_co = mkTcTyConAppCo Nominal tycon
542 [ lookup tv ty | (tv,ty) <- univ_tvs `zip` out_inst_tys ]
543 lookup univ_tv ty = case lookupVarEnv wrap_subst univ_tv of
544 Just co' -> co'
545 Nothing -> mkTcReflCo Nominal ty
546 wrap_subst = mkVarEnv [ (tv, mkTcSymCo (mkTcCoVarCo eq_var))
547 | ((tv,_),eq_var) <- eq_spec `zip` eqs_vars ]
548
549 pat = noLoc $ ConPatOut { pat_con = noLoc (RealDataCon con)
550 , pat_tvs = ex_tvs
551 , pat_dicts = eqs_vars ++ theta_vars
552 , pat_binds = emptyTcEvBinds
553 , pat_args = PrefixCon $ map nlVarPat arg_ids
554 , pat_arg_tys = in_inst_tys
555 , pat_wrap = idHsWrapper }
556 ; let wrapped_rhs | null eq_spec = rhs
557 | otherwise = mkLHsWrap (mkWpCast (mkTcSubCo wrap_co)) rhs
558 ; return (mkSimpleMatch [pat] wrapped_rhs) }
559
560 -- Here is where we desugar the Template Haskell brackets and escapes
561
562 -- Template Haskell stuff
563
564 dsExpr (HsRnBracketOut _ _) = panic "dsExpr HsRnBracketOut"
565 #ifdef GHCI
566 dsExpr (HsTcBracketOut x ps) = dsBracket x ps
567 #else
568 dsExpr (HsTcBracketOut _ _) = panic "dsExpr HsBracketOut"
569 #endif
570 dsExpr (HsSpliceE _ s) = pprPanic "dsExpr:splice" (ppr s)
571
572 -- Arrow notation extension
573 dsExpr (HsProc pat cmd) = dsProcExpr pat cmd
574
575 -- Hpc Support
576
577 dsExpr (HsTick tickish e) = do
578 e' <- dsLExpr e
579 return (Tick tickish e')
580
581 -- There is a problem here. The then and else branches
582 -- have no free variables, so they are open to lifting.
583 -- We need someway of stopping this.
584 -- This will make no difference to binary coverage
585 -- (did you go here: YES or NO), but will effect accurate
586 -- tick counting.
587
588 dsExpr (HsBinTick ixT ixF e) = do
589 e2 <- dsLExpr e
590 do { ASSERT(exprType e2 `eqType` boolTy)
591 mkBinaryTickBox ixT ixF e2
592 }
593
594 -- HsSyn constructs that just shouldn't be here:
595 dsExpr (ExprWithTySig {}) = panic "dsExpr:ExprWithTySig"
596 dsExpr (HsBracket {}) = panic "dsExpr:HsBracket"
597 dsExpr (HsQuasiQuoteE {}) = panic "dsExpr:HsQuasiQuoteE"
598 dsExpr (HsArrApp {}) = panic "dsExpr:HsArrApp"
599 dsExpr (HsArrForm {}) = panic "dsExpr:HsArrForm"
600 dsExpr (HsTickPragma {}) = panic "dsExpr:HsTickPragma"
601 dsExpr (EWildPat {}) = panic "dsExpr:EWildPat"
602 dsExpr (EAsPat {}) = panic "dsExpr:EAsPat"
603 dsExpr (EViewPat {}) = panic "dsExpr:EViewPat"
604 dsExpr (ELazyPat {}) = panic "dsExpr:ELazyPat"
605 dsExpr (HsType {}) = panic "dsExpr:HsType"
606 dsExpr (HsDo {}) = panic "dsExpr:HsDo"
607
608
609 findField :: [LHsRecField Id arg] -> Name -> [arg]
610 findField rbinds lbl
611 = [rhs | L _ (HsRecField { hsRecFieldId = id, hsRecFieldArg = rhs }) <- rbinds
612 , lbl == idName (unLoc id) ]
613
614 {-
615 %--------------------------------------------------------------------
616
617 Note [Desugaring explicit lists]
618 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
619 Explicit lists are desugared in a cleverer way to prevent some
620 fruitless allocations. Essentially, whenever we see a list literal
621 [x_1, ..., x_n] we:
622
623 1. Find the tail of the list that can be allocated statically (say
624 [x_k, ..., x_n]) by later stages and ensure we desugar that
625 normally: this makes sure that we don't cause a code size increase
626 by having the cons in that expression fused (see later) and hence
627 being unable to statically allocate any more
628
629 2. For the prefix of the list which cannot be allocated statically,
630 say [x_1, ..., x_(k-1)], we turn it into an expression involving
631 build so that if we find any foldrs over it it will fuse away
632 entirely!
633
634 So in this example we will desugar to:
635 build (\c n -> x_1 `c` x_2 `c` .... `c` foldr c n [x_k, ..., x_n]
636
637 If fusion fails to occur then build will get inlined and (since we
638 defined a RULE for foldr (:) []) we will get back exactly the
639 normal desugaring for an explicit list.
640
641 This optimisation can be worth a lot: up to 25% of the total
642 allocation in some nofib programs. Specifically
643
644 Program Size Allocs Runtime CompTime
645 rewrite +0.0% -26.3% 0.02 -1.8%
646 ansi -0.3% -13.8% 0.00 +0.0%
647 lift +0.0% -8.7% 0.00 -2.3%
648
649 Of course, if rules aren't turned on then there is pretty much no
650 point doing this fancy stuff, and it may even be harmful.
651
652 =======> Note by SLPJ Dec 08.
653
654 I'm unconvinced that we should *ever* generate a build for an explicit
655 list. See the comments in GHC.Base about the foldr/cons rule, which
656 points out that (foldr k z [a,b,c]) may generate *much* less code than
657 (a `k` b `k` c `k` z).
658
659 Furthermore generating builds messes up the LHS of RULES.
660 Example: the foldr/single rule in GHC.Base
661 foldr k z [x] = ...
662 We do not want to generate a build invocation on the LHS of this RULE!
663
664 We fix this by disabling rules in rule LHSs, and testing that
665 flag here; see Note [Desugaring RULE left hand sides] in Desugar
666
667 To test this I've added a (static) flag -fsimple-list-literals, which
668 makes all list literals be generated via the simple route.
669 -}
670
671 dsExplicitList :: PostTc Id Type -> Maybe (SyntaxExpr Id) -> [LHsExpr Id]
672 -> DsM CoreExpr
673 -- See Note [Desugaring explicit lists]
674 dsExplicitList elt_ty Nothing xs
675 = do { dflags <- getDynFlags
676 ; xs' <- mapM dsLExpr xs
677 ; let (dynamic_prefix, static_suffix) = spanTail is_static xs'
678 ; if gopt Opt_SimpleListLiterals dflags -- -fsimple-list-literals
679 || not (gopt Opt_EnableRewriteRules dflags) -- Rewrite rules off
680 -- Don't generate a build if there are no rules to eliminate it!
681 -- See Note [Desugaring RULE left hand sides] in Desugar
682 || null dynamic_prefix -- Avoid build (\c n. foldr c n xs)!
683 then return $ mkListExpr elt_ty xs'
684 else mkBuildExpr elt_ty (mkSplitExplicitList dynamic_prefix static_suffix) }
685 where
686 is_static :: CoreExpr -> Bool
687 is_static e = all is_static_var (varSetElems (exprFreeVars e))
688
689 is_static_var :: Var -> Bool
690 is_static_var v
691 | isId v = isExternalName (idName v) -- Top-level things are given external names
692 | otherwise = False -- Type variables
693
694 mkSplitExplicitList prefix suffix (c, _) (n, n_ty)
695 = do { let suffix' = mkListExpr elt_ty suffix
696 ; folded_suffix <- mkFoldrExpr elt_ty n_ty (Var c) (Var n) suffix'
697 ; return (foldr (App . App (Var c)) folded_suffix prefix) }
698
699 dsExplicitList elt_ty (Just fln) xs
700 = do { fln' <- dsExpr fln
701 ; list <- dsExplicitList elt_ty Nothing xs
702 ; dflags <- getDynFlags
703 ; return (App (App fln' (mkIntExprInt dflags (length xs))) list) }
704
705 spanTail :: (a -> Bool) -> [a] -> ([a], [a])
706 spanTail f xs = (reverse rejected, reverse satisfying)
707 where (satisfying, rejected) = span f $ reverse xs
708
709 dsArithSeq :: PostTcExpr -> (ArithSeqInfo Id) -> DsM CoreExpr
710 dsArithSeq expr (From from)
711 = App <$> dsExpr expr <*> dsLExpr from
712 dsArithSeq expr (FromTo from to)
713 = do dflags <- getDynFlags
714 warnAboutEmptyEnumerations dflags from Nothing to
715 expr' <- dsExpr expr
716 from' <- dsLExpr from
717 to' <- dsLExpr to
718 return $ mkApps expr' [from', to']
719 dsArithSeq expr (FromThen from thn)
720 = mkApps <$> dsExpr expr <*> mapM dsLExpr [from, thn]
721 dsArithSeq expr (FromThenTo from thn to)
722 = do dflags <- getDynFlags
723 warnAboutEmptyEnumerations dflags from (Just thn) to
724 expr' <- dsExpr expr
725 from' <- dsLExpr from
726 thn' <- dsLExpr thn
727 to' <- dsLExpr to
728 return $ mkApps expr' [from', thn', to']
729
730 {-
731 Desugar 'do' and 'mdo' expressions (NOT list comprehensions, they're
732 handled in DsListComp). Basically does the translation given in the
733 Haskell 98 report:
734 -}
735
736 dsDo :: [ExprLStmt Id] -> DsM CoreExpr
737 dsDo stmts
738 = goL stmts
739 where
740 goL [] = panic "dsDo"
741 goL (L loc stmt:lstmts) = putSrcSpanDs loc (go loc stmt lstmts)
742
743 go _ (LastStmt body _) stmts
744 = ASSERT( null stmts ) dsLExpr body
745 -- The 'return' op isn't used for 'do' expressions
746
747 go _ (BodyStmt rhs then_expr _ _) stmts
748 = do { rhs2 <- dsLExpr rhs
749 ; warnDiscardedDoBindings rhs (exprType rhs2)
750 ; then_expr2 <- dsExpr then_expr
751 ; rest <- goL stmts
752 ; return (mkApps then_expr2 [rhs2, rest]) }
753
754 go _ (LetStmt binds) stmts
755 = do { rest <- goL stmts
756 ; dsLocalBinds binds rest }
757
758 go _ (BindStmt pat rhs bind_op fail_op) stmts
759 = do { body <- goL stmts
760 ; rhs' <- dsLExpr rhs
761 ; bind_op' <- dsExpr bind_op
762 ; var <- selectSimpleMatchVarL pat
763 ; let bind_ty = exprType bind_op' -- rhs -> (pat -> res1) -> res2
764 res1_ty = funResultTy (funArgTy (funResultTy bind_ty))
765 ; match <- matchSinglePat (Var var) (StmtCtxt DoExpr) pat
766 res1_ty (cantFailMatchResult body)
767 ; match_code <- handle_failure pat match fail_op
768 ; return (mkApps bind_op' [rhs', Lam var match_code]) }
769
770 go loc (RecStmt { recS_stmts = rec_stmts, recS_later_ids = later_ids
771 , recS_rec_ids = rec_ids, recS_ret_fn = return_op
772 , recS_mfix_fn = mfix_op, recS_bind_fn = bind_op
773 , recS_rec_rets = rec_rets, recS_ret_ty = body_ty }) stmts
774 = goL (new_bind_stmt : stmts) -- rec_ids can be empty; eg rec { print 'x' }
775 where
776 new_bind_stmt = L loc $ BindStmt (mkBigLHsPatTup later_pats)
777 mfix_app bind_op
778 noSyntaxExpr -- Tuple cannot fail
779
780 tup_ids = rec_ids ++ filterOut (`elem` rec_ids) later_ids
781 tup_ty = mkBigCoreTupTy (map idType tup_ids) -- Deals with singleton case
782 rec_tup_pats = map nlVarPat tup_ids
783 later_pats = rec_tup_pats
784 rets = map noLoc rec_rets
785 mfix_app = nlHsApp (noLoc mfix_op) mfix_arg
786 mfix_arg = noLoc $ HsLam (MG { mg_alts = [mkSimpleMatch [mfix_pat] body]
787 , mg_arg_tys = [tup_ty], mg_res_ty = body_ty
788 , mg_origin = Generated })
789 mfix_pat = noLoc $ LazyPat $ mkBigLHsPatTup rec_tup_pats
790 body = noLoc $ HsDo DoExpr (rec_stmts ++ [ret_stmt]) body_ty
791 ret_app = nlHsApp (noLoc return_op) (mkBigLHsTup rets)
792 ret_stmt = noLoc $ mkLastStmt ret_app
793 -- This LastStmt will be desugared with dsDo,
794 -- which ignores the return_op in the LastStmt,
795 -- so we must apply the return_op explicitly
796
797 go _ (ParStmt {}) _ = panic "dsDo ParStmt"
798 go _ (TransStmt {}) _ = panic "dsDo TransStmt"
799
800 handle_failure :: LPat Id -> MatchResult -> SyntaxExpr Id -> DsM CoreExpr
801 -- In a do expression, pattern-match failure just calls
802 -- the monadic 'fail' rather than throwing an exception
803 handle_failure pat match fail_op
804 | matchCanFail match
805 = do { fail_op' <- dsExpr fail_op
806 ; dflags <- getDynFlags
807 ; fail_msg <- mkStringExpr (mk_fail_msg dflags pat)
808 ; extractMatchResult match (App fail_op' fail_msg) }
809 | otherwise
810 = extractMatchResult match (error "It can't fail")
811
812 mk_fail_msg :: DynFlags -> Located e -> String
813 mk_fail_msg dflags pat = "Pattern match failure in do expression at " ++
814 showPpr dflags (getLoc pat)
815
816 {-
817 ************************************************************************
818 * *
819 \subsection{Errors and contexts}
820 * *
821 ************************************************************************
822 -}
823
824 -- Warn about certain types of values discarded in monadic bindings (#3263)
825 warnDiscardedDoBindings :: LHsExpr Id -> Type -> DsM ()
826 warnDiscardedDoBindings rhs rhs_ty
827 | Just (m_ty, elt_ty) <- tcSplitAppTy_maybe rhs_ty
828 = do { warn_unused <- woptM Opt_WarnUnusedDoBind
829 ; warn_wrong <- woptM Opt_WarnWrongDoBind
830 ; when (warn_unused || warn_wrong) $
831 do { fam_inst_envs <- dsGetFamInstEnvs
832 ; let norm_elt_ty = topNormaliseType fam_inst_envs elt_ty
833
834 -- Warn about discarding non-() things in 'monadic' binding
835 ; if warn_unused && not (isUnitTy norm_elt_ty)
836 then warnDs (badMonadBind rhs elt_ty
837 (ptext (sLit "-fno-warn-unused-do-bind")))
838 else
839
840 -- Warn about discarding m a things in 'monadic' binding of the same type,
841 -- but only if we didn't already warn due to Opt_WarnUnusedDoBind
842 when warn_wrong $
843 do { case tcSplitAppTy_maybe norm_elt_ty of
844 Just (elt_m_ty, _)
845 | m_ty `eqType` topNormaliseType fam_inst_envs elt_m_ty
846 -> warnDs (badMonadBind rhs elt_ty
847 (ptext (sLit "-fno-warn-wrong-do-bind")))
848 _ -> return () } } }
849
850 | otherwise -- RHS does have type of form (m ty), which is weird
851 = return () -- but at lesat this warning is irrelevant
852
853 badMonadBind :: LHsExpr Id -> Type -> SDoc -> SDoc
854 badMonadBind rhs elt_ty flag_doc
855 = vcat [ hang (ptext (sLit "A do-notation statement discarded a result of type"))
856 2 (quotes (ppr elt_ty))
857 , hang (ptext (sLit "Suppress this warning by saying"))
858 2 (quotes $ ptext (sLit "_ <-") <+> ppr rhs)
859 , ptext (sLit "or by using the flag") <+> flag_doc ]