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
69 %************************************************************************
71 dsLocalBinds, dsValBinds
73 %************************************************************************
76 dsLocalBinds :: HsLocalBinds Id -> CoreExpr -> DsM CoreExpr
77 dsLocalBinds EmptyLocalBinds body = return body
78 dsLocalBinds (HsValBinds binds) body = dsValBinds binds body
79 dsLocalBinds (HsIPBinds binds) body = dsIPBinds binds body
81 -------------------------
82 dsValBinds :: HsValBinds Id -> CoreExpr -> DsM CoreExpr
83 dsValBinds (ValBindsOut binds _) body = foldrM ds_val_bind body binds
85 -------------------------
86 dsIPBinds :: HsIPBinds Id -> CoreExpr -> DsM CoreExpr
87 dsIPBinds (IPBinds ip_binds dict_binds) body
88 = do { prs <- dsLHsBinds dict_binds
89 ; let inner = Let (Rec prs) body
90 -- The dict bindings may not be in
91 -- dependency order; hence Rec
92 ; foldrM ds_ip_bind inner ip_binds }
94 ds_ip_bind (L _ (IPBind n e)) body
96 return (Let (NonRec (ipNameName n) e') body)
98 -------------------------
99 ds_val_bind :: (RecFlag, LHsBinds Id) -> CoreExpr -> DsM CoreExpr
100 -- Special case for bindings which bind unlifted variables
101 -- We need to do a case right away, rather than building
102 -- a tuple and doing selections.
103 -- Silently ignore INLINE and SPECIALISE pragmas...
104 ds_val_bind (NonRecursive, hsbinds) body
105 | [L _ (AbsBinds [] [] exports binds)] <- bagToList hsbinds,
106 (L loc bind : null_binds) <- bagToList binds,
108 || isUnboxedTupleBind bind
109 || or [isUnLiftedType (idType g) | (_, g, _, _) <- exports]
111 body_w_exports = foldr bind_export body exports
112 bind_export (tvs, g, l, _) body = ASSERT( null tvs )
113 bindNonRec g (Var l) body
115 ASSERT (null null_binds)
116 -- Non-recursive, non-overloaded bindings only come in ones
117 -- ToDo: in some bizarre case it's conceivable that there
118 -- could be dict binds in the 'binds'. (See the notes
119 -- below. Then pattern-match would fail. Urk.)
122 FunBind { fun_id = L _ fun, fun_matches = matches, fun_co_fn = co_fn,
123 fun_tick = tick, fun_infix = inf }
124 -> do (args, rhs) <- matchWrapper (FunRhs (idName fun ) inf) matches
125 MASSERT( null args ) -- Functions aren't lifted
126 MASSERT( isIdHsWrapper co_fn )
127 rhs' <- mkOptTickBox tick rhs
128 return (bindNonRec fun rhs' body_w_exports)
130 PatBind {pat_lhs = pat, pat_rhs = grhss, pat_rhs_ty = ty }
131 -> -- let C x# y# = rhs in body
132 -- ==> case rhs of C x# y# -> body
134 do { rhs <- dsGuarded grhss ty
135 ; let upat = unLoc pat
136 eqn = EqnInfo { eqn_pats = [upat],
137 eqn_rhs = cantFailMatchResult body_w_exports }
138 ; var <- selectMatchVar upat
139 ; result <- matchEquations PatBindRhs [var] [eqn] (exprType body)
140 ; return (scrungleMatch var rhs result) }
142 _ -> pprPanic "dsLet: unlifted" (pprLHsBinds hsbinds $$ ppr body)
145 -- Ordinary case for bindings; none should be unlifted
146 ds_val_bind (_is_rec, binds) body
147 = do { prs <- dsLHsBinds binds
148 ; ASSERT( not (any (isUnLiftedType . idType . fst) prs) )
151 _ -> return (Let (Rec prs) body) }
152 -- Use a Rec regardless of is_rec.
153 -- Why? Because it allows the binds to be all
154 -- mixed up, which is what happens in one rare case
155 -- Namely, for an AbsBind with no tyvars and no dicts,
156 -- but which does have dictionary bindings.
157 -- See notes with TcSimplify.inferLoop [NO TYVARS]
158 -- It turned out that wrapping a Rec here was the easiest solution
160 -- NB The previous case dealt with unlifted bindings, so we
161 -- only have to deal with lifted ones now; so Rec is ok
163 isUnboxedTupleBind :: HsBind Id -> Bool
164 isUnboxedTupleBind (PatBind { pat_rhs_ty = ty }) = isUnboxedTupleType ty
165 isUnboxedTupleBind _ = False
167 scrungleMatch :: Id -> CoreExpr -> CoreExpr -> CoreExpr
168 -- Returns something like (let var = scrut in body)
169 -- but if var is an unboxed-tuple type, it inlines it in a fragile way
170 -- Special case to handle unboxed tuple patterns; they can't appear nested
172 -- case e of (# p1, p2 #) -> rhs
174 -- case e of (# x1, x2 #) -> ... match p1, p2 ...
176 -- let x = e in case x of ....
178 -- But there may be a big
179 -- let fail = ... in case e of ...
180 -- wrapping the whole case, which complicates matters slightly
181 -- It all seems a bit fragile. Test is dsrun013.
183 scrungleMatch var scrut body
184 | isUnboxedTupleType (idType var) = scrungle body
185 | otherwise = bindNonRec var scrut body
187 scrungle (Case (Var x) bndr ty alts)
188 | x == var = Case scrut bndr ty alts
189 scrungle (Let binds body) = Let binds (scrungle body)
190 scrungle other = panic ("scrungleMatch: tuple pattern:\n" ++ showSDoc (ppr other))
194 %************************************************************************
196 \subsection[DsExpr-vars-and-cons]{Variables, constructors, literals}
198 %************************************************************************
201 dsLExpr :: LHsExpr Id -> DsM CoreExpr
203 dsLExpr (L loc e) = putSrcSpanDs loc $ dsExpr e
205 dsExpr :: HsExpr Id -> DsM CoreExpr
206 dsExpr (HsPar e) = dsLExpr e
207 dsExpr (ExprWithTySigOut e _) = dsLExpr e
208 dsExpr (HsVar var) = return (Var var)
209 dsExpr (HsIPVar ip) = return (Var (ipNameName ip))
210 dsExpr (HsLit lit) = dsLit lit
211 dsExpr (HsOverLit lit) = dsOverLit lit
212 dsExpr (HsWrap co_fn e) = dsCoercion co_fn (dsExpr e)
214 dsExpr (NegApp expr neg_expr)
215 = App <$> dsExpr neg_expr <*> dsLExpr expr
217 dsExpr (HsLam a_Match)
218 = uncurry mkLams <$> matchWrapper LambdaExpr a_Match
220 dsExpr (HsApp fun arg)
221 = mkCoreAppDs <$> dsLExpr fun <*> dsLExpr arg
224 Operator sections. At first it looks as if we can convert
233 But no! expr might be a redex, and we can lose laziness badly this
238 for example. So we convert instead to
240 let y = expr in \x -> op y x
242 If \tr{expr} is actually just a variable, say, then the simplifier
246 dsExpr (OpApp e1 op _ e2)
247 = -- for the type of y, we need the type of op's 2nd argument
248 mkCoreAppsDs <$> dsLExpr op <*> mapM dsLExpr [e1, e2]
250 dsExpr (SectionL expr op) -- Desugar (e !) to ((!) e)
251 = mkCoreAppDs <$> dsLExpr op <*> dsLExpr expr
253 -- dsLExpr (SectionR op expr) -- \ x -> op x expr
254 dsExpr (SectionR op expr) = do
255 core_op <- dsLExpr op
256 -- for the type of x, we need the type of op's 2nd argument
257 let (x_ty:y_ty:_, _) = splitFunTys (exprType core_op)
258 -- See comment with SectionL
259 y_core <- dsLExpr expr
260 x_id <- newSysLocalDs x_ty
261 y_id <- newSysLocalDs y_ty
262 return (bindNonRec y_id y_core $
263 Lam x_id (mkCoreAppsDs core_op [Var x_id, Var y_id]))
265 dsExpr (ExplicitTuple tup_args boxity)
266 = do { let go (lam_vars, args) (Missing ty)
267 -- For every missing expression, we need
268 -- another lambda in the desugaring.
269 = do { lam_var <- newSysLocalDs ty
270 ; return (lam_var : lam_vars, Var lam_var : args) }
271 go (lam_vars, args) (Present expr)
272 -- Expressions that are present don't generate
273 -- lambdas, just arguments.
274 = do { core_expr <- dsLExpr expr
275 ; return (lam_vars, core_expr : args) }
277 ; (lam_vars, args) <- foldM go ([], []) (reverse tup_args)
278 -- The reverse is because foldM goes left-to-right
280 ; return $ mkCoreLams lam_vars $
281 mkConApp (tupleCon boxity (length tup_args))
282 (map (Type . exprType) args ++ args) }
284 dsExpr (HsSCC cc expr) = do
285 mod_name <- getModuleDs
286 Note (SCC (mkUserCC cc mod_name)) <$> dsLExpr expr
289 -- hdaume: core annotation
291 dsExpr (HsCoreAnn fs expr)
292 = Note (CoreNote $ unpackFS fs) <$> dsLExpr expr
294 dsExpr (HsCase discrim matches@(MatchGroup _ rhs_ty))
295 | isEmptyMatchGroup matches -- A Core 'case' is always non-empty
296 = -- So desugar empty HsCase to error call
297 mkErrorAppDs pAT_ERROR_ID (funResultTy rhs_ty) (ptext (sLit "case"))
300 = do { core_discrim <- dsLExpr discrim
301 ; ([discrim_var], matching_code) <- matchWrapper CaseAlt matches
302 ; return (scrungleMatch discrim_var core_discrim matching_code) }
304 -- Pepe: The binds are in scope in the body but NOT in the binding group
305 -- This is to avoid silliness in breakpoints
306 dsExpr (HsLet binds body) = do
307 body' <- dsLExpr body
308 dsLocalBinds binds body'
310 -- We need the `ListComp' form to use `deListComp' (rather than the "do" form)
311 -- because the interpretation of `stmts' depends on what sort of thing it is.
313 dsExpr (HsDo ListComp stmts body result_ty)
314 = -- Special case for list comprehensions
315 dsListComp stmts body elt_ty
317 [elt_ty] = tcTyConAppArgs result_ty
319 dsExpr (HsDo DoExpr stmts body result_ty)
320 = dsDo stmts body result_ty
322 dsExpr (HsDo (MDoExpr tbl) stmts body result_ty)
323 = dsMDo tbl stmts body result_ty
325 dsExpr (HsDo PArrComp stmts body result_ty)
326 = -- Special case for array comprehensions
327 dsPArrComp (map unLoc stmts) body elt_ty
329 [elt_ty] = tcTyConAppArgs result_ty
331 dsExpr (HsIf guard_expr then_expr else_expr)
332 = mkIfThenElse <$> dsLExpr guard_expr <*> dsLExpr then_expr <*> dsLExpr else_expr
337 \underline{\bf Various data construction things}
338 % ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
340 dsExpr (ExplicitList elt_ty xs)
341 = dsExplicitList elt_ty xs
343 -- We desugar [:x1, ..., xn:] as
344 -- singletonP x1 +:+ ... +:+ singletonP xn
346 dsExpr (ExplicitPArr ty []) = do
347 emptyP <- dsLookupGlobalId emptyPName
348 return (Var emptyP `App` Type ty)
349 dsExpr (ExplicitPArr ty xs) = do
350 singletonP <- dsLookupGlobalId singletonPName
351 appP <- dsLookupGlobalId appPName
352 xs' <- mapM dsLExpr xs
353 return . foldr1 (binary appP) $ map (unary singletonP) xs'
355 unary fn x = mkApps (Var fn) [Type ty, x]
356 binary fn x y = mkApps (Var fn) [Type ty, x, y]
358 dsExpr (ArithSeq expr (From from))
359 = App <$> dsExpr expr <*> dsLExpr from
361 dsExpr (ArithSeq expr (FromTo from to))
362 = mkApps <$> dsExpr expr <*> mapM dsLExpr [from, to]
364 dsExpr (ArithSeq expr (FromThen from thn))
365 = mkApps <$> dsExpr expr <*> mapM dsLExpr [from, thn]
367 dsExpr (ArithSeq expr (FromThenTo from thn to))
368 = mkApps <$> dsExpr expr <*> mapM dsLExpr [from, thn, to]
370 dsExpr (PArrSeq expr (FromTo from to))
371 = mkApps <$> dsExpr expr <*> mapM dsLExpr [from, to]
373 dsExpr (PArrSeq expr (FromThenTo from thn to))
374 = mkApps <$> dsExpr expr <*> mapM dsLExpr [from, thn, to]
377 = panic "DsExpr.dsExpr: Infinite parallel array!"
378 -- the parser shouldn't have generated it and the renamer and typechecker
379 -- shouldn't have let it through
383 \underline{\bf Record construction and update}
384 % ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
385 For record construction we do this (assuming T has three arguments)
389 let err = /\a -> recConErr a
390 T (recConErr t1 "M.lhs/230/op1")
392 (recConErr t1 "M.lhs/230/op3")
394 @recConErr@ then converts its arugment string into a proper message
395 before printing it as
397 M.lhs, line 230: missing field op1 was evaluated
400 We also handle @C{}@ as valid construction syntax for an unlabelled
401 constructor @C@, setting all of @C@'s fields to bottom.
404 dsExpr (RecordCon (L _ data_con_id) con_expr rbinds) = do
405 con_expr' <- dsExpr con_expr
407 (arg_tys, _) = tcSplitFunTys (exprType con_expr')
408 -- A newtype in the corner should be opaque;
409 -- hence TcType.tcSplitFunTys
411 mk_arg (arg_ty, lbl) -- Selector id has the field label as its name
412 = case findField (rec_flds rbinds) lbl of
413 (rhs:rhss) -> ASSERT( null rhss )
415 [] -> mkErrorAppDs rEC_CON_ERROR_ID arg_ty (ppr lbl)
416 unlabelled_bottom arg_ty = mkErrorAppDs rEC_CON_ERROR_ID arg_ty empty
418 labels = dataConFieldLabels (idDataCon data_con_id)
419 -- The data_con_id is guaranteed to be the wrapper id of the constructor
421 con_args <- if null labels
422 then mapM unlabelled_bottom arg_tys
423 else mapM mk_arg (zipEqual "dsExpr:RecordCon" arg_tys labels)
425 return (mkApps con_expr' con_args)
428 Record update is a little harder. Suppose we have the decl:
430 data T = T1 {op1, op2, op3 :: Int}
431 | T2 {op4, op2 :: Int}
434 Then we translate as follows:
440 T1 op1 _ op3 -> T1 op1 op2 op3
441 T2 op4 _ -> T2 op4 op2
442 other -> recUpdError "M.lhs/230"
444 It's important that we use the constructor Ids for @T1@, @T2@ etc on the
445 RHSs, and do not generate a Core constructor application directly, because the constructor
446 might do some argument-evaluation first; and may have to throw away some
449 Note [Update for GADTs]
450 ~~~~~~~~~~~~~~~~~~~~~~~
453 T1 { f1 :: a } :: T a Int
455 Then the wrapper function for T1 has type
457 But if x::T a b, then
458 x { f1 = v } :: T a b (not T a Int!)
459 So we need to cast (T a Int) to (T a b). Sigh.
462 dsExpr expr@(RecordUpd record_expr (HsRecFields { rec_flds = fields })
463 cons_to_upd in_inst_tys out_inst_tys)
465 = dsLExpr record_expr
467 = ASSERT2( notNull cons_to_upd, ppr expr )
469 do { record_expr' <- dsLExpr record_expr
470 ; field_binds' <- mapM ds_field fields
471 ; let upd_fld_env :: NameEnv Id -- Maps field name to the LocalId of the field binding
472 upd_fld_env = mkNameEnv [(f,l) | (f,l,_) <- field_binds']
474 -- It's important to generate the match with matchWrapper,
475 -- and the right hand sides with applications of the wrapper Id
476 -- so that everything works when we are doing fancy unboxing on the
477 -- constructor aguments.
478 ; alts <- mapM (mk_alt upd_fld_env) cons_to_upd
479 ; ([discrim_var], matching_code)
480 <- matchWrapper RecUpd (MatchGroup alts in_out_ty)
482 ; return (add_field_binds field_binds' $
483 bindNonRec discrim_var record_expr' matching_code) }
485 ds_field :: HsRecField Id (LHsExpr Id) -> DsM (Name, Id, CoreExpr)
486 -- Clone the Id in the HsRecField, because its Name is that
487 -- of the record selector, and we must not make that a lcoal binder
488 -- else we shadow other uses of the record selector
489 -- Hence 'lcl_id'. Cf Trac #2735
490 ds_field rec_field = do { rhs <- dsLExpr (hsRecFieldArg rec_field)
491 ; let fld_id = unLoc (hsRecFieldId rec_field)
492 ; lcl_id <- newSysLocalDs (idType fld_id)
493 ; return (idName fld_id, lcl_id, rhs) }
495 add_field_binds [] expr = expr
496 add_field_binds ((_,b,r):bs) expr = bindNonRec b r (add_field_binds bs expr)
498 -- Awkwardly, for families, the match goes
499 -- from instance type to family type
500 tycon = dataConTyCon (head cons_to_upd)
501 in_ty = mkTyConApp tycon in_inst_tys
502 in_out_ty = mkFunTy in_ty (mkFamilyTyConApp tycon out_inst_tys)
504 mk_alt upd_fld_env con
505 = do { let (univ_tvs, ex_tvs, eq_spec,
506 eq_theta, dict_theta, arg_tys, _) = dataConFullSig con
507 subst = mkTopTvSubst (univ_tvs `zip` in_inst_tys)
509 -- I'm not bothering to clone the ex_tvs
510 ; eqs_vars <- mapM newPredVarDs (substTheta subst (eqSpecPreds eq_spec))
511 ; theta_vars <- mapM newPredVarDs (substTheta subst (eq_theta ++ dict_theta))
512 ; arg_ids <- newSysLocalsDs (substTys subst arg_tys)
513 ; let val_args = zipWithEqual "dsExpr:RecordUpd" mk_val_arg
514 (dataConFieldLabels con) arg_ids
515 mk_val_arg field_name pat_arg_id
516 = nlHsVar (lookupNameEnv upd_fld_env field_name `orElse` pat_arg_id)
517 inst_con = noLoc $ HsWrap wrap (HsVar (dataConWrapId con))
518 -- Reconstruct with the WrapId so that unpacking happens
519 wrap = mkWpApps theta_vars `WpCompose`
520 mkWpTyApps (mkTyVarTys ex_tvs) `WpCompose`
521 mkWpTyApps [ty | (tv, ty) <- univ_tvs `zip` out_inst_tys
522 , isNothing (lookupTyVar wrap_subst tv) ]
523 rhs = foldl (\a b -> nlHsApp a b) inst_con val_args
525 -- Tediously wrap the application in a cast
526 -- Note [Update for GADTs]
527 wrapped_rhs | null eq_spec = rhs
528 | otherwise = mkLHsWrap (WpCast wrap_co) rhs
529 wrap_co = mkTyConApp tycon [ lookup tv ty
530 | (tv,ty) <- univ_tvs `zip` out_inst_tys]
531 lookup univ_tv ty = case lookupTyVar wrap_subst univ_tv of
534 wrap_subst = mkTopTvSubst [ (tv,mkSymCoercion (mkTyVarTy co_var))
535 | ((tv,_),co_var) <- eq_spec `zip` eqs_vars ]
537 pat = noLoc $ ConPatOut { pat_con = noLoc con, pat_tvs = ex_tvs
538 , pat_dicts = eqs_vars ++ theta_vars
539 , pat_binds = emptyLHsBinds
540 , pat_args = PrefixCon $ map nlVarPat arg_ids
542 ; return (mkSimpleMatch [pat] wrapped_rhs) }
546 Here is where we desugar the Template Haskell brackets and escapes
549 -- Template Haskell stuff
551 #ifdef GHCI /* Only if bootstrapping */
552 dsExpr (HsBracketOut x ps) = dsBracket x ps
553 dsExpr (HsSpliceE s) = pprPanic "dsExpr:splice" (ppr s)
556 -- Arrow notation extension
557 dsExpr (HsProc pat cmd) = dsProcExpr pat cmd
563 dsExpr (HsTick ix vars e) = do
567 -- There is a problem here. The then and else branches
568 -- have no free variables, so they are open to lifting.
569 -- We need someway of stopping this.
570 -- This will make no difference to binary coverage
571 -- (did you go here: YES or NO), but will effect accurate
574 dsExpr (HsBinTick ixT ixF e) = do
576 do { ASSERT(exprType e2 `coreEqType` boolTy)
577 mkBinaryTickBox ixT ixF e2
583 -- HsSyn constructs that just shouldn't be here:
584 dsExpr (ExprWithTySig _ _) = panic "dsExpr:ExprWithTySig"
587 findField :: [HsRecField Id arg] -> Name -> [arg]
589 = [rhs | HsRecField { hsRecFieldId = id, hsRecFieldArg = rhs } <- rbinds
590 , lbl == idName (unLoc id) ]
593 %--------------------------------------------------------------------
595 Note [Desugaring explicit lists]
596 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
597 Explicit lists are desugared in a cleverer way to prevent some
598 fruitless allocations. Essentially, whenever we see a list literal
601 1. Find the tail of the list that can be allocated statically (say
602 [x_k, ..., x_n]) by later stages and ensure we desugar that
603 normally: this makes sure that we don't cause a code size increase
604 by having the cons in that expression fused (see later) and hence
605 being unable to statically allocate any more
607 2. For the prefix of the list which cannot be allocated statically,
608 say [x_1, ..., x_(k-1)], we turn it into an expression involving
609 build so that if we find any foldrs over it it will fuse away
612 So in this example we will desugar to:
613 build (\c n -> x_1 `c` x_2 `c` .... `c` foldr c n [x_k, ..., x_n]
615 If fusion fails to occur then build will get inlined and (since we
616 defined a RULE for foldr (:) []) we will get back exactly the
617 normal desugaring for an explicit list.
619 This optimisation can be worth a lot: up to 25% of the total
620 allocation in some nofib programs. Specifically
622 Program Size Allocs Runtime CompTime
623 rewrite +0.0% -26.3% 0.02 -1.8%
624 ansi -0.3% -13.8% 0.00 +0.0%
625 lift +0.0% -8.7% 0.00 -2.3%
627 Of course, if rules aren't turned on then there is pretty much no
628 point doing this fancy stuff, and it may even be harmful.
630 =======> Note by SLPJ Dec 08.
632 I'm unconvinced that we should *ever* generate a build for an explicit
633 list. See the comments in GHC.Base about the foldr/cons rule, which
634 points out that (foldr k z [a,b,c]) may generate *much* less code than
635 (a `k` b `k` c `k` z).
637 Furthermore generating builds messes up the LHS of RULES.
638 Example: the foldr/single rule in GHC.Base
640 We do not want to generate a build invocation on the LHS of this RULE!
642 To test this I've added a (static) flag -fsimple-list-literals, which
643 makes all list literals be generated via the simple route.
648 dsExplicitList :: PostTcType -> [LHsExpr Id] -> DsM CoreExpr
649 -- See Note [Desugaring explicit lists]
650 dsExplicitList elt_ty xs = do
652 xs' <- mapM dsLExpr xs
653 if opt_SimpleListLiterals || not (dopt Opt_EnableRewriteRules dflags)
654 then return $ mkListExpr elt_ty xs'
655 else mkBuildExpr elt_ty (mkSplitExplicitList (thisPackage dflags) xs')
657 mkSplitExplicitList this_package xs' (c, _) (n, n_ty) = do
658 let (dynamic_prefix, static_suffix) = spanTail (rhsIsStatic this_package) xs'
659 static_suffix' = mkListExpr elt_ty static_suffix
661 folded_static_suffix <- mkFoldrExpr elt_ty n_ty (Var c) (Var n) static_suffix'
662 let build_body = foldr (App . App (Var c)) folded_static_suffix dynamic_prefix
665 spanTail :: (a -> Bool) -> [a] -> ([a], [a])
666 spanTail f xs = (reverse rejected, reverse satisfying)
667 where (satisfying, rejected) = span f $ reverse xs
670 Desugar 'do' and 'mdo' expressions (NOT list comprehensions, they're
671 handled in DsListComp). Basically does the translation given in the
677 -> Type -- Type of the whole expression
680 dsDo stmts body result_ty
683 -- result_ty must be of the form (m b)
684 (m_ty, _b_ty) = tcSplitAppTy result_ty
686 goL [] = dsLExpr body
687 goL ((L loc stmt):lstmts) = putSrcSpanDs loc (go loc stmt lstmts)
689 go _ (ExprStmt rhs then_expr _) stmts
690 = do { rhs2 <- dsLExpr rhs
691 ; case tcSplitAppTy_maybe (exprType rhs2) of
692 Just (container_ty, returning_ty) -> warnDiscardedDoBindings rhs container_ty returning_ty
694 ; then_expr2 <- dsExpr then_expr
696 ; return (mkApps then_expr2 [rhs2, rest]) }
698 go _ (LetStmt binds) stmts
699 = do { rest <- goL stmts
700 ; dsLocalBinds binds rest }
702 go _ (BindStmt pat rhs bind_op fail_op) stmts
703 = do { body <- goL stmts
704 ; rhs' <- dsLExpr rhs
705 ; bind_op' <- dsExpr bind_op
706 ; var <- selectSimpleMatchVarL pat
707 ; let bind_ty = exprType bind_op' -- rhs -> (pat -> res1) -> res2
708 res1_ty = funResultTy (funArgTy (funResultTy bind_ty))
709 ; match <- matchSinglePat (Var var) (StmtCtxt DoExpr) pat
710 res1_ty (cantFailMatchResult body)
711 ; match_code <- handle_failure pat match fail_op
712 ; return (mkApps bind_op' [rhs', Lam var match_code]) }
714 go loc (RecStmt { recS_stmts = rec_stmts, recS_later_ids = later_ids
715 , recS_rec_ids = rec_ids, recS_ret_fn = return_op
716 , recS_mfix_fn = mfix_op, recS_bind_fn = bind_op
717 , recS_rec_rets = rec_rets, recS_dicts = binds }) stmts
718 = ASSERT( length rec_ids > 0 )
719 goL (new_bind_stmt : let_stmt : stmts)
721 -- returnE <- dsExpr return_id
722 -- mfixE <- dsExpr mfix_id
723 new_bind_stmt = L loc $ BindStmt (mkLHsPatTup later_pats) mfix_app
725 noSyntaxExpr -- Tuple cannot fail
727 let_stmt = L loc $ LetStmt (HsValBinds (ValBindsOut [(Recursive, binds)] []))
729 tup_ids = rec_ids ++ filterOut (`elem` rec_ids) later_ids
730 rec_tup_pats = map nlVarPat tup_ids
731 later_pats = rec_tup_pats
732 rets = map noLoc rec_rets
734 mfix_app = nlHsApp (noLoc mfix_op) mfix_arg
735 mfix_arg = noLoc $ HsLam (MatchGroup [mkSimpleMatch [mfix_pat] body]
736 (mkFunTy tup_ty body_ty))
737 mfix_pat = noLoc $ LazyPat $ mkLHsPatTup rec_tup_pats
738 body = noLoc $ HsDo DoExpr rec_stmts return_app body_ty
739 return_app = nlHsApp (noLoc return_op) (mkLHsTupleExpr rets)
740 body_ty = mkAppTy m_ty tup_ty
741 tup_ty = mkCoreTupTy (map idType tup_ids)
742 -- mkCoreTupTy deals with singleton case
744 -- In a do expression, pattern-match failure just calls
745 -- the monadic 'fail' rather than throwing an exception
746 handle_failure pat match fail_op
748 = do { fail_op' <- dsExpr fail_op
749 ; fail_msg <- mkStringExpr (mk_fail_msg pat)
750 ; extractMatchResult match (App fail_op' fail_msg) }
752 = extractMatchResult match (error "It can't fail")
754 mk_fail_msg :: Located e -> String
755 mk_fail_msg pat = "Pattern match failure in do expression at " ++
756 showSDoc (ppr (getLoc pat))
759 Translation for RecStmt's:
760 -----------------------------
761 We turn (RecStmt [v1,..vn] stmts) into:
763 (v1,..,vn) <- mfix (\~(v1,..vn). do stmts
770 -> Type -- Type of the whole expression
773 dsMDo tbl stmts body result_ty
776 goL [] = dsLExpr body
777 goL ((L loc stmt):lstmts) = putSrcSpanDs loc (go loc stmt lstmts)
779 (m_ty, b_ty) = tcSplitAppTy result_ty -- result_ty must be of the form (m b)
780 mfix_id = lookupEvidence tbl mfixName
781 return_id = lookupEvidence tbl returnMName
782 bind_id = lookupEvidence tbl bindMName
783 then_id = lookupEvidence tbl thenMName
784 fail_id = lookupEvidence tbl failMName
787 go _ (LetStmt binds) stmts
788 = do { rest <- goL stmts
789 ; dsLocalBinds binds rest }
791 go _ (ExprStmt rhs _ rhs_ty) stmts
792 = do { rhs2 <- dsLExpr rhs
793 ; warnDiscardedDoBindings rhs m_ty rhs_ty
795 ; return (mkApps (Var then_id) [Type rhs_ty, Type b_ty, rhs2, rest]) }
797 go _ (BindStmt pat rhs _ _) stmts
798 = do { body <- goL stmts
799 ; var <- selectSimpleMatchVarL pat
800 ; match <- matchSinglePat (Var var) (StmtCtxt ctxt) pat
801 result_ty (cantFailMatchResult body)
802 ; fail_msg <- mkStringExpr (mk_fail_msg pat)
803 ; let fail_expr = mkApps (Var fail_id) [Type b_ty, fail_msg]
804 ; match_code <- extractMatchResult match fail_expr
806 ; rhs' <- dsLExpr rhs
807 ; return (mkApps (Var bind_id) [Type (hsLPatType pat), Type b_ty,
808 rhs', Lam var match_code]) }
810 go loc (RecStmt rec_stmts later_ids rec_ids _ _ _ rec_rets binds) stmts
811 = ASSERT( length rec_ids > 0 )
812 ASSERT( length rec_ids == length rec_rets )
813 pprTrace "dsMDo" (ppr later_ids) $
814 goL (new_bind_stmt : let_stmt : stmts)
816 new_bind_stmt = L loc $ mkBindStmt (mk_tup_pat later_pats) mfix_app
817 let_stmt = L loc $ LetStmt (HsValBinds (ValBindsOut [(Recursive, binds)] []))
820 -- Remove the later_ids that appear (without fancy coercions)
821 -- in rec_rets, because there's no need to knot-tie them separately
822 -- See Note [RecStmt] in HsExpr
823 later_ids' = filter (`notElem` mono_rec_ids) later_ids
824 mono_rec_ids = [ id | HsVar id <- rec_rets ]
826 mfix_app = nlHsApp (nlHsTyApp mfix_id [tup_ty]) mfix_arg
827 mfix_arg = noLoc $ HsLam (MatchGroup [mkSimpleMatch [mfix_pat] body]
828 (mkFunTy tup_ty body_ty))
830 -- The rec_tup_pat must bind the rec_ids only; remember that the
831 -- trimmed_laters may share the same Names
832 -- Meanwhile, the later_pats must bind the later_vars
833 rec_tup_pats = map mk_wild_pat later_ids' ++ map nlVarPat rec_ids
834 later_pats = map nlVarPat later_ids' ++ map mk_later_pat rec_ids
835 rets = map nlHsVar later_ids' ++ map noLoc rec_rets
837 mfix_pat = noLoc $ LazyPat $ mk_tup_pat rec_tup_pats
838 body = noLoc $ HsDo ctxt rec_stmts return_app body_ty
839 body_ty = mkAppTy m_ty tup_ty
840 tup_ty = mkCoreTupTy (map idType (later_ids' ++ rec_ids))
841 -- mkCoreTupTy deals with singleton case
843 return_app = nlHsApp (nlHsTyApp return_id [tup_ty])
844 (mkLHsTupleExpr rets)
846 mk_wild_pat :: Id -> LPat Id
847 mk_wild_pat v = noLoc $ WildPat $ idType v
849 mk_later_pat :: Id -> LPat Id
850 mk_later_pat v | v `elem` later_ids' = mk_wild_pat v
851 | otherwise = nlVarPat v
853 mk_tup_pat :: [LPat Id] -> LPat Id
855 mk_tup_pat ps = noLoc $ mkVanillaTuplePat ps Boxed
859 %************************************************************************
861 \subsection{Errors and contexts}
863 %************************************************************************
866 -- Warn about certain types of values discarded in monadic bindings (#3263)
867 warnDiscardedDoBindings :: LHsExpr Id -> Type -> Type -> DsM ()
868 warnDiscardedDoBindings rhs container_ty returning_ty = do {
869 -- Warn about discarding non-() things in 'monadic' binding
870 ; warn_unused <- doptDs Opt_WarnUnusedDoBind
871 ; if warn_unused && not (returning_ty `tcEqType` unitTy)
872 then warnDs (unusedMonadBind rhs returning_ty)
874 -- Warn about discarding m a things in 'monadic' binding of the same type,
875 -- but only if we didn't already warn due to Opt_WarnUnusedDoBind
876 ; warn_wrong <- doptDs Opt_WarnWrongDoBind
877 ; case tcSplitAppTy_maybe returning_ty of
878 Just (returning_container_ty, _) -> when (warn_wrong && container_ty `tcEqType` returning_container_ty) $
879 warnDs (wrongMonadBind rhs returning_ty)
882 unusedMonadBind :: LHsExpr Id -> Type -> SDoc
883 unusedMonadBind rhs returning_ty
884 = ptext (sLit "A do-notation statement discarded a result of type") <+> ppr returning_ty <> dot $$
885 ptext (sLit "Suppress this warning by saying \"_ <- ") <> ppr rhs <> ptext (sLit "\",") $$
886 ptext (sLit "or by using the flag -fno-warn-unused-do-bind")
888 wrongMonadBind :: LHsExpr Id -> Type -> SDoc
889 wrongMonadBind rhs returning_ty
890 = ptext (sLit "A do-notation statement discarded a result of type") <+> ppr returning_ty <> dot $$
891 ptext (sLit "Suppress this warning by saying \"_ <- ") <> ppr rhs <> ptext (sLit "\",") $$
892 ptext (sLit "or by using the flag -fno-warn-wrong-do-bind")