Add a warning for empty enumerations; fixes #7881
[ghc.git] / compiler / deSugar / DsExpr.lhs
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 \begin{code}
9 module DsExpr ( dsExpr, dsLExpr, dsLocalBinds, dsValBinds, dsLit ) where
10
11 #include "HsVersions.h"
12
13 import Match
14 import MatchLit
15 import DsBinds
16 import DsGRHSs
17 import DsListComp
18 import DsUtils
19 import DsArrows
20 import DsMonad
21 import Name
22 import NameEnv
23
24 #ifdef GHCI
25         -- Template Haskell stuff iff bootstrapped
26 import DsMeta
27 #endif
28
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 Type
37 import CoreSyn
38 import CoreUtils
39 import CoreFVs
40 import MkCore
41
42 import DynFlags
43 import CostCentre
44 import Id
45 import Module
46 import VarSet
47 import VarEnv
48 import DataCon
49 import TysWiredIn
50 import BasicTypes
51 import PrelNames
52 import Maybes
53 import SrcLoc
54 import Util
55 import Bag
56 import Outputable
57 import Literal
58 import TyCon
59 import FastString
60
61 import Control.Monad
62 import Data.Int
63 import Data.Traversable (traverse)
64 import Data.Typeable (typeOf)
65 import Data.Word
66 \end{code}
67
68
69 %************************************************************************
70 %*                                                                      *
71                 dsLocalBinds, dsValBinds
72 %*                                                                      *
73 %************************************************************************
74
75 \begin{code}
76 dsLocalBinds :: HsLocalBinds Id -> CoreExpr -> DsM CoreExpr
77 dsLocalBinds EmptyLocalBinds    body = return body
78 dsLocalBinds (HsValBinds binds) body = dsValBinds binds body
79 dsLocalBinds (HsIPBinds binds)  body = dsIPBinds  binds body
80
81 -------------------------
82 dsValBinds :: HsValBinds Id -> CoreExpr -> DsM CoreExpr
83 dsValBinds (ValBindsOut binds _) body = foldrM ds_val_bind body binds
84 dsValBinds (ValBindsIn  _     _) _    = panic "dsValBinds ValBindsIn"
85
86 -------------------------
87 dsIPBinds :: HsIPBinds Id -> CoreExpr -> DsM CoreExpr
88 dsIPBinds (IPBinds ip_binds ev_binds) body
89   = do  { ds_binds <- dsTcEvBinds ev_binds
90         ; let inner = mkCoreLets ds_binds body
91                 -- The dict bindings may not be in 
92                 -- dependency order; hence Rec
93         ; foldrM ds_ip_bind inner ip_binds }
94   where
95     ds_ip_bind (L _ (IPBind ~(Right n) e)) body
96       = do e' <- dsLExpr e
97            return (Let (NonRec n e') body)
98
99 -------------------------
100 ds_val_bind :: (RecFlag, LHsBinds Id) -> CoreExpr -> DsM CoreExpr
101 -- Special case for bindings which bind unlifted variables
102 -- We need to do a case right away, rather than building
103 -- a tuple and doing selections.
104 -- Silently ignore INLINE and SPECIALISE pragmas...
105 ds_val_bind (NonRecursive, hsbinds) body
106   | [L loc bind] <- bagToList hsbinds,
107         -- Non-recursive, non-overloaded bindings only come in ones
108         -- ToDo: in some bizarre case it's conceivable that there
109         --       could be dict binds in the 'binds'.  (See the notes
110         --       below.  Then pattern-match would fail.  Urk.)
111     strictMatchOnly bind
112   = putSrcSpanDs loc (dsStrictBind bind body)
113
114 -- Ordinary case for bindings; none should be unlifted
115 ds_val_bind (_is_rec, binds) body
116   = do  { prs <- dsLHsBinds binds
117         ; ASSERT2( not (any (isUnLiftedType . idType . fst) prs), ppr _is_rec $$ ppr binds )
118           case prs of
119             [] -> return body
120             _  -> return (Let (Rec prs) body) }
121         -- Use a Rec regardless of is_rec. 
122         -- Why? Because it allows the binds to be all
123         -- mixed up, which is what happens in one rare case
124         -- Namely, for an AbsBind with no tyvars and no dicts,
125         --         but which does have dictionary bindings.
126         -- See notes with TcSimplify.inferLoop [NO TYVARS]
127         -- It turned out that wrapping a Rec here was the easiest solution
128         --
129         -- NB The previous case dealt with unlifted bindings, so we
130         --    only have to deal with lifted ones now; so Rec is ok
131
132 ------------------
133 dsStrictBind :: HsBind Id -> CoreExpr -> DsM CoreExpr
134 dsStrictBind (AbsBinds { abs_tvs = [], abs_ev_vars = []
135                , abs_exports = exports
136                , abs_ev_binds = ev_binds
137                , abs_binds = binds }) body
138   = do { let body1 = foldr bind_export body exports
139              bind_export export b = bindNonRec (abe_poly export) (Var (abe_mono export)) b
140        ; body2 <- foldlBagM (\body bind -> dsStrictBind (unLoc bind) body) 
141                             body1 binds 
142        ; ds_binds <- dsTcEvBinds ev_binds
143        ; return (mkCoreLets ds_binds body2) }
144
145 dsStrictBind (FunBind { fun_id = L _ fun, fun_matches = matches, fun_co_fn = co_fn 
146                       , fun_tick = tick, fun_infix = inf }) body
147                 -- Can't be a bang pattern (that looks like a PatBind)
148                 -- so must be simply unboxed
149   = do { (args, rhs) <- matchWrapper (FunRhs (idName fun ) inf) matches
150        ; MASSERT( null args ) -- Functions aren't lifted
151        ; MASSERT( isIdHsWrapper co_fn )
152        ; let rhs' = mkOptTickBox tick rhs
153        ; return (bindNonRec fun rhs' body) }
154
155 dsStrictBind (PatBind {pat_lhs = pat, pat_rhs = grhss, pat_rhs_ty = ty }) body
156   =     -- let C x# y# = rhs in body
157         -- ==> case rhs of C x# y# -> body
158     do { rhs <- dsGuarded grhss ty
159        ; let upat = unLoc pat
160              eqn = EqnInfo { eqn_pats = [upat], 
161                              eqn_rhs = cantFailMatchResult body }
162        ; var    <- selectMatchVar upat
163        ; result <- matchEquations PatBindRhs [var] [eqn] (exprType body)
164        ; return (bindNonRec var rhs result) }
165
166 dsStrictBind bind body = pprPanic "dsLet: unlifted" (ppr bind $$ ppr body)
167
168 ----------------------
169 strictMatchOnly :: HsBind Id -> Bool
170 strictMatchOnly (AbsBinds { abs_binds = binds })
171   = anyBag (strictMatchOnly . unLoc) binds
172 strictMatchOnly (PatBind { pat_lhs = lpat, pat_rhs_ty = ty })
173   =  isUnLiftedType ty 
174   || isBangLPat lpat   
175   || any (isUnLiftedType . idType) (collectPatBinders lpat)
176 strictMatchOnly (FunBind { fun_id = L _ id })
177   = isUnLiftedType (idType id)
178 strictMatchOnly _ = False -- I hope!  Checked immediately by caller in fact
179
180 \end{code}
181
182 %************************************************************************
183 %*                                                                      *
184 \subsection[DsExpr-vars-and-cons]{Variables, constructors, literals}
185 %*                                                                      *
186 %************************************************************************
187
188 \begin{code}
189 dsLExpr :: LHsExpr Id -> DsM CoreExpr
190
191 dsLExpr (L loc e) = putSrcSpanDs loc $ dsExpr e
192
193 dsExpr :: HsExpr Id -> DsM CoreExpr
194 dsExpr (HsPar e)              = dsLExpr e
195 dsExpr (ExprWithTySigOut e _) = dsLExpr e
196 dsExpr (HsVar var)            = return (varToCoreExpr var)   -- See Note [Desugaring vars]
197 dsExpr (HsIPVar _)            = panic "dsExpr: HsIPVar"
198 dsExpr (HsLit lit)            = dsLit lit
199 dsExpr (HsOverLit lit)        = dsOverLit lit
200
201 dsExpr (HsWrap co_fn e)
202   = do { e' <- dsExpr e
203        ; wrapped_e <- dsHsWrapper co_fn e'
204        ; warn_id <- woptM Opt_WarnIdentities
205        ; when warn_id $ warnAboutIdentities e' wrapped_e
206        ; return wrapped_e }
207
208 dsExpr (NegApp expr neg_expr) 
209   = App <$> dsExpr neg_expr <*> dsLExpr expr
210
211 dsExpr (HsLam a_Match)
212   = uncurry mkLams <$> matchWrapper LambdaExpr a_Match
213
214 dsExpr (HsLamCase arg matches)
215   = do { arg_var <- newSysLocalDs arg
216        ; ([discrim_var], matching_code) <- matchWrapper CaseAlt matches
217        ; return $ Lam arg_var $ bindNonRec discrim_var (Var arg_var) matching_code }
218
219 dsExpr (HsApp fun arg)
220   = do ds <- mkCoreAppDs <$> dsLExpr fun <*>  dsLExpr arg
221        warn_overflowed_literals <- woptM Opt_WarnOverflowedLiterals
222        when warn_overflowed_literals $ warnAboutOverflowedLiterals ds
223        return ds
224
225 dsExpr (HsUnboundVar _) = panic "dsExpr: HsUnboundVar"
226 \end{code}
227
228 Note [Desugaring vars]
229 ~~~~~~~~~~~~~~~~~~~~~~
230 In one situation we can get a *coercion* variable in a HsVar, namely
231 the support method for an equality superclass:
232    class (a~b) => C a b where ...
233    instance (blah) => C (T a) (T b) where ..
234 Then we get
235    $dfCT :: forall ab. blah => C (T a) (T b)
236    $dfCT ab blah = MkC ($c$p1C a blah) ($cop a blah)
237
238    $c$p1C :: forall ab. blah => (T a ~ T b)
239    $c$p1C ab blah = let ...; g :: T a ~ T b = ... } in g
240
241 That 'g' in the 'in' part is an evidence variable, and when
242 converting to core it must become a CO.
243    
244 Operator sections.  At first it looks as if we can convert
245 \begin{verbatim}
246         (expr op)
247 \end{verbatim}
248 to
249 \begin{verbatim}
250         \x -> op expr x
251 \end{verbatim}
252
253 But no!  expr might be a redex, and we can lose laziness badly this
254 way.  Consider
255 \begin{verbatim}
256         map (expr op) xs
257 \end{verbatim}
258 for example.  So we convert instead to
259 \begin{verbatim}
260         let y = expr in \x -> op y x
261 \end{verbatim}
262 If \tr{expr} is actually just a variable, say, then the simplifier
263 will sort it out.
264
265 \begin{code}
266 dsExpr (OpApp e1 op _ e2)
267   = -- for the type of y, we need the type of op's 2nd argument
268     mkCoreAppsDs <$> dsLExpr op <*> mapM dsLExpr [e1, e2]
269     
270 dsExpr (SectionL expr op)       -- Desugar (e !) to ((!) e)
271   = mkCoreAppDs <$> dsLExpr op <*> dsLExpr expr
272
273 -- dsLExpr (SectionR op expr)   -- \ x -> op x expr
274 dsExpr (SectionR op expr) = do
275     core_op <- dsLExpr op
276     -- for the type of x, we need the type of op's 2nd argument
277     let (x_ty:y_ty:_, _) = splitFunTys (exprType core_op)
278         -- See comment with SectionL
279     y_core <- dsLExpr expr
280     x_id <- newSysLocalDs x_ty
281     y_id <- newSysLocalDs y_ty
282     return (bindNonRec y_id y_core $
283             Lam x_id (mkCoreAppsDs core_op [Var x_id, Var y_id]))
284
285 dsExpr (ExplicitTuple tup_args boxity)
286   = do { let go (lam_vars, args) (Missing ty)
287                     -- For every missing expression, we need
288                     -- another lambda in the desugaring.
289                = do { lam_var <- newSysLocalDs ty
290                     ; return (lam_var : lam_vars, Var lam_var : args) }
291              go (lam_vars, args) (Present expr)
292                     -- Expressions that are present don't generate
293                     -- lambdas, just arguments.
294                = do { core_expr <- dsLExpr expr
295                     ; return (lam_vars, core_expr : args) }
296
297        ; (lam_vars, args) <- foldM go ([], []) (reverse tup_args)
298                 -- The reverse is because foldM goes left-to-right
299
300        ; return $ mkCoreLams lam_vars $ 
301                   mkConApp (tupleCon (boxityNormalTupleSort boxity) (length tup_args))
302                            (map (Type . exprType) args ++ args) }
303
304 dsExpr (HsSCC cc expr@(L loc _)) = do
305     mod_name <- getModule
306     count <- goptM Opt_ProfCountEntries
307     uniq <- newUnique
308     Tick (ProfNote (mkUserCC cc mod_name loc uniq) count True) <$> dsLExpr expr
309
310 dsExpr (HsCoreAnn _ expr)
311   = dsLExpr expr
312
313 dsExpr (HsCase discrim matches)
314   = do { core_discrim <- dsLExpr discrim
315        ; ([discrim_var], matching_code) <- matchWrapper CaseAlt matches
316        ; return (bindNonRec discrim_var core_discrim matching_code) }
317
318 -- Pepe: The binds are in scope in the body but NOT in the binding group
319 --       This is to avoid silliness in breakpoints
320 dsExpr (HsLet binds body) = do
321     body' <- dsLExpr body
322     dsLocalBinds binds body'
323
324 -- We need the `ListComp' form to use `deListComp' (rather than the "do" form)
325 -- because the interpretation of `stmts' depends on what sort of thing it is.
326 --
327 dsExpr (HsDo ListComp     stmts res_ty) = dsListComp stmts res_ty
328 dsExpr (HsDo PArrComp     stmts _)      = dsPArrComp (map unLoc stmts)
329 dsExpr (HsDo DoExpr       stmts _)      = dsDo stmts 
330 dsExpr (HsDo GhciStmtCtxt stmts _)      = dsDo stmts 
331 dsExpr (HsDo MDoExpr      stmts _)      = dsDo stmts 
332 dsExpr (HsDo MonadComp    stmts _)      = dsMonadComp stmts
333
334 dsExpr (HsIf mb_fun guard_expr then_expr else_expr)
335   = do { pred <- dsLExpr guard_expr
336        ; b1 <- dsLExpr then_expr
337        ; b2 <- dsLExpr else_expr
338        ; case mb_fun of
339            Just fun -> do { core_fun <- dsExpr fun
340                           ; return (mkCoreApps core_fun [pred,b1,b2]) }
341            Nothing  -> return $ mkIfThenElse pred b1 b2 }
342
343 dsExpr (HsMultiIf res_ty alts)
344   | null alts
345   = mkErrorExpr
346
347   | otherwise
348   = do { match_result <- liftM (foldr1 combineMatchResults)
349                                (mapM (dsGRHS IfAlt res_ty) alts)
350        ; error_expr   <- mkErrorExpr
351        ; extractMatchResult match_result error_expr }
352   where
353     mkErrorExpr = mkErrorAppDs nON_EXHAUSTIVE_GUARDS_ERROR_ID res_ty
354                                (ptext (sLit "multi-way if"))
355 \end{code}
356
357
358 \noindent
359 \underline{\bf Various data construction things}
360 %              ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
361 \begin{code}
362 dsExpr (ExplicitList elt_ty wit xs) 
363   = dsExplicitList elt_ty wit xs
364
365 -- We desugar [:x1, ..., xn:] as
366 --   singletonP x1 +:+ ... +:+ singletonP xn
367 --
368 dsExpr (ExplicitPArr ty []) = do
369     emptyP <- dsDPHBuiltin emptyPVar
370     return (Var emptyP `App` Type ty)
371 dsExpr (ExplicitPArr ty xs) = do
372     singletonP <- dsDPHBuiltin singletonPVar
373     appP       <- dsDPHBuiltin appPVar
374     xs'        <- mapM dsLExpr xs
375     return . foldr1 (binary appP) $ map (unary singletonP) xs'
376   where
377     unary  fn x   = mkApps (Var fn) [Type ty, x]
378     binary fn x y = mkApps (Var fn) [Type ty, x, y]
379
380 dsExpr (ArithSeq expr witness seq)
381   = case witness of
382      Nothing -> dsArithSeq expr seq
383      Just fl -> do { 
384        ; fl' <- dsExpr fl
385        ; newArithSeq <- dsArithSeq expr seq
386        ; return (App fl' newArithSeq)}
387
388 dsExpr (PArrSeq expr (FromTo from to))
389   = mkApps <$> dsExpr expr <*> mapM dsLExpr [from, to]
390
391 dsExpr (PArrSeq expr (FromThenTo from thn to))
392   = mkApps <$> dsExpr expr <*> mapM dsLExpr [from, thn, to]
393
394 dsExpr (PArrSeq _ _)
395   = panic "DsExpr.dsExpr: Infinite parallel array!"
396     -- the parser shouldn't have generated it and the renamer and typechecker
397     -- shouldn't have let it through
398 \end{code}
399
400 \noindent
401 \underline{\bf Record construction and update}
402 %              ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
403 For record construction we do this (assuming T has three arguments)
404 \begin{verbatim}
405         T { op2 = e }
406 ==>
407         let err = /\a -> recConErr a 
408         T (recConErr t1 "M.lhs/230/op1") 
409           e 
410           (recConErr t1 "M.lhs/230/op3")
411 \end{verbatim}
412 @recConErr@ then converts its arugment string into a proper message
413 before printing it as
414 \begin{verbatim}
415         M.lhs, line 230: missing field op1 was evaluated
416 \end{verbatim}
417
418 We also handle @C{}@ as valid construction syntax for an unlabelled
419 constructor @C@, setting all of @C@'s fields to bottom.
420
421 \begin{code}
422 dsExpr (RecordCon (L _ data_con_id) con_expr rbinds) = do
423     con_expr' <- dsExpr con_expr
424     let
425         (arg_tys, _) = tcSplitFunTys (exprType con_expr')
426         -- A newtype in the corner should be opaque; 
427         -- hence TcType.tcSplitFunTys
428
429         mk_arg (arg_ty, lbl)    -- Selector id has the field label as its name
430           = case findField (rec_flds rbinds) lbl of
431               (rhs:rhss) -> ASSERT( null rhss )
432                             dsLExpr rhs
433               []         -> mkErrorAppDs rEC_CON_ERROR_ID arg_ty (ppr lbl)
434         unlabelled_bottom arg_ty = mkErrorAppDs rEC_CON_ERROR_ID arg_ty empty
435
436         labels = dataConFieldLabels (idDataCon data_con_id)
437         -- The data_con_id is guaranteed to be the wrapper id of the constructor
438     
439     con_args <- if null labels
440                 then mapM unlabelled_bottom arg_tys
441                 else mapM mk_arg (zipEqual "dsExpr:RecordCon" arg_tys labels)
442     
443     return (mkApps con_expr' con_args)
444 \end{code}
445
446 Record update is a little harder. Suppose we have the decl:
447 \begin{verbatim}
448         data T = T1 {op1, op2, op3 :: Int}
449                | T2 {op4, op2 :: Int}
450                | T3
451 \end{verbatim}
452 Then we translate as follows:
453 \begin{verbatim}
454         r { op2 = e }
455 ===>
456         let op2 = e in
457         case r of
458           T1 op1 _ op3 -> T1 op1 op2 op3
459           T2 op4 _     -> T2 op4 op2
460           other        -> recUpdError "M.lhs/230"
461 \end{verbatim}
462 It's important that we use the constructor Ids for @T1@, @T2@ etc on the
463 RHSs, and do not generate a Core constructor application directly, because the constructor
464 might do some argument-evaluation first; and may have to throw away some
465 dictionaries.
466
467 Note [Update for GADTs]
468 ~~~~~~~~~~~~~~~~~~~~~~~
469 Consider 
470    data T a b where
471      T1 { f1 :: a } :: T a Int
472
473 Then the wrapper function for T1 has type 
474    $WT1 :: a -> T a Int
475 But if x::T a b, then
476    x { f1 = v } :: T a b   (not T a Int!)
477 So we need to cast (T a Int) to (T a b).  Sigh.
478
479 \begin{code}
480 dsExpr expr@(RecordUpd record_expr (HsRecFields { rec_flds = fields })
481                        cons_to_upd in_inst_tys out_inst_tys)
482   | null fields
483   = dsLExpr record_expr
484   | otherwise
485   = ASSERT2( notNull cons_to_upd, ppr expr )
486
487     do  { record_expr' <- dsLExpr record_expr
488         ; field_binds' <- mapM ds_field fields
489         ; let upd_fld_env :: NameEnv Id -- Maps field name to the LocalId of the field binding
490               upd_fld_env = mkNameEnv [(f,l) | (f,l,_) <- field_binds']
491
492         -- It's important to generate the match with matchWrapper,
493         -- and the right hand sides with applications of the wrapper Id
494         -- so that everything works when we are doing fancy unboxing on the
495         -- constructor aguments.
496         ; alts <- mapM (mk_alt upd_fld_env) cons_to_upd
497         ; ([discrim_var], matching_code) 
498                 <- matchWrapper RecUpd (MG { mg_alts = alts, mg_arg_tys = [in_ty], mg_res_ty = out_ty })
499
500         ; return (add_field_binds field_binds' $
501                   bindNonRec discrim_var record_expr' matching_code) }
502   where
503     ds_field :: HsRecField Id (LHsExpr Id) -> DsM (Name, Id, CoreExpr)
504       -- Clone the Id in the HsRecField, because its Name is that
505       -- of the record selector, and we must not make that a lcoal binder
506       -- else we shadow other uses of the record selector
507       -- Hence 'lcl_id'.  Cf Trac #2735
508     ds_field rec_field = do { rhs <- dsLExpr (hsRecFieldArg rec_field)
509                             ; let fld_id = unLoc (hsRecFieldId rec_field)
510                             ; lcl_id <- newSysLocalDs (idType fld_id)
511                             ; return (idName fld_id, lcl_id, rhs) }
512
513     add_field_binds [] expr = expr
514     add_field_binds ((_,b,r):bs) expr = bindNonRec b r (add_field_binds bs expr)
515
516         -- Awkwardly, for families, the match goes 
517         -- from instance type to family type
518     tycon     = dataConTyCon (head cons_to_upd)
519     in_ty     = mkTyConApp tycon in_inst_tys
520     out_ty    = mkFamilyTyConApp tycon out_inst_tys
521
522     mk_alt upd_fld_env con
523       = do { let (univ_tvs, ex_tvs, eq_spec, 
524                   theta, arg_tys, _) = dataConFullSig con
525                  subst = mkTopTvSubst (univ_tvs `zip` in_inst_tys)
526
527                 -- I'm not bothering to clone the ex_tvs
528            ; eqs_vars   <- mapM newPredVarDs (substTheta subst (eqSpecPreds eq_spec))
529            ; theta_vars <- mapM newPredVarDs (substTheta subst theta)
530            ; arg_ids    <- newSysLocalsDs (substTys subst arg_tys)
531            ; let val_args = zipWithEqual "dsExpr:RecordUpd" mk_val_arg
532                                          (dataConFieldLabels con) arg_ids
533                  mk_val_arg field_name pat_arg_id 
534                      = nlHsVar (lookupNameEnv upd_fld_env field_name `orElse` pat_arg_id)
535                  inst_con = noLoc $ HsWrap wrap (HsVar (dataConWrapId con))
536                         -- Reconstruct with the WrapId so that unpacking happens
537                  wrap = mkWpEvVarApps theta_vars          <.>
538                         mkWpTyApps    (mkTyVarTys ex_tvs) <.>
539                         mkWpTyApps [ty | (tv, ty) <- univ_tvs `zip` out_inst_tys
540                                        , not (tv `elemVarEnv` wrap_subst) ]
541                  rhs = foldl (\a b -> nlHsApp a b) inst_con val_args
542
543                         -- Tediously wrap the application in a cast
544                         -- Note [Update for GADTs]
545                  wrap_co = mkTcTyConAppCo tycon
546                                 [ lookup tv ty | (tv,ty) <- univ_tvs `zip` out_inst_tys ]
547                  lookup univ_tv ty = case lookupVarEnv wrap_subst univ_tv of
548                                         Just co' -> co'
549                                         Nothing  -> mkTcReflCo ty
550                  wrap_subst = mkVarEnv [ (tv, mkTcSymCo (mkTcCoVarCo eq_var))
551                                        | ((tv,_),eq_var) <- eq_spec `zip` eqs_vars ]
552
553                  pat = noLoc $ ConPatOut { pat_con = noLoc con, pat_tvs = ex_tvs
554                                          , pat_dicts = eqs_vars ++ theta_vars
555                                          , pat_binds = emptyTcEvBinds
556                                          , pat_args = PrefixCon $ map nlVarPat arg_ids
557                                          , pat_ty = in_ty }
558            ; let wrapped_rhs | null eq_spec = rhs
559                              | otherwise    = mkLHsWrap (WpCast wrap_co) rhs
560            ; return (mkSimpleMatch [pat] wrapped_rhs) }
561
562 \end{code}
563
564 Here is where we desugar the Template Haskell brackets and escapes
565
566 \begin{code}
567 -- Template Haskell stuff
568
569 #ifdef GHCI
570 dsExpr (HsBracketOut x ps) = dsBracket x ps
571 #else
572 dsExpr (HsBracketOut _ _) = panic "dsExpr HsBracketOut"
573 #endif
574 dsExpr (HsSpliceE s)       = pprPanic "dsExpr:splice" (ppr s)
575
576 -- Arrow notation extension
577 dsExpr (HsProc pat cmd) = dsProcExpr pat cmd
578 \end{code}
579
580 Hpc Support 
581
582 \begin{code}
583 dsExpr (HsTick tickish e) = do
584   e' <- dsLExpr e
585   return (Tick tickish e')
586
587 -- There is a problem here. The then and else branches
588 -- have no free variables, so they are open to lifting.
589 -- We need someway of stopping this.
590 -- This will make no difference to binary coverage
591 -- (did you go here: YES or NO), but will effect accurate
592 -- tick counting.
593
594 dsExpr (HsBinTick ixT ixF e) = do
595   e2 <- dsLExpr e
596   do { ASSERT(exprType e2 `eqType` boolTy)
597        mkBinaryTickBox ixT ixF e2
598      }
599 \end{code}
600
601 \begin{code}
602
603 -- HsSyn constructs that just shouldn't be here:
604 dsExpr (ExprWithTySig {})  = panic "dsExpr:ExprWithTySig"
605 dsExpr (HsBracket     {})  = panic "dsExpr:HsBracket"
606 dsExpr (HsQuasiQuoteE {})  = panic "dsExpr:HsQuasiQuoteE"
607 dsExpr (HsArrApp      {})  = panic "dsExpr:HsArrApp"
608 dsExpr (HsArrForm     {})  = panic "dsExpr:HsArrForm"
609 dsExpr (HsTickPragma  {})  = panic "dsExpr:HsTickPragma"
610 dsExpr (EWildPat      {})  = panic "dsExpr:EWildPat"
611 dsExpr (EAsPat        {})  = panic "dsExpr:EAsPat"
612 dsExpr (EViewPat      {})  = panic "dsExpr:EViewPat"
613 dsExpr (ELazyPat      {})  = panic "dsExpr:ELazyPat"
614 dsExpr (HsType        {})  = panic "dsExpr:HsType"
615 dsExpr (HsDo          {})  = panic "dsExpr:HsDo"
616
617
618 findField :: [HsRecField Id arg] -> Name -> [arg]
619 findField rbinds lbl 
620   = [rhs | HsRecField { hsRecFieldId = id, hsRecFieldArg = rhs } <- rbinds 
621          , lbl == idName (unLoc id) ]
622 \end{code}
623
624 %--------------------------------------------------------------------
625
626 Note [Desugaring explicit lists]
627 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
628 Explicit lists are desugared in a cleverer way to prevent some
629 fruitless allocations.  Essentially, whenever we see a list literal
630 [x_1, ..., x_n] we:
631
632 1. Find the tail of the list that can be allocated statically (say
633    [x_k, ..., x_n]) by later stages and ensure we desugar that
634    normally: this makes sure that we don't cause a code size increase
635    by having the cons in that expression fused (see later) and hence
636    being unable to statically allocate any more
637
638 2. For the prefix of the list which cannot be allocated statically,
639    say [x_1, ..., x_(k-1)], we turn it into an expression involving
640    build so that if we find any foldrs over it it will fuse away
641    entirely!
642    
643    So in this example we will desugar to:
644    build (\c n -> x_1 `c` x_2 `c` .... `c` foldr c n [x_k, ..., x_n]
645    
646    If fusion fails to occur then build will get inlined and (since we
647    defined a RULE for foldr (:) []) we will get back exactly the
648    normal desugaring for an explicit list.
649
650 This optimisation can be worth a lot: up to 25% of the total
651 allocation in some nofib programs. Specifically
652
653         Program           Size    Allocs   Runtime  CompTime
654         rewrite          +0.0%    -26.3%      0.02     -1.8%
655            ansi          -0.3%    -13.8%      0.00     +0.0%
656            lift          +0.0%     -8.7%      0.00     -2.3%
657
658 Of course, if rules aren't turned on then there is pretty much no
659 point doing this fancy stuff, and it may even be harmful.
660
661 =======>  Note by SLPJ Dec 08.
662
663 I'm unconvinced that we should *ever* generate a build for an explicit
664 list.  See the comments in GHC.Base about the foldr/cons rule, which 
665 points out that (foldr k z [a,b,c]) may generate *much* less code than
666 (a `k` b `k` c `k` z).
667
668 Furthermore generating builds messes up the LHS of RULES. 
669 Example: the foldr/single rule in GHC.Base
670    foldr k z [x] = ...
671 We do not want to generate a build invocation on the LHS of this RULE!
672
673 We fix this by disabling rules in rule LHSs, and testing that
674 flag here; see Note [Desugaring RULE left hand sides] in Desugar
675
676 To test this I've added a (static) flag -fsimple-list-literals, which
677 makes all list literals be generated via the simple route.  
678
679
680 \begin{code}
681 dsExplicitList :: PostTcType -> Maybe (SyntaxExpr Id) -> [LHsExpr Id] -> DsM CoreExpr
682 -- See Note [Desugaring explicit lists]
683 dsExplicitList elt_ty Nothing xs
684   = do { dflags <- getDynFlags
685        ; xs' <- mapM dsLExpr xs
686        ; let (dynamic_prefix, static_suffix) = spanTail is_static xs'
687        ; if gopt Opt_SimpleListLiterals dflags        -- -fsimple-list-literals
688          || not (gopt Opt_EnableRewriteRules dflags)  -- Rewrite rules off
689                 -- Don't generate a build if there are no rules to eliminate it!
690                 -- See Note [Desugaring RULE left hand sides] in Desugar
691          || null dynamic_prefix   -- Avoid build (\c n. foldr c n xs)!
692          then return $ mkListExpr elt_ty xs'
693          else mkBuildExpr elt_ty (mkSplitExplicitList dynamic_prefix static_suffix) }
694   where
695     is_static :: CoreExpr -> Bool
696     is_static e = all is_static_var (varSetElems (exprFreeVars e))
697
698     is_static_var :: Var -> Bool
699     is_static_var v 
700       | isId v = isExternalName (idName v)  -- Top-level things are given external names
701       | otherwise = False                   -- Type variables
702
703     mkSplitExplicitList prefix suffix (c, _) (n, n_ty)
704       = do { let suffix' = mkListExpr elt_ty suffix
705            ; folded_suffix <- mkFoldrExpr elt_ty n_ty (Var c) (Var n) suffix'
706            ; return (foldr (App . App (Var c)) folded_suffix prefix) }
707
708 dsExplicitList elt_ty (Just fln) xs
709   = do { fln' <- dsExpr fln
710        ; list <- dsExplicitList elt_ty Nothing xs
711        ; dflags <- getDynFlags
712        ; return (App (App fln' (mkIntExprInt dflags (length xs))) list) }
713        
714 spanTail :: (a -> Bool) -> [a] -> ([a], [a])
715 spanTail f xs = (reverse rejected, reverse satisfying)
716     where (satisfying, rejected) = span f $ reverse xs
717     
718 dsArithSeq :: PostTcExpr -> (ArithSeqInfo Id) -> DsM CoreExpr
719 dsArithSeq expr (From from)
720   = App <$> dsExpr expr <*> dsLExpr from
721 dsArithSeq expr (FromTo from to)
722   = do expr' <- dsExpr expr
723        from' <- dsLExpr from
724        to'   <- dsLExpr to
725        warn_empty_enumerations <- woptM Opt_WarnEmptyEnumerations
726        when warn_empty_enumerations $
727            warnAboutEmptyEnumerations from' Nothing to'
728        return $ mkApps expr' [from', to']
729 dsArithSeq expr (FromThen from thn)
730   = mkApps <$> dsExpr expr <*> mapM dsLExpr [from, thn]
731 dsArithSeq expr (FromThenTo from thn to)
732   = do expr' <- dsExpr expr
733        from' <- dsLExpr from
734        thn'  <- dsLExpr thn
735        to'   <- dsLExpr to
736        warn_empty_enumerations <- woptM Opt_WarnEmptyEnumerations
737        when warn_empty_enumerations $
738            warnAboutEmptyEnumerations from' (Just thn') to'
739        return $ mkApps expr' [from', thn', to']
740 \end{code}
741
742 Desugar 'do' and 'mdo' expressions (NOT list comprehensions, they're
743 handled in DsListComp).  Basically does the translation given in the
744 Haskell 98 report:
745
746 \begin{code}
747 dsDo :: [ExprLStmt Id] -> DsM CoreExpr
748 dsDo stmts
749   = goL stmts
750   where
751     goL [] = panic "dsDo"
752     goL (L loc stmt:lstmts) = putSrcSpanDs loc (go loc stmt lstmts)
753   
754     go _ (LastStmt body _) stmts
755       = ASSERT( null stmts ) dsLExpr body
756         -- The 'return' op isn't used for 'do' expressions
757
758     go _ (BodyStmt rhs then_expr _ _) stmts
759       = do { rhs2 <- dsLExpr rhs
760            ; warnDiscardedDoBindings rhs (exprType rhs2) 
761            ; then_expr2 <- dsExpr then_expr
762            ; rest <- goL stmts
763            ; return (mkApps then_expr2 [rhs2, rest]) }
764     
765     go _ (LetStmt binds) stmts
766       = do { rest <- goL stmts
767            ; dsLocalBinds binds rest }
768
769     go _ (BindStmt pat rhs bind_op fail_op) stmts
770       = do  { body     <- goL stmts
771             ; rhs'     <- dsLExpr rhs
772             ; bind_op' <- dsExpr bind_op
773             ; var   <- selectSimpleMatchVarL pat
774             ; let bind_ty = exprType bind_op'   -- rhs -> (pat -> res1) -> res2
775                   res1_ty = funResultTy (funArgTy (funResultTy bind_ty))
776             ; match <- matchSinglePat (Var var) (StmtCtxt DoExpr) pat
777                                       res1_ty (cantFailMatchResult body)
778             ; match_code <- handle_failure pat match fail_op
779             ; return (mkApps bind_op' [rhs', Lam var match_code]) }
780     
781     go loc (RecStmt { recS_stmts = rec_stmts, recS_later_ids = later_ids
782                     , recS_rec_ids = rec_ids, recS_ret_fn = return_op
783                     , recS_mfix_fn = mfix_op, recS_bind_fn = bind_op
784                     , recS_rec_rets = rec_rets, recS_ret_ty = body_ty }) stmts
785       = goL (new_bind_stmt : stmts)  -- rec_ids can be empty; eg  rec { print 'x' }
786       where
787         new_bind_stmt = L loc $ BindStmt (mkBigLHsPatTup later_pats)
788                                          mfix_app bind_op 
789                                          noSyntaxExpr  -- Tuple cannot fail
790
791         tup_ids      = rec_ids ++ filterOut (`elem` rec_ids) later_ids
792         tup_ty       = mkBigCoreTupTy (map idType tup_ids) -- Deals with singleton case
793         rec_tup_pats = map nlVarPat tup_ids
794         later_pats   = rec_tup_pats
795         rets         = map noLoc rec_rets
796         mfix_app     = nlHsApp (noLoc mfix_op) mfix_arg
797         mfix_arg     = noLoc $ HsLam (MG { mg_alts = [mkSimpleMatch [mfix_pat] body]
798                                          , mg_arg_tys = [tup_ty], mg_res_ty = body_ty })
799         mfix_pat     = noLoc $ LazyPat $ mkBigLHsPatTup rec_tup_pats
800         body         = noLoc $ HsDo DoExpr (rec_stmts ++ [ret_stmt]) body_ty
801         ret_app      = nlHsApp (noLoc return_op) (mkBigLHsTup rets)
802         ret_stmt     = noLoc $ mkLastStmt ret_app
803                      -- This LastStmt will be desugared with dsDo, 
804                      -- which ignores the return_op in the LastStmt,
805                      -- so we must apply the return_op explicitly 
806
807     go _ (ParStmt   {}) _ = panic "dsDo ParStmt"
808     go _ (TransStmt {}) _ = panic "dsDo TransStmt"
809
810 handle_failure :: LPat Id -> MatchResult -> SyntaxExpr Id -> DsM CoreExpr
811     -- In a do expression, pattern-match failure just calls
812     -- the monadic 'fail' rather than throwing an exception
813 handle_failure pat match fail_op
814   | matchCanFail match
815   = do { fail_op' <- dsExpr fail_op
816        ; dflags <- getDynFlags
817        ; fail_msg <- mkStringExpr (mk_fail_msg dflags pat)
818        ; extractMatchResult match (App fail_op' fail_msg) }
819   | otherwise
820   = extractMatchResult match (error "It can't fail")
821
822 mk_fail_msg :: DynFlags -> Located e -> String
823 mk_fail_msg dflags pat = "Pattern match failure in do expression at " ++ 
824                          showPpr dflags (getLoc pat)
825 \end{code}
826
827
828 %************************************************************************
829 %*                                                                      *
830                  Warnings
831 %*                                                                      *
832 %************************************************************************
833
834 Warn about functions like toInteger, fromIntegral, that convert
835 between one type and another when the to- and from- types are the
836 same.  Then it's probably (albeit not definitely) the identity
837
838 \begin{code}
839 warnAboutIdentities :: CoreExpr -> CoreExpr -> DsM ()
840 warnAboutIdentities (Var v) wrapped_fun
841   | idName v `elem` conversionNames
842   , let fun_ty = exprType wrapped_fun
843   , Just (arg_ty, res_ty) <- splitFunTy_maybe fun_ty
844   , arg_ty `eqType` res_ty  -- So we are converting  ty -> ty
845   = warnDs (vcat [ ptext (sLit "Call of") <+> ppr v <+> dcolon <+> ppr fun_ty
846                  , nest 2 $ ptext (sLit "can probably be omitted")
847                  , parens (ptext (sLit "Use -fno-warn-identities to suppress this messsage)"))
848            ])
849 warnAboutIdentities _ _ = return ()
850
851 conversionNames :: [Name]
852 conversionNames
853   = [ toIntegerName, toRationalName
854     , fromIntegralName, realToFracName ]
855  -- We can't easily add fromIntegerName, fromRationalName,
856  -- because they are generated by literals
857 \end{code}
858
859 \begin{code}
860 warnAboutOverflowedLiterals :: CoreExpr -> DsM ()
861 warnAboutOverflowedLiterals (App (App (App (Var f) (Type t)) _) (Lit (LitInteger i _)))
862  | idName f == fromIntegerName,
863    Just tc <- tyConAppTyCon_maybe t,
864    let t = tyConName tc
865     = let checkOverflow proxy
866               = when (i < fromIntegral (minBound `asTypeOf` proxy) ||
867                       i > fromIntegral (maxBound `asTypeOf` proxy)) $
868                     warnDs (ptext (sLit "Literal") <+> integer i <+>
869                             ptext (sLit "of type") <+>
870                             text (show (typeOf proxy)) <+>
871                             ptext (sLit "overflows"))
872       in      if t == intTyConName    then checkOverflow (undefined :: Int)
873          else if t == int8TyConName   then checkOverflow (undefined :: Int8)
874          else if t == int16TyConName  then checkOverflow (undefined :: Int16)
875          else if t == int32TyConName  then checkOverflow (undefined :: Int32)
876          else if t == int64TyConName  then checkOverflow (undefined :: Int64)
877          else if t == wordTyConName   then checkOverflow (undefined :: Word)
878          else if t == word8TyConName  then checkOverflow (undefined :: Word8)
879          else if t == word16TyConName then checkOverflow (undefined :: Word16)
880          else if t == word32TyConName then checkOverflow (undefined :: Word32)
881          else if t == word64TyConName then checkOverflow (undefined :: Word64)
882          else return ()
883 warnAboutOverflowedLiterals _ = return ()
884 \end{code}
885
886 \begin{code}
887 warnAboutEmptyEnumerations :: CoreExpr -> Maybe CoreExpr -> CoreExpr -> DsM ()
888 warnAboutEmptyEnumerations fromExpr mThnExpr toExpr
889  | Just from <- getVal fromExpr
890  , Just mThn <- traverse getVal mThnExpr
891  , Just to   <- getVal toExpr
892  , Just t    <- getType fromExpr
893     = let check proxy
894               = let enumeration
895                         = case mThn of
896                           Nothing  -> [(fromInteger from `asTypeOf` proxy) .. fromInteger to]
897                           Just thn -> [fromInteger from, fromInteger thn   .. fromInteger to]
898                 in when (null enumeration) $
899                        warnDs (ptext (sLit "Enumeration is empty"))
900
901       in if t == intTyConName    then check (undefined :: Int)
902     else if t == int8TyConName   then check (undefined :: Int8)
903     else if t == int16TyConName  then check (undefined :: Int16)
904     else if t == int32TyConName  then check (undefined :: Int32)
905     else if t == int64TyConName  then check (undefined :: Int64)
906     else if t == wordTyConName   then check (undefined :: Word)
907     else if t == word8TyConName  then check (undefined :: Word8)
908     else if t == word16TyConName then check (undefined :: Word16)
909     else if t == word32TyConName then check (undefined :: Word32)
910     else if t == word64TyConName then check (undefined :: Word64)
911     else return ()
912
913     where getVal (App (App (App (Var f) (Type _)) _) (Lit (LitInteger i _)))
914            | idName f == fromIntegerName = Just i
915           getVal _ = Nothing
916
917           getType (App (App (App (Var f) (Type t)) _) (Lit (LitInteger _ _)))
918            | idName f == fromIntegerName,
919              Just tc <- tyConAppTyCon_maybe t = Just (tyConName tc)
920           getType _ = Nothing
921
922 warnAboutEmptyEnumerations _ _ _ = return ()
923 \end{code}
924
925 %************************************************************************
926 %*                                                                      *
927 \subsection{Errors and contexts}
928 %*                                                                      *
929 %************************************************************************
930
931 \begin{code}
932 -- Warn about certain types of values discarded in monadic bindings (#3263)
933 warnDiscardedDoBindings :: LHsExpr Id -> Type -> DsM ()
934 warnDiscardedDoBindings rhs rhs_ty
935   | Just (m_ty, elt_ty) <- tcSplitAppTy_maybe rhs_ty
936   = do {  -- Warn about discarding non-() things in 'monadic' binding
937        ; warn_unused <- woptM Opt_WarnUnusedDoBind
938        ; if warn_unused && not (isUnitTy elt_ty)
939          then warnDs (unusedMonadBind rhs elt_ty)
940          else 
941          -- Warn about discarding m a things in 'monadic' binding of the same type,
942          -- but only if we didn't already warn due to Opt_WarnUnusedDoBind
943     do { warn_wrong <- woptM Opt_WarnWrongDoBind
944        ; case tcSplitAppTy_maybe elt_ty of
945            Just (elt_m_ty, _) | warn_wrong, m_ty `eqType` elt_m_ty
946                               -> warnDs (wrongMonadBind rhs elt_ty)
947            _ -> return () } }
948
949   | otherwise   -- RHS does have type of form (m ty), which is wierd
950   = return ()   -- but at lesat this warning is irrelevant
951
952 unusedMonadBind :: LHsExpr Id -> Type -> SDoc
953 unusedMonadBind rhs elt_ty
954   = ptext (sLit "A do-notation statement discarded a result of type") <+> ppr elt_ty <> dot $$
955     ptext (sLit "Suppress this warning by saying \"_ <- ") <> ppr rhs <> ptext (sLit "\",") $$
956     ptext (sLit "or by using the flag -fno-warn-unused-do-bind")
957
958 wrongMonadBind :: LHsExpr Id -> Type -> SDoc
959 wrongMonadBind rhs elt_ty
960   = ptext (sLit "A do-notation statement discarded a result of type") <+> ppr elt_ty <> dot $$
961     ptext (sLit "Suppress this warning by saying \"_ <- ") <> ppr rhs <> ptext (sLit "\",") $$
962     ptext (sLit "or by using the flag -fno-warn-wrong-do-bind")
963 \end{code}