DsExpr.lhs 34.3 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
{-# OPTIONS -fno-warn-incomplete-patterns #-}
10 11 12
-- The above warning supression flag is a temporary kludge.
-- While working on this module you are encouraged to remove it and fix
-- any warnings in the module. See
Ian Lynagh's avatar
Ian Lynagh committed
13
--     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
14 15
-- for details

16
module DsExpr ( dsExpr, dsLExpr, dsLocalBinds, dsValBinds, dsLit ) where
17

18
#include "HsVersions.h"
mnislaih's avatar
mnislaih committed
19

Simon Marlow's avatar
Simon Marlow committed
20 21 22 23 24 25 26
import Match
import MatchLit
import DsBinds
import DsGRHSs
import DsListComp
import DsUtils
import DsArrows
27
import DsMonad
28
import Name
29
import NameEnv
30 31 32

#ifdef GHCI
	-- Template Haskell stuff iff bootstrapped
Simon Marlow's avatar
Simon Marlow committed
33
import DsMeta
34 35
#endif

36
import HsSyn
37 38

-- NB: The desugarer, which straddles the source and Core worlds, sometimes
Simon Marlow's avatar
Simon Marlow committed
39 40 41
--     needs to see source types
import TcType
import Type
42
import Coercion
43
import CoreSyn
Simon Marlow's avatar
Simon Marlow committed
44
import CoreUtils
45
import CoreFVs
46
import MkCore
Simon Marlow's avatar
Simon Marlow committed
47

48
import DynFlags
49
import StaticFlags
Simon Marlow's avatar
Simon Marlow committed
50 51
import CostCentre
import Id
52
import Var
53
import VarSet
Simon Marlow's avatar
Simon Marlow committed
54 55 56 57
import DataCon
import TysWiredIn
import BasicTypes
import PrelNames
58
import Maybes
Simon Marlow's avatar
Simon Marlow committed
59 60 61
import SrcLoc
import Util
import Bag
62
import Outputable
63
import FastString
64 65

import Control.Monad
66 67
\end{code}

68 69 70

%************************************************************************
%*									*
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
71
		dsLocalBinds, dsValBinds
72 73 74 75
%*									*
%************************************************************************

\begin{code}
76 77 78 79 80 81 82
dsLocalBinds :: HsLocalBinds Id -> CoreExpr -> DsM CoreExpr
dsLocalBinds EmptyLocalBinds	body = return body
dsLocalBinds (HsValBinds binds) body = dsValBinds binds body
dsLocalBinds (HsIPBinds binds)  body = dsIPBinds  binds body

-------------------------
dsValBinds :: HsValBinds Id -> CoreExpr -> DsM CoreExpr
83
dsValBinds (ValBindsOut binds _) body = foldrM ds_val_bind body binds
84 85

-------------------------
86
dsIPBinds :: HsIPBinds Id -> CoreExpr -> DsM CoreExpr
87 88 89
dsIPBinds (IPBinds ip_binds ev_binds) body
  = do	{ ds_ev_binds <- dsTcEvBinds ev_binds
	; let inner = wrapDsEvBinds ds_ev_binds body
90 91
		-- The dict bindings may not be in 
		-- dependency order; hence Rec
92
	; foldrM ds_ip_bind inner ip_binds }
93
  where
94
    ds_ip_bind (L _ (IPBind n e)) body
95 96
      = do e' <- dsLExpr e
           return (Let (NonRec (ipNameName n) e') body)
97

98 99
-------------------------
ds_val_bind :: (RecFlag, LHsBinds Id) -> CoreExpr -> DsM CoreExpr
100
-- Special case for bindings which bind unlifted variables
101 102
-- We need to do a case right away, rather than building
-- a tuple and doing selections.
103
-- Silently ignore INLINE and SPECIALISE pragmas...
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
104
ds_val_bind (NonRecursive, hsbinds) body
105
  | [L loc bind] <- bagToList hsbinds,
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
106 107 108 109
	-- 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.)
110 111
    strictMatchOnly bind
  = putSrcSpanDs loc (dsStrictBind bind body)
112

simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
113
-- Ordinary case for bindings; none should be unlifted
114
ds_val_bind (_is_rec, binds) body
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
115
  = do	{ prs <- dsLHsBinds binds
116
	; ASSERT2( not (any (isUnLiftedType . idType . fst) prs), ppr _is_rec $$ ppr binds )
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
117
	  case prs of
118 119
            [] -> return body
            _  -> return (Let (Rec prs) body) }
120
	-- Use a Rec regardless of is_rec. 
121
	-- Why? Because it allows the binds to be all
122 123 124 125 126
	-- 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
127 128 129
	--
	-- NB The previous case dealt with unlifted bindings, so we
	--    only have to deal with lifted ones now; so Rec is ok
130

131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177
------------------
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
  = do { ds_ev_binds <- dsTcEvBinds ev_binds
       ; let body1 = foldr bind_export body exports
             bind_export (_, g, l, _) b = bindNonRec g (Var l) b
       ; body2 <- foldlBagM (\body bind -> dsStrictBind (unLoc bind) body) 
                            body1 binds 
       ; return (wrapDsEvBinds ds_ev_binds body2) }

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

dsStrictBind (PatBind {pat_lhs = pat, pat_rhs = grhss, pat_rhs_ty = ty }) body
  = 	-- let C x# y# = rhs in body
	-- ==> case rhs of C x# y# -> body
    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)
       ; return (scrungleMatch var rhs result) }

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 })
  =  isUnboxedTupleType ty 
  || 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
