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