DsExpr.lhs 33.1 KB
Newer Older
1
%
Simon Marlow's avatar
Simon Marlow committed
2
% (c) The University of Glasgow 2006
3
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
4
%
Simon Marlow's avatar
Simon Marlow committed
5 6

Desugaring exporessions.
7 8

\begin{code}
9
module DsExpr ( dsExpr, dsLExpr, dsLocalBinds, dsValBinds, dsLit ) where
10

11
#include "HsVersions.h"
mnislaih's avatar
mnislaih committed
12

Simon Marlow's avatar
Simon Marlow committed
13 14 15 16 17 18 19
import Match
import MatchLit
import DsBinds
import DsGRHSs
import DsListComp
import DsUtils
import DsArrows
20
import DsMonad
21
import Name
22
import NameEnv
23 24

#ifdef GHCI
25
        -- Template Haskell stuff iff bootstrapped
Simon Marlow's avatar
Simon Marlow committed
26
import DsMeta
27 28
#endif

29
import HsSyn
30 31

-- NB: The desugarer, which straddles the source and Core worlds, sometimes
Simon Marlow's avatar
Simon Marlow committed
32 33
--     needs to see source types
import TcType
34
import TcEvidence
35
import TcRnMonad
Simon Marlow's avatar
Simon Marlow committed
36
import Type
37
import CoreSyn
Simon Marlow's avatar
Simon Marlow committed
38
import CoreUtils
39
import CoreFVs
40
import MkCore
Simon Marlow's avatar
Simon Marlow committed
41

42
import DynFlags
Simon Marlow's avatar
Simon Marlow committed
43 44
import CostCentre
import Id
45
import Module
46
import VarSet
47
import VarEnv
Simon Marlow's avatar
Simon Marlow committed
48 49 50 51
import DataCon
import TysWiredIn
import BasicTypes
import PrelNames
52
import Maybes
Simon Marlow's avatar
Simon Marlow committed
53 54 55
import SrcLoc
import Util
import Bag
56
import Outputable
57
import FastString
58 59

import Control.Monad
60 61
\end{code}

62 63

%************************************************************************
64 65 66
%*                                                                      *
                dsLocalBinds, dsValBinds
%*                                                                      *
67 68 69
%************************************************************************

\begin{code}
70
dsLocalBinds :: HsLocalBinds Id -> CoreExpr -> DsM CoreExpr
71
dsLocalBinds EmptyLocalBinds    body = return body
72 73 74 75 76
dsLocalBinds (HsValBinds binds) body = dsValBinds binds body
dsLocalBinds (HsIPBinds binds)  body = dsIPBinds  binds body

-------------------------
dsValBinds :: HsValBinds Id -> CoreExpr -> DsM CoreExpr
77
dsValBinds (ValBindsOut binds _) body = foldrM ds_val_bind body binds
78
dsValBinds (ValBindsIn  _     _) _    = panic "dsValBinds ValBindsIn"
79 80

-------------------------
81
dsIPBinds :: HsIPBinds Id -> CoreExpr -> DsM CoreExpr
82
dsIPBinds (IPBinds ip_binds ev_binds) body
83 84
  = do  { ds_binds <- dsTcEvBinds ev_binds
        ; let inner = mkCoreLets ds_binds body
85 86 87
                -- The dict bindings may not be in 
                -- dependency order; hence Rec
        ; foldrM ds_ip_bind inner ip_binds }
88
  where
89
    ds_ip_bind (L _ (IPBind ~(Right n) e)) body
90
      = do e' <- dsLExpr e