178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202

scrungleMatch :: Id -> CoreExpr -> CoreExpr -> CoreExpr
-- Returns something like (let var = scrut in body)
-- but if var is an unboxed-tuple type, it inlines it in a fragile way
-- Special case to handle unboxed tuple patterns; they can't appear nested
-- The idea is that 
--	case e of (# p1, p2 #) -> rhs
-- should desugar to
--	case e of (# x1, x2 #) -> ... match p1, p2 ...
-- NOT
--	let x = e in case x of ....
--
-- But there may be a big 
--	let fail = ... in case e of ...
-- wrapping the whole case, which complicates matters slightly
-- It all seems a bit fragile.  Test is dsrun013.

scrungleMatch var scrut body
  | isUnboxedTupleType (idType var) = scrungle body
  | otherwise			    = bindNonRec var scrut body
  where
    scrungle (Case (Var x) bndr ty alts)
		    | x == var = Case scrut bndr ty alts
    scrungle (Let binds body)  = Let binds (scrungle body)
    scrungle other = panic ("scrungleMatch: tuple pattern:\n" ++ showSDoc (ppr other))
mnislaih's avatar
mnislaih committed
203

204
\end{code}
205 206 207

%************************************************************************
%*									*
208
\subsection[DsExpr-vars-and-cons]{Variables, constructors, literals}
209 210 211 212
%*									*
%************************************************************************

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

215 216 217
dsLExpr (L loc e) = putSrcSpanDs loc $ dsExpr e

dsExpr :: HsExpr Id -> DsM CoreExpr
218 219
dsExpr (HsPar e) 	      = dsLExpr e
dsExpr (ExprWithTySigOut e _) = dsLExpr e
220 221
dsExpr (HsVar var)     	      = return (Var var)
dsExpr (HsIPVar ip)    	      = return (Var (ipNameName ip))
222 223
dsExpr (HsLit lit)     	      = dsLit lit
dsExpr (HsOverLit lit) 	      = dsOverLit lit
224 225 226 227 228 229 230

dsExpr (HsWrap co_fn e)
  = do { co_fn' <- dsHsWrapper co_fn
       ; e' <- dsExpr e
       ; warn_id <- doptDs Opt_WarnIdentities
       ; when warn_id $ warnAboutIdentities e' co_fn'
       ; return (co_fn' e') }
231 232

dsExpr (NegApp expr neg_expr) 
233
  = App <$> dsExpr neg_expr <*> dsLExpr expr
234

235
dsExpr (HsLam a_Match)
236
  = uncurry mkLams <$> matchWrapper LambdaExpr a_Match
237

238
dsExpr (HsApp fun arg)
239
  = mkCoreAppDs <$> dsLExpr fun <*>  dsLExpr arg
240 241 242 243 244 245
\end{code}

Operator sections.  At first it looks as if we can convert
\begin{verbatim}
	(expr op)
\end{verbatim}
246
to
247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263
\begin{verbatim}
	\x -> op expr x
\end{verbatim}

But no!  expr might be a redex, and we can lose laziness badly this
way.  Consider
\begin{verbatim}
	map (expr op) xs
\end{verbatim}
for example.  So we convert instead to
\begin{verbatim}
	let y = expr in \x -> op y x
\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
264
dsExpr (OpApp e1 op _ e2)
265
  = -- for the type of y, we need the type of op's 2nd argument
266
    mkCoreAppsDs <$> dsLExpr op <*> mapM dsLExpr [e1, e2]
sof's avatar
sof committed
267
    
268
dsExpr (SectionL expr op)	-- Desugar (e !) to ((!) e)
269
  = mkCoreAppDs <$> dsLExpr op <*> dsLExpr expr
270

271
-- dsLExpr (SectionR op expr)	-- \ x -> op x expr
272 273
dsExpr (SectionR op expr) = do
    core_op <- dsLExpr op
sof's avatar
sof committed
274
    -- for the type of x, we need the type of op's 2nd argument
275 276 277 278 279 280
    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 $
281
            Lam x_id (mkCoreAppsDs core_op [Var x_id, Var y_id]))
282

283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301
dsExpr (ExplicitTuple tup_args boxity)
  = do { let go (lam_vars, args) (Missing ty)
                    -- For every missing expression, we need
		    -- another lambda in the desugaring.
               = do { lam_var <- newSysLocalDs ty
                    ; return (lam_var : lam_vars, Var lam_var : args) }
	     go (lam_vars, args) (Present expr)
     	            -- Expressions that are present don't generate
                    -- lambdas, just arguments.
               = do { core_expr <- dsLExpr expr
                    ; return (lam_vars, core_expr : args) }

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

       ; return $ mkCoreLams lam_vars $ 
                  mkConApp (tupleCon boxity (length tup_args))
                           (map (Type . exprType) args ++ args) }

302 303 304
dsExpr (HsSCC cc expr) = do
    mod_name <- getModuleDs
    Note (SCC (mkUserCC cc mod_name)) <$> dsLExpr expr
305

306
dsExpr (HsCoreAnn fs expr)
307
  = Note (CoreNote $ unpackFS fs) <$> dsLExpr expr
308

309 310 311
dsExpr (HsCase discrim matches@(MatchGroup _ rhs_ty)) 
  | isEmptyMatchGroup matches	-- A Core 'case' is always non-empty
  = 		      		-- So desugar empty HsCase to error call
312
    mkErrorAppDs pAT_ERROR_ID (funResultTy rhs_ty) (ptext (sLit "case"))
313 314 315 316 317

  | otherwise
  = do { core_discrim <- dsLExpr discrim
       ; ([discrim_var], matching_code) <- matchWrapper CaseAlt matches
       ; return (scrungleMatch discrim_var core_discrim matching_code) }
318

319 320
-- Pepe: The binds are in scope in the body but NOT in the binding group
--       This is to avoid silliness in breakpoints
321 322
dsExpr (HsLet binds body) = do
    body' <- dsLExpr body
323
    dsLocalBinds binds body'
324

chak's avatar
chak committed
325 326 327
-- 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.
--
328
dsExpr (HsDo ListComp stmts body result_ty)
sof's avatar
sof committed
329
  =	-- Special case for list comprehensions
330
    dsListComp stmts body elt_ty
chak's avatar
chak committed
331
  where
332
    [elt_ty] = tcTyConAppArgs result_ty
333

334 335 336
dsExpr (HsDo DoExpr stmts body result_ty)
  = dsDo stmts body result_ty

337 338 339
dsExpr (HsDo GhciStmt stmts body result_ty)
  = dsDo stmts body result_ty

340 341
dsExpr (HsDo MDoExpr stmts body result_ty)
  = dsDo stmts body result_ty
chak's avatar
chak committed
342

343
dsExpr (HsDo PArrComp stmts body result_ty)
chak's avatar
chak committed
344
  =	-- Special case for array comprehensions
345
    dsPArrComp (map unLoc stmts) body elt_ty
346
  where
347
    [elt_ty] = tcTyConAppArgs result_ty
348

349 350 351 352 353 354 355 356
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 }
357 358 359
\end{code}


