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