91
           return (Let (NonRec n e') body)
92

93 94
-------------------------
ds_val_bind :: (RecFlag, LHsBinds Id) -> CoreExpr -> DsM CoreExpr
95
-- Special case for bindings which bind unlifted variables
96 97
-- We need to do a case right away, rather than building
-- a tuple and doing selections.
98
-- Silently ignore INLINE and SPECIALISE pragmas...
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
99
ds_val_bind (NonRecursive, hsbinds) body
100
  | [L loc bind] <- bagToList hsbinds,
101 102 103 104
        -- Non-recursive, non-overloaded bindings only come in ones
        -- ToDo: in some bizarre case it's conceivable that there
        --       could be dict binds in the 'binds'.  (See the notes
        --       below.  Then pattern-match would fail.  Urk.)
105 106
    strictMatchOnly bind
  = putSrcSpanDs loc (dsStrictBind bind body)
107

simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
108
-- Ordinary case for bindings; none should be unlifted
109
ds_val_bind (_is_rec, binds) body
110 111 112
  = do  { prs <- dsLHsBinds binds
        ; ASSERT2( not (any (isUnLiftedType . idType . fst) prs), ppr _is_rec $$ ppr binds )
          case prs of
113 114
            [] -> return body
            _  -> return (Let (Rec prs) body) }
115 116 117 118 119 120 121 122 123 124
        -- Use a Rec regardless of is_rec. 
        -- Why? Because it allows the binds to be all
        -- mixed up, which is what happens in one rare case
        -- Namely, for an AbsBind with no tyvars and no dicts,
        --         but which does have dictionary bindings.
        -- See notes with TcSimplify.inferLoop [NO TYVARS]
        -- It turned out that wrapping a Rec here was the easiest solution
        --
        -- NB The previous case dealt with unlifted bindings, so we
        --    only have to deal with lifted ones now; so Rec is ok
125

126 127 128 129 130 131
------------------
dsStrictBind :: HsBind Id -> CoreExpr -> DsM CoreExpr
dsStrictBind (AbsBinds { abs_tvs = [], abs_ev_vars = []
               , abs_exports = exports
               , abs_ev_binds = ev_binds
               , abs_binds = binds }) body
132
  = do { let body1 = foldr bind_export body exports
133
             bind_export export b = bindNonRec (abe_poly export) (Var (abe_mono export)) b
134 135
       ; body2 <- foldlBagM (\body bind -> dsStrictBind (unLoc bind) body) 
                            body1 binds 
136 137
       ; ds_binds <- dsTcEvBinds ev_binds
       ; return (mkCoreLets ds_binds body2) }
138 139

dsStrictBind (FunBind { fun_id = L _ fun, fun_matches = matches, fun_co_fn = co_fn 
140 141 142
                      , fun_tick = tick, fun_infix = inf }) body
                -- Can't be a bang pattern (that looks like a PatBind)
                -- so must be simply unboxed
143 144 145
  = do { (args, rhs) <- matchWrapper (FunRhs (idName fun ) inf) matches
       ; MASSERT( null args ) -- Functions aren't lifted
       ; MASSERT( isIdHsWrapper co_fn )
146
       ; let rhs' = mkOptTickBox tick rhs
147 148 149
       ; return (bindNonRec fun rhs' body) }

dsStrictBind (PatBind {pat_lhs = pat, pat_rhs = grhss, pat_rhs_ty = ty }) body
150 151
  =     -- let C x# y# = rhs in body
        -- ==> case rhs of C x# y# -> body
152 153 154 155 156 157
    do { rhs <- dsGuarded grhss ty
       ; let upat = unLoc pat
             eqn = EqnInfo { eqn_pats = [upat], 
                             eqn_rhs = cantFailMatchResult body }
       ; var    <- selectMatchVar upat
       ; result <- matchEquations PatBindRhs [var] [eqn] (exprType body)
158
       ; return (bindNonRec var rhs result) }
159 160 161 162 163 164 165 166

dsStrictBind bind body = pprPanic "dsLet: unlifted" (ppr bind $$ ppr body)

----------------------
strictMatchOnly :: HsBind Id -> Bool
strictMatchOnly (AbsBinds { abs_binds = binds })
  = anyBag (strictMatchOnly . unLoc) binds
strictMatchOnly (PatBind { pat_lhs = lpat, pat_rhs_ty = ty })
167
  =  isUnLiftedType ty 
168 169 170 171 172
  || isBangLPat lpat   
  || any (isUnLiftedType . idType) (collectPatBinders lpat)
strictMatchOnly (FunBind { fun_id = L _ id })
  = isUnLiftedType (idType id)
strictMatchOnly _ = False -- I hope!  Checked immediately by caller in fact
173

174
\end{code}
175 176

%************************************************************************
177
%*                                                                      *
178
\subsection[DsExpr-vars-and-cons]{Variables, constructors, literals}
179
%*                                                                      *
180 181 182
%************************************************************************

\begin{code}
183
dsLExpr :: LHsExpr Id -> DsM CoreExpr
mnislaih's avatar
mnislaih committed
184

185 186 187
dsLExpr (L loc e) = putSrcSpanDs loc $ dsExpr e

dsExpr :: HsExpr Id -> DsM CoreExpr
188
dsExpr (HsPar e)              = dsLExpr e
189
dsExpr (ExprWithTySigOut e _) = dsLExpr e
190
dsExpr (HsVar var)            = return (varToCoreExpr var)   -- See Note [Desugaring vars]
191
dsExpr (HsIPVar _)            = panic "dsExpr: HsIPVar"
192 193
dsExpr (HsLit lit)            = dsLit lit
dsExpr (HsOverLit lit)        = dsOverLit lit
194 195

dsExpr (HsWrap co_fn e)
196
  = do { e' <- dsExpr e
197
       ; wrapped_e <- dsHsWrapper co_fn e'
198
       ; warn_id <- woptM Opt_WarnIdentities
199 200
       ; when warn_id $ warnAboutIdentities e' wrapped_e
       ; return wrapped_e }
201 202

dsExpr (NegApp expr neg_expr) 
203
  = App <$> dsExpr neg_expr <*> dsLExpr expr
204

205
dsExpr (HsLam a_Match)
206
  = uncurry mkLams <$> matchWrapper LambdaExpr a_Match
207

208
dsExpr (HsLamCase arg matches)
209 210 211 212
  = do { arg_var <- newSysLocalDs arg
       ; ([discrim_var], matching_code) <- matchWrapper CaseAlt matches
       ; return $ Lam arg_var $ bindNonRec discrim_var (Var arg_var) matching_code }

213
dsExpr (HsApp fun arg)
214
  = mkCoreAppDs <$> dsLExpr fun <*>  dsLExpr arg
215

216
dsExpr (HsUnboundVar _) = panic "dsExpr: HsUnboundVar"
217 218
\end{code}

Simon Peyton Jones's avatar
Simon Peyton Jones committed
219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234
Note [Desugaring vars]
~~~~~~~~~~~~~~~~~~~~~~
In one situation we can get a *coercion* variable in a HsVar, namely
the support method for an equality superclass:
   class (a~b) => C a b where ...
   instance (blah) => C (T a) (T b) where ..
Then we get
   $dfCT :: forall ab. blah => C (T a) (T b)
   $dfCT ab blah = MkC ($c$p1C a blah) ($cop a blah)

   $c$p1C :: forall ab. blah => (T a ~ T b)
   $c$p1C ab blah = let ...; g :: T a ~ T b = ... } in g

That 'g' in the 'in' part is an evidence variable, and when
converting to core it must become a CO.
   
235 236
Operator sections.  At first it looks as if we can convert
\begin{verbatim}
237
        (expr op)
238
\end{verbatim}
239
to
240
\begin{verbatim}
241
        \x -> op expr x
242 243 244 245 246
\end{verbatim}

But no!  expr might be a redex, and we can lose laziness badly this
way.  Consider
\begin{verbatim}
247
        map (expr op) xs
248 249 250
\end{verbatim}
for example.  So we convert instead to
\begin{verbatim}
251
        let y = expr in \x -> op y x
252 253 254 255 256
\end{verbatim}
If \tr{expr} is actually just a variable, say, then the simplifier
will sort it out.

\begin{code}
sof's avatar
sof committed
257
dsExpr (OpApp e1 op _ e2)
258
  = -- for the type of y, we need the type of op's 2nd argument
259
    mkCoreAppsDs <$> dsLExpr op <*> mapM dsLExpr [e1, e2]
sof's avatar
sof committed
260
    
261
dsExpr (SectionL expr op)       -- Desugar (e !) to ((!) e)
262
  = mkCoreAppDs <$> dsLExpr op <*> dsLExpr expr
263

264
-- dsLExpr (SectionR op expr)   -- \ x -> op x expr
265 266
dsExpr (SectionR op expr) = do
    core_op <- dsLExpr op
sof's avatar
sof committed
267
    -- for the type of x, we need the type of op's 2nd argument
268 269 270 271 272 273
    let (x_ty:y_ty:_, _) = splitFunTys (exprType core_op)
        -- See comment with SectionL
    y_core <- dsLExpr expr
    x_id <- newSysLocalDs x_ty
    y_id <- newSysLocalDs y_ty
    return (bindNonRec y_id y_core $
274
            Lam x_id (mkCoreAppsDs core_op [Var x_id, Var y_id]))
275

276 277 278
dsExpr (ExplicitTuple tup_args boxity)
  = do { let go (lam_vars, args) (Missing ty)
                    -- For every missing expression, we need
279
                    -- another lambda in the desugaring.
280 281
               = do { lam_var <- newSysLocalDs ty
                    ; return (lam_var : lam_vars, Var lam_var : args) }
282 283
             go (lam_vars, args) (Present expr)
                    -- Expressions that are present don't generate
284 285 286 287 288
                    -- lambdas, just arguments.
               = do { core_expr <- dsLExpr expr
                    ; return (lam_vars, core_expr : args) }

       ; (lam_vars, args) <- foldM go ([], []) (reverse tup_args)
289
                -- The reverse is because foldM goes left-to-right
290 291

       ; return $ mkCoreLams lam_vars $ 
batterseapower's avatar
batterseapower committed
292
                  mkConApp (tupleCon (boxityNormalTupleSort boxity) (length tup_args))
293 294
                           (map (Type . exprType) args ++ args) }

295
dsExpr (HsSCC cc expr@(L loc _)) = do
296
    mod_name <- getModule
ian@well-typed.com's avatar
ian@well-typed.com committed
297
    count <- goptM Opt_ProfCountEntries
298 299
    uniq <- newUnique
    Tick (ProfNote (mkUserCC cc mod_name loc uniq) count True) <$> dsLExpr expr
300

301 302
dsExpr (HsCoreAnn _ expr)
  = dsLExpr expr
303

304
dsExpr (HsCase discrim matches)
305 306
  = do { core_discrim <- dsLExpr discrim
       ; ([discrim_var], matching_code) <- matchWrapper CaseAlt matches
307
       ; return (bindNonRec discrim_var core_discrim matching_code) }
308

309 310
-- Pepe: The binds are in scope in the body but NOT in the binding group
--       This is to avoid silliness in breakpoints
311 312
dsExpr (HsLet binds body) = do
    body' <- dsLExpr body
313
    dsLocalBinds binds body'
314

chak's avatar
chak committed
315 316 317
-- We need the `ListComp' form to use `deListComp' (rather than the "do" form)
-- because the interpretation of `stmts' depends on what sort of thing it is.
--
318 319 320 321 322 323
dsExpr (HsDo ListComp     stmts res_ty) = dsListComp stmts res_ty
dsExpr (HsDo PArrComp     stmts _)      = dsPArrComp (map unLoc stmts)
dsExpr (HsDo DoExpr       stmts _)      = dsDo stmts 
dsExpr (HsDo GhciStmtCtxt stmts _)      = dsDo stmts 
dsExpr (HsDo MDoExpr      stmts _)      = dsDo stmts 
dsExpr (HsDo MonadComp    stmts _)      = dsMonadComp stmts
324

325 326 327 328 329 330 331 332
dsExpr (HsIf mb_fun guard_expr then_expr else_expr)
  = do { pred <- dsLExpr guard_expr
       ; b1 <- dsLExpr then_expr
       ; b2 <- dsLExpr else_expr
       ; case mb_fun of
           Just fun -> do { core_fun <- dsExpr fun
                          ; return (mkCoreApps core_fun [pred,b1,b2]) }
           Nothing  -> return $ mkIfThenElse pred b1 b2 }
333 334 335 336 337 338 339 340 341 342 343 344 345

dsExpr (HsMultiIf res_ty alts)
  | null alts
  = mkErrorExpr

  | otherwise
  = do { match_result <- liftM (foldr1 combineMatchResults)
                               (mapM (dsGRHS IfAlt res_ty) alts)
       ; error_expr   <- mkErrorExpr
       ; extractMatchResult match_result error_expr }
  where
    mkErrorExpr = mkErrorAppDs nON_EXHAUSTIVE_GUARDS_ERROR_ID res_ty
                               (ptext (sLit "multi-way if"))
346 347 348
\end{code}


349 350 351
\noindent
\underline{\bf Various data construction things}
%              ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
352
\begin{code}
353 354
dsExpr (ExplicitList elt_ty xs) 
  = dsExplicitList elt_ty xs
355

356 357
-- We desugar [:x1, ..., xn:] as
--   singletonP x1 +:+ ... +:+ singletonP xn
chak's avatar
chak committed
358
--
359
dsExpr (ExplicitPArr ty []) = do
360
    emptyP <- dsDPHBuiltin emptyPVar
361
    return (Var emptyP `App` Type ty)
362
dsExpr (ExplicitPArr ty xs) = do
363 364
    singletonP <- dsDPHBuiltin singletonPVar
    appP       <- dsDPHBuiltin appPVar
365 366 367 368 369
    xs'        <- mapM dsLExpr xs
    return . foldr1 (binary appP) $ map (unary singletonP) xs'
  where
    unary  fn x   = mkApps (Var fn) [Type ty, x]
    binary fn x y = mkApps (Var fn) [Type ty, x, y]
chak's avatar
chak committed
370

371
dsExpr (ArithSeq expr (From from))
372
  = App <$> dsExpr expr <*> dsLExpr from
373

374 375
dsExpr (ArithSeq expr (FromTo from to))
  = mkApps <$> dsExpr expr <*> mapM dsLExpr [from, to]
376

377
dsExpr (ArithSeq expr (FromThen from thn))
378 379 380 381 382 383 384 385 386 387
  = mkApps <$> dsExpr expr <*> mapM dsLExpr [from, thn]

dsExpr (ArithSeq expr (FromThenTo from thn to))
  = mkApps <$> dsExpr expr <*> mapM dsLExpr [from, thn, to]

dsExpr (PArrSeq expr (FromTo from to))
  = mkApps <$> dsExpr expr <*> mapM dsLExpr [from, to]

dsExpr (PArrSeq expr (FromThenTo from thn to))
  = mkApps <$> dsExpr expr <*> mapM dsLExpr [from, thn, to]
chak's avatar
chak committed
388

389
dsExpr (PArrSeq _ _)
chak's avatar
chak committed
390 391 392
  = panic "DsExpr.dsExpr: Infinite parallel array!"
    -- the parser shouldn't have generated it and the renamer and typechecker
    -- shouldn't have let it through
393 394
\end{code}

395 396 397
\noindent
\underline{\bf Record construction and update}
%              ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
398
For record construction we do this (assuming T has three arguments)
399
\begin{verbatim}
400
        T { op2 = e }
401
==>
402 403 404 405
        let err = /\a -> recConErr a 
        T (recConErr t1 "M.lhs/230/op1") 
          e 
          (recConErr t1 "M.lhs/230/op3")
406 407
\end{verbatim}
@recConErr@ then converts its arugment string into a proper message
408
before printing it as
409
\begin{verbatim}
410
        M.lhs, line 230: missing field op1 was evaluated
411
\end{verbatim}
412

413 414
We also handle @C{}@ as valid construction syntax for an unlabelled
constructor @C@, setting all of @C@'s fields to bottom.
415

416
\begin{code}
417 418
dsExpr (RecordCon (L _ data_con_id) con_expr rbinds) = do
    con_expr' <- dsExpr con_expr
419
    let
420 421 422 423 424 425 426 427
        (arg_tys, _) = tcSplitFunTys (exprType con_expr')
        -- A newtype in the corner should be opaque; 
        -- hence TcType.tcSplitFunTys

        mk_arg (arg_ty, lbl)    -- Selector id has the field label as its name
          = case findField (rec_flds rbinds) lbl of
              (rhs:rhss) -> ASSERT( null rhss )
                            dsLExpr rhs
428 429
              []         -> mkErrorAppDs rEC_CON_ERROR_ID arg_ty (ppr lbl)
        unlabelled_bottom arg_ty = mkErrorAppDs rEC_CON_ERROR_ID arg_ty empty
430 431 432 433 434 435 436 437 438

        labels = dataConFieldLabels (idDataCon data_con_id)
        -- The data_con_id is guaranteed to be the wrapper id of the constructor
    
    con_args <- if null labels
                then mapM unlabelled_bottom arg_tys
                else mapM mk_arg (zipEqual "dsExpr:RecordCon" arg_tys labels)
    
    return (mkApps con_expr' con_args)
439 440 441
\end{code}

Record update is a little harder. Suppose we have the decl:
442
\begin{verbatim}
443 444 445
        data T = T1 {op1, op2, op3 :: Int}
               | T2 {op4, op2 :: Int}
               | T3
446
\end{verbatim}
447
Then we translate as follows:
448
\begin{verbatim}
449
        r { op2 = e }
450
===>
451 452 453 454 455
        let op2 = e in
        case r of
          T1 op1 _ op3 -> T1 op1 op2 op3
          T2 op4 _     -> T2 op4 op2
          other        -> recUpdError "M.lhs/230"
456 457
\end{verbatim}
It's important that we use the constructor Ids for @T1@, @T2@ etc on the
458
RHSs, and do not generate a Core constructor application directly, because the constructor
459 460 461
might do some argument-evaluation first; and may have to throw away some
dictionaries.

462 463 464 465 466 467 468 469 470 471 472 473
Note [Update for GADTs]
~~~~~~~~~~~~~~~~~~~~~~~
Consider 
   data T a b where
     T1 { f1 :: a } :: T a Int

Then the wrapper function for T1 has type 
   $WT1 :: a -> T a Int
But if x::T a b, then
   x { f1 = v } :: T a b   (not T a Int!)
So we need to cast (T a Int) to (T a b).  Sigh.

474
\begin{code}
475
dsExpr expr@(RecordUpd record_expr (HsRecFields { rec_flds = fields })
476
                       cons_to_upd in_inst_tys out_inst_tys)
477
  | null fields
478
  = dsLExpr record_expr
479
  | otherwise
480
  = ASSERT2( notNull cons_to_upd, ppr expr )
481

482 483 484 485 486 487 488 489 490 491 492
    do  { record_expr' <- dsLExpr record_expr
        ; field_binds' <- mapM ds_field fields
        ; let upd_fld_env :: NameEnv Id -- Maps field name to the LocalId of the field binding
              upd_fld_env = mkNameEnv [(f,l) | (f,l,_) <- field_binds']

        -- It's important to generate the match with matchWrapper,
        -- and the right hand sides with applications of the wrapper Id
        -- so that everything works when we are doing fancy unboxing on the
        -- constructor aguments.
        ; alts <- mapM (mk_alt upd_fld_env) cons_to_upd
        ; ([discrim_var], matching_code) 
493
                <- matchWrapper RecUpd (MG { mg_alts = alts, mg_arg_tys = [in_ty], mg_res_ty = out_ty })
494 495 496

        ; return (add_field_binds field_binds' $
                  bindNonRec discrim_var record_expr' matching_code) }
497
  where
498 499 500 501 502
    ds_field :: HsRecField Id (LHsExpr Id) -> DsM (Name, Id, CoreExpr)
      -- Clone the Id in the HsRecField, because its Name is that
      -- of the record selector, and we must not make that a lcoal binder
      -- else we shadow other uses of the record selector
      -- Hence 'lcl_id'.  Cf Trac #2735
503
    ds_field rec_field = do { rhs <- dsLExpr (hsRecFieldArg rec_field)
504 505 506
                            ; let fld_id = unLoc (hsRecFieldId rec_field)
                            ; lcl_id <- newSysLocalDs (idType fld_id)
                            ; return (idName fld_id, lcl_id, rhs) }
507 508

    add_field_binds [] expr = expr
509
    add_field_binds ((_,b,r):bs) expr = bindNonRec b r (add_field_binds bs expr)
510

511 512
        -- Awkwardly, for families, the match goes 
        -- from instance type to family type
513 514
    tycon     = dataConTyCon (head cons_to_upd)
    in_ty     = mkTyConApp tycon in_inst_tys
515
    out_ty    = mkFamilyTyConApp tycon out_inst_tys
516

517
    mk_alt upd_fld_env con
518
      = do { let (univ_tvs, ex_tvs, eq_spec, 
519 520 521 522 523 524 525 526 527
                  theta, arg_tys, _) = dataConFullSig con
                 subst = mkTopTvSubst (univ_tvs `zip` in_inst_tys)

                -- I'm not bothering to clone the ex_tvs
           ; eqs_vars   <- mapM newPredVarDs (substTheta subst (eqSpecPreds eq_spec))
           ; theta_vars <- mapM newPredVarDs (substTheta subst theta)
           ; arg_ids    <- newSysLocalsDs (substTys subst arg_tys)
           ; let val_args = zipWithEqual "dsExpr:RecordUpd" mk_val_arg
                                         (dataConFieldLabels con) arg_ids
528 529
                 mk_val_arg field_name pat_arg_id 
                     = nlHsVar (lookupNameEnv upd_fld_env field_name `orElse` pat_arg_id)
530 531 532 533 534 535 536 537 538 539
                 inst_con = noLoc $ HsWrap wrap (HsVar (dataConWrapId con))
                        -- Reconstruct with the WrapId so that unpacking happens
                 wrap = mkWpEvVarApps theta_vars          <.>
                        mkWpTyApps    (mkTyVarTys ex_tvs) <.>
                        mkWpTyApps [ty | (tv, ty) <- univ_tvs `zip` out_inst_tys
                                       , not (tv `elemVarEnv` wrap_subst) ]
                 rhs = foldl (\a b -> nlHsApp a b) inst_con val_args

                        -- Tediously wrap the application in a cast
                        -- Note [Update for GADTs]
540
                 wrap_co = mkTcTyConAppCo tycon
batterseapower's avatar
batterseapower committed
541
                                [ lookup tv ty | (tv,ty) <- univ_tvs `zip` out_inst_tys ]
542 543
                 lookup univ_tv ty = case lookupVarEnv wrap_subst univ_tv of
                                        Just co' -> co'
544 545
                                        Nothing  -> mkTcReflCo ty
                 wrap_subst = mkVarEnv [ (tv, mkTcSymCo (mkTcCoVarCo eq_var))
546 547 548 549 550 551 552
                                       | ((tv,_),eq_var) <- eq_spec `zip` eqs_vars ]

                 pat = noLoc $ ConPatOut { pat_con = noLoc con, pat_tvs = ex_tvs
                                         , pat_dicts = eqs_vars ++ theta_vars
                                         , pat_binds = emptyTcEvBinds
                                         , pat_args = PrefixCon $ map nlVarPat arg_ids
                                         , pat_ty = in_ty }
batterseapower's avatar
batterseapower committed
553 554
           ; let wrapped_rhs | null eq_spec = rhs
                             | otherwise    = mkLHsWrap (WpCast wrap_co) rhs
555
           ; return (mkSimpleMatch [pat] wrapped_rhs) }
556

557 558
\end{code}

559 560 561 562 563
Here is where we desugar the Template Haskell brackets and escapes

\begin{code}
-- Template Haskell stuff

Ian Lynagh's avatar
Ian Lynagh committed
564
#ifdef GHCI
565
dsExpr (HsBracketOut x ps) = dsBracket x ps
Ian Lynagh's avatar
Ian Lynagh committed
566 567
#else
dsExpr (HsBracketOut _ _) = panic "dsExpr HsBracketOut"
568
#endif
Ian Lynagh's avatar
Ian Lynagh committed
569
dsExpr (HsSpliceE s)       = pprPanic "dsExpr:splice" (ppr s)
570

571
-- Arrow notation extension
572
dsExpr (HsProc pat cmd) = dsProcExpr pat cmd
573 574
\end{code}

andy@galois.com's avatar
andy@galois.com committed
575 576 577
Hpc Support 

\begin{code}
578
dsExpr (HsTick tickish e) = do
andy@galois.com's avatar
andy@galois.com committed
579
  e' <- dsLExpr e
580
  return (Tick tickish e')
andy@galois.com's avatar
andy@galois.com committed
581 582 583 584 585 586 587 588 589 590

-- There is a problem here. The then and else branches
-- have no free variables, so they are open to lifting.
-- We need someway of stopping this.
-- This will make no difference to binary coverage
-- (did you go here: YES or NO), but will effect accurate
-- tick counting.

dsExpr (HsBinTick ixT ixF e) = do
  e2 <- dsLExpr e
591
  do { ASSERT(exprType e2 `eqType` boolTy)
andy@galois.com's avatar
andy@galois.com committed
592 593 594
       mkBinaryTickBox ixT ixF e2
     }
\end{code}
595

596 597
\begin{code}

598
-- HsSyn constructs that just shouldn't be here:
599 600 601 602 603 604 605 606 607 608 609 610
dsExpr (ExprWithTySig {})  = panic "dsExpr:ExprWithTySig"
dsExpr (HsBracket     {})  = panic "dsExpr:HsBracket"
dsExpr (HsQuasiQuoteE {})  = panic "dsExpr:HsQuasiQuoteE"
dsExpr (HsArrApp      {})  = panic "dsExpr:HsArrApp"
dsExpr (HsArrForm     {})  = panic "dsExpr:HsArrForm"
dsExpr (HsTickPragma  {})  = panic "dsExpr:HsTickPragma"
dsExpr (EWildPat      {})  = panic "dsExpr:EWildPat"
dsExpr (EAsPat        {})  = panic "dsExpr:EAsPat"
dsExpr (EViewPat      {})  = panic "dsExpr:EViewPat"
dsExpr (ELazyPat      {})  = panic "dsExpr:ELazyPat"
dsExpr (HsType        {})  = panic "dsExpr:HsType"
dsExpr (HsDo          {})  = panic "dsExpr:HsDo"
611

612 613 614 615

findField :: [HsRecField Id arg] -> Name -> [arg]
findField rbinds lbl 
  = [rhs | HsRecField { hsRecFieldId = id, hsRecFieldArg = rhs } <- rbinds 
616
         , lbl == idName (unLoc id) ]
617 618
\end{code}

sof's avatar
sof committed
619
%--------------------------------------------------------------------
620

621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642
Note [Desugaring explicit lists]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Explicit lists are desugared in a cleverer way to prevent some
fruitless allocations.  Essentially, whenever we see a list literal
[x_1, ..., x_n] we:

1. Find the tail of the list that can be allocated statically (say
   [x_k, ..., x_n]) by later stages and ensure we desugar that
   normally: this makes sure that we don't cause a code size increase
   by having the cons in that expression fused (see later) and hence
   being unable to statically allocate any more

2. For the prefix of the list which cannot be allocated statically,
   say [x_1, ..., x_(k-1)], we turn it into an expression involving
   build so that if we find any foldrs over it it will fuse away
   entirely!
   
   So in this example we will desugar to:
   build (\c n -> x_1 `c` x_2 `c` .... `c` foldr c n [x_k, ..., x_n]
   
   If fusion fails to occur then build will get inlined and (since we
   defined a RULE for foldr (:) []) we will get back exactly the
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
643 644 645 646 647 648 649 650 651
   normal desugaring for an explicit list.

This optimisation can be worth a lot: up to 25% of the total
allocation in some nofib programs. Specifically

        Program           Size    Allocs   Runtime  CompTime
        rewrite          +0.0%    -26.3%      0.02     -1.8%
           ansi          -0.3%    -13.8%      0.00     +0.0%
           lift          +0.0%     -8.7%      0.00     -2.3%
652 653 654

Of course, if rules aren't turned on then there is pretty much no
point doing this fancy stuff, and it may even be harmful.
655 656 657 658 659 660 661 662 663 664 665 666 667

=======>  Note by SLPJ Dec 08.

I'm unconvinced that we should *ever* generate a build for an explicit
list.  See the comments in GHC.Base about the foldr/cons rule, which 
points out that (foldr k z [a,b,c]) may generate *much* less code than
(a `k` b `k` c `k` z).

Furthermore generating builds messes up the LHS of RULES. 
Example: the foldr/single rule in GHC.Base
   foldr k z [x] = ...
We do not want to generate a build invocation on the LHS of this RULE!

simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
668 669 670
We fix this by disabling rules in rule LHSs, and testing that
flag here; see Note [Desugaring RULE left hand sides] in Desugar

671 672 673 674
To test this I've added a (static) flag -fsimple-list-literals, which
makes all list literals be generated via the simple route.  


675 676 677
\begin{code}
dsExplicitList :: PostTcType -> [LHsExpr Id] -> DsM CoreExpr
-- See Note [Desugaring explicit lists]
678
dsExplicitList elt_ty xs
679
  = do { dflags <- getDynFlags
680 681
       ; xs' <- mapM dsLExpr xs
       ; let (dynamic_prefix, static_suffix) = spanTail is_static xs'
ian@well-typed.com's avatar
ian@well-typed.com committed
682 683
       ; if gopt Opt_SimpleListLiterals dflags        -- -fsimple-list-literals
         || not (gopt Opt_EnableRewriteRules dflags)  -- Rewrite rules off
684 685
                -- Don't generate a build if there are no rules to eliminate it!
                -- See Note [Desugaring RULE left hand sides] in Desugar
686 687 688
         || null dynamic_prefix   -- Avoid build (\c n. foldr c n xs)!
         then return $ mkListExpr elt_ty xs'
         else mkBuildExpr elt_ty (mkSplitExplicitList dynamic_prefix static_suffix) }
689
  where
690 691 692 693 694 695 696 697 698 699 700 701
    is_static :: CoreExpr -> Bool
    is_static e = all is_static_var (varSetElems (exprFreeVars e))

    is_static_var :: Var -> Bool
    is_static_var v 
      | isId v = isExternalName (idName v)  -- Top-level things are given external names
      | otherwise = False                   -- Type variables

    mkSplitExplicitList prefix suffix (c, _) (n, n_ty)
      = do { let suffix' = mkListExpr elt_ty suffix
           ; folded_suffix <- mkFoldrExpr elt_ty n_ty (Var c) (Var n) suffix'
           ; return (foldr (App . App (Var c)) folded_suffix prefix) }
702 703 704 705 706 707

spanTail :: (a -> Bool) -> [a] -> ([a], [a])
spanTail f xs = (reverse rejected, reverse satisfying)
    where (satisfying, rejected) = span f $ reverse xs
\end{code}

708 709 710
Desugar 'do' and 'mdo' expressions (NOT list comprehensions, they're
handled in DsListComp).  Basically does the translation given in the
Haskell 98 report:
711

712
\begin{code}
713
dsDo :: [ExprLStmt Id] -> DsM CoreExpr
714
dsDo stmts
715
  = goL stmts
716
  where
717 718
    goL [] = panic "dsDo"
    goL (L loc stmt:lstmts) = putSrcSpanDs loc (go loc stmt lstmts)
719
  
720 721 722
    go _ (LastStmt body _) stmts
      = ASSERT( null stmts ) dsLExpr body
        -- The 'return' op isn't used for 'do' expressions
723

724
    go _ (BodyStmt rhs then_expr _ _) stmts
725
      = do { rhs2 <- dsLExpr rhs
726
           ; warnDiscardedDoBindings rhs (exprType rhs2) 
727
           ; then_expr2 <- dsExpr then_expr
728 729
           ; rest <- goL stmts
           ; return (mkApps then_expr2 [rhs2, rest]) }
730
    
731
    go _ (LetStmt binds) stmts
732
      = do { rest <- goL stmts
733
           ; dsLocalBinds binds rest }
734

735 736 737
    go _ (BindStmt pat rhs bind_op fail_op) stmts
      = do  { body     <- goL stmts
            ; rhs'     <- dsLExpr rhs
738 739 740 741 742 743 744 745
            ; bind_op' <- dsExpr bind_op
            ; var   <- selectSimpleMatchVarL pat
            ; let bind_ty = exprType bind_op'   -- rhs -> (pat -> res1) -> res2
                  res1_ty = funResultTy (funArgTy (funResultTy bind_ty))
            ; match <- matchSinglePat (Var var) (StmtCtxt DoExpr) pat
                                      res1_ty (cantFailMatchResult body)
            ; match_code <- handle_failure pat match fail_op
            ; return (mkApps bind_op' [rhs', Lam var match_code]) }
746
    
747 748 749
    go loc (RecStmt { recS_stmts = rec_stmts, recS_later_ids = later_ids
                    , recS_rec_ids = rec_ids, recS_ret_fn = return_op
                    , recS_mfix_fn = mfix_op, recS_bind_fn = bind_op
750
                    , recS_rec_rets = rec_rets, recS_ret_ty = body_ty }) stmts
751
      = ASSERT( length rec_ids > 0 )
752
        goL (new_bind_stmt : stmts)
753
      where
754
        new_bind_stmt = L loc $ BindStmt (mkBigLHsPatTup later_pats)
755
                                         mfix_app bind_op 
756
                                         noSyntaxExpr  -- Tuple cannot fail
757 758

        tup_ids      = rec_ids ++ filterOut (`elem` rec_ids) later_ids
759
        tup_ty       = mkBigCoreTupTy (map idType tup_ids) -- Deals with singleton case
760 761 762
        rec_tup_pats = map nlVarPat tup_ids
        later_pats   = rec_tup_pats
        rets         = map noLoc rec_rets
763
        mfix_app     = nlHsApp (noLoc mfix_op) mfix_arg
764 765
        mfix_arg     = noLoc $ HsLam (MG { mg_alts = [mkSimpleMatch [mfix_pat] body]
                                         , mg_arg_tys = [tup_ty], mg_res_ty = body_ty })
766
        mfix_pat     = noLoc $ LazyPat $ mkBigLHsPatTup rec_tup_pats
767
        body         = noLoc $ HsDo DoExpr (rec_stmts ++ [ret_stmt]) body_ty
768
        ret_app      = nlHsApp (noLoc return_op) (mkBigLHsTup rets)
769
        ret_stmt     = noLoc $ mkLastStmt ret_app
770 771 772 773 774 775
                     -- This LastStmt will be desugared with dsDo, 
                     -- which ignores the return_op in the LastStmt,
                     -- so we must apply the return_op explicitly 

    go _ (ParStmt   {}) _ = panic "dsDo ParStmt"
    go _ (TransStmt {}) _ = panic "dsDo TransStmt"
776

777
handle_failure :: LPat Id -> MatchResult -> SyntaxExpr Id -> DsM CoreExpr
778 779
    -- In a do expression, pattern-match failure just calls
    -- the monadic 'fail' rather than throwing an exception
780 781 782
handle_failure pat match fail_op
  | matchCanFail match
  = do { fail_op' <- dsExpr fail_op
Ian Lynagh's avatar
Ian Lynagh committed
783 784
       ; dflags <- getDynFlags
       ; fail_msg <- mkStringExpr (mk_fail_msg dflags pat)
785 786 787
       ; extractMatchResult match (App fail_op' fail_msg) }
  | otherwise
  = extractMatchResult match (error "It can't fail")
788

Ian Lynagh's avatar
Ian Lynagh committed
789 790 791
mk_fail_msg :: DynFlags -> Located e -> String
mk_fail_msg dflags pat = "Pattern match failure in do expression at " ++ 
                         showPpr dflags (getLoc pat)
792
\end{code}
793

794

795
%************************************************************************
796
%*                                                                      *
797
                 Warning about identities
798
%*                                                                      *
799 800
%************************************************************************

801 802 803 804
Warn about functions like toInteger, fromIntegral, that convert
between one type and another when the to- and from- types are the
same.  Then it's probably (albeit not definitely) the identity

805
\begin{code}
806 807
warnAboutIdentities :: CoreExpr -> CoreExpr -> DsM ()
warnAboutIdentities (Var v) wrapped_fun
808
  | idName v `elem` conversionNames
809
  , let fun_ty = exprType wrapped_fun
810
  , Just (arg_ty, res_ty) <- splitFunTy_maybe fun_ty
811
  , arg_ty `eqType` res_ty  -- So we are converting  ty -> ty
812 813 814 815 816 817 818 819 820 821 822
  = warnDs (vcat [ ptext (sLit "Call of") <+> ppr v <+> dcolon <+> ppr fun_ty
                 , nest 2 $ ptext (sLit "can probably be omitted")
                 , parens (ptext (sLit "Use -fno-warn-identities to suppress this messsage)"))
           ])
warnAboutIdentities _ _ = return ()

conversionNames :: [Name]
conversionNames
  = [ toIntegerName, toRationalName
    , fromIntegralName, realToFracName ]
 -- We can't easily add fromIntegerName, fromRationalName,
Gabor Greif's avatar
typos  
Gabor Greif committed
823
 -- because they are generated by literals
824 825
\end{code}

826
%************************************************************************
827
%*                                                                      *
828
\subsection{Errors and contexts}
829
%*                                                                      *
830 831 832 833
%************************************************************************

\begin{code}
-- Warn about certain types of values discarded in monadic bindings (#3263)
834 835 836 837
warnDiscardedDoBindings :: LHsExpr Id -> Type -> DsM ()
warnDiscardedDoBindings rhs rhs_ty
  | Just (m_ty, elt_ty) <- tcSplitAppTy_maybe rhs_ty
  = do {  -- Warn about discarding non-() things in 'monadic' binding
838
       ; warn_unused <- woptM Opt_WarnUnusedDoBind
839 840 841 842 843
       ; if warn_unused && not (isUnitTy elt_ty)
         then warnDs (unusedMonadBind rhs elt_ty)
         else 
         -- Warn about discarding m a things in 'monadic' binding of the same type,
         -- but only if we didn't already warn due to Opt_WarnUnusedDoBind
844
    do { warn_wrong <- woptM Opt_WarnWrongDoBind
845
       ; case tcSplitAppTy_maybe elt_ty of
846
           Just (elt_m_ty, _) | warn_wrong, m_ty `eqType` elt_m_ty
847 848 849
                              -> warnDs (wrongMonadBind rhs elt_ty)
           _ -> return () } }

850
  | otherwise   -- RHS does have type of form (m ty), which is wierd
851
  = return ()   -- but at lesat this warning is irrelevant
852 853

unusedMonadBind :: LHsExpr Id -> Type -> SDoc
854 855
unusedMonadBind rhs elt_ty
  = ptext (sLit "A do-notation statement discarded a result of type") <+> ppr elt_ty <> dot $$
856 857 858 859
    ptext (sLit "Suppress this warning by saying \"_ <- ") <> ppr rhs <> ptext (sLit "\",") $$
    ptext (sLit "or by using the flag -fno-warn-unused-do-bind")

wrongMonadBind :: LHsExpr Id -> Type -> SDoc
860 861
wrongMonadBind rhs elt_ty
  = ptext (sLit "A do-notation statement discarded a result of type") <+> ppr elt_ty <> dot $$
862 863
    ptext (sLit "Suppress this warning by saying \"_ <- ") <> ppr rhs <> ptext (sLit "\",") $$
    ptext (sLit "or by using the flag -fno-warn-wrong-do-bind")
864
\end{code}