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
68 %************************************************************************
70 dsLocalBinds, dsValBinds
72 %************************************************************************
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
80 -------------------------
81 dsValBinds :: HsValBinds Id -> CoreExpr -> DsM CoreExpr
82 dsValBinds (ValBindsOut binds _) body = foldrM ds_val_bind body binds
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 }
93 ds_ip_bind (L _ (IPBind n e)) body
95 return (Let (NonRec (ipNameName n) e') body)
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,
107 || isUnboxedTupleBind bind
108 || or [isUnLiftedType (idType g) | (_, g, _, _) <- exports]
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
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.)
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)
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
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) }
141 _ -> pprPanic "dsLet: unlifted" (pprLHsBinds hsbinds $$ ppr body)
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) )
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
159 -- NB The previous case dealt with unlifted bindings, so we
160 -- only have to deal with lifted ones now; so Rec is ok
162 isUnboxedTupleBind :: HsBind Id -> Bool
163 isUnboxedTupleBind (PatBind { pat_rhs_ty = ty }) = isUnboxedTupleType ty
164 isUnboxedTupleBind _ = False
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
171 -- case e of (# p1, p2 #) -> rhs
173 -- case e of (# x1, x2 #) -> ... match p1, p2 ...
175 -- let x = e in case x of ....
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.
182 scrungleMatch var scrut body
183 | isUnboxedTupleType (idType var) = scrungle body
184 | otherwise = bindNonRec var scrut body
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))
193 %************************************************************************
195 \subsection[DsExpr-vars-and-cons]{Variables, constructors, literals}
197 %************************************************************************
200 dsLExpr :: LHsExpr Id -> DsM CoreExpr
202 dsLExpr (L loc e) = putSrcSpanDs loc $ dsExpr e
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)
213 dsExpr (NegApp expr neg_expr)
214 = App <$> dsExpr neg_expr <*> dsLExpr expr
216 dsExpr (HsLam a_Match)
217 = uncurry mkLams <$> matchWrapper LambdaExpr a_Match
219 dsExpr (HsApp fun arg)
220 = mkCoreAppDs <$> dsLExpr fun <*> dsLExpr arg
223 Operator sections. At first it looks as if we can convert
232 But no! expr might be a redex, and we can lose laziness badly this
237 for example. So we convert instead to
239 let y = expr in \x -> op y x
241 If \tr{expr} is actually just a variable, say, then the simplifier
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]
249 dsExpr (SectionL expr op) -- Desugar (e !) to ((!) e)
250 = mkCoreAppDs <$> dsLExpr op <*> dsLExpr expr
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]))
264 dsExpr (ExplicitTuple tup_args boxity)
265 = do { let go (lam_vars, args) (Missing ty)
266 -- For every missing expression, we need
267 -- another lambda in the desugaring.
268 = do { lam_var <- newSysLocalDs ty
269 ; return (lam_var : lam_vars, Var lam_var : args) }
270 go (lam_vars, args) (Present expr)
271 -- Expressions that are present don't generate
272 -- lambdas, just arguments.
273 = do { core_expr <- dsLExpr expr
274 ; return (lam_vars, core_expr : args) }
276 ; (lam_vars, args) <- foldM go ([], []) (reverse tup_args)
277 -- The reverse is because foldM goes left-to-right
279 ; return $ mkCoreLams lam_vars $
280 mkConApp (tupleCon boxity (length tup_args))
281 (map (Type . exprType) args ++ args) }
283 dsExpr (HsSCC cc expr) = do
284 mod_name <- getModuleDs
285 Note (SCC (mkUserCC cc mod_name)) <$> dsLExpr expr
288 -- hdaume: core annotation
290 dsExpr (HsCoreAnn fs expr)
291 = Note (CoreNote $ unpackFS fs) <$> dsLExpr expr
293 dsExpr (HsCase discrim matches@(MatchGroup _ rhs_ty))
294 | isEmptyMatchGroup matches -- A Core 'case' is always non-empty
295 = -- So desugar empty HsCase to error call
296 mkErrorAppDs pAT_ERROR_ID (funResultTy rhs_ty) (ptext (sLit "case"))
299 = do { core_discrim <- dsLExpr discrim
300 ; ([discrim_var], matching_code) <- matchWrapper CaseAlt matches
301 ; return (scrungleMatch discrim_var core_discrim matching_code) }
303 -- Pepe: The binds are in scope in the body but NOT in the binding group
304 -- This is to avoid silliness in breakpoints
305 dsExpr (HsLet binds body) = do
306 body' <- dsLExpr body
307 dsLocalBinds binds body'
309 -- We need the `ListComp' form to use `deListComp' (rather than the "do" form)
310 -- because the interpretation of `stmts' depends on what sort of thing it is.
312 dsExpr (HsDo ListComp stmts body result_ty)
313 = -- Special case for list comprehensions
314 dsListComp stmts body elt_ty
316 [elt_ty] = tcTyConAppArgs result_ty
318 dsExpr (HsDo DoExpr stmts body result_ty)
319 = dsDo stmts body result_ty
321 dsExpr (HsDo (MDoExpr tbl) stmts body result_ty)
322 = dsMDo tbl stmts body result_ty
324 dsExpr (HsDo PArrComp stmts body result_ty)
325 = -- Special case for array comprehensions
326 dsPArrComp (map unLoc stmts) body elt_ty
328 [elt_ty] = tcTyConAppArgs result_ty
330 dsExpr (HsIf guard_expr then_expr else_expr)
331 = mkIfThenElse <$> dsLExpr guard_expr <*> dsLExpr then_expr <*> dsLExpr else_expr
336 \underline{\bf Various data construction things}
337 % ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
339 dsExpr (ExplicitList elt_ty xs)
340 = dsExplicitList elt_ty xs
342 -- We desugar [:x1, ..., xn:] as
343 -- singletonP x1 +:+ ... +:+ singletonP xn
345 dsExpr (ExplicitPArr ty []) = do
346 emptyP <- dsLookupGlobalId emptyPName
347 return (Var emptyP `App` Type ty)
348 dsExpr (ExplicitPArr ty xs) = do
349 singletonP <- dsLookupGlobalId singletonPName
350 appP <- dsLookupGlobalId appPName
351 xs' <- mapM dsLExpr xs
352 return . foldr1 (binary appP) $ map (unary singletonP) xs'
354 unary fn x = mkApps (Var fn) [Type ty, x]
355 binary fn x y = mkApps (Var fn) [Type ty, x, y]
357 dsExpr (ArithSeq expr (From from))
358 = App <$> dsExpr expr <*> dsLExpr from
360 dsExpr (ArithSeq expr (FromTo from to))
361 = mkApps <$> dsExpr expr <*> mapM dsLExpr [from, to]
363 dsExpr (ArithSeq expr (FromThen from thn))
364 = mkApps <$> dsExpr expr <*> mapM dsLExpr [from, thn]
366 dsExpr (ArithSeq expr (FromThenTo from thn to))
367 = mkApps <$> dsExpr expr <*> mapM dsLExpr [from, thn, to]
369 dsExpr (PArrSeq expr (FromTo from to))
370 = mkApps <$> dsExpr expr <*> mapM dsLExpr [from, to]
372 dsExpr (PArrSeq expr (FromThenTo from thn to))
373 = mkApps <$> dsExpr expr <*> mapM dsLExpr [from, thn, to]
376 = panic "DsExpr.dsExpr: Infinite parallel array!"
377 -- the parser shouldn't have generated it and the renamer and typechecker
378 -- shouldn't have let it through
382 \underline{\bf Record construction and update}
383 % ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
384 For record construction we do this (assuming T has three arguments)
388 let err = /\a -> recConErr a
389 T (recConErr t1 "M.lhs/230/op1")
391 (recConErr t1 "M.lhs/230/op3")
393 @recConErr@ then converts its arugment string into a proper message
394 before printing it as
396 M.lhs, line 230: missing field op1 was evaluated
399 We also handle @C{}@ as valid construction syntax for an unlabelled
400 constructor @C@, setting all of @C@'s fields to bottom.
403 dsExpr (RecordCon (L _ data_con_id) con_expr rbinds) = do
404 con_expr' <- dsExpr con_expr
406 (arg_tys, _) = tcSplitFunTys (exprType con_expr')
407 -- A newtype in the corner should be opaque;
408 -- hence TcType.tcSplitFunTys
410 mk_arg (arg_ty, lbl) -- Selector id has the field label as its name
411 = case findField (rec_flds rbinds) lbl of
412 (rhs:rhss) -> ASSERT( null rhss )
414 [] -> mkErrorAppDs rEC_CON_ERROR_ID arg_ty (ppr lbl)
415 unlabelled_bottom arg_ty = mkErrorAppDs rEC_CON_ERROR_ID arg_ty empty
417 labels = dataConFieldLabels (idDataCon data_con_id)
418 -- The data_con_id is guaranteed to be the wrapper id of the constructor
420 con_args <- if null labels
421 then mapM unlabelled_bottom arg_tys
422 else mapM mk_arg (zipEqual "dsExpr:RecordCon" arg_tys labels)
424 return (mkApps con_expr' con_args)
427 Record update is a little harder. Suppose we have the decl:
429 data T = T1 {op1, op2, op3 :: Int}
430 | T2 {op4, op2 :: Int}
433 Then we translate as follows:
439 T1 op1 _ op3 -> T1 op1 op2 op3
440 T2 op4 _ -> T2 op4 op2
441 other -> recUpdError "M.lhs/230"
443 It's important that we use the constructor Ids for @T1@, @T2@ etc on the
444 RHSs, and do not generate a Core constructor application directly, because the constructor
445 might do some argument-evaluation first; and may have to throw away some
448 Note [Update for GADTs]
449 ~~~~~~~~~~~~~~~~~~~~~~~
452 T1 { f1 :: a } :: T a Int
454 Then the wrapper function for T1 has type
456 But if x::T a b, then
457 x { f1 = v } :: T a b (not T a Int!)
458 So we need to cast (T a Int) to (T a b). Sigh.
461 dsExpr expr@(RecordUpd record_expr (HsRecFields { rec_flds = fields })
462 cons_to_upd in_inst_tys out_inst_tys)
464 = dsLExpr record_expr
466 = ASSERT2( notNull cons_to_upd, ppr expr )
468 do { record_expr' <- dsLExpr record_expr
469 ; field_binds' <- mapM ds_field fields
470 ; let upd_fld_env :: NameEnv Id -- Maps field name to the LocalId of the field binding
471 upd_fld_env = mkNameEnv [(f,l) | (f,l,_) <- field_binds']
473 -- It's important to generate the match with matchWrapper,
474 -- and the right hand sides with applications of the wrapper Id
475 -- so that everything works when we are doing fancy unboxing on the
476 -- constructor aguments.
477 ; alts <- mapM (mk_alt upd_fld_env) cons_to_upd
478 ; ([discrim_var], matching_code)
479 <- matchWrapper RecUpd (MatchGroup alts in_out_ty)
481 ; return (add_field_binds field_binds' $
482 bindNonRec discrim_var record_expr' matching_code) }
484 ds_field :: HsRecField Id (LHsExpr Id) -> DsM (Name, Id, CoreExpr)
485 -- Clone the Id in the HsRecField, because its Name is that
486 -- of the record selector, and we must not make that a lcoal binder
487 -- else we shadow other uses of the record selector
488 -- Hence 'lcl_id'. Cf Trac #2735
489 ds_field rec_field = do { rhs <- dsLExpr (hsRecFieldArg rec_field)
490 ; let fld_id = unLoc (hsRecFieldId rec_field)
491 ; lcl_id <- newSysLocalDs (idType fld_id)
492 ; return (idName fld_id, lcl_id, rhs) }
494 add_field_binds [] expr = expr
495 add_field_binds ((_,b,r):bs) expr = bindNonRec b r (add_field_binds bs expr)
497 -- Awkwardly, for families, the match goes
498 -- from instance type to family type
499 tycon = dataConTyCon (head cons_to_upd)
500 in_ty = mkTyConApp tycon in_inst_tys
501 in_out_ty = mkFunTy in_ty (mkFamilyTyConApp tycon out_inst_tys)
503 mk_alt upd_fld_env con
504 = do { let (univ_tvs, ex_tvs, eq_spec,
505 eq_theta, dict_theta, arg_tys, _) = dataConFullSig con
506 subst = mkTopTvSubst (univ_tvs `zip` in_inst_tys)
508 -- I'm not bothering to clone the ex_tvs
509 ; eqs_vars <- mapM newPredVarDs (substTheta subst (eqSpecPreds eq_spec))
510 ; theta_vars <- mapM newPredVarDs (substTheta subst (eq_theta ++ dict_theta))
511 ; arg_ids <- newSysLocalsDs (substTys subst arg_tys)
512 ; let val_args = zipWithEqual "dsExpr:RecordUpd" mk_val_arg
513 (dataConFieldLabels con) arg_ids
514 mk_val_arg field_name pat_arg_id
515 = nlHsVar (lookupNameEnv upd_fld_env field_name `orElse` pat_arg_id)
516 inst_con = noLoc $ HsWrap wrap (HsVar (dataConWrapId con))
517 -- Reconstruct with the WrapId so that unpacking happens
518 wrap = mkWpApps theta_vars `WpCompose`
519 mkWpTyApps (mkTyVarTys ex_tvs) `WpCompose`
520 mkWpTyApps [ty | (tv, ty) <- univ_tvs `zip` out_inst_tys
521 , isNothing (lookupTyVar wrap_subst tv) ]
522 rhs = foldl (\a b -> nlHsApp a b) inst_con val_args
524 -- Tediously wrap the application in a cast
525 -- Note [Update for GADTs]
526 wrapped_rhs | null eq_spec = rhs
527 | otherwise = mkLHsWrap (WpCast wrap_co) rhs
528 wrap_co = mkTyConApp tycon [ lookup tv ty
529 | (tv,ty) <- univ_tvs `zip` out_inst_tys]
530 lookup univ_tv ty = case lookupTyVar wrap_subst univ_tv of
533 wrap_subst = mkTopTvSubst [ (tv,mkSymCoercion (mkTyVarTy co_var))
534 | ((tv,_),co_var) <- eq_spec `zip` eqs_vars ]
536 pat = noLoc $ ConPatOut { pat_con = noLoc con, pat_tvs = ex_tvs
537 , pat_dicts = eqs_vars ++ theta_vars
538 , pat_binds = emptyLHsBinds
539 , pat_args = PrefixCon $ map nlVarPat arg_ids
541 ; return (mkSimpleMatch [pat] wrapped_rhs) }
545 Here is where we desugar the Template Haskell brackets and escapes
548 -- Template Haskell stuff
550 #ifdef GHCI /* Only if bootstrapping */
551 dsExpr (HsBracketOut x ps) = dsBracket x ps
552 dsExpr (HsSpliceE s) = pprPanic "dsExpr:splice" (ppr s)
555 -- Arrow notation extension
556 dsExpr (HsProc pat cmd) = dsProcExpr pat cmd
562 dsExpr (HsTick ix vars e) = do
566 -- There is a problem here. The then and else branches
567 -- have no free variables, so they are open to lifting.
568 -- We need someway of stopping this.
569 -- This will make no difference to binary coverage
570 -- (did you go here: YES or NO), but will effect accurate
573 dsExpr (HsBinTick ixT ixF e) = do
575 do { ASSERT(exprType e2 `coreEqType` boolTy)
576 mkBinaryTickBox ixT ixF e2
582 -- HsSyn constructs that just shouldn't be here:
583 dsExpr (ExprWithTySig _ _) = panic "dsExpr:ExprWithTySig"
586 findField :: [HsRecField Id arg] -> Name -> [arg]
588 = [rhs | HsRecField { hsRecFieldId = id, hsRecFieldArg = rhs } <- rbinds
589 , lbl == idName (unLoc id) ]
592 %--------------------------------------------------------------------
594 Note [Desugaring explicit lists]
595 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
596 Explicit lists are desugared in a cleverer way to prevent some
597 fruitless allocations. Essentially, whenever we see a list literal
600 1. Find the tail of the list that can be allocated statically (say
601 [x_k, ..., x_n]) by later stages and ensure we desugar that
602 normally: this makes sure that we don't cause a code size increase
603 by having the cons in that expression fused (see later) and hence
604 being unable to statically allocate any more
606 2. For the prefix of the list which cannot be allocated statically,
607 say [x_1, ..., x_(k-1)], we turn it into an expression involving
608 build so that if we find any foldrs over it it will fuse away
611 So in this example we will desugar to:
612 build (\c n -> x_1 `c` x_2 `c` .... `c` foldr c n [x_k, ..., x_n]
614 If fusion fails to occur then build will get inlined and (since we
615 defined a RULE for foldr (:) []) we will get back exactly the
616 normal desugaring for an explicit list.
618 This optimisation can be worth a lot: up to 25% of the total
619 allocation in some nofib programs. Specifically
621 Program Size Allocs Runtime CompTime
622 rewrite +0.0% -26.3% 0.02 -1.8%
623 ansi -0.3% -13.8% 0.00 +0.0%
624 lift +0.0% -8.7% 0.00 -2.3%
626 Of course, if rules aren't turned on then there is pretty much no
627 point doing this fancy stuff, and it may even be harmful.
629 =======> Note by SLPJ Dec 08.
631 I'm unconvinced that we should *ever* generate a build for an explicit
632 list. See the comments in GHC.Base about the foldr/cons rule, which
633 points out that (foldr k z [a,b,c]) may generate *much* less code than
634 (a `k` b `k` c `k` z).
636 Furthermore generating builds messes up the LHS of RULES.
637 Example: the foldr/single rule in GHC.Base
639 We do not want to generate a build invocation on the LHS of this RULE!
641 To test this I've added a (static) flag -fsimple-list-literals, which
642 makes all list literals be generated via the simple route.
647 dsExplicitList :: PostTcType -> [LHsExpr Id] -> DsM CoreExpr
648 -- See Note [Desugaring explicit lists]
649 dsExplicitList elt_ty xs = do
651 xs' <- mapM dsLExpr xs
652 if opt_SimpleListLiterals || not (dopt Opt_EnableRewriteRules dflags)
653 then return $ mkListExpr elt_ty xs'
654 else mkBuildExpr elt_ty (mkSplitExplicitList (thisPackage dflags) xs')
656 mkSplitExplicitList this_package xs' (c, _) (n, n_ty) = do
657 let (dynamic_prefix, static_suffix) = spanTail (rhsIsStatic this_package) xs'
658 static_suffix' = mkListExpr elt_ty static_suffix
660 folded_static_suffix <- mkFoldrExpr elt_ty n_ty (Var c) (Var n) static_suffix'
661 let build_body = foldr (App . App (Var c)) folded_static_suffix dynamic_prefix
664 spanTail :: (a -> Bool) -> [a] -> ([a], [a])
665 spanTail f xs = (reverse rejected, reverse satisfying)
666 where (satisfying, rejected) = span f $ reverse xs
669 Desugar 'do' and 'mdo' expressions (NOT list comprehensions, they're
670 handled in DsListComp). Basically does the translation given in the
676 -> Type -- Type of the whole expression
679 dsDo stmts body _result_ty
682 goL [] = dsLExpr body
683 goL ((L loc stmt):lstmts) = putSrcSpanDs loc (go stmt lstmts)
685 go (ExprStmt rhs then_expr _) stmts
686 = do { rhs2 <- dsLExpr rhs
687 ; case tcSplitAppTy_maybe (exprType rhs2) of
688 Just (container_ty, returning_ty) -> warnDiscardedDoBindings rhs container_ty returning_ty
690 ; then_expr2 <- dsExpr then_expr
692 ; return (mkApps then_expr2 [rhs2, rest]) }
694 go (LetStmt binds) stmts
695 = do { rest <- goL stmts
696 ; dsLocalBinds binds rest }
698 go (BindStmt pat rhs bind_op fail_op) stmts
700 do { body <- goL stmts
701 ; rhs' <- dsLExpr rhs
702 ; bind_op' <- dsExpr bind_op
703 ; var <- selectSimpleMatchVarL pat
704 ; let bind_ty = exprType bind_op' -- rhs -> (pat -> res1) -> res2
705 res1_ty = funResultTy (funArgTy (funResultTy bind_ty))
706 ; match <- matchSinglePat (Var var) (StmtCtxt DoExpr) pat
707 res1_ty (cantFailMatchResult body)
708 ; match_code <- handle_failure pat match fail_op
709 ; return (mkApps bind_op' [rhs', Lam var match_code]) }
711 -- In a do expression, pattern-match failure just calls
712 -- the monadic 'fail' rather than throwing an exception
713 handle_failure pat match fail_op
715 = do { fail_op' <- dsExpr fail_op
716 ; fail_msg <- mkStringExpr (mk_fail_msg pat)
717 ; extractMatchResult match (App fail_op' fail_msg) }
719 = extractMatchResult match (error "It can't fail")
721 mk_fail_msg :: Located e -> String
722 mk_fail_msg pat = "Pattern match failure in do expression at " ++
723 showSDoc (ppr (getLoc pat))
726 Translation for RecStmt's:
727 -----------------------------
728 We turn (RecStmt [v1,..vn] stmts) into:
730 (v1,..,vn) <- mfix (\~(v1,..vn). do stmts
737 -> Type -- Type of the whole expression
740 dsMDo tbl stmts body result_ty
743 goL [] = dsLExpr body
744 goL ((L loc stmt):lstmts) = putSrcSpanDs loc (go loc stmt lstmts)
746 (m_ty, b_ty) = tcSplitAppTy result_ty -- result_ty must be of the form (m b)
747 mfix_id = lookupEvidence tbl mfixName
748 return_id = lookupEvidence tbl returnMName
749 bind_id = lookupEvidence tbl bindMName
750 then_id = lookupEvidence tbl thenMName
751 fail_id = lookupEvidence tbl failMName
754 go _ (LetStmt binds) stmts
755 = do { rest <- goL stmts
756 ; dsLocalBinds binds rest }
758 go _ (ExprStmt rhs _ rhs_ty) stmts
759 = do { rhs2 <- dsLExpr rhs
760 ; warnDiscardedDoBindings rhs m_ty rhs_ty
762 ; return (mkApps (Var then_id) [Type rhs_ty, Type b_ty, rhs2, rest]) }
764 go _ (BindStmt pat rhs _ _) stmts
765 = do { body <- goL stmts
766 ; var <- selectSimpleMatchVarL pat
767 ; match <- matchSinglePat (Var var) (StmtCtxt ctxt) pat
768 result_ty (cantFailMatchResult body)
769 ; fail_msg <- mkStringExpr (mk_fail_msg pat)
770 ; let fail_expr = mkApps (Var fail_id) [Type b_ty, fail_msg]
771 ; match_code <- extractMatchResult match fail_expr
773 ; rhs' <- dsLExpr rhs
774 ; return (mkApps (Var bind_id) [Type (hsLPatType pat), Type b_ty,
775 rhs', Lam var match_code]) }
777 go loc (RecStmt rec_stmts later_ids rec_ids rec_rets binds) stmts
778 = ASSERT( length rec_ids > 0 )
779 ASSERT( length rec_ids == length rec_rets )
780 goL (new_bind_stmt : let_stmt : stmts)
782 new_bind_stmt = L loc $ mkBindStmt (mk_tup_pat later_pats) mfix_app
783 let_stmt = L loc $ LetStmt (HsValBinds (ValBindsOut [(Recursive, binds)] []))
786 -- Remove the later_ids that appear (without fancy coercions)
787 -- in rec_rets, because there's no need to knot-tie them separately
788 -- See Note [RecStmt] in HsExpr
789 later_ids' = filter (`notElem` mono_rec_ids) later_ids
790 mono_rec_ids = [ id | HsVar id <- rec_rets ]
792 mfix_app = nlHsApp (nlHsTyApp mfix_id [tup_ty]) mfix_arg
793 mfix_arg = noLoc $ HsLam (MatchGroup [mkSimpleMatch [mfix_pat] body]
794 (mkFunTy tup_ty body_ty))
796 -- The rec_tup_pat must bind the rec_ids only; remember that the
797 -- trimmed_laters may share the same Names
798 -- Meanwhile, the later_pats must bind the later_vars
799 rec_tup_pats = map mk_wild_pat later_ids' ++ map nlVarPat rec_ids
800 later_pats = map nlVarPat later_ids' ++ map mk_later_pat rec_ids
801 rets = map nlHsVar later_ids' ++ map noLoc rec_rets
803 mfix_pat = noLoc $ LazyPat $ mk_tup_pat rec_tup_pats
804 body = noLoc $ HsDo ctxt rec_stmts return_app body_ty
805 body_ty = mkAppTy m_ty tup_ty
806 tup_ty = mkCoreTupTy (map idType (later_ids' ++ rec_ids))
807 -- mkCoreTupTy deals with singleton case
809 return_app = nlHsApp (nlHsTyApp return_id [tup_ty])
810 (mkLHsTupleExpr rets)
812 mk_wild_pat :: Id -> LPat Id
813 mk_wild_pat v = noLoc $ WildPat $ idType v
815 mk_later_pat :: Id -> LPat Id
816 mk_later_pat v | v `elem` later_ids' = mk_wild_pat v
817 | otherwise = nlVarPat v
819 mk_tup_pat :: [LPat Id] -> LPat Id
821 mk_tup_pat ps = noLoc $ mkVanillaTuplePat ps Boxed
825 %************************************************************************
827 \subsection{Errors and contexts}
829 %************************************************************************
832 -- Warn about certain types of values discarded in monadic bindings (#3263)
833 warnDiscardedDoBindings :: LHsExpr Id -> Type -> Type -> DsM ()
834 warnDiscardedDoBindings rhs container_ty returning_ty = do {
835 -- Warn about discarding non-() things in 'monadic' binding
836 ; warn_unused <- doptDs Opt_WarnUnusedDoBind
837 ; if warn_unused && not (returning_ty `tcEqType` unitTy)
838 then warnDs (unusedMonadBind rhs returning_ty)
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 ; warn_wrong <- doptDs Opt_WarnWrongDoBind
843 ; case tcSplitAppTy_maybe returning_ty of
844 Just (returning_container_ty, _) -> when (warn_wrong && container_ty `tcEqType` returning_container_ty) $
845 warnDs (wrongMonadBind rhs returning_ty)
848 unusedMonadBind :: LHsExpr Id -> Type -> SDoc
849 unusedMonadBind rhs returning_ty
850 = ptext (sLit "A do-notation statement discarded a result of type") <+> ppr returning_ty <> dot $$
851 ptext (sLit "Suppress this warning by saying \"_ <- ") <> ppr rhs <> ptext (sLit "\",") $$
852 ptext (sLit "or by using the flag -fno-warn-unused-do-bind")
854 wrongMonadBind :: LHsExpr Id -> Type -> SDoc
855 wrongMonadBind rhs returning_ty
856 = ptext (sLit "A do-notation statement discarded a result of type") <+> ppr returning_ty <> dot $$
857 ptext (sLit "Suppress this warning by saying \"_ <- ") <> ppr rhs <> ptext (sLit "\",") $$
858 ptext (sLit "or by using the flag -fno-warn-wrong-do-bind")