2 % (c) The University of Glasgow 2006
3 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
6 Desugaring exporessions.
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
16 module DsExpr ( dsExpr, dsLExpr, dsLocalBinds, dsValBinds, dsLit ) where
18 #include "HsVersions.h"
32 -- Template Haskell stuff iff bootstrapped
39 -- NB: The desugarer, which straddles the source and Core worlds, sometimes
40 -- needs to see source types
71 %************************************************************************
73 dsLocalBinds, dsValBinds
75 %************************************************************************
78 dsLocalBinds :: HsLocalBinds Id -> CoreExpr -> DsM CoreExpr
79 dsLocalBinds EmptyLocalBinds body = return body
80 dsLocalBinds (HsValBinds binds) body = dsValBinds binds body
81 dsLocalBinds (HsIPBinds binds) body = dsIPBinds binds body
83 -------------------------
84 dsValBinds :: HsValBinds Id -> CoreExpr -> DsM CoreExpr
85 dsValBinds (ValBindsOut binds _) body = foldrM ds_val_bind body binds
87 -------------------------
88 dsIPBinds :: HsIPBinds Id -> CoreExpr -> DsM CoreExpr
89 dsIPBinds (IPBinds ip_binds dict_binds) body
90 = do { prs <- dsLHsBinds dict_binds
91 ; let inner = Let (Rec prs) body
92 -- The dict bindings may not be in
93 -- dependency order; hence Rec
94 ; foldrM ds_ip_bind inner ip_binds }
96 ds_ip_bind (L _ (IPBind n e)) body
98 return (Let (NonRec (ipNameName n) e') body)
100 -------------------------
101 ds_val_bind :: (RecFlag, LHsBinds Id) -> CoreExpr -> DsM CoreExpr
102 -- Special case for bindings which bind unlifted variables
103 -- We need to do a case right away, rather than building
104 -- a tuple and doing selections.
105 -- Silently ignore INLINE and SPECIALISE pragmas...
106 ds_val_bind (NonRecursive, hsbinds) body
107 | [L _ (AbsBinds [] [] exports binds)] <- bagToList hsbinds,
108 (L loc bind : null_binds) <- bagToList binds,
110 || isUnboxedTupleBind bind
111 || or [isUnLiftedType (idType g) | (_, g, _, _) <- exports]
113 body_w_exports = foldr bind_export body exports
114 bind_export (tvs, g, l, _) body = ASSERT( null tvs )
115 bindNonRec g (Var l) body
117 ASSERT (null null_binds)
118 -- Non-recursive, non-overloaded bindings only come in ones
119 -- ToDo: in some bizarre case it's conceivable that there
120 -- could be dict binds in the 'binds'. (See the notes
121 -- below. Then pattern-match would fail. Urk.)
124 FunBind { fun_id = L _ fun, fun_matches = matches, fun_co_fn = co_fn,
125 fun_tick = tick, fun_infix = inf }
126 -> do (args, rhs) <- matchWrapper (FunRhs (idName fun ) inf) matches
127 MASSERT( null args ) -- Functions aren't lifted
128 MASSERT( isIdHsWrapper co_fn )
129 rhs' <- mkOptTickBox tick rhs
130 return (bindNonRec fun rhs' body_w_exports)
132 PatBind {pat_lhs = pat, pat_rhs = grhss, pat_rhs_ty = ty }
133 -> -- let C x# y# = rhs in body
134 -- ==> case rhs of C x# y# -> body
136 do { rhs <- dsGuarded grhss ty
137 ; let upat = unLoc pat
138 eqn = EqnInfo { eqn_pats = [upat],
139 eqn_rhs = cantFailMatchResult body_w_exports }
140 ; var <- selectMatchVar upat
141 ; result <- matchEquations PatBindRhs [var] [eqn] (exprType body)
142 ; return (scrungleMatch var rhs result) }
144 _ -> pprPanic "dsLet: unlifted" (pprLHsBinds hsbinds $$ ppr body)
147 -- Ordinary case for bindings; none should be unlifted
148 ds_val_bind (_is_rec, binds) body
149 = do { prs <- dsLHsBinds binds
150 ; ASSERT( not (any (isUnLiftedType . idType . fst) prs) )
153 _ -> return (Let (Rec prs) body) }
154 -- Use a Rec regardless of is_rec.
155 -- Why? Because it allows the binds to be all
156 -- mixed up, which is what happens in one rare case
157 -- Namely, for an AbsBind with no tyvars and no dicts,
158 -- but which does have dictionary bindings.
159 -- See notes with TcSimplify.inferLoop [NO TYVARS]
160 -- It turned out that wrapping a Rec here was the easiest solution
162 -- NB The previous case dealt with unlifted bindings, so we
163 -- only have to deal with lifted ones now; so Rec is ok
165 isUnboxedTupleBind :: HsBind Id -> Bool
166 isUnboxedTupleBind (PatBind { pat_rhs_ty = ty }) = isUnboxedTupleType ty
167 isUnboxedTupleBind _ = False
169 scrungleMatch :: Id -> CoreExpr -> CoreExpr -> CoreExpr
170 -- Returns something like (let var = scrut in body)
171 -- but if var is an unboxed-tuple type, it inlines it in a fragile way
172 -- Special case to handle unboxed tuple patterns; they can't appear nested
174 -- case e of (# p1, p2 #) -> rhs
176 -- case e of (# x1, x2 #) -> ... match p1, p2 ...
178 -- let x = e in case x of ....
180 -- But there may be a big
181 -- let fail = ... in case e of ...
182 -- wrapping the whole case, which complicates matters slightly
183 -- It all seems a bit fragile. Test is dsrun013.
185 scrungleMatch var scrut body
186 | isUnboxedTupleType (idType var) = scrungle body
187 | otherwise = bindNonRec var scrut body
189 scrungle (Case (Var x) bndr ty alts)
190 | x == var = Case scrut bndr ty alts
191 scrungle (Let binds body) = Let binds (scrungle body)
192 scrungle other = panic ("scrungleMatch: tuple pattern:\n" ++ showSDoc (ppr other))
196 %************************************************************************
198 \subsection[DsExpr-vars-and-cons]{Variables, constructors, literals}
200 %************************************************************************
203 dsLExpr :: LHsExpr Id -> DsM CoreExpr
205 dsLExpr (L loc e) = putSrcSpanDs loc $ dsExpr e
207 dsExpr :: HsExpr Id -> DsM CoreExpr
208 dsExpr (HsPar e) = dsLExpr e
209 dsExpr (ExprWithTySigOut e _) = dsLExpr e
210 dsExpr (HsVar var) = return (Var var)
211 dsExpr (HsIPVar ip) = return (Var (ipNameName ip))
212 dsExpr (HsLit lit) = dsLit lit
213 dsExpr (HsOverLit lit) = dsOverLit lit
214 dsExpr (HsWrap co_fn e) = do { co_fn' <- dsCoercion co_fn
216 ; return (co_fn' e') }
218 dsExpr (NegApp expr neg_expr)
219 = App <$> dsExpr neg_expr <*> dsLExpr expr
221 dsExpr (HsLam a_Match)
222 = uncurry mkLams <$> matchWrapper LambdaExpr a_Match
224 dsExpr (HsApp fun arg)
225 = mkCoreAppDs <$> dsLExpr fun <*> dsLExpr arg
228 Operator sections. At first it looks as if we can convert
237 But no! expr might be a redex, and we can lose laziness badly this
242 for example. So we convert instead to
244 let y = expr in \x -> op y x
246 If \tr{expr} is actually just a variable, say, then the simplifier
250 dsExpr (OpApp e1 op _ e2)
251 = -- for the type of y, we need the type of op's 2nd argument
252 mkCoreAppsDs <$> dsLExpr op <*> mapM dsLExpr [e1, e2]
254 dsExpr (SectionL expr op) -- Desugar (e !) to ((!) e)
255 = mkCoreAppDs <$> dsLExpr op <*> dsLExpr expr
257 -- dsLExpr (SectionR op expr) -- \ x -> op x expr
258 dsExpr (SectionR op expr) = do
259 core_op <- dsLExpr op
260 -- for the type of x, we need the type of op's 2nd argument
261 let (x_ty:y_ty:_, _) = splitFunTys (exprType core_op)
262 -- See comment with SectionL
263 y_core <- dsLExpr expr
264 x_id <- newSysLocalDs x_ty
265 y_id <- newSysLocalDs y_ty
266 return (bindNonRec y_id y_core $
267 Lam x_id (mkCoreAppsDs core_op [Var x_id, Var y_id]))
269 dsExpr (ExplicitTuple tup_args boxity)
270 = do { let go (lam_vars, args) (Missing ty)
271 -- For every missing expression, we need
272 -- another lambda in the desugaring.
273 = do { lam_var <- newSysLocalDs ty
274 ; return (lam_var : lam_vars, Var lam_var : args) }
275 go (lam_vars, args) (Present expr)
276 -- Expressions that are present don't generate
277 -- lambdas, just arguments.
278 = do { core_expr <- dsLExpr expr
279 ; return (lam_vars, core_expr : args) }
281 ; (lam_vars, args) <- foldM go ([], []) (reverse tup_args)
282 -- The reverse is because foldM goes left-to-right
284 ; return $ mkCoreLams lam_vars $
285 mkConApp (tupleCon boxity (length tup_args))
286 (map (Type . exprType) args ++ args) }
288 dsExpr (HsSCC cc expr) = do
289 mod_name <- getModuleDs
290 Note (SCC (mkUserCC cc mod_name)) <$> dsLExpr expr
293 -- hdaume: core annotation
295 dsExpr (HsCoreAnn fs expr)
296 = Note (CoreNote $ unpackFS fs) <$> dsLExpr expr
298 dsExpr (HsCase discrim matches@(MatchGroup _ rhs_ty))
299 | isEmptyMatchGroup matches -- A Core 'case' is always non-empty
300 = -- So desugar empty HsCase to error call
301 mkErrorAppDs pAT_ERROR_ID (funResultTy rhs_ty) (ptext (sLit "case"))
304 = do { core_discrim <- dsLExpr discrim
305 ; ([discrim_var], matching_code) <- matchWrapper CaseAlt matches
306 ; return (scrungleMatch discrim_var core_discrim matching_code) }
308 -- Pepe: The binds are in scope in the body but NOT in the binding group
309 -- This is to avoid silliness in breakpoints
310 dsExpr (HsLet binds body) = do
311 body' <- dsLExpr body
312 dsLocalBinds binds body'
314 -- We need the `ListComp' form to use `deListComp' (rather than the "do" form)
315 -- because the interpretation of `stmts' depends on what sort of thing it is.
317 dsExpr (HsDo ListComp stmts body result_ty)
318 = -- Special case for list comprehensions
319 dsListComp stmts body elt_ty
321 [elt_ty] = tcTyConAppArgs result_ty
323 dsExpr (HsDo DoExpr stmts body result_ty)
324 = dsDo stmts body result_ty
326 dsExpr (HsDo GhciStmt stmts body result_ty)
327 = dsDo stmts body result_ty
329 dsExpr (HsDo (MDoExpr tbl) stmts body result_ty)
330 = dsMDo tbl stmts body result_ty
332 dsExpr (HsDo PArrComp stmts body result_ty)
333 = -- Special case for array comprehensions
334 dsPArrComp (map unLoc stmts) body elt_ty
336 [elt_ty] = tcTyConAppArgs result_ty
338 dsExpr (HsIf guard_expr then_expr else_expr)
339 = mkIfThenElse <$> dsLExpr guard_expr <*> dsLExpr then_expr <*> dsLExpr else_expr
344 \underline{\bf Various data construction things}
345 % ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
347 dsExpr (ExplicitList elt_ty xs)
348 = dsExplicitList elt_ty xs
350 -- We desugar [:x1, ..., xn:] as
351 -- singletonP x1 +:+ ... +:+ singletonP xn
353 dsExpr (ExplicitPArr ty []) = do
354 emptyP <- dsLookupGlobalId emptyPName
355 return (Var emptyP `App` Type ty)
356 dsExpr (ExplicitPArr ty xs) = do
357 singletonP <- dsLookupGlobalId singletonPName
358 appP <- dsLookupGlobalId appPName
359 xs' <- mapM dsLExpr xs
360 return . foldr1 (binary appP) $ map (unary singletonP) xs'
362 unary fn x = mkApps (Var fn) [Type ty, x]
363 binary fn x y = mkApps (Var fn) [Type ty, x, y]
365 dsExpr (ArithSeq expr (From from))
366 = App <$> dsExpr expr <*> dsLExpr from
368 dsExpr (ArithSeq expr (FromTo from to))
369 = mkApps <$> dsExpr expr <*> mapM dsLExpr [from, to]
371 dsExpr (ArithSeq expr (FromThen from thn))
372 = mkApps <$> dsExpr expr <*> mapM dsLExpr [from, thn]
374 dsExpr (ArithSeq expr (FromThenTo from thn to))
375 = mkApps <$> dsExpr expr <*> mapM dsLExpr [from, thn, to]
377 dsExpr (PArrSeq expr (FromTo from to))
378 = mkApps <$> dsExpr expr <*> mapM dsLExpr [from, to]
380 dsExpr (PArrSeq expr (FromThenTo from thn to))
381 = mkApps <$> dsExpr expr <*> mapM dsLExpr [from, thn, to]
384 = panic "DsExpr.dsExpr: Infinite parallel array!"
385 -- the parser shouldn't have generated it and the renamer and typechecker
386 -- shouldn't have let it through
390 \underline{\bf Record construction and update}
391 % ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
392 For record construction we do this (assuming T has three arguments)
396 let err = /\a -> recConErr a
397 T (recConErr t1 "M.lhs/230/op1")
399 (recConErr t1 "M.lhs/230/op3")
401 @recConErr@ then converts its arugment string into a proper message
402 before printing it as
404 M.lhs, line 230: missing field op1 was evaluated
407 We also handle @C{}@ as valid construction syntax for an unlabelled
408 constructor @C@, setting all of @C@'s fields to bottom.
411 dsExpr (RecordCon (L _ data_con_id) con_expr rbinds) = do
412 con_expr' <- dsExpr con_expr
414 (arg_tys, _) = tcSplitFunTys (exprType con_expr')
415 -- A newtype in the corner should be opaque;
416 -- hence TcType.tcSplitFunTys
418 mk_arg (arg_ty, lbl) -- Selector id has the field label as its name
419 = case findField (rec_flds rbinds) lbl of
420 (rhs:rhss) -> ASSERT( null rhss )
422 [] -> mkErrorAppDs rEC_CON_ERROR_ID arg_ty (ppr lbl)
423 unlabelled_bottom arg_ty = mkErrorAppDs rEC_CON_ERROR_ID arg_ty empty
425 labels = dataConFieldLabels (idDataCon data_con_id)
426 -- The data_con_id is guaranteed to be the wrapper id of the constructor
428 con_args <- if null labels
429 then mapM unlabelled_bottom arg_tys
430 else mapM mk_arg (zipEqual "dsExpr:RecordCon" arg_tys labels)
432 return (mkApps con_expr' con_args)
435 Record update is a little harder. Suppose we have the decl:
437 data T = T1 {op1, op2, op3 :: Int}
438 | T2 {op4, op2 :: Int}
441 Then we translate as follows:
447 T1 op1 _ op3 -> T1 op1 op2 op3
448 T2 op4 _ -> T2 op4 op2
449 other -> recUpdError "M.lhs/230"
451 It's important that we use the constructor Ids for @T1@, @T2@ etc on the
452 RHSs, and do not generate a Core constructor application directly, because the constructor
453 might do some argument-evaluation first; and may have to throw away some
456 Note [Update for GADTs]
457 ~~~~~~~~~~~~~~~~~~~~~~~
460 T1 { f1 :: a } :: T a Int
462 Then the wrapper function for T1 has type
464 But if x::T a b, then
465 x { f1 = v } :: T a b (not T a Int!)
466 So we need to cast (T a Int) to (T a b). Sigh.
469 dsExpr expr@(RecordUpd record_expr (HsRecFields { rec_flds = fields })
470 cons_to_upd in_inst_tys out_inst_tys)
472 = dsLExpr record_expr
474 = ASSERT2( notNull cons_to_upd, ppr expr )
476 do { record_expr' <- dsLExpr record_expr
477 ; field_binds' <- mapM ds_field fields
478 ; let upd_fld_env :: NameEnv Id -- Maps field name to the LocalId of the field binding
479 upd_fld_env = mkNameEnv [(f,l) | (f,l,_) <- field_binds']
481 -- It's important to generate the match with matchWrapper,
482 -- and the right hand sides with applications of the wrapper Id
483 -- so that everything works when we are doing fancy unboxing on the
484 -- constructor aguments.
485 ; alts <- mapM (mk_alt upd_fld_env) cons_to_upd
486 ; ([discrim_var], matching_code)
487 <- matchWrapper RecUpd (MatchGroup alts in_out_ty)
489 ; return (add_field_binds field_binds' $
490 bindNonRec discrim_var record_expr' matching_code) }
492 ds_field :: HsRecField Id (LHsExpr Id) -> DsM (Name, Id, CoreExpr)
493 -- Clone the Id in the HsRecField, because its Name is that
494 -- of the record selector, and we must not make that a lcoal binder
495 -- else we shadow other uses of the record selector
496 -- Hence 'lcl_id'. Cf Trac #2735
497 ds_field rec_field = do { rhs <- dsLExpr (hsRecFieldArg rec_field)
498 ; let fld_id = unLoc (hsRecFieldId rec_field)
499 ; lcl_id <- newSysLocalDs (idType fld_id)
500 ; return (idName fld_id, lcl_id, rhs) }
502 add_field_binds [] expr = expr
503 add_field_binds ((_,b,r):bs) expr = bindNonRec b r (add_field_binds bs expr)
505 -- Awkwardly, for families, the match goes
506 -- from instance type to family type
507 tycon = dataConTyCon (head cons_to_upd)
508 in_ty = mkTyConApp tycon in_inst_tys
509 in_out_ty = mkFunTy in_ty (mkFamilyTyConApp tycon out_inst_tys)
511 mk_alt upd_fld_env con
512 = do { let (univ_tvs, ex_tvs, eq_spec,
513 eq_theta, dict_theta, arg_tys, _) = dataConFullSig con
514 subst = mkTopTvSubst (univ_tvs `zip` in_inst_tys)
516 -- I'm not bothering to clone the ex_tvs
517 ; eqs_vars <- mapM newPredVarDs (substTheta subst (eqSpecPreds eq_spec))
518 ; theta_vars <- mapM newPredVarDs (substTheta subst (eq_theta ++ dict_theta))
519 ; arg_ids <- newSysLocalsDs (substTys subst arg_tys)
520 ; let val_args = zipWithEqual "dsExpr:RecordUpd" mk_val_arg
521 (dataConFieldLabels con) arg_ids
522 mk_val_arg field_name pat_arg_id
523 = nlHsVar (lookupNameEnv upd_fld_env field_name `orElse` pat_arg_id)
524 inst_con = noLoc $ HsWrap wrap (HsVar (dataConWrapId con))
525 -- Reconstruct with the WrapId so that unpacking happens
526 wrap = mkWpApps theta_vars `WpCompose`
527 mkWpTyApps (mkTyVarTys ex_tvs) `WpCompose`
528 mkWpTyApps [ty | (tv, ty) <- univ_tvs `zip` out_inst_tys
529 , isNothing (lookupTyVar wrap_subst tv) ]
530 rhs = foldl (\a b -> nlHsApp a b) inst_con val_args
532 -- Tediously wrap the application in a cast
533 -- Note [Update for GADTs]
534 wrapped_rhs | null eq_spec = rhs
535 | otherwise = mkLHsWrap (WpCast wrap_co) rhs
536 wrap_co = mkTyConApp tycon [ lookup tv ty
537 | (tv,ty) <- univ_tvs `zip` out_inst_tys]
538 lookup univ_tv ty = case lookupTyVar wrap_subst univ_tv of
541 wrap_subst = mkTopTvSubst [ (tv,mkSymCoercion (mkTyVarTy co_var))
542 | ((tv,_),co_var) <- eq_spec `zip` eqs_vars ]
544 pat = noLoc $ ConPatOut { pat_con = noLoc con, pat_tvs = ex_tvs
545 , pat_dicts = eqs_vars ++ theta_vars
546 , pat_binds = emptyLHsBinds
547 , pat_args = PrefixCon $ map nlVarPat arg_ids
549 ; return (mkSimpleMatch [pat] wrapped_rhs) }
553 Here is where we desugar the Template Haskell brackets and escapes
556 -- Template Haskell stuff
558 #ifdef GHCI /* Only if bootstrapping */
559 dsExpr (HsBracketOut x ps) = dsBracket x ps
560 dsExpr (HsSpliceE s) = pprPanic "dsExpr:splice" (ppr s)
563 -- Arrow notation extension
564 dsExpr (HsProc pat cmd) = dsProcExpr pat cmd
570 dsExpr (HsTick ix vars e) = do
574 -- There is a problem here. The then and else branches
575 -- have no free variables, so they are open to lifting.
576 -- We need someway of stopping this.
577 -- This will make no difference to binary coverage
578 -- (did you go here: YES or NO), but will effect accurate
581 dsExpr (HsBinTick ixT ixF e) = do
583 do { ASSERT(exprType e2 `coreEqType` boolTy)
584 mkBinaryTickBox ixT ixF e2
590 -- HsSyn constructs that just shouldn't be here:
591 dsExpr (ExprWithTySig _ _) = panic "dsExpr:ExprWithTySig"
594 findField :: [HsRecField Id arg] -> Name -> [arg]
596 = [rhs | HsRecField { hsRecFieldId = id, hsRecFieldArg = rhs } <- rbinds
597 , lbl == idName (unLoc id) ]
600 %--------------------------------------------------------------------
602 Note [Desugaring explicit lists]
603 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
604 Explicit lists are desugared in a cleverer way to prevent some
605 fruitless allocations. Essentially, whenever we see a list literal
608 1. Find the tail of the list that can be allocated statically (say
609 [x_k, ..., x_n]) by later stages and ensure we desugar that
610 normally: this makes sure that we don't cause a code size increase
611 by having the cons in that expression fused (see later) and hence
612 being unable to statically allocate any more
614 2. For the prefix of the list which cannot be allocated statically,
615 say [x_1, ..., x_(k-1)], we turn it into an expression involving
616 build so that if we find any foldrs over it it will fuse away
619 So in this example we will desugar to:
620 build (\c n -> x_1 `c` x_2 `c` .... `c` foldr c n [x_k, ..., x_n]
622 If fusion fails to occur then build will get inlined and (since we
623 defined a RULE for foldr (:) []) we will get back exactly the
624 normal desugaring for an explicit list.
626 This optimisation can be worth a lot: up to 25% of the total
627 allocation in some nofib programs. Specifically
629 Program Size Allocs Runtime CompTime
630 rewrite +0.0% -26.3% 0.02 -1.8%
631 ansi -0.3% -13.8% 0.00 +0.0%
632 lift +0.0% -8.7% 0.00 -2.3%
634 Of course, if rules aren't turned on then there is pretty much no
635 point doing this fancy stuff, and it may even be harmful.
637 =======> Note by SLPJ Dec 08.
639 I'm unconvinced that we should *ever* generate a build for an explicit
640 list. See the comments in GHC.Base about the foldr/cons rule, which
641 points out that (foldr k z [a,b,c]) may generate *much* less code than
642 (a `k` b `k` c `k` z).
644 Furthermore generating builds messes up the LHS of RULES.
645 Example: the foldr/single rule in GHC.Base
647 We do not want to generate a build invocation on the LHS of this RULE!
649 We fix this by disabling rules in rule LHSs, and testing that
650 flag here; see Note [Desugaring RULE left hand sides] in Desugar
652 To test this I've added a (static) flag -fsimple-list-literals, which
653 makes all list literals be generated via the simple route.
657 dsExplicitList :: PostTcType -> [LHsExpr Id] -> DsM CoreExpr
658 -- See Note [Desugaring explicit lists]
659 dsExplicitList elt_ty xs
660 = do { dflags <- getDOptsDs
661 ; xs' <- mapM dsLExpr xs
662 ; let (dynamic_prefix, static_suffix) = spanTail is_static xs'
663 ; if opt_SimpleListLiterals -- -fsimple-list-literals
664 || not (dopt Opt_EnableRewriteRules dflags) -- Rewrite rules off
665 -- Don't generate a build if there are no rules to eliminate it!
666 -- See Note [Desugaring RULE left hand sides] in Desugar
667 || null dynamic_prefix -- Avoid build (\c n. foldr c n xs)!
668 then return $ mkListExpr elt_ty xs'
669 else mkBuildExpr elt_ty (mkSplitExplicitList dynamic_prefix static_suffix) }
671 is_static :: CoreExpr -> Bool
672 is_static e = all is_static_var (varSetElems (exprFreeVars e))
674 is_static_var :: Var -> Bool
676 | isId v = isExternalName (idName v) -- Top-level things are given external names
677 | otherwise = False -- Type variables
679 mkSplitExplicitList prefix suffix (c, _) (n, n_ty)
680 = do { let suffix' = mkListExpr elt_ty suffix
681 ; folded_suffix <- mkFoldrExpr elt_ty n_ty (Var c) (Var n) suffix'
682 ; return (foldr (App . App (Var c)) folded_suffix prefix) }
684 spanTail :: (a -> Bool) -> [a] -> ([a], [a])
685 spanTail f xs = (reverse rejected, reverse satisfying)
686 where (satisfying, rejected) = span f $ reverse xs
689 Desugar 'do' and 'mdo' expressions (NOT list comprehensions, they're
690 handled in DsListComp). Basically does the translation given in the
696 -> Type -- Type of the whole expression
699 dsDo stmts body result_ty
702 -- result_ty must be of the form (m b)
703 (m_ty, _b_ty) = tcSplitAppTy result_ty
705 goL [] = dsLExpr body
706 goL ((L loc stmt):lstmts) = putSrcSpanDs loc (go loc stmt lstmts)
708 go _ (ExprStmt rhs then_expr _) stmts
709 = do { rhs2 <- dsLExpr rhs
710 ; case tcSplitAppTy_maybe (exprType rhs2) of
711 Just (container_ty, returning_ty) -> warnDiscardedDoBindings rhs container_ty returning_ty
713 ; then_expr2 <- dsExpr then_expr
715 ; return (mkApps then_expr2 [rhs2, rest]) }
717 go _ (LetStmt binds) stmts
718 = do { rest <- goL stmts
719 ; dsLocalBinds binds rest }
721 go _ (BindStmt pat rhs bind_op fail_op) stmts
722 = do { body <- goL stmts
723 ; rhs' <- dsLExpr rhs
724 ; bind_op' <- dsExpr bind_op
725 ; var <- selectSimpleMatchVarL pat
726 ; let bind_ty = exprType bind_op' -- rhs -> (pat -> res1) -> res2
727 res1_ty = funResultTy (funArgTy (funResultTy bind_ty))
728 ; match <- matchSinglePat (Var var) (StmtCtxt DoExpr) pat
729 res1_ty (cantFailMatchResult body)
730 ; match_code <- handle_failure pat match fail_op
731 ; return (mkApps bind_op' [rhs', Lam var match_code]) }
733 go loc (RecStmt { recS_stmts = rec_stmts, recS_later_ids = later_ids
734 , recS_rec_ids = rec_ids, recS_ret_fn = return_op
735 , recS_mfix_fn = mfix_op, recS_bind_fn = bind_op
736 , recS_rec_rets = rec_rets, recS_dicts = binds }) stmts
737 = ASSERT( length rec_ids > 0 )
738 goL (new_bind_stmt : let_stmt : stmts)
740 -- returnE <- dsExpr return_id
741 -- mfixE <- dsExpr mfix_id
742 new_bind_stmt = L loc $ BindStmt (mkLHsPatTup later_pats) mfix_app
744 noSyntaxExpr -- Tuple cannot fail
746 let_stmt = L loc $ LetStmt (HsValBinds (ValBindsOut [(Recursive, binds)] []))
748 tup_ids = rec_ids ++ filterOut (`elem` rec_ids) later_ids
749 rec_tup_pats = map nlVarPat tup_ids
750 later_pats = rec_tup_pats
751 rets = map noLoc rec_rets
753 mfix_app = nlHsApp (noLoc mfix_op) mfix_arg
754 mfix_arg = noLoc $ HsLam (MatchGroup [mkSimpleMatch [mfix_pat] body]
755 (mkFunTy tup_ty body_ty))
756 mfix_pat = noLoc $ LazyPat $ mkLHsPatTup rec_tup_pats
757 body = noLoc $ HsDo DoExpr rec_stmts return_app body_ty
758 return_app = nlHsApp (noLoc return_op) (mkLHsTupleExpr rets)
759 body_ty = mkAppTy m_ty tup_ty
760 tup_ty = mkBoxedTupleTy (map idType tup_ids) -- Deals with singleton case
762 -- In a do expression, pattern-match failure just calls
763 -- the monadic 'fail' rather than throwing an exception
764 handle_failure pat match fail_op
766 = do { fail_op' <- dsExpr fail_op
767 ; fail_msg <- mkStringExpr (mk_fail_msg pat)
768 ; extractMatchResult match (App fail_op' fail_msg) }
770 = extractMatchResult match (error "It can't fail")
772 mk_fail_msg :: Located e -> String
773 mk_fail_msg pat = "Pattern match failure in do expression at " ++
774 showSDoc (ppr (getLoc pat))
777 Translation for RecStmt's:
778 -----------------------------
779 We turn (RecStmt [v1,..vn] stmts) into:
781 (v1,..,vn) <- mfix (\~(v1,..vn). do stmts
788 -> Type -- Type of the whole expression
791 dsMDo tbl stmts body result_ty
794 goL [] = dsLExpr body
795 goL ((L loc stmt):lstmts) = putSrcSpanDs loc (go loc stmt lstmts)
797 (m_ty, b_ty) = tcSplitAppTy result_ty -- result_ty must be of the form (m b)
798 mfix_id = lookupEvidence tbl mfixName
799 return_id = lookupEvidence tbl returnMName
800 bind_id = lookupEvidence tbl bindMName
801 then_id = lookupEvidence tbl thenMName
802 fail_id = lookupEvidence tbl failMName
805 go _ (LetStmt binds) stmts
806 = do { rest <- goL stmts
807 ; dsLocalBinds binds rest }
809 go _ (ExprStmt rhs _ rhs_ty) stmts
810 = do { rhs2 <- dsLExpr rhs
811 ; warnDiscardedDoBindings rhs m_ty rhs_ty
813 ; return (mkApps (Var then_id) [Type rhs_ty, Type b_ty, rhs2, rest]) }
815 go _ (BindStmt pat rhs _ _) stmts
816 = do { body <- goL stmts
817 ; var <- selectSimpleMatchVarL pat
818 ; match <- matchSinglePat (Var var) (StmtCtxt ctxt) pat
819 result_ty (cantFailMatchResult body)
820 ; fail_msg <- mkStringExpr (mk_fail_msg pat)
821 ; let fail_expr = mkApps (Var fail_id) [Type b_ty, fail_msg]
822 ; match_code <- extractMatchResult match fail_expr
824 ; rhs' <- dsLExpr rhs
825 ; return (mkApps (Var bind_id) [Type (hsLPatType pat), Type b_ty,
826 rhs', Lam var match_code]) }
828 go loc (RecStmt rec_stmts later_ids rec_ids _ _ _ rec_rets binds) stmts
829 = ASSERT( length rec_ids > 0 )
830 ASSERT( length rec_ids == length rec_rets )
831 pprTrace "dsMDo" (ppr later_ids) $
832 goL (new_bind_stmt : let_stmt : stmts)
834 new_bind_stmt = L loc $ mkBindStmt (mk_tup_pat later_pats) mfix_app
835 let_stmt = L loc $ LetStmt (HsValBinds (ValBindsOut [(Recursive, binds)] []))
838 -- Remove the later_ids that appear (without fancy coercions)
839 -- in rec_rets, because there's no need to knot-tie them separately
840 -- See Note [RecStmt] in HsExpr
841 later_ids' = filter (`notElem` mono_rec_ids) later_ids
842 mono_rec_ids = [ id | HsVar id <- rec_rets ]
844 mfix_app = nlHsApp (nlHsTyApp mfix_id [tup_ty]) mfix_arg
845 mfix_arg = noLoc $ HsLam (MatchGroup [mkSimpleMatch [mfix_pat] body]
846 (mkFunTy tup_ty body_ty))
848 -- The rec_tup_pat must bind the rec_ids only; remember that the
849 -- trimmed_laters may share the same Names
850 -- Meanwhile, the later_pats must bind the later_vars
851 rec_tup_pats = map mk_wild_pat later_ids' ++ map nlVarPat rec_ids
852 later_pats = map nlVarPat later_ids' ++ map mk_later_pat rec_ids
853 rets = map nlHsVar later_ids' ++ map noLoc rec_rets
855 mfix_pat = noLoc $ LazyPat $ mk_tup_pat rec_tup_pats
856 body = noLoc $ HsDo ctxt rec_stmts return_app body_ty
857 body_ty = mkAppTy m_ty tup_ty
858 tup_ty = mkBoxedTupleTy (map idType (later_ids' ++ rec_ids)) -- Deals with singleton case
860 return_app = nlHsApp (nlHsTyApp return_id [tup_ty])
861 (mkLHsTupleExpr rets)
863 mk_wild_pat :: Id -> LPat Id
864 mk_wild_pat v = noLoc $ WildPat $ idType v
866 mk_later_pat :: Id -> LPat Id
867 mk_later_pat v | v `elem` later_ids' = mk_wild_pat v
868 | otherwise = nlVarPat v
870 mk_tup_pat :: [LPat Id] -> LPat Id
872 mk_tup_pat ps = noLoc $ mkVanillaTuplePat ps Boxed
876 %************************************************************************
878 \subsection{Errors and contexts}
880 %************************************************************************
883 -- Warn about certain types of values discarded in monadic bindings (#3263)
884 warnDiscardedDoBindings :: LHsExpr Id -> Type -> Type -> DsM ()
885 warnDiscardedDoBindings rhs container_ty returning_ty = do {
886 -- Warn about discarding non-() things in 'monadic' binding
887 ; warn_unused <- doptDs Opt_WarnUnusedDoBind
888 ; if warn_unused && not (returning_ty `tcEqType` unitTy)
889 then warnDs (unusedMonadBind rhs returning_ty)
891 -- Warn about discarding m a things in 'monadic' binding of the same type,
892 -- but only if we didn't already warn due to Opt_WarnUnusedDoBind
893 ; warn_wrong <- doptDs Opt_WarnWrongDoBind
894 ; case tcSplitAppTy_maybe returning_ty of
895 Just (returning_container_ty, _) -> when (warn_wrong && container_ty `tcEqType` returning_container_ty) $
896 warnDs (wrongMonadBind rhs returning_ty)
899 unusedMonadBind :: LHsExpr Id -> Type -> SDoc
900 unusedMonadBind rhs returning_ty
901 = ptext (sLit "A do-notation statement discarded a result of type") <+> ppr returning_ty <> dot $$
902 ptext (sLit "Suppress this warning by saying \"_ <- ") <> ppr rhs <> ptext (sLit "\",") $$
903 ptext (sLit "or by using the flag -fno-warn-unused-do-bind")
905 wrongMonadBind :: LHsExpr Id -> Type -> SDoc
906 wrongMonadBind rhs returning_ty
907 = ptext (sLit "A do-notation statement discarded a result of type") <+> ppr returning_ty <> dot $$
908 ptext (sLit "Suppress this warning by saying \"_ <- ") <> ppr rhs <> ptext (sLit "\",") $$
909 ptext (sLit "or by using the flag -fno-warn-wrong-do-bind")