360 361 362
\noindent
\underline{\bf Various data construction things}
%              ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
363
\begin{code}
364 365
dsExpr (ExplicitList elt_ty xs) 
  = dsExplicitList elt_ty xs
366

367 368
-- We desugar [:x1, ..., xn:] as
--   singletonP x1 +:+ ... +:+ singletonP xn
chak's avatar
chak committed
369
--
370 371 372
dsExpr (ExplicitPArr ty []) = do
    emptyP <- dsLookupGlobalId emptyPName
    return (Var emptyP `App` Type ty)
373
dsExpr (ExplicitPArr ty xs) = do
374 375 376 377 378 379 380
    singletonP <- dsLookupGlobalId singletonPName
    appP       <- dsLookupGlobalId appPName
    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
381

382
dsExpr (ArithSeq expr (From from))
383
  = App <$> dsExpr expr <*> dsLExpr from
384

385 386
dsExpr (ArithSeq expr (FromTo from to))
  = mkApps <$> dsExpr expr <*> mapM dsLExpr [from, to]
387

388
dsExpr (ArithSeq expr (FromThen from thn))
389 390 391 392 393 394 395 396 397 398
  = 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
399

400
dsExpr (PArrSeq _ _)
chak's avatar
chak committed
401 402 403
  = panic "DsExpr.dsExpr: Infinite parallel array!"
    -- the parser shouldn't have generated it and the renamer and typechecker
    -- shouldn't have let it through
