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"
33 -- Template Haskell stuff iff bootstrapped
40 -- NB: The desugarer, which straddles the source and Core worlds, sometimes
41 -- needs to see source types
66 %************************************************************************
68 dsLocalBinds, dsValBinds
70 %************************************************************************
73 dsLocalBinds :: HsLocalBinds Id -> CoreExpr -> DsM CoreExpr
74 dsLocalBinds EmptyLocalBinds body = return body
75 dsLocalBinds (HsValBinds binds) body = dsValBinds binds body
76 dsLocalBinds (HsIPBinds binds) body = dsIPBinds binds body
78 -------------------------
79 dsValBinds :: HsValBinds Id -> CoreExpr -> DsM CoreExpr
80 dsValBinds (ValBindsOut binds _) body = foldrM ds_val_bind body binds
82 -------------------------
83 dsIPBinds :: HsIPBinds Id -> CoreExpr -> DsM CoreExpr
84 dsIPBinds (IPBinds ip_binds dict_binds) body
85 = do { prs <- dsLHsBinds dict_binds
86 ; let inner = Let (Rec prs) body
87 -- The dict bindings may not be in
88 -- dependency order; hence Rec
89 ; foldrM ds_ip_bind inner ip_binds }
91 ds_ip_bind (L _ (IPBind n e)) body
93 return (Let (NonRec (ipNameName n) e') body)
95 -------------------------
96 ds_val_bind :: (RecFlag, LHsBinds Id) -> CoreExpr -> DsM CoreExpr
97 -- Special case for bindings which bind unlifted variables
98 -- We need to do a case right away, rather than building
99 -- a tuple and doing selections.
100 -- Silently ignore INLINE and SPECIALISE pragmas...
101 ds_val_bind (NonRecursive, hsbinds) body
102 | [L _ (AbsBinds [] [] exports binds)] <- bagToList hsbinds,
103 (L loc bind : null_binds) <- bagToList binds,
105 || isUnboxedTupleBind bind
106 || or [isUnLiftedType (idType g) | (_, g, _, _) <- exports]
108 body_w_exports = foldr bind_export body exports
109 bind_export (tvs, g, l, _) body = ASSERT( null tvs )
110 bindNonRec g (Var l) body
112 ASSERT (null null_binds)
113 -- Non-recursive, non-overloaded bindings only come in ones
114 -- ToDo: in some bizarre case it's conceivable that there
115 -- could be dict binds in the 'binds'. (See the notes
116 -- below. Then pattern-match would fail. Urk.)
119 FunBind { fun_id = L _ fun, fun_matches = matches, fun_co_fn = co_fn,
120 fun_tick = tick, fun_infix = inf }
121 -> do (args, rhs) <- matchWrapper (FunRhs (idName fun ) inf) matches
122 MASSERT( null args ) -- Functions aren't lifted
123 MASSERT( isIdHsWrapper co_fn )
124 rhs' <- mkOptTickBox tick rhs
125 return (bindNonRec fun rhs' body_w_exports)
127 PatBind {pat_lhs = pat, pat_rhs = grhss, pat_rhs_ty = ty }
128 -> -- let C x# y# = rhs in body
129 -- ==> case rhs of C x# y# -> body
131 do { rhs <- dsGuarded grhss ty
132 ; let upat = unLoc pat
133 eqn = EqnInfo { eqn_pats = [upat],
134 eqn_rhs = cantFailMatchResult body_w_exports }
135 ; var <- selectMatchVar upat
136 ; result <- matchEquations PatBindRhs [var] [eqn] (exprType body)
137 ; return (scrungleMatch var rhs result) }
139 _ -> pprPanic "dsLet: unlifted" (pprLHsBinds hsbinds $$ ppr body)
142 -- Ordinary case for bindings; none should be unlifted
143 ds_val_bind (_is_rec, binds) body
144 = do { prs <- dsLHsBinds binds
145 ; ASSERT( not (any (isUnLiftedType . idType . fst) prs) )
148 _ -> return (Let (Rec prs) body) }
149 -- Use a Rec regardless of is_rec.
150 -- Why? Because it allows the binds to be all
151 -- mixed up, which is what happens in one rare case
152 -- Namely, for an AbsBind with no tyvars and no dicts,
153 -- but which does have dictionary bindings.
154 -- See notes with TcSimplify.inferLoop [NO TYVARS]
155 -- It turned out that wrapping a Rec here was the easiest solution
157 -- NB The previous case dealt with unlifted bindings, so we
158 -- only have to deal with lifted ones now; so Rec is ok
160 isUnboxedTupleBind :: HsBind Id -> Bool
161 isUnboxedTupleBind (PatBind { pat_rhs_ty = ty }) = isUnboxedTupleType ty
162 isUnboxedTupleBind _ = False
164 scrungleMatch :: Id -> CoreExpr -> CoreExpr -> CoreExpr
165 -- Returns something like (let var = scrut in body)
166 -- but if var is an unboxed-tuple type, it inlines it in a fragile way
167 -- Special case to handle unboxed tuple patterns; they can't appear nested
169 -- case e of (# p1, p2 #) -> rhs
171 -- case e of (# x1, x2 #) -> ... match p1, p2 ...
173 -- let x = e in case x of ....
175 -- But there may be a big
176 -- let fail = ... in case e of ...
177 -- wrapping the whole case, which complicates matters slightly
178 -- It all seems a bit fragile. Test is dsrun013.
180 scrungleMatch var scrut body
181 | isUnboxedTupleType (idType var) = scrungle body
182 | otherwise = bindNonRec var scrut body
184 scrungle (Case (Var x) bndr ty alts)
185 | x == var = Case scrut bndr ty alts
186 scrungle (Let binds body) = Let binds (scrungle body)
187 scrungle other = panic ("scrungleMatch: tuple pattern:\n" ++ showSDoc (ppr other))
191 %************************************************************************
193 \subsection[DsExpr-vars-and-cons]{Variables, constructors, literals}
195 %************************************************************************
198 dsLExpr :: LHsExpr Id -> DsM CoreExpr
200 dsLExpr (L loc e) = putSrcSpanDs loc $ dsExpr e
202 dsExpr :: HsExpr Id -> DsM CoreExpr
203 dsExpr (HsPar e) = dsLExpr e
204 dsExpr (ExprWithTySigOut e _) = dsLExpr e
205 dsExpr (HsVar var) = return (Var var)
206 dsExpr (HsIPVar ip) = return (Var (ipNameName ip))
207 dsExpr (HsLit lit) = dsLit lit
208 dsExpr (HsOverLit lit) = dsOverLit lit
209 dsExpr (HsWrap co_fn e) = dsCoercion co_fn (dsExpr e)
211 dsExpr (NegApp expr neg_expr)
212 = App <$> dsExpr neg_expr <*> dsLExpr expr
214 dsExpr (HsLam a_Match)
215 = uncurry mkLams <$> matchWrapper LambdaExpr a_Match
217 dsExpr (HsApp fun arg)
218 = mkCoreApp <$> dsLExpr fun <*> dsLExpr arg
221 Operator sections. At first it looks as if we can convert
230 But no! expr might be a redex, and we can lose laziness badly this
235 for example. So we convert instead to
237 let y = expr in \x -> op y x
239 If \tr{expr} is actually just a variable, say, then the simplifier
243 dsExpr (OpApp e1 op _ e2)
244 = -- for the type of y, we need the type of op's 2nd argument
245 mkCoreApps <$> dsLExpr op <*> mapM dsLExpr [e1, e2]
247 dsExpr (SectionL expr op) -- Desugar (e !) to ((!) e)
248 = mkCoreApp <$> dsLExpr op <*> dsLExpr expr
250 -- dsLExpr (SectionR op expr) -- \ x -> op x expr
251 dsExpr (SectionR op expr) = do
252 core_op <- dsLExpr op
253 -- for the type of x, we need the type of op's 2nd argument
254 let (x_ty:y_ty:_, _) = splitFunTys (exprType core_op)
255 -- See comment with SectionL
256 y_core <- dsLExpr expr
257 x_id <- newSysLocalDs x_ty
258 y_id <- newSysLocalDs y_ty
259 return (bindNonRec y_id y_core $
260 Lam x_id (mkCoreApps core_op [Var x_id, Var y_id]))
262 dsExpr (HsSCC cc expr) = do
263 mod_name <- getModuleDs
264 Note (SCC (mkUserCC cc mod_name)) <$> dsLExpr expr
267 -- hdaume: core annotation
269 dsExpr (HsCoreAnn fs expr)
270 = Note (CoreNote $ unpackFS fs) <$> dsLExpr expr
272 dsExpr (HsCase discrim matches@(MatchGroup _ rhs_ty))
273 | isEmptyMatchGroup matches -- A Core 'case' is always non-empty
274 = -- So desugar empty HsCase to error call
275 mkErrorAppDs pAT_ERROR_ID (funResultTy rhs_ty) "case"
278 = do { core_discrim <- dsLExpr discrim
279 ; ([discrim_var], matching_code) <- matchWrapper CaseAlt matches
280 ; return (scrungleMatch discrim_var core_discrim matching_code) }
282 -- Pepe: The binds are in scope in the body but NOT in the binding group
283 -- This is to avoid silliness in breakpoints
284 dsExpr (HsLet binds body) = do
285 body' <- dsLExpr body
286 dsLocalBinds binds body'
288 -- We need the `ListComp' form to use `deListComp' (rather than the "do" form)
289 -- because the interpretation of `stmts' depends on what sort of thing it is.
291 dsExpr (HsDo ListComp stmts body result_ty)
292 = -- Special case for list comprehensions
293 dsListComp stmts body elt_ty
295 [elt_ty] = tcTyConAppArgs result_ty
297 dsExpr (HsDo DoExpr stmts body result_ty)
298 = dsDo stmts body result_ty
300 dsExpr (HsDo (MDoExpr tbl) stmts body result_ty)
301 = dsMDo tbl stmts body result_ty
303 dsExpr (HsDo PArrComp stmts body result_ty)
304 = -- Special case for array comprehensions
305 dsPArrComp (map unLoc stmts) body elt_ty
307 [elt_ty] = tcTyConAppArgs result_ty
309 dsExpr (HsIf guard_expr then_expr else_expr)
310 = mkIfThenElse <$> dsLExpr guard_expr <*> dsLExpr then_expr <*> dsLExpr else_expr
315 \underline{\bf Various data construction things}
316 % ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
318 dsExpr (ExplicitList elt_ty xs)
319 = dsExplicitList elt_ty xs
321 -- We desugar [:x1, ..., xn:] as
322 -- singletonP x1 +:+ ... +:+ singletonP xn
324 dsExpr (ExplicitPArr ty []) = do
325 emptyP <- dsLookupGlobalId emptyPName
326 return (Var emptyP `App` Type ty)
327 dsExpr (ExplicitPArr ty xs) = do
328 singletonP <- dsLookupGlobalId singletonPName
329 appP <- dsLookupGlobalId appPName
330 xs' <- mapM dsLExpr xs
331 return . foldr1 (binary appP) $ map (unary singletonP) xs'
333 unary fn x = mkApps (Var fn) [Type ty, x]
334 binary fn x y = mkApps (Var fn) [Type ty, x, y]
336 dsExpr (ExplicitTuple expr_list boxity) = do
337 core_exprs <- mapM dsLExpr expr_list
338 return (mkConApp (tupleCon boxity (length expr_list))
339 (map (Type . exprType) core_exprs ++ core_exprs))
341 dsExpr (ArithSeq expr (From from))
342 = App <$> dsExpr expr <*> dsLExpr from
344 dsExpr (ArithSeq expr (FromTo from to))
345 = mkApps <$> dsExpr expr <*> mapM dsLExpr [from, to]
347 dsExpr (ArithSeq expr (FromThen from thn))
348 = mkApps <$> dsExpr expr <*> mapM dsLExpr [from, thn]
350 dsExpr (ArithSeq expr (FromThenTo from thn to))
351 = mkApps <$> dsExpr expr <*> mapM dsLExpr [from, thn, to]
353 dsExpr (PArrSeq expr (FromTo from to))
354 = mkApps <$> dsExpr expr <*> mapM dsLExpr [from, to]
356 dsExpr (PArrSeq expr (FromThenTo from thn to))
357 = mkApps <$> dsExpr expr <*> mapM dsLExpr [from, thn, to]
360 = panic "DsExpr.dsExpr: Infinite parallel array!"
361 -- the parser shouldn't have generated it and the renamer and typechecker
362 -- shouldn't have let it through
366 \underline{\bf Record construction and update}
367 % ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
368 For record construction we do this (assuming T has three arguments)
372 let err = /\a -> recConErr a
373 T (recConErr t1 "M.lhs/230/op1")
375 (recConErr t1 "M.lhs/230/op3")
377 @recConErr@ then converts its arugment string into a proper message
378 before printing it as
380 M.lhs, line 230: missing field op1 was evaluated
383 We also handle @C{}@ as valid construction syntax for an unlabelled
384 constructor @C@, setting all of @C@'s fields to bottom.
387 dsExpr (RecordCon (L _ data_con_id) con_expr rbinds) = do
388 con_expr' <- dsExpr con_expr
390 (arg_tys, _) = tcSplitFunTys (exprType con_expr')
391 -- A newtype in the corner should be opaque;
392 -- hence TcType.tcSplitFunTys
394 mk_arg (arg_ty, lbl) -- Selector id has the field label as its name
395 = case findField (rec_flds rbinds) lbl of
396 (rhs:rhss) -> ASSERT( null rhss )
398 [] -> mkErrorAppDs rEC_CON_ERROR_ID arg_ty (showSDoc (ppr lbl))
399 unlabelled_bottom arg_ty = mkErrorAppDs rEC_CON_ERROR_ID arg_ty ""
401 labels = dataConFieldLabels (idDataCon data_con_id)
402 -- The data_con_id is guaranteed to be the wrapper id of the constructor
404 con_args <- if null labels
405 then mapM unlabelled_bottom arg_tys
406 else mapM mk_arg (zipEqual "dsExpr:RecordCon" arg_tys labels)
408 return (mkApps con_expr' con_args)
411 Record update is a little harder. Suppose we have the decl:
413 data T = T1 {op1, op2, op3 :: Int}
414 | T2 {op4, op2 :: Int}
417 Then we translate as follows:
423 T1 op1 _ op3 -> T1 op1 op2 op3
424 T2 op4 _ -> T2 op4 op2
425 other -> recUpdError "M.lhs/230"
427 It's important that we use the constructor Ids for @T1@, @T2@ etc on the
428 RHSs, and do not generate a Core constructor application directly, because the constructor
429 might do some argument-evaluation first; and may have to throw away some
432 Note [Update for GADTs]
433 ~~~~~~~~~~~~~~~~~~~~~~~
436 T1 { f1 :: a } :: T a Int
438 Then the wrapper function for T1 has type
440 But if x::T a b, then
441 x { f1 = v } :: T a b (not T a Int!)
442 So we need to cast (T a Int) to (T a b). Sigh.
445 dsExpr expr@(RecordUpd record_expr (HsRecFields { rec_flds = fields })
446 cons_to_upd in_inst_tys out_inst_tys)
448 = dsLExpr record_expr
450 = ASSERT2( notNull cons_to_upd, ppr expr )
452 do { record_expr' <- dsLExpr record_expr
453 ; field_binds' <- mapM ds_field fields
454 ; let upd_fld_env :: NameEnv Id -- Maps field name to the LocalId of the field binding
455 upd_fld_env = mkNameEnv [(f,l) | (f,l,_) <- field_binds']
457 -- It's important to generate the match with matchWrapper,
458 -- and the right hand sides with applications of the wrapper Id
459 -- so that everything works when we are doing fancy unboxing on the
460 -- constructor aguments.
461 ; alts <- mapM (mk_alt upd_fld_env) cons_to_upd
462 ; ([discrim_var], matching_code)
463 <- matchWrapper RecUpd (MatchGroup alts in_out_ty)
465 ; return (add_field_binds field_binds' $
466 bindNonRec discrim_var record_expr' matching_code) }
468 ds_field :: HsRecField Id (LHsExpr Id) -> DsM (Name, Id, CoreExpr)
469 -- Clone the Id in the HsRecField, because its Name is that
470 -- of the record selector, and we must not make that a lcoal binder
471 -- else we shadow other uses of the record selector
472 -- Hence 'lcl_id'. Cf Trac #2735
473 ds_field rec_field = do { rhs <- dsLExpr (hsRecFieldArg rec_field)
474 ; let fld_id = unLoc (hsRecFieldId rec_field)
475 ; lcl_id <- newSysLocalDs (idType fld_id)
476 ; return (idName fld_id, lcl_id, rhs) }
478 add_field_binds [] expr = expr
479 add_field_binds ((_,b,r):bs) expr = bindNonRec b r (add_field_binds bs expr)
481 -- Awkwardly, for families, the match goes
482 -- from instance type to family type
483 tycon = dataConTyCon (head cons_to_upd)
484 in_ty = mkTyConApp tycon in_inst_tys
485 in_out_ty = mkFunTy in_ty (mkFamilyTyConApp tycon out_inst_tys)
487 mk_alt upd_fld_env con
488 = do { let (univ_tvs, ex_tvs, eq_spec,
489 eq_theta, dict_theta, arg_tys, _) = dataConFullSig con
490 subst = mkTopTvSubst (univ_tvs `zip` in_inst_tys)
492 -- I'm not bothering to clone the ex_tvs
493 ; eqs_vars <- mapM newPredVarDs (substTheta subst (eqSpecPreds eq_spec))
494 ; theta_vars <- mapM newPredVarDs (substTheta subst (eq_theta ++ dict_theta))
495 ; arg_ids <- newSysLocalsDs (substTys subst arg_tys)
496 ; let val_args = zipWithEqual "dsExpr:RecordUpd" mk_val_arg
497 (dataConFieldLabels con) arg_ids
498 mk_val_arg field_name pat_arg_id
499 = nlHsVar (lookupNameEnv upd_fld_env field_name `orElse` pat_arg_id)
500 inst_con = noLoc $ HsWrap wrap (HsVar (dataConWrapId con))
501 -- Reconstruct with the WrapId so that unpacking happens
502 wrap = mkWpApps theta_vars `WpCompose`
503 mkWpTyApps (mkTyVarTys ex_tvs) `WpCompose`
504 mkWpTyApps [ty | (tv, ty) <- univ_tvs `zip` out_inst_tys
505 , isNothing (lookupTyVar wrap_subst tv) ]
506 rhs = foldl (\a b -> nlHsApp a b) inst_con val_args
508 -- Tediously wrap the application in a cast
509 -- Note [Update for GADTs]
510 wrapped_rhs | null eq_spec = rhs
511 | otherwise = mkLHsWrap (WpCast wrap_co) rhs
512 wrap_co = mkTyConApp tycon [ lookup tv ty
513 | (tv,ty) <- univ_tvs `zip` out_inst_tys]
514 lookup univ_tv ty = case lookupTyVar wrap_subst univ_tv of
517 wrap_subst = mkTopTvSubst [ (tv,mkSymCoercion (mkTyVarTy co_var))
518 | ((tv,_),co_var) <- eq_spec `zip` eqs_vars ]
520 pat = noLoc $ ConPatOut { pat_con = noLoc con, pat_tvs = ex_tvs
521 , pat_dicts = eqs_vars ++ theta_vars
522 , pat_binds = emptyLHsBinds
523 , pat_args = PrefixCon $ map nlVarPat arg_ids
525 ; return (mkSimpleMatch [pat] wrapped_rhs) }
529 Here is where we desugar the Template Haskell brackets and escapes
532 -- Template Haskell stuff
534 #ifdef GHCI /* Only if bootstrapping */
535 dsExpr (HsBracketOut x ps) = dsBracket x ps
536 dsExpr (HsSpliceE s) = pprPanic "dsExpr:splice" (ppr s)
539 -- Arrow notation extension
540 dsExpr (HsProc pat cmd) = dsProcExpr pat cmd
546 dsExpr (HsTick ix vars e) = do
550 -- There is a problem here. The then and else branches
551 -- have no free variables, so they are open to lifting.
552 -- We need someway of stopping this.
553 -- This will make no difference to binary coverage
554 -- (did you go here: YES or NO), but will effect accurate
557 dsExpr (HsBinTick ixT ixF e) = do
559 do { ASSERT(exprType e2 `coreEqType` boolTy)
560 mkBinaryTickBox ixT ixF e2
566 -- HsSyn constructs that just shouldn't be here:
567 dsExpr (ExprWithTySig _ _) = panic "dsExpr:ExprWithTySig"
570 findField :: [HsRecField Id arg] -> Name -> [arg]
572 = [rhs | HsRecField { hsRecFieldId = id, hsRecFieldArg = rhs } <- rbinds
573 , lbl == idName (unLoc id) ]
576 %--------------------------------------------------------------------
578 Note [Desugaring explicit lists]
579 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
580 Explicit lists are desugared in a cleverer way to prevent some
581 fruitless allocations. Essentially, whenever we see a list literal
584 1. Find the tail of the list that can be allocated statically (say
585 [x_k, ..., x_n]) by later stages and ensure we desugar that
586 normally: this makes sure that we don't cause a code size increase
587 by having the cons in that expression fused (see later) and hence
588 being unable to statically allocate any more
590 2. For the prefix of the list which cannot be allocated statically,
591 say [x_1, ..., x_(k-1)], we turn it into an expression involving
592 build so that if we find any foldrs over it it will fuse away
595 So in this example we will desugar to:
596 build (\c n -> x_1 `c` x_2 `c` .... `c` foldr c n [x_k, ..., x_n]
598 If fusion fails to occur then build will get inlined and (since we
599 defined a RULE for foldr (:) []) we will get back exactly the
600 normal desugaring for an explicit list.
602 This optimisation can be worth a lot: up to 25% of the total
603 allocation in some nofib programs. Specifically
605 Program Size Allocs Runtime CompTime
606 rewrite +0.0% -26.3% 0.02 -1.8%
607 ansi -0.3% -13.8% 0.00 +0.0%
608 lift +0.0% -8.7% 0.00 -2.3%
610 Of course, if rules aren't turned on then there is pretty much no
611 point doing this fancy stuff, and it may even be harmful.
614 dsExplicitList :: PostTcType -> [LHsExpr Id] -> DsM CoreExpr
615 -- See Note [Desugaring explicit lists]
616 dsExplicitList elt_ty xs = do
618 xs' <- mapM dsLExpr xs
619 if not (dopt Opt_EnableRewriteRules dflags)
620 then return $ mkListExpr elt_ty xs'
621 else mkBuildExpr elt_ty (mkSplitExplicitList (thisPackage dflags) xs')
623 mkSplitExplicitList this_package xs' (c, _) (n, n_ty) = do
624 let (dynamic_prefix, static_suffix) = spanTail (rhsIsStatic this_package) xs'
625 static_suffix' = mkListExpr elt_ty static_suffix
627 folded_static_suffix <- mkFoldrExpr elt_ty n_ty (Var c) (Var n) static_suffix'
628 let build_body = foldr (App . App (Var c)) folded_static_suffix dynamic_prefix
631 spanTail :: (a -> Bool) -> [a] -> ([a], [a])
632 spanTail f xs = (reverse rejected, reverse satisfying)
633 where (satisfying, rejected) = span f $ reverse xs
636 Desugar 'do' and 'mdo' expressions (NOT list comprehensions, they're
637 handled in DsListComp). Basically does the translation given in the
643 -> Type -- Type of the whole expression
646 dsDo stmts body _result_ty
647 = go (map unLoc stmts)
651 go (ExprStmt rhs then_expr _ : stmts)
652 = do { rhs2 <- dsLExpr rhs
653 ; then_expr2 <- dsExpr then_expr
655 ; return (mkApps then_expr2 [rhs2, rest]) }
657 go (LetStmt binds : stmts)
658 = do { rest <- go stmts
659 ; dsLocalBinds binds rest }
661 go (BindStmt pat rhs bind_op fail_op : stmts)
663 do { body <- go stmts
664 ; rhs' <- dsLExpr rhs
665 ; bind_op' <- dsExpr bind_op
666 ; var <- selectSimpleMatchVarL pat
667 ; let bind_ty = exprType bind_op' -- rhs -> (pat -> res1) -> res2
668 res1_ty = funResultTy (funArgTy (funResultTy bind_ty))
669 ; match <- matchSinglePat (Var var) (StmtCtxt DoExpr) pat
670 res1_ty (cantFailMatchResult body)
671 ; match_code <- handle_failure pat match fail_op
672 ; return (mkApps bind_op' [rhs', Lam var match_code]) }
674 -- In a do expression, pattern-match failure just calls
675 -- the monadic 'fail' rather than throwing an exception
676 handle_failure pat match fail_op
678 = do { fail_op' <- dsExpr fail_op
679 ; fail_msg <- mkStringExpr (mk_fail_msg pat)
680 ; extractMatchResult match (App fail_op' fail_msg) }
682 = extractMatchResult match (error "It can't fail")
684 mk_fail_msg :: Located e -> String
685 mk_fail_msg pat = "Pattern match failure in do expression at " ++
686 showSDoc (ppr (getLoc pat))
689 Translation for RecStmt's:
690 -----------------------------
691 We turn (RecStmt [v1,..vn] stmts) into:
693 (v1,..,vn) <- mfix (\~(v1,..vn). do stmts
700 -> Type -- Type of the whole expression
703 dsMDo tbl stmts body result_ty
704 = go (map unLoc stmts)
706 (m_ty, b_ty) = tcSplitAppTy result_ty -- result_ty must be of the form (m b)
707 mfix_id = lookupEvidence tbl mfixName
708 return_id = lookupEvidence tbl returnMName
709 bind_id = lookupEvidence tbl bindMName
710 then_id = lookupEvidence tbl thenMName
711 fail_id = lookupEvidence tbl failMName
716 go (LetStmt binds : stmts)
717 = do { rest <- go stmts
718 ; dsLocalBinds binds rest }
720 go (ExprStmt rhs _ rhs_ty : stmts)
721 = do { rhs2 <- dsLExpr rhs
723 ; return (mkApps (Var then_id) [Type rhs_ty, Type b_ty, rhs2, rest]) }
725 go (BindStmt pat rhs _ _ : stmts)
726 = do { body <- go stmts
727 ; var <- selectSimpleMatchVarL pat
728 ; match <- matchSinglePat (Var var) (StmtCtxt ctxt) pat
729 result_ty (cantFailMatchResult body)
730 ; fail_msg <- mkStringExpr (mk_fail_msg pat)
731 ; let fail_expr = mkApps (Var fail_id) [Type b_ty, fail_msg]
732 ; match_code <- extractMatchResult match fail_expr
734 ; rhs' <- dsLExpr rhs
735 ; return (mkApps (Var bind_id) [Type (hsLPatType pat), Type b_ty,
736 rhs', Lam var match_code]) }
738 go (RecStmt rec_stmts later_ids rec_ids rec_rets binds : stmts)
739 = ASSERT( length rec_ids > 0 )
740 ASSERT( length rec_ids == length rec_rets )
741 go (new_bind_stmt : let_stmt : stmts)
743 new_bind_stmt = mkBindStmt (mk_tup_pat later_pats) mfix_app
744 let_stmt = LetStmt (HsValBinds (ValBindsOut [(Recursive, binds)] []))
747 -- Remove the later_ids that appear (without fancy coercions)
748 -- in rec_rets, because there's no need to knot-tie them separately
749 -- See Note [RecStmt] in HsExpr
750 later_ids' = filter (`notElem` mono_rec_ids) later_ids
751 mono_rec_ids = [ id | HsVar id <- rec_rets ]
753 mfix_app = nlHsApp (nlHsTyApp mfix_id [tup_ty]) mfix_arg
754 mfix_arg = noLoc $ HsLam (MatchGroup [mkSimpleMatch [mfix_pat] body]
755 (mkFunTy tup_ty body_ty))
757 -- The rec_tup_pat must bind the rec_ids only; remember that the
758 -- trimmed_laters may share the same Names
759 -- Meanwhile, the later_pats must bind the later_vars
760 rec_tup_pats = map mk_wild_pat later_ids' ++ map nlVarPat rec_ids
761 later_pats = map nlVarPat later_ids' ++ map mk_later_pat rec_ids
762 rets = map nlHsVar later_ids' ++ map noLoc rec_rets
764 mfix_pat = noLoc $ LazyPat $ mk_tup_pat rec_tup_pats
765 body = noLoc $ HsDo ctxt rec_stmts return_app body_ty
766 body_ty = mkAppTy m_ty tup_ty
767 tup_ty = mkCoreTupTy (map idType (later_ids' ++ rec_ids))
768 -- mkCoreTupTy deals with singleton case
770 return_app = nlHsApp (nlHsTyApp return_id [tup_ty])
773 mk_wild_pat :: Id -> LPat Id
774 mk_wild_pat v = noLoc $ WildPat $ idType v
776 mk_later_pat :: Id -> LPat Id
777 mk_later_pat v | v `elem` later_ids' = mk_wild_pat v
778 | otherwise = nlVarPat v
780 mk_tup_pat :: [LPat Id] -> LPat Id
782 mk_tup_pat ps = noLoc $ mkVanillaTuplePat ps Boxed
784 mk_ret_tup :: [LHsExpr Id] -> LHsExpr Id
786 mk_ret_tup rs = noLoc $ ExplicitTuple rs Boxed