TTG3 Combined Step 1 and 3 for Trees That Grow
[ghc.git] / compiler / deSugar / DsExpr.hs
1 {-
2 (c) The University of Glasgow 2006
3 (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
4
5
6 Desugaring exporessions.
7 -}
8
9 {-# LANGUAGE CPP, MultiWayIf #-}
10 {-# LANGUAGE TypeFamilies #-}
11
12 module DsExpr ( dsExpr, dsLExpr, dsLExprNoLP, dsLocalBinds
13 , dsValBinds, dsLit, dsSyntaxExpr ) where
14
15 #include "HsVersions.h"
16
17 import GhcPrelude
18
19 import Match
20 import MatchLit
21 import DsBinds
22 import DsGRHSs
23 import DsListComp
24 import DsUtils
25 import DsArrows
26 import DsMonad
27 import Name
28 import NameEnv
29 import FamInstEnv( topNormaliseType )
30 import DsMeta
31 import HsSyn
32
33 -- NB: The desugarer, which straddles the source and Core worlds, sometimes
34 -- needs to see source types
35 import TcType
36 import TcEvidence
37 import TcRnMonad
38 import TcHsSyn
39 import Type
40 import CoreSyn
41 import CoreUtils
42 import MkCore
43
44 import DynFlags
45 import CostCentre
46 import Id
47 import MkId
48 import Module
49 import ConLike
50 import DataCon
51 import TysWiredIn
52 import PrelNames
53 import BasicTypes
54 import Maybes
55 import VarEnv
56 import SrcLoc
57 import Util
58 import Bag
59 import Outputable
60 import PatSyn
61
62 import Control.Monad
63
64 {-
65 ************************************************************************
66 * *
67 dsLocalBinds, dsValBinds
68 * *
69 ************************************************************************
70 -}
71
72 dsLocalBinds :: LHsLocalBinds GhcTc -> CoreExpr -> DsM CoreExpr
73 dsLocalBinds (L _ EmptyLocalBinds) body = return body
74 dsLocalBinds (L loc (HsValBinds binds)) body = putSrcSpanDs loc $
75 dsValBinds binds body
76 dsLocalBinds (L _ (HsIPBinds binds)) body = dsIPBinds binds body
77
78 -------------------------
79 -- caller sets location
80 dsValBinds :: HsValBinds GhcTc -> CoreExpr -> DsM CoreExpr
81 dsValBinds (XValBindsLR (NValBinds binds _)) body
82 = foldrM ds_val_bind body binds
83 dsValBinds (ValBinds {}) _ = panic "dsValBinds ValBindsIn"
84
85 -------------------------
86 dsIPBinds :: HsIPBinds GhcTc -> CoreExpr -> DsM CoreExpr
87 dsIPBinds (IPBinds ip_binds ev_binds) body
88 = do { ds_binds <- dsTcEvBinds ev_binds
89 ; let inner = mkCoreLets ds_binds body
90 -- The dict bindings may not be in
91 -- dependency order; hence Rec
92 ; foldrM ds_ip_bind inner ip_binds }
93 where
94 ds_ip_bind (L _ (IPBind ~(Right n) e)) body
95 = do e' <- dsLExpr e
96 return (Let (NonRec n e') body)
97
98 -------------------------
99 -- caller sets location
100 ds_val_bind :: (RecFlag, LHsBinds GhcTc) -> CoreExpr -> DsM CoreExpr
101 -- Special case for bindings which bind unlifted variables
102 -- We need to do a case right away, rather than building
103 -- a tuple and doing selections.
104 -- Silently ignore INLINE and SPECIALISE pragmas...
105 ds_val_bind (NonRecursive, hsbinds) body
106 | [L loc bind] <- bagToList hsbinds
107 -- Non-recursive, non-overloaded bindings only come in ones
108 -- ToDo: in some bizarre case it's conceivable that there
109 -- could be dict binds in the 'binds'. (See the notes
110 -- below. Then pattern-match would fail. Urk.)
111 , isUnliftedHsBind bind
112 = putSrcSpanDs loc $
113 -- see Note [Strict binds checks] in DsBinds
114 if is_polymorphic bind
115 then errDsCoreExpr (poly_bind_err bind)
116 -- data Ptr a = Ptr Addr#
117 -- f x = let p@(Ptr y) = ... in ...
118 -- Here the binding for 'p' is polymorphic, but does
119 -- not mix with an unlifted binding for 'y'. You should
120 -- use a bang pattern. Trac #6078.
121
122 else do { when (looksLazyPatBind bind) $
123 warnIfSetDs Opt_WarnUnbangedStrictPatterns (unlifted_must_be_bang bind)
124 -- Complain about a binding that looks lazy
125 -- e.g. let I# y = x in ...
126 -- Remember, in checkStrictBinds we are going to do strict
127 -- matching, so (for software engineering reasons) we insist
128 -- that the strictness is manifest on each binding
129 -- However, lone (unboxed) variables are ok
130
131
132 ; dsUnliftedBind bind body }
133 where
134 is_polymorphic (AbsBinds { abs_tvs = tvs, abs_ev_vars = evs })
135 = not (null tvs && null evs)
136 is_polymorphic _ = False
137
138 unlifted_must_be_bang bind
139 = hang (text "Pattern bindings containing unlifted types should use" $$
140 text "an outermost bang pattern:")
141 2 (ppr bind)
142
143 poly_bind_err bind
144 = hang (text "You can't mix polymorphic and unlifted bindings:")
145 2 (ppr bind) $$
146 text "Probable fix: add a type signature"
147
148 ds_val_bind (is_rec, binds) _body
149 | anyBag (isUnliftedHsBind . unLoc) binds -- see Note [Strict binds checks] in DsBinds
150 = ASSERT( isRec is_rec )
151 errDsCoreExpr $
152 hang (text "Recursive bindings for unlifted types aren't allowed:")
153 2 (vcat (map ppr (bagToList binds)))
154
155 -- Ordinary case for bindings; none should be unlifted
156 ds_val_bind (is_rec, binds) body
157 = do { MASSERT( isRec is_rec || isSingletonBag binds )
158 -- we should never produce a non-recursive list of multiple binds
159
160 ; (force_vars,prs) <- dsLHsBinds binds
161 ; let body' = foldr seqVar body force_vars
162 ; ASSERT2( not (any (isUnliftedType . idType . fst) prs), ppr is_rec $$ ppr binds )
163 case prs of
164 [] -> return body
165 _ -> return (Let (Rec prs) body') }
166 -- Use a Rec regardless of is_rec.
167 -- Why? Because it allows the binds to be all
168 -- mixed up, which is what happens in one rare case
169 -- Namely, for an AbsBind with no tyvars and no dicts,
170 -- but which does have dictionary bindings.
171 -- See notes with TcSimplify.inferLoop [NO TYVARS]
172 -- It turned out that wrapping a Rec here was the easiest solution
173 --
174 -- NB The previous case dealt with unlifted bindings, so we
175 -- only have to deal with lifted ones now; so Rec is ok
176
177 ------------------
178 dsUnliftedBind :: HsBind GhcTc -> CoreExpr -> DsM CoreExpr
179 dsUnliftedBind (AbsBinds { abs_tvs = [], abs_ev_vars = []
180 , abs_exports = exports
181 , abs_ev_binds = ev_binds
182 , abs_binds = lbinds }) body
183 = do { let body1 = foldr bind_export body exports
184 bind_export export b = bindNonRec (abe_poly export) (Var (abe_mono export)) b
185 ; body2 <- foldlBagM (\body lbind -> dsUnliftedBind (unLoc lbind) body)
186 body1 lbinds
187 ; ds_binds <- dsTcEvBinds_s ev_binds
188 ; return (mkCoreLets ds_binds body2) }
189
190 dsUnliftedBind (FunBind { fun_id = L l fun
191 , fun_matches = matches
192 , fun_co_fn = co_fn
193 , fun_tick = tick }) body
194 -- Can't be a bang pattern (that looks like a PatBind)
195 -- so must be simply unboxed
196 = do { (args, rhs) <- matchWrapper (mkPrefixFunRhs (L l $ idName fun))
197 Nothing matches
198 ; MASSERT( null args ) -- Functions aren't lifted
199 ; MASSERT( isIdHsWrapper co_fn )
200 ; let rhs' = mkOptTickBox tick rhs
201 ; return (bindNonRec fun rhs' body) }
202
203 dsUnliftedBind (PatBind {pat_lhs = pat, pat_rhs = grhss, pat_rhs_ty = ty }) body
204 = -- let C x# y# = rhs in body
205 -- ==> case rhs of C x# y# -> body
206 do { rhs <- dsGuarded grhss ty
207 ; let upat = unLoc pat
208 eqn = EqnInfo { eqn_pats = [upat],
209 eqn_rhs = cantFailMatchResult body }
210 ; var <- selectMatchVar upat
211 ; result <- matchEquations PatBindRhs [var] [eqn] (exprType body)
212 ; return (bindNonRec var rhs result) }
213
214 dsUnliftedBind bind body = pprPanic "dsLet: unlifted" (ppr bind $$ ppr body)
215
216 {-
217 ************************************************************************
218 * *
219 \subsection[DsExpr-vars-and-cons]{Variables, constructors, literals}
220 * *
221 ************************************************************************
222 -}
223
224 dsLExpr :: LHsExpr GhcTc -> DsM CoreExpr
225
226 dsLExpr (L loc e)
227 = putSrcSpanDs loc $
228 do { core_expr <- dsExpr e
229 -- uncomment this check to test the hsExprType function in TcHsSyn
230 -- ; MASSERT2( exprType core_expr `eqType` hsExprType e
231 -- , ppr e <+> dcolon <+> ppr (hsExprType e) $$
232 -- ppr core_expr <+> dcolon <+> ppr (exprType core_expr) )
233 ; return core_expr }
234
235 -- | Variant of 'dsLExpr' that ensures that the result is not levity
236 -- polymorphic. This should be used when the resulting expression will
237 -- be an argument to some other function.
238 -- See Note [Levity polymorphism checking] in DsMonad
239 -- See Note [Levity polymorphism invariants] in CoreSyn
240 dsLExprNoLP :: LHsExpr GhcTc -> DsM CoreExpr
241 dsLExprNoLP (L loc e)
242 = putSrcSpanDs loc $
243 do { e' <- dsExpr e
244 ; dsNoLevPolyExpr e' (text "In the type of expression:" <+> ppr e)
245 ; return e' }
246
247 dsExpr :: HsExpr GhcTc -> DsM CoreExpr
248 dsExpr = ds_expr False
249
250 ds_expr :: Bool -- are we directly inside an HsWrap?
251 -- See Wrinkle in Note [Detecting forced eta expansion]
252 -> HsExpr GhcTc -> DsM CoreExpr
253 ds_expr _ (HsPar _ e) = dsLExpr e
254 ds_expr _ (ExprWithTySig _ e) = dsLExpr e
255 ds_expr w (HsVar _ (L _ var)) = dsHsVar w var
256 ds_expr _ (HsUnboundVar {}) = panic "dsExpr: HsUnboundVar" -- Typechecker eliminates them
257 ds_expr w (HsConLikeOut _ con) = dsConLike w con
258 ds_expr _ (HsIPVar {}) = panic "dsExpr: HsIPVar"
259 ds_expr _ (HsOverLabel{}) = panic "dsExpr: HsOverLabel"
260 ds_expr _ (HsLit _ lit) = dsLit (convertLit lit)
261 ds_expr _ (HsOverLit _ lit) = dsOverLit lit
262 ds_expr _ (XExpr {}) = panic "dsExpr: XExpr"
263
264 ds_expr _ (HsWrap _ co_fn e)
265 = do { e' <- ds_expr True e
266 ; wrap' <- dsHsWrapper co_fn
267 ; dflags <- getDynFlags
268 ; let wrapped_e = wrap' e'
269 wrapped_ty = exprType wrapped_e
270 ; checkForcedEtaExpansion e wrapped_ty -- See Note [Detecting forced eta expansion]
271 ; warnAboutIdentities dflags e' wrapped_ty
272 ; return wrapped_e }
273
274 ds_expr _ (NegApp _ (L loc (HsOverLit _ lit@(OverLit { ol_val = HsIntegral i})))
275 neg_expr)
276 = do { expr' <- putSrcSpanDs loc $ do
277 { dflags <- getDynFlags
278 ; warnAboutOverflowedLiterals dflags
279 (lit { ol_val = HsIntegral (negateIntegralLit i) })
280 ; dsOverLit' dflags lit }
281 ; dsSyntaxExpr neg_expr [expr'] }
282
283 ds_expr _ (NegApp _ expr neg_expr)
284 = do { expr' <- dsLExpr expr
285 ; dsSyntaxExpr neg_expr [expr'] }
286
287 ds_expr _ (HsLam _ a_Match)
288 = uncurry mkLams <$> matchWrapper LambdaExpr Nothing a_Match
289
290 ds_expr _ (HsLamCase _ matches)
291 = do { ([discrim_var], matching_code) <- matchWrapper CaseAlt Nothing matches
292 ; return $ Lam discrim_var matching_code }
293
294 ds_expr _ e@(HsApp _ fun arg)
295 = do { fun' <- dsLExpr fun
296 ; dsWhenNoErrs (dsLExprNoLP arg)
297 (\arg' -> mkCoreAppDs (text "HsApp" <+> ppr e) fun' arg') }
298
299 ds_expr _ (HsAppType _ e)
300 -- ignore type arguments here; they're in the wrappers instead at this point
301 = dsLExpr e
302
303
304 {-
305 Note [Desugaring vars]
306 ~~~~~~~~~~~~~~~~~~~~~~
307 In one situation we can get a *coercion* variable in a HsVar, namely
308 the support method for an equality superclass:
309 class (a~b) => C a b where ...
310 instance (blah) => C (T a) (T b) where ..
311 Then we get
312 $dfCT :: forall ab. blah => C (T a) (T b)
313 $dfCT ab blah = MkC ($c$p1C a blah) ($cop a blah)
314
315 $c$p1C :: forall ab. blah => (T a ~ T b)
316 $c$p1C ab blah = let ...; g :: T a ~ T b = ... } in g
317
318 That 'g' in the 'in' part is an evidence variable, and when
319 converting to core it must become a CO.
320
321 Operator sections. At first it looks as if we can convert
322 \begin{verbatim}
323 (expr op)
324 \end{verbatim}
325 to
326 \begin{verbatim}
327 \x -> op expr x
328 \end{verbatim}
329
330 But no! expr might be a redex, and we can lose laziness badly this
331 way. Consider
332 \begin{verbatim}
333 map (expr op) xs
334 \end{verbatim}
335 for example. So we convert instead to
336 \begin{verbatim}
337 let y = expr in \x -> op y x
338 \end{verbatim}
339 If \tr{expr} is actually just a variable, say, then the simplifier
340 will sort it out.
341 -}
342
343 ds_expr _ e@(OpApp _ e1 op e2)
344 = -- for the type of y, we need the type of op's 2nd argument
345 do { op' <- dsLExpr op
346 ; dsWhenNoErrs (mapM dsLExprNoLP [e1, e2])
347 (\exprs' -> mkCoreAppsDs (text "opapp" <+> ppr e) op' exprs') }
348
349 ds_expr _ (SectionL _ expr op) -- Desugar (e !) to ((!) e)
350 = do { op' <- dsLExpr op
351 ; dsWhenNoErrs (dsLExprNoLP expr)
352 (\expr' -> mkCoreAppDs (text "sectionl" <+> ppr expr) op' expr') }
353
354 -- dsLExpr (SectionR op expr) -- \ x -> op x expr
355 ds_expr _ e@(SectionR _ op expr) = do
356 core_op <- dsLExpr op
357 -- for the type of x, we need the type of op's 2nd argument
358 let (x_ty:y_ty:_, _) = splitFunTys (exprType core_op)
359 -- See comment with SectionL
360 y_core <- dsLExpr expr
361 dsWhenNoErrs (mapM newSysLocalDsNoLP [x_ty, y_ty])
362 (\[x_id, y_id] -> bindNonRec y_id y_core $
363 Lam x_id (mkCoreAppsDs (text "sectionr" <+> ppr e)
364 core_op [Var x_id, Var y_id]))
365
366 ds_expr _ (ExplicitTuple _ tup_args boxity)
367 = do { let go (lam_vars, args) (L _ (Missing ty))
368 -- For every missing expression, we need
369 -- another lambda in the desugaring.
370 = do { lam_var <- newSysLocalDsNoLP ty
371 ; return (lam_var : lam_vars, Var lam_var : args) }
372 go (lam_vars, args) (L _ (Present _ expr))
373 -- Expressions that are present don't generate
374 -- lambdas, just arguments.
375 = do { core_expr <- dsLExprNoLP expr
376 ; return (lam_vars, core_expr : args) }
377 go _ (L _ (XTupArg {})) = panic "ds_expr"
378
379 ; dsWhenNoErrs (foldM go ([], []) (reverse tup_args))
380 -- The reverse is because foldM goes left-to-right
381 (\(lam_vars, args) -> mkCoreLams lam_vars $
382 mkCoreTupBoxity boxity args) }
383
384 ds_expr _ (ExplicitSum types alt arity expr)
385 = do { dsWhenNoErrs (dsLExprNoLP expr)
386 (\core_expr -> mkCoreConApps (sumDataCon alt arity)
387 (map (Type . getRuntimeRep) types ++
388 map Type types ++
389 [core_expr]) ) }
390
391 ds_expr _ (HsSCC _ _ cc expr@(L loc _)) = do
392 dflags <- getDynFlags
393 if gopt Opt_SccProfilingOn dflags
394 then do
395 mod_name <- getModule
396 count <- goptM Opt_ProfCountEntries
397 uniq <- newUnique
398 Tick (ProfNote (mkUserCC (sl_fs cc) mod_name loc uniq) count True)
399 <$> dsLExpr expr
400 else dsLExpr expr
401
402 ds_expr _ (HsCoreAnn _ _ _ expr)
403 = dsLExpr expr
404
405 ds_expr _ (HsCase _ discrim matches)
406 = do { core_discrim <- dsLExpr discrim
407 ; ([discrim_var], matching_code) <- matchWrapper CaseAlt (Just discrim) matches
408 ; return (bindNonRec discrim_var core_discrim matching_code) }
409
410 -- Pepe: The binds are in scope in the body but NOT in the binding group
411 -- This is to avoid silliness in breakpoints
412 ds_expr _ (HsLet _ binds body) = do
413 body' <- dsLExpr body
414 dsLocalBinds binds body'
415
416 -- We need the `ListComp' form to use `deListComp' (rather than the "do" form)
417 -- because the interpretation of `stmts' depends on what sort of thing it is.
418 --
419 ds_expr _ (HsDo res_ty ListComp (L _ stmts)) = dsListComp stmts res_ty
420 ds_expr _ (HsDo _ PArrComp (L _ stmts)) = dsPArrComp (map unLoc stmts)
421 ds_expr _ (HsDo _ DoExpr (L _ stmts)) = dsDo stmts
422 ds_expr _ (HsDo _ GhciStmtCtxt (L _ stmts)) = dsDo stmts
423 ds_expr _ (HsDo _ MDoExpr (L _ stmts)) = dsDo stmts
424 ds_expr _ (HsDo _ MonadComp (L _ stmts)) = dsMonadComp stmts
425
426 ds_expr _ (HsIf _ mb_fun guard_expr then_expr else_expr)
427 = do { pred <- dsLExpr guard_expr
428 ; b1 <- dsLExpr then_expr
429 ; b2 <- dsLExpr else_expr
430 ; case mb_fun of
431 Just fun -> dsSyntaxExpr fun [pred, b1, b2]
432 Nothing -> return $ mkIfThenElse pred b1 b2 }
433
434 ds_expr _ (HsMultiIf res_ty alts)
435 | null alts
436 = mkErrorExpr
437
438 | otherwise
439 = do { match_result <- liftM (foldr1 combineMatchResults)
440 (mapM (dsGRHS IfAlt res_ty) alts)
441 ; error_expr <- mkErrorExpr
442 ; extractMatchResult match_result error_expr }
443 where
444 mkErrorExpr = mkErrorAppDs nON_EXHAUSTIVE_GUARDS_ERROR_ID res_ty
445 (text "multi-way if")
446
447 {-
448 \noindent
449 \underline{\bf Various data construction things}
450 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
451 -}
452
453 ds_expr _ (ExplicitList elt_ty wit xs)
454 = dsExplicitList elt_ty wit xs
455
456 -- We desugar [:x1, ..., xn:] as
457 -- singletonP x1 +:+ ... +:+ singletonP xn
458 --
459 ds_expr _ (ExplicitPArr ty []) = do
460 emptyP <- dsDPHBuiltin emptyPVar
461 return (Var emptyP `App` Type ty)
462 ds_expr _ (ExplicitPArr ty xs) = do
463 singletonP <- dsDPHBuiltin singletonPVar
464 appP <- dsDPHBuiltin appPVar
465 xs' <- mapM dsLExprNoLP xs
466 let unary fn x = mkApps (Var fn) [Type ty, x]
467 binary fn x y = mkApps (Var fn) [Type ty, x, y]
468
469 return . foldr1 (binary appP) $ map (unary singletonP) xs'
470
471 ds_expr _ (ArithSeq expr witness seq)
472 = case witness of
473 Nothing -> dsArithSeq expr seq
474 Just fl -> do { newArithSeq <- dsArithSeq expr seq
475 ; dsSyntaxExpr fl [newArithSeq] }
476
477 ds_expr _ (PArrSeq expr (FromTo from to))
478 = mkApps <$> dsExpr expr <*> mapM dsLExprNoLP [from, to]
479
480 ds_expr _ (PArrSeq expr (FromThenTo from thn to))
481 = mkApps <$> dsExpr expr <*> mapM dsLExprNoLP [from, thn, to]
482
483 ds_expr _ (PArrSeq _ _)
484 = panic "DsExpr.dsExpr: Infinite parallel array!"
485 -- the parser shouldn't have generated it and the renamer and typechecker
486 -- shouldn't have let it through
487
488 {-
489 Static Pointers
490 ~~~~~~~~~~~~~~~
491
492 See Note [Grand plan for static forms] in StaticPtrTable for an overview.
493
494 g = ... static f ...
495 ==>
496 g = ... makeStatic loc f ...
497 -}
498
499 ds_expr _ (HsStatic _ expr@(L loc _)) = do
500 expr_ds <- dsLExprNoLP expr
501 let ty = exprType expr_ds
502 makeStaticId <- dsLookupGlobalId makeStaticName
503
504 dflags <- getDynFlags
505 let (line, col) = case loc of
506 RealSrcSpan r -> ( srcLocLine $ realSrcSpanStart r
507 , srcLocCol $ realSrcSpanStart r
508 )
509 _ -> (0, 0)
510 srcLoc = mkCoreConApps (tupleDataCon Boxed 2)
511 [ Type intTy , Type intTy
512 , mkIntExprInt dflags line, mkIntExprInt dflags col
513 ]
514
515 putSrcSpanDs loc $ return $
516 mkCoreApps (Var makeStaticId) [ Type ty, srcLoc, expr_ds ]
517
518 {-
519 \noindent
520 \underline{\bf Record construction and update}
521 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
522 For record construction we do this (assuming T has three arguments)
523 \begin{verbatim}
524 T { op2 = e }
525 ==>
526 let err = /\a -> recConErr a
527 T (recConErr t1 "M.hs/230/op1")
528 e
529 (recConErr t1 "M.hs/230/op3")
530 \end{verbatim}
531 @recConErr@ then converts its argument string into a proper message
532 before printing it as
533 \begin{verbatim}
534 M.hs, line 230: missing field op1 was evaluated
535 \end{verbatim}
536
537 We also handle @C{}@ as valid construction syntax for an unlabelled
538 constructor @C@, setting all of @C@'s fields to bottom.
539 -}
540
541 ds_expr _ (RecordCon { rcon_flds = rbinds
542 , rcon_ext = RecordConTc { rcon_con_expr = con_expr
543 , rcon_con_like = con_like }})
544 = do { con_expr' <- dsExpr con_expr
545 ; let
546 (arg_tys, _) = tcSplitFunTys (exprType con_expr')
547 -- A newtype in the corner should be opaque;
548 -- hence TcType.tcSplitFunTys
549
550 mk_arg (arg_ty, fl)
551 = case findField (rec_flds rbinds) (flSelector fl) of
552 (rhs:rhss) -> ASSERT( null rhss )
553 dsLExprNoLP rhs
554 [] -> mkErrorAppDs rEC_CON_ERROR_ID arg_ty (ppr (flLabel fl))
555 unlabelled_bottom arg_ty = mkErrorAppDs rEC_CON_ERROR_ID arg_ty Outputable.empty
556
557 labels = conLikeFieldLabels con_like
558
559 ; con_args <- if null labels
560 then mapM unlabelled_bottom arg_tys
561 else mapM mk_arg (zipEqual "dsExpr:RecordCon" arg_tys labels)
562
563 ; return (mkCoreApps con_expr' con_args) }
564
565 {-
566 Record update is a little harder. Suppose we have the decl:
567 \begin{verbatim}
568 data T = T1 {op1, op2, op3 :: Int}
569 | T2 {op4, op2 :: Int}
570 | T3
571 \end{verbatim}
572 Then we translate as follows:
573 \begin{verbatim}
574 r { op2 = e }
575 ===>
576 let op2 = e in
577 case r of
578 T1 op1 _ op3 -> T1 op1 op2 op3
579 T2 op4 _ -> T2 op4 op2
580 other -> recUpdError "M.hs/230"
581 \end{verbatim}
582 It's important that we use the constructor Ids for @T1@, @T2@ etc on the
583 RHSs, and do not generate a Core constructor application directly, because the constructor
584 might do some argument-evaluation first; and may have to throw away some
585 dictionaries.
586
587 Note [Update for GADTs]
588 ~~~~~~~~~~~~~~~~~~~~~~~
589 Consider
590 data T a b where
591 T1 :: { f1 :: a } -> T a Int
592
593 Then the wrapper function for T1 has type
594 $WT1 :: a -> T a Int
595 But if x::T a b, then
596 x { f1 = v } :: T a b (not T a Int!)
597 So we need to cast (T a Int) to (T a b). Sigh.
598
599 -}
600
601 ds_expr _ expr@(RecordUpd { rupd_expr = record_expr, rupd_flds = fields
602 , rupd_ext = RecordUpdTc
603 { rupd_cons = cons_to_upd
604 , rupd_in_tys = in_inst_tys
605 , rupd_out_tys = out_inst_tys
606 , rupd_wrap = dict_req_wrap }} )
607 | null fields
608 = dsLExpr record_expr
609 | otherwise
610 = ASSERT2( notNull cons_to_upd, ppr expr )
611
612 do { record_expr' <- dsLExpr record_expr
613 ; field_binds' <- mapM ds_field fields
614 ; let upd_fld_env :: NameEnv Id -- Maps field name to the LocalId of the field binding
615 upd_fld_env = mkNameEnv [(f,l) | (f,l,_) <- field_binds']
616
617 -- It's important to generate the match with matchWrapper,
618 -- and the right hand sides with applications of the wrapper Id
619 -- so that everything works when we are doing fancy unboxing on the
620 -- constructor arguments.
621 ; alts <- mapM (mk_alt upd_fld_env) cons_to_upd
622 ; ([discrim_var], matching_code)
623 <- matchWrapper RecUpd Nothing (MG { mg_alts = noLoc alts
624 , mg_arg_tys = [in_ty]
625 , mg_res_ty = out_ty, mg_origin = FromSource })
626 -- FromSource is not strictly right, but we
627 -- want incomplete pattern-match warnings
628
629 ; return (add_field_binds field_binds' $
630 bindNonRec discrim_var record_expr' matching_code) }
631 where
632 ds_field :: LHsRecUpdField GhcTc -> DsM (Name, Id, CoreExpr)
633 -- Clone the Id in the HsRecField, because its Name is that
634 -- of the record selector, and we must not make that a local binder
635 -- else we shadow other uses of the record selector
636 -- Hence 'lcl_id'. Cf Trac #2735
637 ds_field (L _ rec_field) = do { rhs <- dsLExpr (hsRecFieldArg rec_field)
638 ; let fld_id = unLoc (hsRecUpdFieldId rec_field)
639 ; lcl_id <- newSysLocalDs (idType fld_id)
640 ; return (idName fld_id, lcl_id, rhs) }
641
642 add_field_binds [] expr = expr
643 add_field_binds ((_,b,r):bs) expr = bindNonRec b r (add_field_binds bs expr)
644
645 -- Awkwardly, for families, the match goes
646 -- from instance type to family type
647 (in_ty, out_ty) =
648 case (head cons_to_upd) of
649 RealDataCon data_con ->
650 let tycon = dataConTyCon data_con in
651 (mkTyConApp tycon in_inst_tys, mkFamilyTyConApp tycon out_inst_tys)
652 PatSynCon pat_syn ->
653 ( patSynInstResTy pat_syn in_inst_tys
654 , patSynInstResTy pat_syn out_inst_tys)
655 mk_alt upd_fld_env con
656 = do { let (univ_tvs, ex_tvs, eq_spec,
657 prov_theta, _req_theta, arg_tys, _) = conLikeFullSig con
658 subst = zipTvSubst univ_tvs in_inst_tys
659
660 -- I'm not bothering to clone the ex_tvs
661 ; eqs_vars <- mapM newPredVarDs (substTheta subst (eqSpecPreds eq_spec))
662 ; theta_vars <- mapM newPredVarDs (substTheta subst prov_theta)
663 ; arg_ids <- newSysLocalsDs (substTysUnchecked subst arg_tys)
664 ; let field_labels = conLikeFieldLabels con
665 val_args = zipWithEqual "dsExpr:RecordUpd" mk_val_arg
666 field_labels arg_ids
667 mk_val_arg fl pat_arg_id
668 = nlHsVar (lookupNameEnv upd_fld_env (flSelector fl) `orElse` pat_arg_id)
669
670 inst_con = noLoc $ mkHsWrap wrap (HsConLikeOut noExt con)
671 -- Reconstruct with the WrapId so that unpacking happens
672 -- The order here is because of the order in `TcPatSyn`.
673 wrap = mkWpEvVarApps theta_vars <.>
674 dict_req_wrap <.>
675 mkWpTyApps (mkTyVarTys ex_tvs) <.>
676 mkWpTyApps [ ty
677 | (tv, ty) <- univ_tvs `zip` out_inst_tys
678 , not (tv `elemVarEnv` wrap_subst) ]
679 rhs = foldl (\a b -> nlHsApp a b) inst_con val_args
680
681 -- Tediously wrap the application in a cast
682 -- Note [Update for GADTs]
683 wrapped_rhs =
684 case con of
685 RealDataCon data_con ->
686 let
687 wrap_co =
688 mkTcTyConAppCo Nominal
689 (dataConTyCon data_con)
690 [ lookup tv ty
691 | (tv,ty) <- univ_tvs `zip` out_inst_tys ]
692 lookup univ_tv ty =
693 case lookupVarEnv wrap_subst univ_tv of
694 Just co' -> co'
695 Nothing -> mkTcReflCo Nominal ty
696 in if null eq_spec
697 then rhs
698 else mkLHsWrap (mkWpCastN wrap_co) rhs
699 -- eq_spec is always null for a PatSynCon
700 PatSynCon _ -> rhs
701
702 wrap_subst =
703 mkVarEnv [ (tv, mkTcSymCo (mkTcCoVarCo eq_var))
704 | (spec, eq_var) <- eq_spec `zip` eqs_vars
705 , let tv = eqSpecTyVar spec ]
706
707 req_wrap = dict_req_wrap <.> mkWpTyApps in_inst_tys
708
709 pat = noLoc $ ConPatOut { pat_con = noLoc con
710 , pat_tvs = ex_tvs
711 , pat_dicts = eqs_vars ++ theta_vars
712 , pat_binds = emptyTcEvBinds
713 , pat_args = PrefixCon $ map nlVarPat arg_ids
714 , pat_arg_tys = in_inst_tys
715 , pat_wrap = req_wrap }
716 ; return (mkSimpleMatch RecUpd [pat] wrapped_rhs) }
717
718 -- Here is where we desugar the Template Haskell brackets and escapes
719
720 -- Template Haskell stuff
721
722 ds_expr _ (HsRnBracketOut _ _ _) = panic "dsExpr HsRnBracketOut"
723 ds_expr _ (HsTcBracketOut _ x ps) = dsBracket x ps
724 ds_expr _ (HsSpliceE _ s) = pprPanic "dsExpr:splice" (ppr s)
725
726 -- Arrow notation extension
727 ds_expr _ (HsProc _ pat cmd) = dsProcExpr pat cmd
728
729 -- Hpc Support
730
731 ds_expr _ (HsTick _ tickish e) = do
732 e' <- dsLExpr e
733 return (Tick tickish e')
734
735 -- There is a problem here. The then and else branches
736 -- have no free variables, so they are open to lifting.
737 -- We need someway of stopping this.
738 -- This will make no difference to binary coverage
739 -- (did you go here: YES or NO), but will effect accurate
740 -- tick counting.
741
742 ds_expr _ (HsBinTick _ ixT ixF e) = do
743 e2 <- dsLExpr e
744 do { ASSERT(exprType e2 `eqType` boolTy)
745 mkBinaryTickBox ixT ixF e2
746 }
747
748 ds_expr _ (HsTickPragma _ _ _ _ expr) = do
749 dflags <- getDynFlags
750 if gopt Opt_Hpc dflags
751 then panic "dsExpr:HsTickPragma"
752 else dsLExpr expr
753
754 -- HsSyn constructs that just shouldn't be here:
755 ds_expr _ (HsBracket {}) = panic "dsExpr:HsBracket"
756 ds_expr _ (HsArrApp {}) = panic "dsExpr:HsArrApp"
757 ds_expr _ (HsArrForm {}) = panic "dsExpr:HsArrForm"
758 ds_expr _ (EWildPat {}) = panic "dsExpr:EWildPat"
759 ds_expr _ (EAsPat {}) = panic "dsExpr:EAsPat"
760 ds_expr _ (EViewPat {}) = panic "dsExpr:EViewPat"
761 ds_expr _ (ELazyPat {}) = panic "dsExpr:ELazyPat"
762 ds_expr _ (HsDo {}) = panic "dsExpr:HsDo"
763 ds_expr _ (HsRecFld {}) = panic "dsExpr:HsRecFld"
764
765 ------------------------------
766 dsSyntaxExpr :: SyntaxExpr GhcTc -> [CoreExpr] -> DsM CoreExpr
767 dsSyntaxExpr (SyntaxExpr { syn_expr = expr
768 , syn_arg_wraps = arg_wraps
769 , syn_res_wrap = res_wrap })
770 arg_exprs
771 = do { fun <- dsExpr expr
772 ; core_arg_wraps <- mapM dsHsWrapper arg_wraps
773 ; core_res_wrap <- dsHsWrapper res_wrap
774 ; let wrapped_args = zipWith ($) core_arg_wraps arg_exprs
775 ; dsWhenNoErrs (zipWithM_ dsNoLevPolyExpr wrapped_args [ mk_doc n | n <- [1..] ])
776 (\_ -> core_res_wrap (mkApps fun wrapped_args)) }
777 where
778 mk_doc n = text "In the" <+> speakNth n <+> text "argument of" <+> quotes (ppr expr)
779
780 findField :: [LHsRecField GhcTc arg] -> Name -> [arg]
781 findField rbinds sel
782 = [hsRecFieldArg fld | L _ fld <- rbinds
783 , sel == idName (unLoc $ hsRecFieldId fld) ]
784
785 {-
786 %--------------------------------------------------------------------
787
788 Note [Desugaring explicit lists]
789 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
790 Explicit lists are desugared in a cleverer way to prevent some
791 fruitless allocations. Essentially, whenever we see a list literal
792 [x_1, ..., x_n] we generate the corresponding expression in terms of
793 build:
794
795 Explicit lists (literals) are desugared to allow build/foldr fusion when
796 beneficial. This is a bit of a trade-off,
797
798 * build/foldr fusion can generate far larger code than the corresponding
799 cons-chain (e.g. see #11707)
800
801 * even when it doesn't produce more code, build can still fail to fuse,
802 requiring that the simplifier do more work to bring the expression
803 back into cons-chain form; this costs compile time
804
805 * when it works, fusion can be a significant win. Allocations are reduced
806 by up to 25% in some nofib programs. Specifically,
807
808 Program Size Allocs Runtime CompTime
809 rewrite +0.0% -26.3% 0.02 -1.8%
810 ansi -0.3% -13.8% 0.00 +0.0%
811 lift +0.0% -8.7% 0.00 -2.3%
812
813 At the moment we use a simple heuristic to determine whether build will be
814 fruitful: for small lists we assume the benefits of fusion will be worthwhile;
815 for long lists we assume that the benefits will be outweighted by the cost of
816 code duplication. This magic length threshold is @maxBuildLength@. Also, fusion
817 won't work at all if rewrite rules are disabled, so we don't use the build-based
818 desugaring in this case.
819
820 We used to have a more complex heuristic which would try to break the list into
821 "static" and "dynamic" parts and only build-desugar the dynamic part.
822 Unfortunately, determining "static-ness" reliably is a bit tricky and the
823 heuristic at times produced surprising behavior (see #11710) so it was dropped.
824 -}
825
826 {- | The longest list length which we will desugar using @build@.
827
828 This is essentially a magic number and its setting is unfortunate rather
829 arbitrary. The idea here, as mentioned in Note [Desugaring explicit lists],
830 is to avoid deforesting large static data into large(r) code. Ideally we'd
831 want a smaller threshold with larger consumers and vice-versa, but we have no
832 way of knowing what will be consuming our list in the desugaring impossible to
833 set generally correctly.
834
835 The effect of reducing this number will be that 'build' fusion is applied
836 less often. From a runtime performance perspective, applying 'build' more
837 liberally on "moderately" sized lists should rarely hurt and will often it can
838 only expose further optimization opportunities; if no fusion is possible it will
839 eventually get rule-rewritten back to a list). We do, however, pay in compile
840 time.
841 -}
842 maxBuildLength :: Int
843 maxBuildLength = 32
844
845 dsExplicitList :: Type -> Maybe (SyntaxExpr GhcTc) -> [LHsExpr GhcTc]
846 -> DsM CoreExpr
847 -- See Note [Desugaring explicit lists]
848 dsExplicitList elt_ty Nothing xs
849 = do { dflags <- getDynFlags
850 ; xs' <- mapM dsLExprNoLP xs
851 ; if xs' `lengthExceeds` maxBuildLength
852 -- Don't generate builds if the list is very long.
853 || null xs'
854 -- Don't generate builds when the [] constructor will do
855 || not (gopt Opt_EnableRewriteRules dflags) -- Rewrite rules off
856 -- Don't generate a build if there are no rules to eliminate it!
857 -- See Note [Desugaring RULE left hand sides] in Desugar
858 then return $ mkListExpr elt_ty xs'
859 else mkBuildExpr elt_ty (mk_build_list xs') }
860 where
861 mk_build_list xs' (cons, _) (nil, _)
862 = return (foldr (App . App (Var cons)) (Var nil) xs')
863
864 dsExplicitList elt_ty (Just fln) xs
865 = do { list <- dsExplicitList elt_ty Nothing xs
866 ; dflags <- getDynFlags
867 ; dsSyntaxExpr fln [mkIntExprInt dflags (length xs), list] }
868
869 dsArithSeq :: PostTcExpr -> (ArithSeqInfo GhcTc) -> DsM CoreExpr
870 dsArithSeq expr (From from)
871 = App <$> dsExpr expr <*> dsLExprNoLP from
872 dsArithSeq expr (FromTo from to)
873 = do dflags <- getDynFlags
874 warnAboutEmptyEnumerations dflags from Nothing to
875 expr' <- dsExpr expr
876 from' <- dsLExprNoLP from
877 to' <- dsLExprNoLP to
878 return $ mkApps expr' [from', to']
879 dsArithSeq expr (FromThen from thn)
880 = mkApps <$> dsExpr expr <*> mapM dsLExprNoLP [from, thn]
881 dsArithSeq expr (FromThenTo from thn to)
882 = do dflags <- getDynFlags
883 warnAboutEmptyEnumerations dflags from (Just thn) to
884 expr' <- dsExpr expr
885 from' <- dsLExprNoLP from
886 thn' <- dsLExprNoLP thn
887 to' <- dsLExprNoLP to
888 return $ mkApps expr' [from', thn', to']
889
890 {-
891 Desugar 'do' and 'mdo' expressions (NOT list comprehensions, they're
892 handled in DsListComp). Basically does the translation given in the
893 Haskell 98 report:
894 -}
895
896 dsDo :: [ExprLStmt GhcTc] -> DsM CoreExpr
897 dsDo stmts
898 = goL stmts
899 where
900 goL [] = panic "dsDo"
901 goL (L loc stmt:lstmts) = putSrcSpanDs loc (go loc stmt lstmts)
902
903 go _ (LastStmt body _ _) stmts
904 = ASSERT( null stmts ) dsLExpr body
905 -- The 'return' op isn't used for 'do' expressions
906
907 go _ (BodyStmt rhs then_expr _ _) stmts
908 = do { rhs2 <- dsLExpr rhs
909 ; warnDiscardedDoBindings rhs (exprType rhs2)
910 ; rest <- goL stmts
911 ; dsSyntaxExpr then_expr [rhs2, rest] }
912
913 go _ (LetStmt binds) stmts
914 = do { rest <- goL stmts
915 ; dsLocalBinds binds rest }
916
917 go _ (BindStmt pat rhs bind_op fail_op res1_ty) stmts
918 = do { body <- goL stmts
919 ; rhs' <- dsLExpr rhs
920 ; var <- selectSimpleMatchVarL pat
921 ; match <- matchSinglePat (Var var) (StmtCtxt DoExpr) pat
922 res1_ty (cantFailMatchResult body)
923 ; match_code <- handle_failure pat match fail_op
924 ; dsSyntaxExpr bind_op [rhs', Lam var match_code] }
925
926 go _ (ApplicativeStmt args mb_join body_ty) stmts
927 = do {
928 let
929 (pats, rhss) = unzip (map (do_arg . snd) args)
930
931 do_arg (ApplicativeArgOne pat expr _) =
932 (pat, dsLExpr expr)
933 do_arg (ApplicativeArgMany stmts ret pat) =
934 (pat, dsDo (stmts ++ [noLoc $ mkLastStmt (noLoc ret)]))
935
936 arg_tys = map hsLPatType pats
937
938 ; rhss' <- sequence rhss
939
940 ; let body' = noLoc $ HsDo body_ty DoExpr (noLoc stmts)
941
942 ; let fun = L noSrcSpan $ HsLam noExt $
943 MG { mg_alts = noLoc [mkSimpleMatch LambdaExpr pats
944 body']
945 , mg_arg_tys = arg_tys
946 , mg_res_ty = body_ty
947 , mg_origin = Generated }
948
949 ; fun' <- dsLExpr fun
950 ; let mk_ap_call l (op,r) = dsSyntaxExpr op [l,r]
951 ; expr <- foldlM mk_ap_call fun' (zip (map fst args) rhss')
952 ; case mb_join of
953 Nothing -> return expr
954 Just join_op -> dsSyntaxExpr join_op [expr] }
955
956 go loc (RecStmt { recS_stmts = rec_stmts, recS_later_ids = later_ids
957 , recS_rec_ids = rec_ids, recS_ret_fn = return_op
958 , recS_mfix_fn = mfix_op, recS_bind_fn = bind_op
959 , recS_bind_ty = bind_ty
960 , recS_rec_rets = rec_rets, recS_ret_ty = body_ty }) stmts
961 = goL (new_bind_stmt : stmts) -- rec_ids can be empty; eg rec { print 'x' }
962 where
963 new_bind_stmt = L loc $ BindStmt (mkBigLHsPatTupId later_pats)
964 mfix_app bind_op
965 noSyntaxExpr -- Tuple cannot fail
966 bind_ty
967
968 tup_ids = rec_ids ++ filterOut (`elem` rec_ids) later_ids
969 tup_ty = mkBigCoreTupTy (map idType tup_ids) -- Deals with singleton case
970 rec_tup_pats = map nlVarPat tup_ids
971 later_pats = rec_tup_pats
972 rets = map noLoc rec_rets
973 mfix_app = nlHsSyntaxApps mfix_op [mfix_arg]
974 mfix_arg = noLoc $ HsLam noExt
975 (MG { mg_alts = noLoc [mkSimpleMatch
976 LambdaExpr
977 [mfix_pat] body]
978 , mg_arg_tys = [tup_ty], mg_res_ty = body_ty
979 , mg_origin = Generated })
980 mfix_pat = noLoc $ LazyPat noExt $ mkBigLHsPatTupId rec_tup_pats
981 body = noLoc $ HsDo body_ty
982 DoExpr (noLoc (rec_stmts ++ [ret_stmt]))
983 ret_app = nlHsSyntaxApps return_op [mkBigLHsTupId rets]
984 ret_stmt = noLoc $ mkLastStmt ret_app
985 -- This LastStmt will be desugared with dsDo,
986 -- which ignores the return_op in the LastStmt,
987 -- so we must apply the return_op explicitly
988
989 go _ (ParStmt {}) _ = panic "dsDo ParStmt"
990 go _ (TransStmt {}) _ = panic "dsDo TransStmt"
991
992 handle_failure :: LPat GhcTc -> MatchResult -> SyntaxExpr GhcTc -> DsM CoreExpr
993 -- In a do expression, pattern-match failure just calls
994 -- the monadic 'fail' rather than throwing an exception
995 handle_failure pat match fail_op
996 | matchCanFail match
997 = do { dflags <- getDynFlags
998 ; fail_msg <- mkStringExpr (mk_fail_msg dflags pat)
999 ; fail_expr <- dsSyntaxExpr fail_op [fail_msg]
1000 ; extractMatchResult match fail_expr }
1001 | otherwise
1002 = extractMatchResult match (error "It can't fail")
1003
1004 mk_fail_msg :: DynFlags -> Located e -> String
1005 mk_fail_msg dflags pat = "Pattern match failure in do expression at " ++
1006 showPpr dflags (getLoc pat)
1007
1008 {-
1009 ************************************************************************
1010 * *
1011 Desugaring Variables
1012 * *
1013 ************************************************************************
1014 -}
1015
1016 dsHsVar :: Bool -- are we directly inside an HsWrap?
1017 -- See Wrinkle in Note [Detecting forced eta expansion]
1018 -> Id -> DsM CoreExpr
1019 dsHsVar w var
1020 | not w
1021 , let bad_tys = badUseOfLevPolyPrimop var ty
1022 , not (null bad_tys)
1023 = do { levPolyPrimopErr var ty bad_tys
1024 ; return unitExpr } -- return something eminently safe
1025
1026 | otherwise
1027 = return (varToCoreExpr var) -- See Note [Desugaring vars]
1028
1029 where
1030 ty = idType var
1031
1032 dsConLike :: Bool -- as in dsHsVar
1033 -> ConLike -> DsM CoreExpr
1034 dsConLike w (RealDataCon dc) = dsHsVar w (dataConWrapId dc)
1035 dsConLike _ (PatSynCon ps) = return $ case patSynBuilder ps of
1036 Just (id, add_void)
1037 | add_void -> mkCoreApp (text "dsConLike" <+> ppr ps) (Var id) (Var voidPrimId)
1038 | otherwise -> Var id
1039 _ -> pprPanic "dsConLike" (ppr ps)
1040
1041 {-
1042 ************************************************************************
1043 * *
1044 \subsection{Errors and contexts}
1045 * *
1046 ************************************************************************
1047 -}
1048
1049 -- Warn about certain types of values discarded in monadic bindings (#3263)
1050 warnDiscardedDoBindings :: LHsExpr GhcTc -> Type -> DsM ()
1051 warnDiscardedDoBindings rhs rhs_ty
1052 | Just (m_ty, elt_ty) <- tcSplitAppTy_maybe rhs_ty
1053 = do { warn_unused <- woptM Opt_WarnUnusedDoBind
1054 ; warn_wrong <- woptM Opt_WarnWrongDoBind
1055 ; when (warn_unused || warn_wrong) $
1056 do { fam_inst_envs <- dsGetFamInstEnvs
1057 ; let norm_elt_ty = topNormaliseType fam_inst_envs elt_ty
1058
1059 -- Warn about discarding non-() things in 'monadic' binding
1060 ; if warn_unused && not (isUnitTy norm_elt_ty)
1061 then warnDs (Reason Opt_WarnUnusedDoBind)
1062 (badMonadBind rhs elt_ty)
1063 else
1064
1065 -- Warn about discarding m a things in 'monadic' binding of the same type,
1066 -- but only if we didn't already warn due to Opt_WarnUnusedDoBind
1067 when warn_wrong $
1068 do { case tcSplitAppTy_maybe norm_elt_ty of
1069 Just (elt_m_ty, _)
1070 | m_ty `eqType` topNormaliseType fam_inst_envs elt_m_ty
1071 -> warnDs (Reason Opt_WarnWrongDoBind)
1072 (badMonadBind rhs elt_ty)
1073 _ -> return () } } }
1074
1075 | otherwise -- RHS does have type of form (m ty), which is weird
1076 = return () -- but at lesat this warning is irrelevant
1077
1078 badMonadBind :: LHsExpr GhcTc -> Type -> SDoc
1079 badMonadBind rhs elt_ty
1080 = vcat [ hang (text "A do-notation statement discarded a result of type")
1081 2 (quotes (ppr elt_ty))
1082 , hang (text "Suppress this warning by saying")
1083 2 (quotes $ text "_ <-" <+> ppr rhs)
1084 ]
1085
1086 {-
1087 ************************************************************************
1088 * *
1089 Forced eta expansion and levity polymorphism
1090 * *
1091 ************************************************************************
1092
1093 Note [Detecting forced eta expansion]
1094 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1095 We cannot have levity polymorphic function arguments. See
1096 Note [Levity polymorphism invariants] in CoreSyn. But we *can* have
1097 functions that take levity polymorphism arguments, as long as these
1098 functions are eta-reduced. (See #12708 for an example.)
1099
1100 However, we absolutely cannot do this for functions that have no
1101 binding (i.e., say True to Id.hasNoBinding), like primops and unboxed
1102 tuple constructors. These get eta-expanded in CorePrep.maybeSaturate.
1103
1104 Detecting when this is about to happen is a bit tricky, though. When
1105 the desugarer is looking at the Id itself (let's be concrete and
1106 suppose we have (#,#)), we don't know whether it will be levity
1107 polymorphic. So the right spot seems to be to look after the Id has
1108 been applied to its type arguments. To make the algorithm efficient,
1109 it's important to be able to spot ((#,#) @a @b @c @d) without looking
1110 past all the type arguments. We thus require that
1111 * The body of an HsWrap is not an HsWrap.
1112 With that representation invariant, we simply look inside every HsWrap
1113 to see if its body is an HsVar whose Id hasNoBinding. Then, we look
1114 at the wrapped type. If it has any levity polymorphic arguments, reject.
1115
1116 Interestingly, this approach does not look to see whether the Id in
1117 question will be eta expanded. The logic is this:
1118 * Either the Id in question is saturated or not.
1119 * If it is, then it surely can't have levity polymorphic arguments.
1120 If its wrapped type contains levity polymorphic arguments, reject.
1121 * If it's not, then it can't be eta expanded with levity polymorphic
1122 argument. If its wrapped type contains levity polymorphic arguments, reject.
1123 So, either way, we're good to reject.
1124
1125 Wrinkle
1126 ~~~~~~~
1127 Not all polymorphic Ids are wrapped in
1128 HsWrap, due to the lazy instantiation of TypeApplications. (See "Visible type
1129 application", ESOP '16.) But if we spot a levity-polymorphic hasNoBinding Id
1130 without a wrapper, then that is surely problem and we can reject.
1131
1132 We thus have a parameter to `dsExpr` that tracks whether or not we are
1133 directly in an HsWrap. If we find a levity-polymorphic hasNoBinding Id when
1134 we're not directly in an HsWrap, reject.
1135
1136 -}
1137
1138 -- | Takes an expression and its instantiated type. If the expression is an
1139 -- HsVar with a hasNoBinding primop and the type has levity-polymorphic arguments,
1140 -- issue an error. See Note [Detecting forced eta expansion]
1141 checkForcedEtaExpansion :: HsExpr GhcTc -> Type -> DsM ()
1142 checkForcedEtaExpansion expr ty
1143 | Just var <- case expr of
1144 HsVar _ (L _ var) -> Just var
1145 HsConLikeOut _ (RealDataCon dc) -> Just (dataConWrapId dc)
1146 _ -> Nothing
1147 , let bad_tys = badUseOfLevPolyPrimop var ty
1148 , not (null bad_tys)
1149 = levPolyPrimopErr var ty bad_tys
1150 checkForcedEtaExpansion _ _ = return ()
1151
1152 -- | Is this a hasNoBinding Id with a levity-polymorphic type?
1153 -- Returns the arguments that are levity polymorphic if they are bad;
1154 -- or an empty list otherwise
1155 -- See Note [Detecting forced eta expansion]
1156 badUseOfLevPolyPrimop :: Id -> Type -> [Type]
1157 badUseOfLevPolyPrimop id ty
1158 | hasNoBinding id
1159 = filter isTypeLevPoly arg_tys
1160 | otherwise
1161 = []
1162 where
1163 (binders, _) = splitPiTys ty
1164 arg_tys = mapMaybe binderRelevantType_maybe binders
1165
1166 levPolyPrimopErr :: Id -> Type -> [Type] -> DsM ()
1167 levPolyPrimopErr primop ty bad_tys
1168 = errDs $ vcat [ hang (text "Cannot use primitive with levity-polymorphic arguments:")
1169 2 (ppr primop <+> dcolon <+> ppr ty)
1170 , hang (text "Levity-polymorphic arguments:")
1171 2 (vcat (map (\t -> ppr t <+> dcolon <+> ppr (typeKind t)) bad_tys)) ]