404 405
\end{code}

406 407 408
\noindent
\underline{\bf Record construction and update}
%              ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
409
For record construction we do this (assuming T has three arguments)
410
\begin{verbatim}
411 412 413 414 415 416
	T { op2 = e }
==>
	let err = /\a -> recConErr a 
	T (recConErr t1 "M.lhs/230/op1") 
	  e 
	  (recConErr t1 "M.lhs/230/op3")
417 418
\end{verbatim}
@recConErr@ then converts its arugment string into a proper message
419
before printing it as
420 421 422
\begin{verbatim}
	M.lhs, line 230: missing field op1 was evaluated
\end{verbatim}
423

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

427
\begin{code}
428 429
dsExpr (RecordCon (L _ data_con_id) con_expr rbinds) = do
    con_expr' <- dsExpr con_expr
430
    let
431 432 433 434 435 436 437 438
        (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
439 440
              []         -> mkErrorAppDs rEC_CON_ERROR_ID arg_ty (ppr lbl)
        unlabelled_bottom arg_ty = mkErrorAppDs rEC_CON_ERROR_ID arg_ty empty
441 442 443 444 445 446 447 448 449

        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)
450 451 452
\end{code}

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

473 474 475 476 477 478 479 480 481 482 483 484
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.

485
\begin{code}
486 487 488
dsExpr expr@(RecordUpd record_expr (HsRecFields { rec_flds = fields })
		       cons_to_upd in_inst_tys out_inst_tys)
  | null fields
489
  = dsLExpr record_expr
490
  | otherwise
491
  = ASSERT2( notNull cons_to_upd, ppr expr )
