DsExpr.lhs 26.7 KB
Newer Older
1
%
2
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
3
4
5
6
%
\section[DsExpr]{Matching expressions (Exprs)}

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

9
#include "HsVersions.h"
10
11
12
13
#if defined(GHCI) && defined(BREAKPOINT)
import Foreign.StablePtr ( newStablePtr, castStablePtrToPtr )
import GHC.Exts         ( Ptr(..), Int(..), addr2Int# )
import IOEnv            ( ioToIOEnv )
David Himmelstrup's avatar
David Himmelstrup committed
14
import PrelNames        ( breakpointJumpName, breakpointCondJumpName )
15
16
import TysWiredIn       ( unitTy )
import TypeRep          ( Type(..) )
17
import TyCon            ( isUnLiftedTyCon )
18
#endif
19

20
import Match		( matchWrapper, matchSinglePat, matchEquations )
21
import MatchLit		( dsLit, dsOverLit )
22
import DsBinds		( dsLHsBinds, dsCoercion )
23
24
import DsGRHSs		( dsGuarded )
import DsListComp	( dsListComp, dsPArrComp )
25
import DsUtils		( mkErrorAppDs, mkStringExpr, mkConsExpr, mkNilExpr,
26
			  extractMatchResult, cantFailMatchResult, matchCanFail,
27
			  mkCoreTupTy, selectSimpleMatchVarL, lookupEvidence, selectMatchVar )
28
import DsArrows		( dsProcExpr )
29
30
31
32
import DsMonad

#ifdef GHCI
	-- Template Haskell stuff iff bootstrapped
33
import DsMeta		( dsBracket )
34
35
#endif

36
import HsSyn
37
import TcHsSyn		( hsPatType, mkVanillaTuplePat )
38
39
40
41
42
43

-- NB: The desugarer, which straddles the source and Core worlds, sometimes
--     needs to see source types (newtypes etc), and sometimes not
--     So WATCH OUT; check each use of split*Ty functions.
-- Sigh.  This is a pain.

44
import TcType		( tcSplitAppTy, tcSplitFunTys, tcTyConAppTyCon, 
45
			  tcTyConAppArgs, isUnLiftedType, Type, mkAppTy )
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
46
import Type		( splitFunTys, isUnboxedTupleType, mkFunTy )
47
import CoreSyn
48
import CoreUtils	( exprType, mkIfThenElse, bindNonRec )
49
50

import CostCentre	( mkUserCC )
51
import Id		( Id, idType, idName, idDataCon )
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
52
import PrelInfo		( rEC_CON_ERROR_ID )
53
import DataCon		( DataCon, dataConWrapId, dataConFieldLabels, dataConInstOrigArgTys )
54
55
import DataCon		( isVanillaDataCon )
import TyCon		( FieldLabel, tyConDataCons )
56
import TysWiredIn	( tupleCon )
57
import BasicTypes	( RecFlag(..), Boxity(..), ipNameName )
58
59
60
import PrelNames	( toPName,
			  returnMName, bindMName, thenMName, failMName,
			  mfixName )
61
import SrcLoc		( Located(..), unLoc, getLoc, noLoc )
62
import Util		( zipEqual, zipWithEqual )
63
import Bag		( bagToList )
64
import Outputable
65
import FastString
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 = foldrDs ds_val_bind body binds
84
85
86
87

-------------------------
dsIPBinds (IPBinds ip_binds dict_binds) body
  = do	{ prs <- dsLHsBinds dict_binds
88
89
90
	; let inner = Let (Rec prs) body
		-- The dict bindings may not be in 
		-- dependency order; hence Rec
91
	; foldrDs ds_ip_bind inner ip_binds }
92
  where
93
94
95
    ds_ip_bind (L _ (IPBind n e)) body
      = dsLExpr e	`thenDs` \ e' ->
	returnDs (Let (NonRec (ipNameName n) e') body)
96

97
98
-------------------------
ds_val_bind :: (RecFlag, LHsBinds Id) -> CoreExpr -> DsM CoreExpr
99
-- Special case for bindings which bind unlifted variables
100
101
-- We need to do a case right away, rather than building
-- a tuple and doing selections.
102
-- Silently ignore INLINE and SPECIALISE pragmas...
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
103
ds_val_bind (NonRecursive, hsbinds) body
104
  | [L _ (AbsBinds [] [] exports binds)] <- bagToList hsbinds,
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
105
    (L loc bind : null_binds) <- bagToList binds,
106
107
108
    isBangHsBind bind
    || isUnboxedTupleBind bind
    || or [isUnLiftedType (idType g) | (_, g, _, _) <- exports]
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
109
  = let
110
111
112
      body_w_exports		      = foldr bind_export body exports
      bind_export (tvs, g, l, _) body = ASSERT( null tvs )
				        bindNonRec g (Var l) body
113
    in
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
114
115
116
117
118
119
120
121
122
    ASSERT (null null_binds)
	-- 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.)
    putSrcSpanDs loc	$
    case bind of
      FunBind { fun_id = L _ fun, fun_matches = matches, fun_co_fn = co_fn }
	-> matchWrapper (FunRhs (idName fun)) matches 	 	`thenDs` \ (args, rhs) ->
123
	   ASSERT( null args )	-- Functions aren't lifted
124
	   ASSERT( isIdCoercion co_fn )
125
126
	   returnDs (bindNonRec fun rhs body_w_exports)

simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
127
      PatBind {pat_lhs = pat, pat_rhs = grhss, pat_rhs_ty = ty }
128
129
130
131
132
133
134
135
136
137
	-> 	-- let C x# y# = rhs in body
		-- ==> case rhs of C x# y# -> body
	   putSrcSpanDs loc			$
	   do { rhs <- dsGuarded grhss ty
	      ; let upat = unLoc pat
		    eqn = EqnInfo { eqn_wrap = idWrapper, eqn_pats = [upat], 
				    eqn_rhs = cantFailMatchResult body_w_exports }
	      ; var    <- selectMatchVar upat ty
	      ; result <- matchEquations PatBindRhs [var] [eqn] (exprType body)
	      ; return (scrungleMatch var rhs result) }
138

139
      other -> pprPanic "dsLet: unlifted" (pprLHsBinds hsbinds $$ ppr body)
140

141

simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
142
-- Ordinary case for bindings; none should be unlifted
143
ds_val_bind (is_rec, binds) body
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
144
145
146
147
148
  = do	{ prs <- dsLHsBinds binds
	; ASSERT( not (any (isUnLiftedType . idType . fst) prs) )
	  case prs of
	    []    -> return body
	    other -> return (Let (Rec prs) body) }
149
	-- Use a Rec regardless of is_rec. 
150
	-- Why? Because it allows the binds to be all
151
152
153
154
155
	-- 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
156
157
158
	--
	-- NB The previous case dealt with unlifted bindings, so we
	--    only have to deal with lifted ones now; so Rec is ok
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187

isUnboxedTupleBind :: HsBind Id -> Bool
isUnboxedTupleBind (PatBind { pat_rhs_ty = ty }) = isUnboxedTupleType ty
isUnboxedTupleBind other			 = False

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))
188
\end{code}	
189
190
191

