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