492 493

    do	{ record_expr' <- dsLExpr record_expr
494
	; field_binds' <- mapM ds_field fields
495 496
	; 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']
497

498 499 500 501
	-- 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.
502
	; alts <- mapM (mk_alt upd_fld_env) cons_to_upd
503 504
	; ([discrim_var], matching_code) 
		<- matchWrapper RecUpd (MatchGroup alts in_out_ty)
505

506 507 508
	; return (add_field_binds field_binds' $
		  bindNonRec discrim_var record_expr' matching_code) }
  where
509 510 511 512 513
    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
514
    ds_field rec_field = do { rhs <- dsLExpr (hsRecFieldArg rec_field)
515 516 517
    	     	       	    ; let fld_id = unLoc (hsRecFieldId rec_field)
    	     	       	    ; lcl_id <- newSysLocalDs (idType fld_id)
			    ; return (idName fld_id, lcl_id, rhs) }
518 519

    add_field_binds [] expr = expr
520
    add_field_binds ((_,b,r):bs) expr = bindNonRec b r (add_field_binds bs expr)
521 522 523 524 525 526 527

	-- Awkwardly, for families, the match goes 
	-- from instance type to family type
    tycon     = dataConTyCon (head cons_to_upd)
    in_ty     = mkTyConApp tycon in_inst_tys
    in_out_ty = mkFunTy in_ty (mkFamilyTyConApp tycon out_inst_tys)

528
    mk_alt upd_fld_env con
529 530 531 532 533 534 535 536 537 538
      = do { let (univ_tvs, ex_tvs, eq_spec, 
		  eq_theta, dict_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 (eq_theta ++ dict_theta))
	   ; arg_ids    <- newSysLocalsDs (substTys subst arg_tys)
	   ; let val_args = zipWithEqual "dsExpr:RecordUpd" mk_val_arg
    					 (dataConFieldLabels con) arg_ids
539 540
                 mk_val_arg field_name pat_arg_id 
                     = nlHsVar (lookupNameEnv upd_fld_env field_name `orElse` pat_arg_id)
541 542
		 inst_con = noLoc $ HsWrap wrap (HsVar (dataConWrapId con))
			-- Reconstruct with the WrapId so that unpacking happens
543 544
		 wrap = mkWpEvVarApps theta_vars          `WpCompose` 
			mkWpTyApps    (mkTyVarTys ex_tvs) `WpCompose`
545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562
			mkWpTyApps [ty | (tv, ty) <- univ_tvs `zip` out_inst_tys
				       , isNothing (lookupTyVar wrap_subst tv) ]
    	         rhs = foldl (\a b -> nlHsApp a b) inst_con val_args

			-- Tediously wrap the application in a cast
			-- Note [Update for GADTs]
		 wrapped_rhs | null eq_spec = rhs
			     | otherwise    = mkLHsWrap (WpCast wrap_co) rhs
		 wrap_co = mkTyConApp tycon [ lookup tv ty 
					    | (tv,ty) <- univ_tvs `zip` out_inst_tys]
		 lookup univ_tv ty = case lookupTyVar wrap_subst univ_tv of
					Just ty' -> ty'
					Nothing  -> ty
		 wrap_subst = mkTopTvSubst [ (tv,mkSymCoercion (mkTyVarTy co_var))
					   | ((tv,_),co_var) <- eq_spec `zip` eqs_vars ]
		 
    	         pat = noLoc $ ConPatOut { pat_con = noLoc con, pat_tvs = ex_tvs
					 , pat_dicts = eqs_vars ++ theta_vars
563
					 , pat_binds = emptyTcEvBinds
564 565 566 567
					 , pat_args = PrefixCon $ map nlVarPat arg_ids
					 , pat_ty = in_ty }
	   ; return (mkSimpleMatch [pat] wrapped_rhs) }

568 569
\end{code}

570 571 572 573 574 575 576
Here is where we desugar the Template Haskell brackets and escapes

\begin{code}
-- Template Haskell stuff

#ifdef GHCI	/* Only if bootstrapping */
dsExpr (HsBracketOut x ps) = dsBracket x ps
577
dsExpr (HsSpliceE s)       = pprPanic "dsExpr:splice" (ppr s)
578 579
#endif

580
-- Arrow notation extension
581
dsExpr (HsProc pat cmd) = dsProcExpr pat cmd
582 583
\end{code}

andy@galois.com's avatar
andy@galois.com committed
584 585 586
Hpc Support 

\begin{code}
587
dsExpr (HsTick ix vars e) = do
andy@galois.com's avatar
andy@galois.com committed
588
  e' <- dsLExpr e
589
  mkTickBox ix vars e'
andy@galois.com's avatar
andy@galois.com committed
590 591 592 593 594 595 596 597 598 599 600 601 602 603

-- 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
  do { ASSERT(exprType e2 `coreEqType` boolTy)
       mkBinaryTickBox ixT ixF e2
     }
\end{code}
604

605 606
\begin{code}

607 608 609
-- HsSyn constructs that just shouldn't be here:
dsExpr (ExprWithTySig _ _)  = panic "dsExpr:ExprWithTySig"

610 611 612 613 614

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

sof's avatar
sof committed
617
%--------------------------------------------------------------------
618

619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640
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
641 642 643 644 645 646 647 648 649
   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%
650 651 652

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.
653 654 655 656 657 658 659 660 661 662 663 664 665

=======>  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
666 667 668
We fix this by disabling rules in rule LHSs, and testing that
flag here; see Note [Desugaring RULE left hand sides] in Desugar

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


673 674 675
\begin{code}
dsExplicitList :: PostTcType -> [LHsExpr Id] -> DsM CoreExpr
-- See Note [Desugaring explicit lists]
676 677 678 679 680 681
dsExplicitList elt_ty xs
  = do { dflags <- getDOptsDs
       ; xs' <- mapM dsLExpr xs
       ; let (dynamic_prefix, static_suffix) = spanTail is_static xs'
       ; if opt_SimpleListLiterals 	       		-- -fsimple-list-literals
         || not (dopt Opt_EnableRewriteRules dflags)	-- Rewrite rules off
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
682
	    	-- Don't generate a build if there are no rules to eliminate it!
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
683
		-- See Note [Desugaring RULE left hand sides] in Desugar
684 685 686
         || 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) }
687
  where
688 689 690 691 692 693 694 695 696 697 698 699
    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) }