%************************************************************************
%*									*
192
\subsection[DsExpr-vars-and-cons]{Variables, constructors, literals}
193
194
195
196
%*									*
%************************************************************************

\begin{code}
197
198
199
200
dsLExpr :: LHsExpr Id -> DsM CoreExpr
dsLExpr (L loc e) = putSrcSpanDs loc $ dsExpr e

dsExpr :: HsExpr Id -> DsM CoreExpr
201

202
203
dsExpr (HsPar e) 	      = dsLExpr e
dsExpr (ExprWithTySigOut e _) = dsLExpr e
204
205
206
207
208
209
210
211
212
dsExpr (HsVar var)     	      = returnDs (Var var)
dsExpr (HsIPVar ip)    	      = returnDs (Var (ipNameName ip))
dsExpr (HsLit lit)     	      = dsLit lit
dsExpr (HsOverLit lit) 	      = dsOverLit lit

dsExpr (NegApp expr neg_expr) 
  = do	{ core_expr <- dsLExpr expr
	; core_neg  <- dsExpr neg_expr
	; return (core_neg `App` core_expr) }
213

214
dsExpr expr@(HsLam a_Match)
215
  = matchWrapper LambdaExpr a_Match	`thenDs` \ (binders, matching_code) ->
216
    returnDs (mkLams binders matching_code)
