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