700 701 702 703 704 705

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

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

710
\begin{code}
711 712 713
dsDo	:: [LStmt Id]
	-> LHsExpr Id
	-> Type			-- Type of the whole expression
714 715
	-> DsM CoreExpr

716
dsDo stmts body result_ty
717
  = goL stmts
718
  where
719 720 721
    -- result_ty must be of the form (m b)
    (m_ty, _b_ty) = tcSplitAppTy result_ty

722
    goL [] = dsLExpr body
723
    goL ((L loc stmt):lstmts) = putSrcSpanDs loc (go loc stmt lstmts)
724
  
725
    go _ (ExprStmt rhs then_expr _) stmts
726
      = do { rhs2 <- dsLExpr rhs
727
           ; case tcSplitAppTy_maybe (exprType rhs2) of
728
                Just (container_ty, returning_ty) -> warnDiscardedDoBindings rhs container_ty returning_ty
729 730 731
                _                                 -> return ()
           ; then_expr2 <- dsExpr then_expr
	   ; rest <- goL stmts
732
	   ; return (mkApps then_expr2 [rhs2, rest]) }
733
    
734
    go _ (LetStmt binds) stmts
735
      = do { rest <- goL stmts
736
	   ; dsLocalBinds binds rest }
737

738 739 740 741 742 743 744 745 746 747 748
    go _ (BindStmt pat rhs bind_op fail_op) stmts
      = do  { body     <- goL stmts
            ; rhs'     <- dsLExpr rhs
	    ; 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]) }
749
    
750 751 752
    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
753
                    , recS_rec_rets = rec_rets }) stmts
754
      = ASSERT( length rec_ids > 0 )
755
        goL (new_bind_stmt : stmts)
756 757 758 759 760
      where
        -- returnE <- dsExpr return_id
        -- mfixE <- dsExpr mfix_id
        new_bind_stmt = L loc $ BindStmt (mkLHsPatTup later_pats) mfix_app
                                         bind_op 
761
                                         noSyntaxExpr  -- Tuple cannot fail