217

218
219
220
#if defined(GHCI) && defined(BREAKPOINT)
dsExpr (HsApp (L _ (HsApp realFun@(L _ (HsCoerce _ fun)) (L loc arg))) _)
    | HsVar funId <- fun
David Himmelstrup's avatar
David Himmelstrup committed
221
    , idName funId `elem` [breakpointJumpName, breakpointCondJumpName]
222
    , ids <- filter (isValidType . idType) (extractIds arg)
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
    = do dsWarn (text "Extracted ids:" <+> ppr ids <+> ppr (map idType ids))
         stablePtr <- ioToIOEnv $ newStablePtr ids
         -- Yes, I know... I'm gonna burn in hell.
         let Ptr addr# = castStablePtrToPtr stablePtr
         funCore <- dsLExpr realFun
         argCore <- dsLExpr (L loc (HsLit (HsInt (fromIntegral (I# (addr2Int# addr#))))))
         hvalCore <- dsLExpr (L loc (extractHVals ids))
         return ((funCore `App` argCore) `App` hvalCore)
    where extractIds :: HsExpr Id -> [Id]
          extractIds (HsApp fn arg)
              | HsVar argId <- unLoc arg
              = argId:extractIds (unLoc fn)
              | TyApp arg' ts <- unLoc arg
              , HsVar argId <- unLoc arg'
              = error (showSDoc (ppr ts)) -- argId:extractIds (unLoc fn)
          extractIds x = []
          extractHVals ids = ExplicitList unitTy (map (L loc . HsVar) ids)
240
241
242
243
244
245
246
          -- checks for tyvars and unlifted kinds.
          isValidType (TyVarTy _) = False
          isValidType (FunTy a b) = isValidType a && isValidType b
          isValidType (NoteTy _ t) = isValidType t
          isValidType (AppTy a b) = isValidType a && isValidType b
          isValidType (TyConApp con ts) = not (isUnLiftedTyCon con) && all isValidType ts
          isValidType _ = True
247
248
#endif

sof's avatar
sof committed
249
dsExpr expr@(HsApp fun arg)      
250
251
  = dsLExpr fun		`thenDs` \ core_fun ->
    dsLExpr arg		`thenDs` \ core_arg ->
252
    returnDs (core_fun `App` core_arg)
253
254
255
256
257
258
\end{code}

Operator sections.  At first it looks as if we can convert
\begin{verbatim}
	(expr op)
\end{verbatim}
259
to
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
\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
277
dsExpr (OpApp e1 op _ e2)
278
  = dsLExpr op						`thenDs` \ core_op ->
sof's avatar
sof committed
279
    -- for the type of y, we need the type of op's 2nd argument
280
281
    dsLExpr e1				`thenDs` \ x_core ->
    dsLExpr e2				`thenDs` \ y_core ->
282
    returnDs (mkApps core_op [x_core, y_core])
sof's avatar
sof committed
283
    
284
dsExpr (SectionL expr op)
285
  = dsLExpr op						`thenDs` \ core_op ->
sof's avatar
sof committed
286
    -- for the type of y, we need the type of op's 2nd argument
287
    let
288
289
290
	(x_ty:y_ty:_, _) = splitFunTys (exprType core_op)
	-- Must look through an implicit-parameter type; 
	-- newtype impossible; hence Type.splitFunTys
291
    in
292
    dsLExpr expr				`thenDs` \ x_core ->
293
    newSysLocalDs x_ty			`thenDs` \ x_id ->
sof's avatar
sof committed
294
    newSysLocalDs y_ty			`thenDs` \ y_id ->
295
296
297

    returnDs (bindNonRec x_id x_core $
	      Lam y_id (mkApps core_op [Var x_id, Var y_id]))
298

299
-- dsLExpr (SectionR op expr)	-- \ x -> op x expr
300
dsExpr (SectionR op expr)
301
  = dsLExpr op			`thenDs` \ core_op ->
sof's avatar
sof committed
302
    -- for the type of x, we need the type of op's 2nd argument
303
    let
304
305
	(x_ty:y_ty:_, _) = splitFunTys (exprType core_op)
	-- See comment with SectionL
306
    in
307
    dsLExpr expr				`thenDs` \ y_core ->
sof's avatar
sof committed
308
    newSysLocalDs x_ty			`thenDs` \ x_id ->
309
310
311
312
    newSysLocalDs y_ty			`thenDs` \ y_id ->

    returnDs (bindNonRec y_id y_core $
	      Lam x_id (mkApps core_op [Var x_id, Var y_id]))
313

314
dsExpr (HsSCC cc expr)
315
  = dsLExpr expr			`thenDs` \ core_expr ->
316
317
    getModuleDs			`thenDs` \ mod_name ->
    returnDs (Note (SCC (mkUserCC cc mod_name)) core_expr)
318

319
320
321
322

-- hdaume: core annotation

dsExpr (HsCoreAnn fs expr)
323
  = dsLExpr expr        `thenDs` \ core_expr ->
324
325
    returnDs (Note (CoreNote $ unpackFS fs) core_expr)

326
327
dsExpr (HsCase discrim matches)
  = dsLExpr discrim			`thenDs` \ core_discrim ->
328
    matchWrapper CaseAlt matches 	`thenDs` \ ([discrim_var], matching_code) ->
329
    returnDs (scrungleMatch discrim_var core_discrim matching_code)
330

331
dsExpr (HsLet binds body)
332
  = dsLExpr body		`thenDs` \ body' ->
333
    dsLocalBinds binds body'
334

chak's avatar
chak committed
335
336
337
-- 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.
--
338
dsExpr (HsDo ListComp stmts body result_ty)
sof's avatar
sof committed
339
  =	-- Special case for list comprehensions
340
    dsListComp stmts body elt_ty
chak's avatar
chak committed
341
  where
342
    [elt_ty] = tcTyConAppArgs result_ty
343

344
345
346
347
348
dsExpr (HsDo DoExpr stmts body result_ty)
  = dsDo stmts body result_ty

dsExpr (HsDo (MDoExpr tbl) stmts body result_ty)
  = dsMDo tbl stmts body result_ty
chak's avatar
chak committed
349

350
dsExpr (HsDo PArrComp stmts body result_ty)
chak's avatar
chak committed
351
  =	-- Special case for array comprehensions
352
    dsPArrComp (map unLoc stmts) body elt_ty
353
  where
354
    [elt_ty] = tcTyConAppArgs result_ty
355

356
357
358
359
dsExpr (HsIf guard_expr then_expr else_expr)
  = dsLExpr guard_expr	`thenDs` \ core_guard ->
    dsLExpr then_expr	`thenDs` \ core_then ->
    dsLExpr else_expr	`thenDs` \ core_else ->
360
    returnDs (mkIfThenElse core_guard core_then core_else)
361
362
363
\end{code}


364
365
366
\noindent
\underline{\bf Type lambda and application}
%              ~~~~~~~~~~~~~~~~~~~~~~~~~~~
367
368
\begin{code}
dsExpr (TyLam tyvars expr)
369
  = dsLExpr expr `thenDs` \ core_expr ->
370
    returnDs (mkLams tyvars core_expr)
371

sof's avatar
sof committed
372
dsExpr (TyApp expr tys)
373
  = dsLExpr expr		`thenDs` \ core_expr ->
374
    returnDs (mkTyApps core_expr tys)
375
376
377
\end{code}


378
379
380
\noindent
\underline{\bf Various data construction things}
%              ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
381
\begin{code}
382
dsExpr (ExplicitList ty xs)
sof's avatar
sof committed
383
384
  = go xs
  where
385
    go []     = returnDs (mkNilExpr ty)
386
    go (x:xs) = dsLExpr x				`thenDs` \ core_x ->
sof's avatar
sof committed
387
		go xs					`thenDs` \ core_xs ->
388
		returnDs (mkConsExpr ty core_x core_xs)
389

chak's avatar
chak committed
390
391
392
-- we create a list from the array elements and convert them into a list using
-- `PrelPArr.toP'
--
393
--  * the main disadvantage to this scheme is that `toP' traverses the list
chak's avatar
chak committed
394
395
396
397
398
399
400
--   twice: once to determine the length and a second time to put to elements
--   into the array; this inefficiency could be avoided by exposing some of
--   the innards of `PrelPArr' to the compiler (ie, have a `PrelPArrBase') so
--   that we can exploit the fact that we already know the length of the array
--   here at compile time
--
dsExpr (ExplicitPArr ty xs)
401
  = dsLookupGlobalId toPName				`thenDs` \toP      ->
chak's avatar
chak committed
402
403
404
    dsExpr (ExplicitList ty xs)				`thenDs` \coreList ->
    returnDs (mkApps (Var toP) [Type ty, coreList])

405
dsExpr (ExplicitTuple expr_list boxity)
406
  = mappM dsLExpr expr_list	  `thenDs` \ core_exprs  ->
407
    returnDs (mkConApp (tupleCon boxity (length expr_list))
408
	    	       (map (Type .  exprType) core_exprs ++ core_exprs))
409

410
411
412
dsExpr (ArithSeq expr (From from))
  = dsExpr expr		  `thenDs` \ expr2 ->
    dsLExpr from	  `thenDs` \ from2 ->
413
    returnDs (App expr2 from2)
414

415
416
417
dsExpr (ArithSeq expr (FromTo from two))
  = dsExpr expr		  `thenDs` \ expr2 ->
    dsLExpr from	  `thenDs` \ from2 ->
418
    dsLExpr two		  `thenDs` \ two2 ->
419
    returnDs (mkApps expr2 [from2, two2])
420

421
422
423
dsExpr (ArithSeq expr (FromThen from thn))
  = dsExpr expr		  `thenDs` \ expr2 ->
    dsLExpr from	  `thenDs` \ from2 ->
424
    dsLExpr thn		  `thenDs` \ thn2 ->
425
    returnDs (mkApps expr2 [from2, thn2])
426

427
428
429
dsExpr (ArithSeq expr (FromThenTo from thn two))
  = dsExpr expr		  `thenDs` \ expr2 ->
    dsLExpr from	  `thenDs` \ from2 ->
430
431
    dsLExpr thn		  `thenDs` \ thn2 ->
    dsLExpr two		  `thenDs` \ two2 ->
432
    returnDs (mkApps expr2 [from2, thn2, two2])
chak's avatar
chak committed
433

434
435
436
dsExpr (PArrSeq expr (FromTo from two))
  = dsExpr expr		  `thenDs` \ expr2 ->
    dsLExpr from	  `thenDs` \ from2 ->
437
    dsLExpr two		  `thenDs` \ two2 ->
chak's avatar
chak committed
438
439
    returnDs (mkApps expr2 [from2, two2])

440
441
442
dsExpr (PArrSeq expr (FromThenTo from thn two))
  = dsExpr expr		  `thenDs` \ expr2 ->
    dsLExpr from	  `thenDs` \ from2 ->
443
444
    dsLExpr thn		  `thenDs` \ thn2 ->
    dsLExpr two		  `thenDs` \ two2 ->
chak's avatar
chak committed
445
446
    returnDs (mkApps expr2 [from2, thn2, two2])

447
dsExpr (PArrSeq expr _)
chak's avatar
chak committed
448
449
450
  = panic "DsExpr.dsExpr: Infinite parallel array!"
    -- the parser shouldn't have generated it and the renamer and typechecker
    -- shouldn't have let it through
451
452
\end{code}

453
454
455
\noindent
\underline{\bf Record construction and update}
%              ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
456
For record construction we do this (assuming T has three arguments)
457
\begin{verbatim}
458
459
460
461
462
463
	T { op2 = e }
==>
	let err = /\a -> recConErr a 
	T (recConErr t1 "M.lhs/230/op1") 
	  e 
	  (recConErr t1 "M.lhs/230/op3")
464
465
\end{verbatim}
@recConErr@ then converts its arugment string into a proper message
466
before printing it as
467
468
469
\begin{verbatim}
	M.lhs, line 230: missing field op1 was evaluated
\end{verbatim}
470

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

474
\begin{code}
475
476
dsExpr (RecordCon (L _ data_con_id) con_expr rbinds)
  = dsExpr con_expr	`thenDs` \ con_expr' ->
477
    let
478
	(arg_tys, _) = tcSplitFunTys (exprType con_expr')
479
480
	-- A newtype in the corner should be opaque; 
	-- hence TcType.tcSplitFunTys
481

482
483
	mk_arg (arg_ty, lbl)	-- Selector id has the field label as its name
	  = case [rhs | (L _ sel_id, rhs) <- rbinds, lbl == idName sel_id] of
484
	      (rhs:rhss) -> ASSERT( null rhss )
485
		 	    dsLExpr rhs
486
	      []         -> mkErrorAppDs rEC_CON_ERROR_ID arg_ty (showSDoc (ppr lbl))
487
488
	unlabelled_bottom arg_ty = mkErrorAppDs rEC_CON_ERROR_ID arg_ty ""

489
490
	labels = dataConFieldLabels (idDataCon data_con_id)
	-- The data_con_id is guaranteed to be the wrapper id of the constructor
491
    in
492
493

    (if null labels
494
495
	then mappM unlabelled_bottom arg_tys
	else mappM mk_arg (zipEqual "dsExpr:RecordCon" arg_tys labels))
496
497
	`thenDs` \ con_args ->

498
    returnDs (mkApps con_expr' con_args)
499
500
501
\end{code}

Record update is a little harder. Suppose we have the decl:
502
\begin{verbatim}
503
	data T = T1 {op1, op2, op3 :: Int}
504
	       | T2 {op4, op2 :: Int}
505
	       | T3
506
\end{verbatim}
507
Then we translate as follows:
508
\begin{verbatim}
509
510
511
512
513
514
515
	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"
516
517
\end{verbatim}
It's important that we use the constructor Ids for @T1@, @T2@ etc on the
518
RHSs, and do not generate a Core constructor application directly, because the constructor
519
520
521
522
might do some argument-evaluation first; and may have to throw away some
dictionaries.

\begin{code}
523
dsExpr (RecordUpd record_expr [] record_in_ty record_out_ty)
524
  = dsLExpr record_expr
525

526
dsExpr expr@(RecordUpd record_expr rbinds record_in_ty record_out_ty)
527
  = dsLExpr record_expr	 	`thenDs` \ record_expr' ->
528
529
530

	-- Desugar the rbinds, and generate let-bindings if
	-- necessary so that we don't lose sharing
531
532

    let
533
534
	in_inst_tys  = tcTyConAppArgs record_in_ty	-- Newtype opaque
	out_inst_tys = tcTyConAppArgs record_out_ty	-- Newtype opaque
535
	in_out_ty    = mkFunTy record_in_ty record_out_ty
536

537
	mk_val_arg field old_arg_id 
538
	  = case [rhs | (L _ sel_id, rhs) <- rbinds, field == idName sel_id] of
539
	      (rhs:rest) -> ASSERT(null rest) rhs
540
	      []	 -> nlHsVar old_arg_id
541
542

	mk_alt con
543
	  = newSysLocalsDs (dataConInstOrigArgTys con in_inst_tys) `thenDs` \ arg_ids ->
544
		-- This call to dataConInstOrigArgTys won't work for existentials
545
		-- but existentials don't have record types anyway
546
	    let 
547
548
		val_args = zipWithEqual "dsExpr:RecordUpd" mk_val_arg
					(dataConFieldLabels con) arg_ids
549
550
551
552
		rhs = foldl (\a b -> nlHsApp a b)
			(noLoc $ TyApp (nlHsVar (dataConWrapId con)) 
				out_inst_tys)
			  val_args
553
	    in
554
	    returnDs (mkSimpleMatch [noLoc $ ConPatOut (noLoc con) [] [] emptyLHsBinds 
555
556
						       (PrefixCon (map nlVarPat arg_ids)) record_in_ty]
				    rhs)
557
    in
558
	-- Record stuff doesn't work for existentials
559
560
	-- The type checker checks for this, but we need 
	-- worry only about the constructors that are to be updated
561
    ASSERT2( all isVanillaDataCon cons_to_upd, ppr expr )
562

563
564
565
566
	-- 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.
567
568
    mappM mk_alt cons_to_upd				`thenDs` \ alts ->
    matchWrapper RecUpd (MatchGroup alts in_out_ty)	`thenDs` \ ([discrim_var], matching_code) ->
569
570

    returnDs (bindNonRec discrim_var record_expr' matching_code)
571
572

  where
573
    updated_fields :: [FieldLabel]
574
    updated_fields = [ idName sel_id | (L _ sel_id,_) <- rbinds]
575

576
	-- Get the type constructor from the record_in_ty
577
578
579
	-- so that we are sure it'll have all its DataCons
	-- (In GHCI, it's possible that some TyCons may not have all
	--  their constructors, in a module-loop situation.)
580
    tycon       = tcTyConAppTyCon record_in_ty
581
582
583
    data_cons   = tyConDataCons tycon
    cons_to_upd = filter has_all_fields data_cons

584
    has_all_fields :: DataCon -> Bool
585
    has_all_fields con_id 
586
      = all (`elem` con_fields) updated_fields
587
      where
588
	con_fields = dataConFieldLabels con_id
589
590
\end{code}

591
592
593
594

\noindent
\underline{\bf Dictionary lambda and application}
%              ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
595
596
597
598
599
@DictLam@ and @DictApp@ turn into the regular old things.
(OLD:) @DictFunApp@ also becomes a curried application, albeit slightly more
complicated; reminiscent of fully-applied constructors.
\begin{code}
dsExpr (DictLam dictvars expr)
600
  = dsLExpr expr `thenDs` \ core_expr ->
601
    returnDs (mkLams dictvars core_expr)
602
603
604

------------------

sof's avatar
sof committed
605
dsExpr (DictApp expr dicts)	-- becomes a curried application
606
  = dsLExpr expr			`thenDs` \ core_expr ->
607
    returnDs (foldl (\f d -> f `App` (Var d)) core_expr dicts)
608
609

dsExpr (HsCoerce co_fn e) = dsCoercion co_fn (dsExpr e)
610
611
\end{code}

612
613
614
615
616
617
618
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
619
dsExpr (HsSpliceE s)       = pprPanic "dsExpr:splice" (ppr s)
620
621
#endif

622
-- Arrow notation extension
623
dsExpr (HsProc pat cmd) = dsProcExpr pat cmd
624
625
626
\end{code}


627
628
\begin{code}

629
630
631
632
633
#ifdef DEBUG
-- HsSyn constructs that just shouldn't be here:
dsExpr (ExprWithTySig _ _)  = panic "dsExpr:ExprWithTySig"
#endif

634
635
\end{code}

sof's avatar
sof committed
636
%--------------------------------------------------------------------
637

638
639
640
Desugar 'do' and 'mdo' expressions (NOT list comprehensions, they're
handled in DsListComp).  Basically does the translation given in the
Haskell 98 report:
641

642
\begin{code}
643
644
645
dsDo	:: [LStmt Id]
	-> LHsExpr Id
	-> Type			-- Type of the whole expression
646
647
	-> DsM CoreExpr

648
649
dsDo stmts body result_ty
  = go (map unLoc stmts)
650
  where
651
652
653
654
655
656
657
658
659
660
    go [] = dsLExpr body
    
    go (ExprStmt rhs then_expr _ : stmts)
      = do { rhs2 <- dsLExpr rhs
	   ; then_expr2 <- dsExpr then_expr
	   ; rest <- go stmts
	   ; returnDs (mkApps then_expr2 [rhs2, rest]) }
    
    go (LetStmt binds : stmts)
      = do { rest <- go stmts
661
	   ; dsLocalBinds binds rest }
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
        
    go (BindStmt pat rhs bind_op fail_op : stmts)
      = do { body  <- go stmts
	   ; var   <- selectSimpleMatchVarL pat
	   ; match <- matchSinglePat (Var var) (StmtCtxt DoExpr) pat
    				  result_ty (cantFailMatchResult body)
	   ; match_code <- handle_failure pat match fail_op
	   ; rhs'       <- dsLExpr rhs
	   ; bind_op'   <- dsExpr bind_op
	   ; returnDs (mkApps bind_op' [rhs', Lam var match_code]) }
    
    -- In a do expression, pattern-match failure just calls
    -- the monadic 'fail' rather than throwing an exception
    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") 

mk_fail_msg pat = "Pattern match failure in do expression at " ++ 
		  showSDoc (ppr (getLoc pat))
685
\end{code}
686
687
688
689
690
691
692
693
694

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

\begin{code}
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
dsMDo	:: PostTcTable
	-> [LStmt Id]
	-> LHsExpr Id
	-> Type			-- Type of the whole expression
	-> DsM CoreExpr

dsMDo tbl stmts body result_ty
  = go (map unLoc stmts)
  where
    (m_ty, b_ty) = tcSplitAppTy result_ty	-- result_ty must be of the form (m b)
    mfix_id   = lookupEvidence tbl mfixName
    return_id = lookupEvidence tbl returnMName
    bind_id   = lookupEvidence tbl bindMName
    then_id   = lookupEvidence tbl thenMName
    fail_id   = lookupEvidence tbl failMName
    ctxt      = MDoExpr tbl

    go [] = dsLExpr body
    
    go (LetStmt binds : stmts)
      = do { rest <- go stmts
716
	   ; dsLocalBinds binds rest }
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741

    go (ExprStmt rhs _ rhs_ty : stmts)
      = do { rhs2 <- dsLExpr rhs
	   ; rest <- go stmts
	   ; returnDs (mkApps (Var then_id) [Type rhs_ty, Type b_ty, rhs2, rest]) }
    
    go (BindStmt pat rhs _ _ : stmts)
      = do { body  <- go stmts
	   ; var   <- selectSimpleMatchVarL pat
	   ; match <- matchSinglePat (Var var) (StmtCtxt ctxt) pat
    				  result_ty (cantFailMatchResult body)
	   ; fail_msg   <- mkStringExpr (mk_fail_msg pat)
	   ; let fail_expr = mkApps (Var fail_id) [Type b_ty, fail_msg]
	   ; match_code <- extractMatchResult match fail_expr

	   ; rhs'       <- dsLExpr rhs
	   ; returnDs (mkApps (Var bind_id) [Type (hsPatType pat), Type b_ty, 
					     rhs', Lam var match_code]) }
    
    go (RecStmt rec_stmts later_ids rec_ids rec_rets binds : stmts)
      = ASSERT( length rec_ids > 0 )
        ASSERT( length rec_ids == length rec_rets )
	go (new_bind_stmt : let_stmt : stmts)
      where
        new_bind_stmt = mkBindStmt (mk_tup_pat later_pats) mfix_app
742
	let_stmt = LetStmt (HsValBinds (ValBindsOut [(Recursive, binds)] []))
743

744
745
746
747
748
749
750
	
		-- 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 ]
    
751
	mfix_app = nlHsApp (noLoc $ TyApp (nlHsVar mfix_id) [tup_ty]) mfix_arg
752
	mfix_arg = noLoc $ HsLam (MatchGroup [mkSimpleMatch [mfix_pat] body]
753
					     (mkFunTy tup_ty body_ty))
754

755
	-- The rec_tup_pat must bind the rec_ids only; remember that the 
756
757
	-- 	trimmed_laters may share the same Names
	-- Meanwhile, the later_pats must bind the later_vars
758
759
760
	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
761
762

	mfix_pat = noLoc $ LazyPat $ mk_tup_pat rec_tup_pats
763
	body     = noLoc $ HsDo ctxt rec_stmts return_app body_ty
764
	body_ty = mkAppTy m_ty tup_ty
765
	tup_ty  = mkCoreTupTy (map idType (later_ids' ++ rec_ids))
766
		  -- mkCoreTupTy deals with singleton case
767

768
769
770
771
772
773
774
	return_app  = nlHsApp (noLoc $ TyApp (nlHsVar return_id) [tup_ty]) 
			      (mk_ret_tup rets)

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

	mk_later_pat :: Id -> LPat Id
775
776
	mk_later_pat v | v `elem` later_ids' = mk_wild_pat v
		       | otherwise	     = nlVarPat v
777
778
779

 	mk_tup_pat :: [LPat Id] -> LPat Id
  	mk_tup_pat [p] = p
780
	mk_tup_pat ps  = noLoc $ mkVanillaTuplePat ps Boxed
781
782
783
784

	mk_ret_tup :: [LHsExpr Id] -> LHsExpr Id
	mk_ret_tup [r] = r
	mk_ret_tup rs  = noLoc $ ExplicitTuple rs Boxed
785
\end{code}