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
63 %************************************************************************
65 dsLocalBinds, dsValBinds
67 %************************************************************************
70 dsLocalBinds :: HsLocalBinds Id -> CoreExpr -> DsM CoreExpr
71 dsLocalBinds EmptyLocalBinds body = return body
72 dsLocalBinds (HsValBinds binds) body = dsValBinds binds body
73 dsLocalBinds (HsIPBinds binds) body = dsIPBinds binds body
75 -------------------------
76 dsValBinds :: HsValBinds Id -> CoreExpr -> DsM CoreExpr
77 dsValBinds (ValBindsOut binds _) body = foldrM ds_val_bind body binds
79 -------------------------
80 dsIPBinds :: HsIPBinds Id -> CoreExpr -> DsM CoreExpr
81 dsIPBinds (IPBinds ip_binds dict_binds) body
82 = do { prs <- dsLHsBinds dict_binds
83 ; let inner = Let (Rec prs) body
84 -- The dict bindings may not be in
85 -- dependency order; hence Rec
86 ; foldrM ds_ip_bind inner ip_binds }
88 ds_ip_bind (L _ (IPBind n e)) body
90 return (Let (NonRec (ipNameName n) e') body)
92 -------------------------
93 ds_val_bind :: (RecFlag, LHsBinds Id) -> CoreExpr -> DsM CoreExpr
94 -- Special case for bindings which bind unlifted variables
95 -- We need to do a case right away, rather than building
96 -- a tuple and doing selections.
97 -- Silently ignore INLINE and SPECIALISE pragmas...
98 ds_val_bind (NonRecursive, hsbinds) body
99 | [L _ (AbsBinds [] [] exports binds)] <- bagToList hsbinds,
100 (L loc bind : null_binds) <- bagToList binds,
102 || isUnboxedTupleBind bind
103 || or [isUnLiftedType (idType g) | (_, g, _, _) <- exports]
105 body_w_exports = foldr bind_export body exports
106 bind_export (tvs, g, l, _) body = ASSERT( null tvs )
107 bindNonRec g (Var l) body
109 ASSERT (null null_binds)
110 -- Non-recursive, non-overloaded bindings only come in ones
111 -- ToDo: in some bizarre case it's conceivable that there
112 -- could be dict binds in the 'binds'. (See the notes
113 -- below. Then pattern-match would fail. Urk.)
116 FunBind { fun_id = L _ fun, fun_matches = matches, fun_co_fn = co_fn,
117 fun_tick = tick, fun_infix = inf }
118 -> do (args, rhs) <- matchWrapper (FunRhs (idName fun ) inf) matches
119 MASSERT( null args ) -- Functions aren't lifted
120 MASSERT( isIdHsWrapper co_fn )
121 rhs' <- mkOptTickBox tick rhs
122 return (bindNonRec fun rhs' body_w_exports)
124 PatBind {pat_lhs = pat, pat_rhs = grhss, pat_rhs_ty = ty }
125 -> -- let C x# y# = rhs in body
126 -- ==> case rhs of C x# y# -> body
128 do { rhs <- dsGuarded grhss ty
129 ; let upat = unLoc pat
130 eqn = EqnInfo { eqn_pats = [upat],
131 eqn_rhs = cantFailMatchResult body_w_exports }
132 ; var <- selectMatchVar upat
133 ; result <- matchEquations PatBindRhs [var] [eqn] (exprType body)
134 ; return (scrungleMatch var rhs result) }
136 _ -> pprPanic "dsLet: unlifted" (pprLHsBinds hsbinds $$ ppr body)
139 -- Ordinary case for bindings; none should be unlifted
140 ds_val_bind (_is_rec, binds) body
141 = do { prs <- dsLHsBinds binds
142 ; ASSERT( not (any (isUnLiftedType . idType . fst) prs) )
145 _ -> return (Let (Rec prs) body) }
146 -- Use a Rec regardless of is_rec.
147 -- Why? Because it allows the binds to be all
148 -- mixed up, which is what happens in one rare case
149 -- Namely, for an AbsBind with no tyvars and no dicts,
150 -- but which does have dictionary bindings.
151 -- See notes with TcSimplify.inferLoop [NO TYVARS]
152 -- It turned out that wrapping a Rec here was the easiest solution
154 -- NB The previous case dealt with unlifted bindings, so we
155 -- only have to deal with lifted ones now; so Rec is ok
157 isUnboxedTupleBind :: HsBind Id -> Bool
158 isUnboxedTupleBind (PatBind { pat_rhs_ty = ty }) = isUnboxedTupleType ty
159 isUnboxedTupleBind _ = False
161 scrungleMatch :: Id -> CoreExpr -> CoreExpr -> CoreExpr
162 -- Returns something like (let var = scrut in body)
163 -- but if var is an unboxed-tuple type, it inlines it in a fragile way
164 -- Special case to handle unboxed tuple patterns; they can't appear nested
166 -- case e of (# p1, p2 #) -> rhs
168 -- case e of (# x1, x2 #) -> ... match p1, p2 ...
170 -- let x = e in case x of ....
172 -- But there may be a big
173 -- let fail = ... in case e of ...
174 -- wrapping the whole case, which complicates matters slightly
175 -- It all seems a bit fragile. Test is dsrun013.
177 scrungleMatch var scrut body
178 | isUnboxedTupleType (idType var) = scrungle body
179 | otherwise = bindNonRec var scrut body
181 scrungle (Case (Var x) bndr ty alts)
182 | x == var = Case scrut bndr ty alts
183 scrungle (Let binds body) = Let binds (scrungle body)
184 scrungle other = panic ("scrungleMatch: tuple pattern:\n" ++ showSDoc (ppr other))
188 %************************************************************************
190 \subsection[DsExpr-vars-and-cons]{Variables, constructors, literals}
192 %************************************************************************
195 dsLExpr :: LHsExpr Id -> DsM CoreExpr
197 dsLExpr (L loc e) = putSrcSpanDs loc $ dsExpr e
199 dsExpr :: HsExpr Id -> DsM CoreExpr
200 dsExpr (HsPar e) = dsLExpr e
201 dsExpr (ExprWithTySigOut e _) = dsLExpr e
202 dsExpr (HsVar var) = return (Var var)
203 dsExpr (HsIPVar ip) = return (Var (ipNameName ip))
204 dsExpr (HsLit lit) = dsLit lit
205 dsExpr (HsOverLit lit) = dsOverLit lit
206 dsExpr (HsWrap co_fn e) = dsCoercion co_fn (dsExpr e)
208 dsExpr (NegApp expr neg_expr)
209 = App <$> dsExpr neg_expr <*> dsLExpr expr
211 dsExpr (HsLam a_Match)
212 = uncurry mkLams <$> matchWrapper LambdaExpr a_Match
214 dsExpr (HsApp fun arg)
215 = mkCoreApp <$> dsLExpr fun <*> dsLExpr arg
218 Operator sections. At first it looks as if we can convert
227 But no! expr might be a redex, and we can lose laziness badly this
232 for example. So we convert instead to
234 let y = expr in \x -> op y x
236 If \tr{expr} is actually just a variable, say, then the simplifier
240 dsExpr (OpApp e1 op _ e2)
241 = -- for the type of y, we need the type of op's 2nd argument
242 mkCoreApps <$> dsLExpr op <*> mapM dsLExpr [e1, e2]
244 dsExpr (SectionL expr op) -- Desugar (e !) to ((!) e)
245 = mkCoreApp <$> dsLExpr op <*> dsLExpr expr
247 -- dsLExpr (SectionR op expr) -- \ x -> op x expr
248 dsExpr (SectionR op expr) = do
249 core_op <- dsLExpr op
250 -- for the type of x, we need the type of op's 2nd argument
251 let (x_ty:y_ty:_, _) = splitFunTys (exprType core_op)
252 -- See comment with SectionL
253 y_core <- dsLExpr expr
254 x_id <- newSysLocalDs x_ty
255 y_id <- newSysLocalDs y_ty
256 return (bindNonRec y_id y_core $
257 Lam x_id (mkCoreApps core_op [Var x_id, Var y_id]))
259 dsExpr (HsSCC cc expr) = do
260 mod_name <- getModuleDs
261 Note (SCC (mkUserCC cc mod_name)) <$> dsLExpr expr
264 -- hdaume: core annotation
266 dsExpr (HsCoreAnn fs expr)
267 = Note (CoreNote $ unpackFS fs) <$> dsLExpr expr
269 dsExpr (HsCase discrim matches) = do
270 core_discrim <- dsLExpr discrim
271 ([discrim_var], matching_code) <- matchWrapper CaseAlt matches
272 return (scrungleMatch discrim_var core_discrim matching_code)
274 -- Pepe: The binds are in scope in the body but NOT in the binding group
275 -- This is to avoid silliness in breakpoints
276 dsExpr (HsLet binds body) = do
277 body' <- dsLExpr body
278 dsLocalBinds binds body'
280 -- We need the `ListComp' form to use `deListComp' (rather than the "do" form)
281 -- because the interpretation of `stmts' depends on what sort of thing it is.
283 dsExpr (HsDo ListComp stmts body result_ty)
284 = -- Special case for list comprehensions
285 dsListComp stmts body elt_ty
287 [elt_ty] = tcTyConAppArgs result_ty
289 dsExpr (HsDo DoExpr stmts body result_ty)
290 = dsDo stmts body result_ty
292 dsExpr (HsDo (MDoExpr tbl) stmts body result_ty)
293 = dsMDo tbl stmts body result_ty
295 dsExpr (HsDo PArrComp stmts body result_ty)
296 = -- Special case for array comprehensions
297 dsPArrComp (map unLoc stmts) body elt_ty
299 [elt_ty] = tcTyConAppArgs result_ty
301 dsExpr (HsIf guard_expr then_expr else_expr)
302 = mkIfThenElse <$> dsLExpr guard_expr <*> dsLExpr then_expr <*> dsLExpr else_expr
307 \underline{\bf Various data construction things}
308 % ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
310 dsExpr (ExplicitList elt_ty xs)
311 = dsExplicitList elt_ty xs
313 -- we create a list from the array elements and convert them into a list using
316 -- * the main disadvantage to this scheme is that `toP' traverses the list
317 -- twice: once to determine the length and a second time to put to elements
318 -- into the array; this inefficiency could be avoided by exposing some of
319 -- the innards of `PrelPArr' to the compiler (ie, have a `PrelPArrBase') so
320 -- that we can exploit the fact that we already know the length of the array
321 -- here at compile time
323 dsExpr (ExplicitPArr ty xs) = do
324 toP <- dsLookupGlobalId toPName
325 coreList <- dsExpr (ExplicitList ty xs)
326 return (mkApps (Var toP) [Type ty, coreList])
328 dsExpr (ExplicitTuple expr_list boxity) = do
329 core_exprs <- mapM dsLExpr expr_list
330 return (mkConApp (tupleCon boxity (length expr_list))
331 (map (Type . exprType) core_exprs ++ core_exprs))
333 dsExpr (ArithSeq expr (From from))
334 = App <$> dsExpr expr <*> dsLExpr from
336 dsExpr (ArithSeq expr (FromTo from to))
337 = mkApps <$> dsExpr expr <*> mapM dsLExpr [from, to]
339 dsExpr (ArithSeq expr (FromThen from thn))
340 = mkApps <$> dsExpr expr <*> mapM dsLExpr [from, thn]
342 dsExpr (ArithSeq expr (FromThenTo from thn to))
343 = mkApps <$> dsExpr expr <*> mapM dsLExpr [from, thn, to]
345 dsExpr (PArrSeq expr (FromTo from to))
346 = mkApps <$> dsExpr expr <*> mapM dsLExpr [from, to]
348 dsExpr (PArrSeq expr (FromThenTo from thn to))
349 = mkApps <$> dsExpr expr <*> mapM dsLExpr [from, thn, to]
352 = panic "DsExpr.dsExpr: Infinite parallel array!"
353 -- the parser shouldn't have generated it and the renamer and typechecker
354 -- shouldn't have let it through
358 \underline{\bf Record construction and update}
359 % ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
360 For record construction we do this (assuming T has three arguments)
364 let err = /\a -> recConErr a
365 T (recConErr t1 "M.lhs/230/op1")
367 (recConErr t1 "M.lhs/230/op3")
369 @recConErr@ then converts its arugment string into a proper message
370 before printing it as
372 M.lhs, line 230: missing field op1 was evaluated
375 We also handle @C{}@ as valid construction syntax for an unlabelled
376 constructor @C@, setting all of @C@'s fields to bottom.
379 dsExpr (RecordCon (L _ data_con_id) con_expr rbinds) = do
380 con_expr' <- dsExpr con_expr
382 (arg_tys, _) = tcSplitFunTys (exprType con_expr')
383 -- A newtype in the corner should be opaque;
384 -- hence TcType.tcSplitFunTys
386 mk_arg (arg_ty, lbl) -- Selector id has the field label as its name
387 = case findField (rec_flds rbinds) lbl of
388 (rhs:rhss) -> ASSERT( null rhss )
390 [] -> mkErrorAppDs rEC_CON_ERROR_ID arg_ty (showSDoc (ppr lbl))
391 unlabelled_bottom arg_ty = mkErrorAppDs rEC_CON_ERROR_ID arg_ty ""
393 labels = dataConFieldLabels (idDataCon data_con_id)
394 -- The data_con_id is guaranteed to be the wrapper id of the constructor
396 con_args <- if null labels
397 then mapM unlabelled_bottom arg_tys
398 else mapM mk_arg (zipEqual "dsExpr:RecordCon" arg_tys labels)
400 return (mkApps con_expr' con_args)
403 Record update is a little harder. Suppose we have the decl:
405 data T = T1 {op1, op2, op3 :: Int}
406 | T2 {op4, op2 :: Int}
409 Then we translate as follows:
415 T1 op1 _ op3 -> T1 op1 op2 op3
416 T2 op4 _ -> T2 op4 op2
417 other -> recUpdError "M.lhs/230"
419 It's important that we use the constructor Ids for @T1@, @T2@ etc on the
420 RHSs, and do not generate a Core constructor application directly, because the constructor
421 might do some argument-evaluation first; and may have to throw away some
425 dsExpr expr@(RecordUpd record_expr (HsRecFields { rec_flds = fields })
426 cons_to_upd in_inst_tys out_inst_tys)
428 = dsLExpr record_expr
430 = -- Record stuff doesn't work for existentials
431 -- The type checker checks for this, but we need
432 -- worry only about the constructors that are to be updated
433 ASSERT2( notNull cons_to_upd && all isVanillaDataCon cons_to_upd, ppr expr )
435 do { record_expr' <- dsLExpr record_expr
436 ; let -- Awkwardly, for families, the match goes
437 -- from instance type to family type
438 tycon = dataConTyCon (head cons_to_upd)
439 in_ty = mkTyConApp tycon in_inst_tys
440 in_out_ty = mkFunTy in_ty
441 (mkFamilyTyConApp tycon out_inst_tys)
443 mk_val_arg field old_arg_id
444 = case findField fields field of
445 (rhs:rest) -> ASSERT(null rest) rhs
446 [] -> nlHsVar old_arg_id
449 = ASSERT( isVanillaDataCon con )
450 do { arg_ids <- newSysLocalsDs (dataConInstOrigArgTys con in_inst_tys)
451 -- This call to dataConInstOrigArgTys won't work for existentials
452 -- but existentials don't have record types anyway
453 ; let val_args = zipWithEqual "dsExpr:RecordUpd" mk_val_arg
454 (dataConFieldLabels con) arg_ids
455 rhs = foldl (\a b -> nlHsApp a b)
456 (nlHsTyApp (dataConWrapId con) out_inst_tys)
458 pat = mkPrefixConPat con (map nlVarPat arg_ids) in_ty
460 ; return (mkSimpleMatch [pat] rhs) }
462 -- It's important to generate the match with matchWrapper,
463 -- and the right hand sides with applications of the wrapper Id
464 -- so that everything works when we are doing fancy unboxing on the
465 -- constructor aguments.
466 ; alts <- mapM mk_alt cons_to_upd
467 ; ([discrim_var], matching_code) <- matchWrapper RecUpd (MatchGroup alts in_out_ty)
469 ; return (bindNonRec discrim_var record_expr' matching_code) }
472 Here is where we desugar the Template Haskell brackets and escapes
475 -- Template Haskell stuff
477 #ifdef GHCI /* Only if bootstrapping */
478 dsExpr (HsBracketOut x ps) = dsBracket x ps
479 dsExpr (HsSpliceE s) = pprPanic "dsExpr:splice" (ppr s)
482 -- Arrow notation extension
483 dsExpr (HsProc pat cmd) = dsProcExpr pat cmd
489 dsExpr (HsTick ix vars e) = do
493 -- There is a problem here. The then and else branches
494 -- have no free variables, so they are open to lifting.
495 -- We need someway of stopping this.
496 -- This will make no difference to binary coverage
497 -- (did you go here: YES or NO), but will effect accurate
500 dsExpr (HsBinTick ixT ixF e) = do
502 do { ASSERT(exprType e2 `coreEqType` boolTy)
503 mkBinaryTickBox ixT ixF e2
509 -- HsSyn constructs that just shouldn't be here:
510 dsExpr (ExprWithTySig _ _) = panic "dsExpr:ExprWithTySig"
513 findField :: [HsRecField Id arg] -> Name -> [arg]
515 = [rhs | HsRecField { hsRecFieldId = id, hsRecFieldArg = rhs } <- rbinds
516 , lbl == idName (unLoc id) ]
519 %--------------------------------------------------------------------
521 Note [Desugaring explicit lists]
522 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
523 Explicit lists are desugared in a cleverer way to prevent some
524 fruitless allocations. Essentially, whenever we see a list literal
527 1. Find the tail of the list that can be allocated statically (say
528 [x_k, ..., x_n]) by later stages and ensure we desugar that
529 normally: this makes sure that we don't cause a code size increase
530 by having the cons in that expression fused (see later) and hence
531 being unable to statically allocate any more
533 2. For the prefix of the list which cannot be allocated statically,
534 say [x_1, ..., x_(k-1)], we turn it into an expression involving
535 build so that if we find any foldrs over it it will fuse away
538 So in this example we will desugar to:
539 build (\c n -> x_1 `c` x_2 `c` .... `c` foldr c n [x_k, ..., x_n]
541 If fusion fails to occur then build will get inlined and (since we
542 defined a RULE for foldr (:) []) we will get back exactly the
543 normal desugaring for an explicit list.
545 This optimisation can be worth a lot: up to 25% of the total
546 allocation in some nofib programs. Specifically
548 Program Size Allocs Runtime CompTime
549 rewrite +0.0% -26.3% 0.02 -1.8%
550 ansi -0.3% -13.8% 0.00 +0.0%
551 lift +0.0% -8.7% 0.00 -2.3%
553 Of course, if rules aren't turned on then there is pretty much no
554 point doing this fancy stuff, and it may even be harmful.
557 dsExplicitList :: PostTcType -> [LHsExpr Id] -> DsM CoreExpr
558 -- See Note [Desugaring explicit lists]
559 dsExplicitList elt_ty xs = do
561 xs' <- mapM dsLExpr xs
562 if not (dopt Opt_RewriteRules dflags)
563 then return $ mkListExpr elt_ty xs'
564 else mkBuildExpr elt_ty (mkSplitExplicitList (thisPackage dflags) xs')
566 mkSplitExplicitList this_package xs' (c, _) (n, n_ty) = do
567 let (dynamic_prefix, static_suffix) = spanTail (rhsIsStatic this_package) xs'
568 static_suffix' = mkListExpr elt_ty static_suffix
570 folded_static_suffix <- mkFoldrExpr elt_ty n_ty (Var c) (Var n) static_suffix'
571 let build_body = foldr (App . App (Var c)) folded_static_suffix dynamic_prefix
574 spanTail :: (a -> Bool) -> [a] -> ([a], [a])
575 spanTail f xs = (reverse rejected, reverse satisfying)
576 where (satisfying, rejected) = span f $ reverse xs
579 Desugar 'do' and 'mdo' expressions (NOT list comprehensions, they're
580 handled in DsListComp). Basically does the translation given in the
586 -> Type -- Type of the whole expression
589 dsDo stmts body _result_ty
590 = go (map unLoc stmts)
594 go (ExprStmt rhs then_expr _ : stmts)
595 = do { rhs2 <- dsLExpr rhs
596 ; then_expr2 <- dsExpr then_expr
598 ; return (mkApps then_expr2 [rhs2, rest]) }
600 go (LetStmt binds : stmts)
601 = do { rest <- go stmts
602 ; dsLocalBinds binds rest }
604 go (BindStmt pat rhs bind_op fail_op : stmts)
606 do { body <- go stmts
607 ; rhs' <- dsLExpr rhs
608 ; bind_op' <- dsExpr bind_op
609 ; var <- selectSimpleMatchVarL pat
610 ; let bind_ty = exprType bind_op' -- rhs -> (pat -> res1) -> res2
611 res1_ty = funResultTy (funArgTy (funResultTy bind_ty))
612 ; match <- matchSinglePat (Var var) (StmtCtxt DoExpr) pat
613 res1_ty (cantFailMatchResult body)
614 ; match_code <- handle_failure pat match fail_op
615 ; return (mkApps bind_op' [rhs', Lam var match_code]) }
617 -- In a do expression, pattern-match failure just calls
618 -- the monadic 'fail' rather than throwing an exception
619 handle_failure pat match fail_op
621 = do { fail_op' <- dsExpr fail_op
622 ; fail_msg <- mkStringExpr (mk_fail_msg pat)
623 ; extractMatchResult match (App fail_op' fail_msg) }
625 = extractMatchResult match (error "It can't fail")
627 mk_fail_msg :: Located e -> String
628 mk_fail_msg pat = "Pattern match failure in do expression at " ++
629 showSDoc (ppr (getLoc pat))
632 Translation for RecStmt's:
633 -----------------------------
634 We turn (RecStmt [v1,..vn] stmts) into:
636 (v1,..,vn) <- mfix (\~(v1,..vn). do stmts
643 -> Type -- Type of the whole expression
646 dsMDo tbl stmts body result_ty
647 = go (map unLoc stmts)
649 (m_ty, b_ty) = tcSplitAppTy result_ty -- result_ty must be of the form (m b)
650 mfix_id = lookupEvidence tbl mfixName
651 return_id = lookupEvidence tbl returnMName
652 bind_id = lookupEvidence tbl bindMName
653 then_id = lookupEvidence tbl thenMName
654 fail_id = lookupEvidence tbl failMName
659 go (LetStmt binds : stmts)
660 = do { rest <- go stmts
661 ; dsLocalBinds binds rest }
663 go (ExprStmt rhs _ rhs_ty : stmts)
664 = do { rhs2 <- dsLExpr rhs
666 ; return (mkApps (Var then_id) [Type rhs_ty, Type b_ty, rhs2, rest]) }
668 go (BindStmt pat rhs _ _ : stmts)
669 = do { body <- go stmts
670 ; var <- selectSimpleMatchVarL pat
671 ; match <- matchSinglePat (Var var) (StmtCtxt ctxt) pat
672 result_ty (cantFailMatchResult body)
673 ; fail_msg <- mkStringExpr (mk_fail_msg pat)
674 ; let fail_expr = mkApps (Var fail_id) [Type b_ty, fail_msg]
675 ; match_code <- extractMatchResult match fail_expr
677 ; rhs' <- dsLExpr rhs
678 ; return (mkApps (Var bind_id) [Type (hsLPatType pat), Type b_ty,
679 rhs', Lam var match_code]) }
681 go (RecStmt rec_stmts later_ids rec_ids rec_rets binds : stmts)
682 = ASSERT( length rec_ids > 0 )
683 ASSERT( length rec_ids == length rec_rets )
684 go (new_bind_stmt : let_stmt : stmts)
686 new_bind_stmt = mkBindStmt (mk_tup_pat later_pats) mfix_app
687 let_stmt = LetStmt (HsValBinds (ValBindsOut [(Recursive, binds)] []))
690 -- Remove the later_ids that appear (without fancy coercions)
691 -- in rec_rets, because there's no need to knot-tie them separately
692 -- See Note [RecStmt] in HsExpr
693 later_ids' = filter (`notElem` mono_rec_ids) later_ids
694 mono_rec_ids = [ id | HsVar id <- rec_rets ]
696 mfix_app = nlHsApp (nlHsTyApp mfix_id [tup_ty]) mfix_arg
697 mfix_arg = noLoc $ HsLam (MatchGroup [mkSimpleMatch [mfix_pat] body]
698 (mkFunTy tup_ty body_ty))
700 -- The rec_tup_pat must bind the rec_ids only; remember that the
701 -- trimmed_laters may share the same Names
702 -- Meanwhile, the later_pats must bind the later_vars
703 rec_tup_pats = map mk_wild_pat later_ids' ++ map nlVarPat rec_ids
704 later_pats = map nlVarPat later_ids' ++ map mk_later_pat rec_ids
705 rets = map nlHsVar later_ids' ++ map noLoc rec_rets
707 mfix_pat = noLoc $ LazyPat $ mk_tup_pat rec_tup_pats
708 body = noLoc $ HsDo ctxt rec_stmts return_app body_ty
709 body_ty = mkAppTy m_ty tup_ty
710 tup_ty = mkCoreTupTy (map idType (later_ids' ++ rec_ids))
711 -- mkCoreTupTy deals with singleton case
713 return_app = nlHsApp (nlHsTyApp return_id [tup_ty])
716 mk_wild_pat :: Id -> LPat Id
717 mk_wild_pat v = noLoc $ WildPat $ idType v
719 mk_later_pat :: Id -> LPat Id
720 mk_later_pat v | v `elem` later_ids' = mk_wild_pat v
721 | otherwise = nlVarPat v
723 mk_tup_pat :: [LPat Id] -> LPat Id
725 mk_tup_pat ps = noLoc $ mkVanillaTuplePat ps Boxed
727 mk_ret_tup :: [LHsExpr Id] -> LHsExpr Id
729 mk_ret_tup rs = noLoc $ ExplicitTuple rs Boxed