762 763 764 765 766 767 768 769 770 771 772 773 774

        tup_ids      = rec_ids ++ filterOut (`elem` rec_ids) later_ids
        rec_tup_pats = map nlVarPat tup_ids
        later_pats   = rec_tup_pats
        rets         = map noLoc rec_rets

        mfix_app   = nlHsApp (noLoc mfix_op) mfix_arg
        mfix_arg   = noLoc $ HsLam (MatchGroup [mkSimpleMatch [mfix_pat] body]
                                             (mkFunTy tup_ty body_ty))
        mfix_pat   = noLoc $ LazyPat $ mkLHsPatTup rec_tup_pats
        body       = noLoc $ HsDo DoExpr rec_stmts return_app body_ty
        return_app = nlHsApp (noLoc return_op) (mkLHsTupleExpr rets)
	body_ty    = mkAppTy m_ty tup_ty
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
775
        tup_ty     = mkBoxedTupleTy (map idType tup_ids) -- Deals with singleton case
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 783 784 785 786
handle_failure pat match fail_op
  | matchCanFail match
  = do { fail_op' <- dsExpr fail_op
       ; fail_msg <- mkStringExpr (mk_fail_msg pat)
       ; extractMatchResult match (App fail_op' fail_msg) }
  | otherwise
  = extractMatchResult match (error "It can't fail")
787

788
mk_fail_msg :: Located e -> String
789 790
mk_fail_msg pat = "Pattern match failure in do expression at " ++ 
		  showSDoc (ppr (getLoc pat))
791
\end{code}
792 793 794 795 796 797 798 799 800

Translation for RecStmt's: 
-----------------------------
We turn (RecStmt [v1,..vn] stmts) into:
  
  (v1,..,vn) <- mfix (\~(v1,..vn). do stmts
				      return (v1,..vn))

\begin{code}
801 802
{-
dsMDo   :: HsStmtContext Name
803
        -> [(Name,Id)]
804 805 806 807 808
	-> [LStmt Id]
	-> LHsExpr Id
	-> Type			-- Type of the whole expression
	-> DsM CoreExpr

809
dsMDo ctxt tbl stmts body result_ty
810
  = goL stmts
811
  where
812 813 814
    goL [] = dsLExpr body
    goL ((L loc stmt):lstmts) = putSrcSpanDs loc (go loc stmt lstmts)
  
815 816 817 818 819 820
    (m_ty, b_ty) = tcSplitAppTy result_ty	-- result_ty must be of the form (m b)
    return_id = lookupEvidence tbl returnMName
    bind_id   = lookupEvidence tbl bindMName
    then_id   = lookupEvidence tbl thenMName
    fail_id   = lookupEvidence tbl failMName

821 822
    go _ (LetStmt binds) stmts
      = do { rest <- goL stmts
823
	   ; dsLocalBinds binds rest }
824

825
    go _ (ExprStmt rhs then_expr rhs_ty) stmts
826
      = do { rhs2 <- dsLExpr rhs
827
	   ; warnDiscardedDoBindings rhs m_ty rhs_ty
828
           ; then_expr2 <- dsExpr then_expr
829
           ; rest <- goL stmts
830
           ; return (mkApps then_expr2 [rhs2, rest]) }
831
    
832 833 834 835 836
    go _ (BindStmt pat rhs bind_op _) stmts
      = do { body     <- goL stmts
           ; rhs'     <- dsLExpr rhs
           ; bind_op' <- dsExpr bind_op
           ; var   <- selectSimpleMatchVarL pat
837
	   ; match <- matchSinglePat (Var var) (StmtCtxt ctxt) pat
838 839 840
                                     result_ty (cantFailMatchResult body)
           ; match_code <- handle_failure pat match fail_op
           ; return (mkApps bind_op [rhs', Lam var match_code]) }
841
    
842
    go loc (RecStmt { recS_stmts = rec_stmts, recS_later_ids = later_ids
843 844
                    , recS_rec_ids = rec_ids, recS_rec_rets = rec_rets
                    , recS_mfix_fn = mfix_op, recS_bind_fn = bind_op }) stmts
845 846
      = ASSERT( length rec_ids > 0 )
        ASSERT( length rec_ids == length rec_rets )
847
        ASSERT( isEmptyTcEvBinds _ev_binds )
848
        pprTrace "dsMDo" (ppr later_ids) $
849
	 goL (new_bind_stmt : stmts)
850
      where
851 852
        new_bind_stmt = L loc $ BindStmt (mk_tup_pat later_pats) mfix_app
                                         bind_op noSyntaxExpr
853 854 855 856 857 858 859
	
		-- Remove the later_ids that appear (without fancy coercions) 
		-- in rec_rets, because there's no need to knot-tie them separately
		-- See Note [RecStmt] in HsExpr
	later_ids'   = filter (`notElem` mono_rec_ids) later_ids
	mono_rec_ids = [ id | HsVar id <- rec_rets ]
    
860
        mfix_app = nlHsApp (noLoc mfix_op) mfix_arg
861
	mfix_arg = noLoc $ HsLam (MatchGroup [mkSimpleMatch [mfix_pat] body]
862
					     (mkFunTy tup_ty body_ty))
863

864
	-- The rec_tup_pat must bind the rec_ids only; remember that the 
865 866
	-- 	trimmed_laters may share the same Names
	-- Meanwhile, the later_pats must bind the later_vars
867 868 869
	rec_tup_pats = map mk_wild_pat later_ids' ++ map nlVarPat rec_ids
	later_pats   = map nlVarPat    later_ids' ++ map mk_later_pat rec_ids
	rets         = map nlHsVar     later_ids' ++ map noLoc rec_rets
870 871

	mfix_pat = noLoc $ LazyPat $ mk_tup_pat rec_tup_pats
872
	body     = noLoc $ HsDo ctxt rec_stmts return_app body_ty
873
	body_ty = mkAppTy m_ty tup_ty
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
874
	tup_ty  = mkBoxedTupleTy (map idType (later_ids' ++ rec_ids))  -- Deals with singleton case
875

876
        return_app  = nlHsApp (noLoc return_op) (mkLHsTupleExpr rets)
877 878 879 880 881

	mk_wild_pat :: Id -> LPat Id 
   	mk_wild_pat v = noLoc $ WildPat $ idType v

	mk_later_pat :: Id -> LPat Id
882 883
	mk_later_pat v | v `elem` later_ids' = mk_wild_pat v
		       | otherwise	     = nlVarPat v
884 885 886

 	mk_tup_pat :: [LPat Id] -> LPat Id
  	mk_tup_pat [p] = p
887
	mk_tup_pat ps  = noLoc $ mkVanillaTuplePat ps Boxed
888
-}
889
\end{code}
890 891


892 893 894 895 896 897 898 899 900 901 902 903 904 905 906 907 908 909 910 911 912 913 914 915 916 917 918 919 920 921
%************************************************************************
%*									*
                 Warning about identities
%*									*
%************************************************************************

Warn about functions 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
\begin{code}
warnAboutIdentities :: CoreExpr -> (CoreExpr -> CoreExpr) -> DsM ()
warnAboutIdentities (Var v) co_fn
  | idName v `elem` conversionNames
  , let fun_ty = exprType (co_fn (Var v))
  , Just (arg_ty, res_ty) <- splitFunTy_maybe fun_ty
  , arg_ty `tcEqType` res_ty  -- So we are converting  ty -> ty
  = 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,
 -- becuase they are generated by literals
\end{code}

922 923 924 925 926 927 928 929
%************************************************************************
%*									*
\subsection{Errors and contexts}
%*									*
%************************************************************************

\begin{code}
-- Warn about certain types of values discarded in monadic bindings (#3263)
930 931 932 933 934 935 936 937 938 939 940 941 942 943 944 945 946 947 948 949 950 951 952 953 954 955
warnDiscardedDoBindings :: LHsExpr Id -> Type -> Type -> DsM ()
warnDiscardedDoBindings rhs container_ty returning_ty = do {
          -- Warn about discarding non-() things in 'monadic' binding
        ; warn_unused <- doptDs Opt_WarnUnusedDoBind
        ; if warn_unused && not (returning_ty `tcEqType` unitTy)
           then warnDs (unusedMonadBind rhs returning_ty)
           else do {
          -- 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
        ; warn_wrong <- doptDs Opt_WarnWrongDoBind
        ; case tcSplitAppTy_maybe returning_ty of
                  Just (returning_container_ty, _) -> when (warn_wrong && container_ty `tcEqType` returning_container_ty) $
                                                            warnDs (wrongMonadBind rhs returning_ty)
                  _ -> return () } }

unusedMonadBind :: LHsExpr Id -> Type -> SDoc
unusedMonadBind rhs returning_ty
  = ptext (sLit "A do-notation statement discarded a result of type") <+> ppr returning_ty <> dot $$
    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
wrongMonadBind rhs returning_ty
  = ptext (sLit "A do-notation statement discarded a result of type") <+> ppr returning_ty <> dot $$
    ptext (sLit "Suppress this warning by saying \"_ <- ") <> ppr rhs <> ptext (sLit "\",") $$
    ptext (sLit "or by using the flag -fno-warn-wrong-do-bind")
956
\end{code}