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
62 %************************************************************************
64 dsLocalBinds, dsValBinds
66 %************************************************************************
69 dsLocalBinds :: HsLocalBinds Id -> CoreExpr -> DsM CoreExpr
70 dsLocalBinds EmptyLocalBinds body = return body
71 dsLocalBinds (HsValBinds binds) body = dsValBinds binds body
72 dsLocalBinds (HsIPBinds binds) body = dsIPBinds binds body
74 -------------------------
75 dsValBinds :: HsValBinds Id -> CoreExpr -> DsM CoreExpr
76 dsValBinds (ValBindsOut binds _) body = foldrM ds_val_bind body binds
78 -------------------------
79 dsIPBinds :: HsIPBinds Id -> CoreExpr -> DsM CoreExpr
80 dsIPBinds (IPBinds ip_binds dict_binds) body
81 = do { prs <- dsLHsBinds dict_binds
82 ; let inner = Let (Rec prs) body
83 -- The dict bindings may not be in
84 -- dependency order; hence Rec
85 ; foldrM ds_ip_bind inner ip_binds }
87 ds_ip_bind (L _ (IPBind n e)) body
89 return (Let (NonRec (ipNameName n) e') body)
91 -------------------------
92 ds_val_bind :: (RecFlag, LHsBinds Id) -> CoreExpr -> DsM CoreExpr
93 -- Special case for bindings which bind unlifted variables
94 -- We need to do a case right away, rather than building
95 -- a tuple and doing selections.
96 -- Silently ignore INLINE and SPECIALISE pragmas...
97 ds_val_bind (NonRecursive, hsbinds) body
98 | [L _ (AbsBinds [] [] exports binds)] <- bagToList hsbinds,
99 (L loc bind : null_binds) <- bagToList binds,
101 || isUnboxedTupleBind bind
102 || or [isUnLiftedType (idType g) | (_, g, _, _) <- exports]
104 body_w_exports = foldr bind_export body exports
105 bind_export (tvs, g, l, _) body = ASSERT( null tvs )
106 bindNonRec g (Var l) body
108 ASSERT (null null_binds)
109 -- Non-recursive, non-overloaded bindings only come in ones
110 -- ToDo: in some bizarre case it's conceivable that there
111 -- could be dict binds in the 'binds'. (See the notes
112 -- below. Then pattern-match would fail. Urk.)
115 FunBind { fun_id = L _ fun, fun_matches = matches, fun_co_fn = co_fn,
116 fun_tick = tick, fun_infix = inf }
117 -> do (args, rhs) <- matchWrapper (FunRhs (idName fun ) inf) matches
118 MASSERT( null args ) -- Functions aren't lifted
119 MASSERT( isIdHsWrapper co_fn )
120 rhs' <- mkOptTickBox tick rhs
121 return (bindNonRec fun rhs' body_w_exports)
123 PatBind {pat_lhs = pat, pat_rhs = grhss, pat_rhs_ty = ty }
124 -> -- let C x# y# = rhs in body
125 -- ==> case rhs of C x# y# -> body
127 do { rhs <- dsGuarded grhss ty
128 ; let upat = unLoc pat
129 eqn = EqnInfo { eqn_pats = [upat],
130 eqn_rhs = cantFailMatchResult body_w_exports }
131 ; var <- selectMatchVar upat
132 ; result <- matchEquations PatBindRhs [var] [eqn] (exprType body)
133 ; return (scrungleMatch var rhs result) }
135 _ -> pprPanic "dsLet: unlifted" (pprLHsBinds hsbinds $$ ppr body)
138 -- Ordinary case for bindings; none should be unlifted
139 ds_val_bind (_is_rec, binds) body
140 = do { prs <- dsLHsBinds binds
141 ; ASSERT( not (any (isUnLiftedType . idType . fst) prs) )
144 _ -> return (Let (Rec prs) body) }
145 -- Use a Rec regardless of is_rec.
146 -- Why? Because it allows the binds to be all
147 -- mixed up, which is what happens in one rare case
148 -- Namely, for an AbsBind with no tyvars and no dicts,
149 -- but which does have dictionary bindings.
150 -- See notes with TcSimplify.inferLoop [NO TYVARS]
151 -- It turned out that wrapping a Rec here was the easiest solution
153 -- NB The previous case dealt with unlifted bindings, so we
154 -- only have to deal with lifted ones now; so Rec is ok
156 isUnboxedTupleBind :: HsBind Id -> Bool
157 isUnboxedTupleBind (PatBind { pat_rhs_ty = ty }) = isUnboxedTupleType ty
158 isUnboxedTupleBind _ = False
160 scrungleMatch :: Id -> CoreExpr -> CoreExpr -> CoreExpr
161 -- Returns something like (let var = scrut in body)
162 -- but if var is an unboxed-tuple type, it inlines it in a fragile way
163 -- Special case to handle unboxed tuple patterns; they can't appear nested
165 -- case e of (# p1, p2 #) -> rhs
167 -- case e of (# x1, x2 #) -> ... match p1, p2 ...
169 -- let x = e in case x of ....
171 -- But there may be a big
172 -- let fail = ... in case e of ...
173 -- wrapping the whole case, which complicates matters slightly
174 -- It all seems a bit fragile. Test is dsrun013.
176 scrungleMatch var scrut body
177 | isUnboxedTupleType (idType var) = scrungle body
178 | otherwise = bindNonRec var scrut body
180 scrungle (Case (Var x) bndr ty alts)
181 | x == var = Case scrut bndr ty alts
182 scrungle (Let binds body) = Let binds (scrungle body)
183 scrungle other = panic ("scrungleMatch: tuple pattern:\n" ++ showSDoc (ppr other))
187 %************************************************************************
189 \subsection[DsExpr-vars-and-cons]{Variables, constructors, literals}
191 %************************************************************************
194 dsLExpr :: LHsExpr Id -> DsM CoreExpr
196 dsLExpr (L loc e) = putSrcSpanDs loc $ dsExpr e
198 dsExpr :: HsExpr Id -> DsM CoreExpr
199 dsExpr (HsPar e) = dsLExpr e
200 dsExpr (ExprWithTySigOut e _) = dsLExpr e
201 dsExpr (HsVar var) = return (Var var)
202 dsExpr (HsIPVar ip) = return (Var (ipNameName ip))
203 dsExpr (HsLit lit) = dsLit lit
204 dsExpr (HsOverLit lit) = dsOverLit lit
205 dsExpr (HsWrap co_fn e) = dsCoercion co_fn (dsExpr e)
207 dsExpr (NegApp expr neg_expr)
208 = App <$> dsExpr neg_expr <*> dsLExpr expr
210 dsExpr (HsLam a_Match)
211 = uncurry mkLams <$> matchWrapper LambdaExpr a_Match
213 dsExpr (HsApp fun arg)
214 = mkDsApp <$> dsLExpr fun <*> dsLExpr arg
217 Operator sections. At first it looks as if we can convert
226 But no! expr might be a redex, and we can lose laziness badly this
231 for example. So we convert instead to
233 let y = expr in \x -> op y x
235 If \tr{expr} is actually just a variable, say, then the simplifier
239 dsExpr (OpApp e1 op _ e2)
240 = -- for the type of y, we need the type of op's 2nd argument
241 mkDsApps <$> dsLExpr op <*> mapM dsLExpr [e1, e2]
243 dsExpr (SectionL expr op) -- Desugar (e !) to ((!) e)
244 = mkDsApp <$> dsLExpr op <*> dsLExpr expr
246 -- dsLExpr (SectionR op expr) -- \ x -> op x expr
247 dsExpr (SectionR op expr) = do
248 core_op <- dsLExpr op
249 -- for the type of x, we need the type of op's 2nd argument
250 let (x_ty:y_ty:_, _) = splitFunTys (exprType core_op)
251 -- See comment with SectionL
252 y_core <- dsLExpr expr
253 x_id <- newSysLocalDs x_ty
254 y_id <- newSysLocalDs y_ty
255 return (bindNonRec y_id y_core $
256 Lam x_id (mkDsApps core_op [Var x_id, Var y_id]))
258 dsExpr (HsSCC cc expr) = do
259 mod_name <- getModuleDs
260 Note (SCC (mkUserCC cc mod_name)) <$> dsLExpr expr
263 -- hdaume: core annotation
265 dsExpr (HsCoreAnn fs expr)
266 = Note (CoreNote $ unpackFS fs) <$> dsLExpr expr
268 dsExpr (HsCase discrim matches) = do
269 core_discrim <- dsLExpr discrim
270 ([discrim_var], matching_code) <- matchWrapper CaseAlt matches
271 return (scrungleMatch discrim_var core_discrim matching_code)
273 -- Pepe: The binds are in scope in the body but NOT in the binding group
274 -- This is to avoid silliness in breakpoints
275 dsExpr (HsLet binds body) = do
276 body' <- dsLExpr body
277 dsLocalBinds binds body'
279 -- We need the `ListComp' form to use `deListComp' (rather than the "do" form)
280 -- because the interpretation of `stmts' depends on what sort of thing it is.
282 dsExpr (HsDo ListComp stmts body result_ty)
283 = -- Special case for list comprehensions
284 dsListComp stmts body elt_ty
286 [elt_ty] = tcTyConAppArgs result_ty
288 dsExpr (HsDo DoExpr stmts body result_ty)
289 = dsDo stmts body result_ty
291 dsExpr (HsDo (MDoExpr tbl) stmts body result_ty)
292 = dsMDo tbl stmts body result_ty
294 dsExpr (HsDo PArrComp stmts body result_ty)
295 = -- Special case for array comprehensions
296 dsPArrComp (map unLoc stmts) body elt_ty
298 [elt_ty] = tcTyConAppArgs result_ty
300 dsExpr (HsIf guard_expr then_expr else_expr)
301 = mkIfThenElse <$> dsLExpr guard_expr <*> dsLExpr then_expr <*> dsLExpr else_expr
306 \underline{\bf Various data construction things}
307 % ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
309 dsExpr (ExplicitList elt_ty xs)
310 = dsExplicitList elt_ty xs
312 -- we create a list from the array elements and convert them into a list using
315 -- * the main disadvantage to this scheme is that `toP' traverses the list
316 -- twice: once to determine the length and a second time to put to elements
317 -- into the array; this inefficiency could be avoided by exposing some of
318 -- the innards of `PrelPArr' to the compiler (ie, have a `PrelPArrBase') so
319 -- that we can exploit the fact that we already know the length of the array
320 -- here at compile time
322 dsExpr (ExplicitPArr ty xs) = do
323 toP <- dsLookupGlobalId toPName
324 coreList <- dsExpr (ExplicitList ty xs)
325 return (mkApps (Var toP) [Type ty, coreList])
327 dsExpr (ExplicitTuple expr_list boxity) = do
328 core_exprs <- mapM dsLExpr expr_list
329 return (mkConApp (tupleCon boxity (length expr_list))
330 (map (Type . exprType) core_exprs ++ core_exprs))
332 dsExpr (ArithSeq expr (From from))
333 = App <$> dsExpr expr <*> dsLExpr from
335 dsExpr (ArithSeq expr (FromTo from to))
336 = mkApps <$> dsExpr expr <*> mapM dsLExpr [from, to]
338 dsExpr (ArithSeq expr (FromThen from thn))
339 = mkApps <$> dsExpr expr <*> mapM dsLExpr [from, thn]
341 dsExpr (ArithSeq expr (FromThenTo from thn to))
342 = mkApps <$> dsExpr expr <*> mapM dsLExpr [from, thn, to]
344 dsExpr (PArrSeq expr (FromTo from to))
345 = mkApps <$> dsExpr expr <*> mapM dsLExpr [from, to]
347 dsExpr (PArrSeq expr (FromThenTo from thn to))
348 = mkApps <$> dsExpr expr <*> mapM dsLExpr [from, thn, to]
351 = panic "DsExpr.dsExpr: Infinite parallel array!"
352 -- the parser shouldn't have generated it and the renamer and typechecker
353 -- shouldn't have let it through
357 \underline{\bf Record construction and update}
358 % ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
359 For record construction we do this (assuming T has three arguments)
363 let err = /\a -> recConErr a
364 T (recConErr t1 "M.lhs/230/op1")
366 (recConErr t1 "M.lhs/230/op3")
368 @recConErr@ then converts its arugment string into a proper message
369 before printing it as
371 M.lhs, line 230: missing field op1 was evaluated
374 We also handle @C{}@ as valid construction syntax for an unlabelled
375 constructor @C@, setting all of @C@'s fields to bottom.
378 dsExpr (RecordCon (L _ data_con_id) con_expr rbinds) = do
379 con_expr' <- dsExpr con_expr
381 (arg_tys, _) = tcSplitFunTys (exprType con_expr')
382 -- A newtype in the corner should be opaque;
383 -- hence TcType.tcSplitFunTys
385 mk_arg (arg_ty, lbl) -- Selector id has the field label as its name
386 = case findField (rec_flds rbinds) lbl of
387 (rhs:rhss) -> ASSERT( null rhss )
389 [] -> mkErrorAppDs rEC_CON_ERROR_ID arg_ty (showSDoc (ppr lbl))
390 unlabelled_bottom arg_ty = mkErrorAppDs rEC_CON_ERROR_ID arg_ty ""
392 labels = dataConFieldLabels (idDataCon data_con_id)
393 -- The data_con_id is guaranteed to be the wrapper id of the constructor
395 con_args <- if null labels
396 then mapM unlabelled_bottom arg_tys
397 else mapM mk_arg (zipEqual "dsExpr:RecordCon" arg_tys labels)
399 return (mkApps con_expr' con_args)
402 Record update is a little harder. Suppose we have the decl:
404 data T = T1 {op1, op2, op3 :: Int}
405 | T2 {op4, op2 :: Int}
408 Then we translate as follows:
414 T1 op1 _ op3 -> T1 op1 op2 op3
415 T2 op4 _ -> T2 op4 op2
416 other -> recUpdError "M.lhs/230"
418 It's important that we use the constructor Ids for @T1@, @T2@ etc on the
419 RHSs, and do not generate a Core constructor application directly, because the constructor
420 might do some argument-evaluation first; and may have to throw away some
424 dsExpr expr@(RecordUpd record_expr (HsRecFields { rec_flds = fields })
425 cons_to_upd in_inst_tys out_inst_tys)
427 = dsLExpr record_expr
429 = -- Record stuff doesn't work for existentials
430 -- The type checker checks for this, but we need
431 -- worry only about the constructors that are to be updated
432 ASSERT2( notNull cons_to_upd && all isVanillaDataCon cons_to_upd, ppr expr )
434 do { record_expr' <- dsLExpr record_expr
435 ; let -- Awkwardly, for families, the match goes
436 -- from instance type to family type
437 tycon = dataConTyCon (head cons_to_upd)
438 in_ty = mkTyConApp tycon in_inst_tys
439 in_out_ty = mkFunTy in_ty
440 (mkFamilyTyConApp tycon out_inst_tys)
442 mk_val_arg field old_arg_id
443 = case findField fields field of
444 (rhs:rest) -> ASSERT(null rest) rhs
445 [] -> nlHsVar old_arg_id
448 = ASSERT( isVanillaDataCon con )
449 do { arg_ids <- newSysLocalsDs (dataConInstOrigArgTys con in_inst_tys)
450 -- This call to dataConInstOrigArgTys won't work for existentials
451 -- but existentials don't have record types anyway
452 ; let val_args = zipWithEqual "dsExpr:RecordUpd" mk_val_arg
453 (dataConFieldLabels con) arg_ids
454 rhs = foldl (\a b -> nlHsApp a b)
455 (nlHsTyApp (dataConWrapId con) out_inst_tys)
457 pat = mkPrefixConPat con (map nlVarPat arg_ids) in_ty
459 ; return (mkSimpleMatch [pat] rhs) }
461 -- It's important to generate the match with matchWrapper,
462 -- and the right hand sides with applications of the wrapper Id
463 -- so that everything works when we are doing fancy unboxing on the
464 -- constructor aguments.
465 ; alts <- mapM mk_alt cons_to_upd
466 ; ([discrim_var], matching_code) <- matchWrapper RecUpd (MatchGroup alts in_out_ty)
468 ; return (bindNonRec discrim_var record_expr' matching_code) }
471 Here is where we desugar the Template Haskell brackets and escapes
474 -- Template Haskell stuff
476 #ifdef GHCI /* Only if bootstrapping */
477 dsExpr (HsBracketOut x ps) = dsBracket x ps
478 dsExpr (HsSpliceE s) = pprPanic "dsExpr:splice" (ppr s)
481 -- Arrow notation extension
482 dsExpr (HsProc pat cmd) = dsProcExpr pat cmd
488 dsExpr (HsTick ix vars e) = do
492 -- There is a problem here. The then and else branches
493 -- have no free variables, so they are open to lifting.
494 -- We need someway of stopping this.
495 -- This will make no difference to binary coverage
496 -- (did you go here: YES or NO), but will effect accurate
499 dsExpr (HsBinTick ixT ixF e) = do
501 do { ASSERT(exprType e2 `coreEqType` boolTy)
502 mkBinaryTickBox ixT ixF e2
508 -- HsSyn constructs that just shouldn't be here:
509 dsExpr (ExprWithTySig _ _) = panic "dsExpr:ExprWithTySig"
512 findField :: [HsRecField Id arg] -> Name -> [arg]
514 = [rhs | HsRecField { hsRecFieldId = id, hsRecFieldArg = rhs } <- rbinds
515 , lbl == idName (unLoc id) ]
518 %--------------------------------------------------------------------
520 Note [Desugaring explicit lists]
521 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
522 Explicit lists are desugared in a cleverer way to prevent some
523 fruitless allocations. Essentially, whenever we see a list literal
526 1. Find the tail of the list that can be allocated statically (say
527 [x_k, ..., x_n]) by later stages and ensure we desugar that
528 normally: this makes sure that we don't cause a code size increase
529 by having the cons in that expression fused (see later) and hence
530 being unable to statically allocate any more
532 2. For the prefix of the list which cannot be allocated statically,
533 say [x_1, ..., x_(k-1)], we turn it into an expression involving
534 build so that if we find any foldrs over it it will fuse away
537 So in this example we will desugar to:
538 build (\c n -> x_1 `c` x_2 `c` .... `c` foldr c n [x_k, ..., x_n]
540 If fusion fails to occur then build will get inlined and (since we
541 defined a RULE for foldr (:) []) we will get back exactly the
542 normal desugaring for an explicit list.
544 This optimisation can be worth a lot: up to 25% of the total
545 allocation in some nofib programs. Specifically
547 Program Size Allocs Runtime CompTime
548 rewrite +0.0% -26.3% 0.02 -1.8%
549 ansi -0.3% -13.8% 0.00 +0.0%
550 lift +0.0% -8.7% 0.00 -2.3%
552 Of course, if rules aren't turned on then there is pretty much no
553 point doing this fancy stuff, and it may even be harmful.
556 dsExplicitList :: PostTcType -> [LHsExpr Id] -> DsM CoreExpr
557 -- See Note [Desugaring explicit lists]
558 dsExplicitList elt_ty xs = do
560 xs' <- mapM dsLExpr xs
561 if not (dopt Opt_RewriteRules dflags)
562 then return $ mkListExpr elt_ty xs'
563 else mkBuildExpr elt_ty (mkSplitExplicitList (thisPackage dflags) xs')
565 mkSplitExplicitList this_package xs' (c, _) (n, n_ty) = do
566 let (dynamic_prefix, static_suffix) = spanTail (rhsIsStatic this_package) xs'
567 static_suffix' = mkListExpr elt_ty static_suffix
569 folded_static_suffix <- mkFoldrExpr elt_ty n_ty (Var c) (Var n) static_suffix'
570 let build_body = foldr (App . App (Var c)) folded_static_suffix dynamic_prefix
573 spanTail :: (a -> Bool) -> [a] -> ([a], [a])
574 spanTail f xs = (reverse rejected, reverse satisfying)
575 where (satisfying, rejected) = span f $ reverse xs
578 Desugar 'do' and 'mdo' expressions (NOT list comprehensions, they're
579 handled in DsListComp). Basically does the translation given in the
585 -> Type -- Type of the whole expression
588 dsDo stmts body _result_ty
589 = go (map unLoc stmts)
593 go (ExprStmt rhs then_expr _ : stmts)
594 = do { rhs2 <- dsLExpr rhs
595 ; then_expr2 <- dsExpr then_expr
597 ; return (mkApps then_expr2 [rhs2, rest]) }
599 go (LetStmt binds : stmts)
600 = do { rest <- go stmts
601 ; dsLocalBinds binds rest }
603 go (BindStmt pat rhs bind_op fail_op : stmts)
605 do { body <- go stmts
606 ; rhs' <- dsLExpr rhs
607 ; bind_op' <- dsExpr bind_op
608 ; var <- selectSimpleMatchVarL pat
609 ; let bind_ty = exprType bind_op' -- rhs -> (pat -> res1) -> res2
610 res1_ty = funResultTy (funArgTy (funResultTy bind_ty))
611 ; match <- matchSinglePat (Var var) (StmtCtxt DoExpr) pat
612 res1_ty (cantFailMatchResult body)
613 ; match_code <- handle_failure pat match fail_op
614 ; return (mkApps bind_op' [rhs', Lam var match_code]) }
616 -- In a do expression, pattern-match failure just calls
617 -- the monadic 'fail' rather than throwing an exception
618 handle_failure pat match fail_op
620 = do { fail_op' <- dsExpr fail_op
621 ; fail_msg <- mkStringExpr (mk_fail_msg pat)
622 ; extractMatchResult match (App fail_op' fail_msg) }
624 = extractMatchResult match (error "It can't fail")
626 mk_fail_msg :: Located e -> String
627 mk_fail_msg pat = "Pattern match failure in do expression at " ++
628 showSDoc (ppr (getLoc pat))
631 Translation for RecStmt's:
632 -----------------------------
633 We turn (RecStmt [v1,..vn] stmts) into:
635 (v1,..,vn) <- mfix (\~(v1,..vn). do stmts
642 -> Type -- Type of the whole expression
645 dsMDo tbl stmts body result_ty
646 = go (map unLoc stmts)
648 (m_ty, b_ty) = tcSplitAppTy result_ty -- result_ty must be of the form (m b)
649 mfix_id = lookupEvidence tbl mfixName
650 return_id = lookupEvidence tbl returnMName
651 bind_id = lookupEvidence tbl bindMName
652 then_id = lookupEvidence tbl thenMName
653 fail_id = lookupEvidence tbl failMName
658 go (LetStmt binds : stmts)
659 = do { rest <- go stmts
660 ; dsLocalBinds binds rest }
662 go (ExprStmt rhs _ rhs_ty : stmts)
663 = do { rhs2 <- dsLExpr rhs
665 ; return (mkApps (Var then_id) [Type rhs_ty, Type b_ty, rhs2, rest]) }
667 go (BindStmt pat rhs _ _ : stmts)
668 = do { body <- go stmts
669 ; var <- selectSimpleMatchVarL pat
670 ; match <- matchSinglePat (Var var) (StmtCtxt ctxt) pat
671 result_ty (cantFailMatchResult body)
672 ; fail_msg <- mkStringExpr (mk_fail_msg pat)
673 ; let fail_expr = mkApps (Var fail_id) [Type b_ty, fail_msg]
674 ; match_code <- extractMatchResult match fail_expr
676 ; rhs' <- dsLExpr rhs
677 ; return (mkApps (Var bind_id) [Type (hsLPatType pat), Type b_ty,
678 rhs', Lam var match_code]) }
680 go (RecStmt rec_stmts later_ids rec_ids rec_rets binds : stmts)
681 = ASSERT( length rec_ids > 0 )
682 ASSERT( length rec_ids == length rec_rets )
683 go (new_bind_stmt : let_stmt : stmts)
685 new_bind_stmt = mkBindStmt (mk_tup_pat later_pats) mfix_app
686 let_stmt = LetStmt (HsValBinds (ValBindsOut [(Recursive, binds)] []))
689 -- Remove the later_ids that appear (without fancy coercions)
690 -- in rec_rets, because there's no need to knot-tie them separately
691 -- See Note [RecStmt] in HsExpr
692 later_ids' = filter (`notElem` mono_rec_ids) later_ids
693 mono_rec_ids = [ id | HsVar id <- rec_rets ]
695 mfix_app = nlHsApp (nlHsTyApp mfix_id [tup_ty]) mfix_arg
696 mfix_arg = noLoc $ HsLam (MatchGroup [mkSimpleMatch [mfix_pat] body]
697 (mkFunTy tup_ty body_ty))
699 -- The rec_tup_pat must bind the rec_ids only; remember that the
700 -- trimmed_laters may share the same Names
701 -- Meanwhile, the later_pats must bind the later_vars
702 rec_tup_pats = map mk_wild_pat later_ids' ++ map nlVarPat rec_ids
703 later_pats = map nlVarPat later_ids' ++ map mk_later_pat rec_ids
704 rets = map nlHsVar later_ids' ++ map noLoc rec_rets
706 mfix_pat = noLoc $ LazyPat $ mk_tup_pat rec_tup_pats
707 body = noLoc $ HsDo ctxt rec_stmts return_app body_ty
708 body_ty = mkAppTy m_ty tup_ty
709 tup_ty = mkCoreTupTy (map idType (later_ids' ++ rec_ids))
710 -- mkCoreTupTy deals with singleton case
712 return_app = nlHsApp (nlHsTyApp return_id [tup_ty])
715 mk_wild_pat :: Id -> LPat Id
716 mk_wild_pat v = noLoc $ WildPat $ idType v
718 mk_later_pat :: Id -> LPat Id
719 mk_later_pat v | v `elem` later_ids' = mk_wild_pat v
720 | otherwise = nlVarPat v
722 mk_tup_pat :: [LPat Id] -> LPat Id
724 mk_tup_pat ps = noLoc $ mkVanillaTuplePat ps Boxed
726 mk_ret_tup :: [LHsExpr Id] -> LHsExpr Id
728 mk_ret_tup rs = noLoc $ ExplicitTuple rs Boxed