RnExpr.lhs 32.7 KB
Newer Older
1
%
2
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
3
4
5
6
7
%
\section[RnExpr]{Renaming of expressions}

Basically dependency analysis.

8
Handles @Match@, @GRHSs@, @HsExpr@, and @Qualifier@ datatypes.  In
9
10
11
12
13
general, all of these functions return a renamed thing, and a set of
free variables.

\begin{code}
module RnExpr (
14
	rnMatch, rnGRHSs, rnPat, rnExpr, rnExprs, rnStmt,
15
	checkPrecMatch
16
17
   ) where

18
19
#include "HsVersions.h"

20
import {-# SOURCE #-} RnBinds  ( rnBinds ) 
21
22
23
24
25

import HsSyn
import RdrHsSyn
import RnHsSyn
import RnMonad
26
import RnEnv
27
import RnTypes		( rnHsTypeFVs )
28
import RnHiFiles	( lookupFixityRn )
29
import CmdLineOpts	( DynFlag(..), opt_IgnoreAsserts )
30
import Literal		( inIntRange, inCharRange )
chak's avatar
chak committed
31
32
import BasicTypes	( Fixity(..), FixityDirection(..), IPName(..),
			  defaultFixity, negateFixity )
33
import PrelNames	( hasKey, assertIdKey, 
34
35
36
			  eqClassName, foldrName, buildName, eqStringName,
			  cCallableClassName, cReturnableClassName, 
			  monadClassName, enumClassName, ordClassName,
chak's avatar
chak committed
37
			  ratioDataConName, splitName, fstName, sndName,
38
			  ioDataConName, plusIntegerName, timesIntegerName,
chak's avatar
chak committed
39
40
41
42
43
			  assertErr_RDR,
			  replicatePName, mapPName, filterPName,
			  falseDataConName, trueDataConName, crossPName,
			  zipPName, lengthPName, indexPName, toPName,
			  enumFromToPName, enumFromThenToPName )
44
import TysPrim		( charPrimTyCon, addrPrimTyCon, intPrimTyCon, 
chak's avatar
chak committed
45
			  floatPrimTyCon, doublePrimTyCon )
46
import TysWiredIn	( intTyCon )
47
import Name		( NamedThing(..), mkSysLocalName, nameSrcLoc )
48
import NameSet
49
import UniqFM		( isNullUFM )
50
import UniqSet		( emptyUniqSet )
51
import List		( intersectBy )
52
import ListSetOps	( removeDups )
sof's avatar
sof committed
53
import Outputable
54
55
56
57
58
59
60
61
62
63
\end{code}


*********************************************************
*							*
\subsection{Patterns}
*							*
*********************************************************

\begin{code}
64
rnPat :: RdrNamePat -> RnMS (RenamedPat, FreeVars)
65

66
rnPat WildPatIn = returnRn (WildPatIn, emptyFVs)
67
68

rnPat (VarPatIn name)
69
  = lookupBndrRn  name			`thenRn` \ vname ->
70
    returnRn (VarPatIn vname, emptyFVs)
71

72
rnPat (SigPatIn pat ty)
73
  = doptRn Opt_GlasgowExts `thenRn` \ glaExts ->
74
    
75
    if glaExts
76
    then rnPat pat		`thenRn` \ (pat', fvs1) ->
77
         rnHsTypeFVs doc ty	`thenRn` \ (ty',  fvs2) ->
78
79
80
81
         returnRn (SigPatIn pat' ty', fvs1 `plusFV` fvs2)

    else addErrRn (patSigErr ty)	`thenRn_`
         rnPat pat
82
83
84
  where
    doc = text "a pattern type-signature"
    
85
rnPat (LitPatIn s@(HsString _)) 
86
  = returnRn (LitPatIn s, unitFV eqStringName)
87

88
rnPat (LitPatIn lit) 
89
90
91
92
93
  = litFVs lit		`thenRn` \ fvs ->
    returnRn (LitPatIn lit, fvs) 

rnPat (NPatIn lit) 
  = rnOverLit lit			`thenRn` \ (lit', fvs1) ->
94
    returnRn (NPatIn lit', fvs1 `addOneFV` eqClassName)	-- Needed to find equality on pattern
95

96
rnPat (NPlusKPatIn name lit minus)
97
98
  = rnOverLit lit			`thenRn` \ (lit', fvs) ->
    lookupBndrRn name			`thenRn` \ name' ->
99
    lookupSyntaxName minus		`thenRn` \ minus' ->
100
    returnRn (NPlusKPatIn name' lit' minus', fvs `addOneFV` ordClassName `addOneFV` minus')
101
102

rnPat (LazyPatIn pat)
103
104
  = rnPat pat		`thenRn` \ (pat', fvs) ->
    returnRn (LazyPatIn pat', fvs)
105
106

rnPat (AsPatIn name pat)
107
  = rnPat pat		`thenRn` \ (pat', fvs) ->
108
    lookupBndrRn name	`thenRn` \ vname ->
109
    returnRn (AsPatIn vname pat', fvs)
110

111
rnPat (ConPatIn con pats)
112
  = lookupOccRn con		`thenRn` \ con' ->
113
114
    mapFvRn rnPat pats  	`thenRn` \ (patslist, fvs) ->
    returnRn (ConPatIn con' patslist, fvs `addOneFV` con')
115

116
rnPat (ConOpPatIn pat1 con _ pat2)
117
  = rnPat pat1		`thenRn` \ (pat1', fvs1) ->
118
    lookupOccRn con	`thenRn` \ con' ->
119
    rnPat pat2		`thenRn` \ (pat2', fvs2) ->
120
121
122

    getModeRn		`thenRn` \ mode ->
	-- See comments with rnExpr (OpApp ...)
123
124
125
126
    (if isInterfaceMode mode
	then returnRn (ConOpPatIn pat1' con' defaultFixity pat2')
	else lookupFixityRn con'	`thenRn` \ fixity ->
	     mkConOpPatRn pat1' con' fixity pat2'
127
    )								`thenRn` \ pat' ->
128
    returnRn (pat', fvs1 `plusFV` fvs2 `addOneFV` con')
129
130

rnPat (ParPatIn pat)
131
132
  = rnPat pat		`thenRn` \ (pat', fvs) ->
    returnRn (ParPatIn pat', fvs)
133
134

rnPat (ListPatIn pats)
135
136
  = mapFvRn rnPat pats			`thenRn` \ (patslist, fvs) ->
    returnRn (ListPatIn patslist, fvs `addOneFV` listTyCon_name)
137

chak's avatar
chak committed
138
139
140
141
142
143
144
rnPat (PArrPatIn pats)
  = mapFvRn rnPat pats			`thenRn` \ (patslist, fvs) ->
    returnRn (PArrPatIn patslist, 
	      fvs `plusFV` implicit_fvs `addOneFV` parrTyCon_name)
  where
    implicit_fvs = mkFVs [lengthPName, indexPName]

145
rnPat (TuplePatIn pats boxed)
146
147
148
149
  = mapFvRn rnPat pats					   `thenRn` \ (patslist, fvs) ->
    returnRn (TuplePatIn patslist boxed, fvs `addOneFV` tycon_name)
  where
    tycon_name = tupleTyCon_name boxed (length pats)
150
151

rnPat (RecPatIn con rpats)
152
  = lookupOccRn con 	`thenRn` \ con' ->
153
154
    rnRpats rpats	`thenRn` \ (rpats', fvs) ->
    returnRn (RecPatIn con' rpats', fvs `addOneFV` con')
155

156
rnPat (TypePatIn name) =
157
    rnHsTypeFVs (text "type pattern") name	`thenRn` \ (name', fvs) ->
158
    returnRn (TypePatIn name', fvs)
159
160
161
162
163
164
165
166
167
\end{code}

************************************************************************
*									*
\subsection{Match}
*									*
************************************************************************

\begin{code}
168
rnMatch :: HsMatchContext RdrName -> RdrNameMatch -> RnMS (RenamedMatch, FreeVars)
169

170
rnMatch ctxt match@(Match pats maybe_rhs_sig grhss)
171
  = pushSrcLocRn (getMatchLoc match)	$
172

173
	-- Bind pattern-bound type variables
174
    let
175
	rhs_sig_tys =  case maybe_rhs_sig of
176
				Nothing -> []
177
178
				Just ty -> [ty]
	pat_sig_tys = collectSigTysFromPats pats
179
180
	doc_sig     = text "In a result type-signature"
 	doc_pat     = pprMatchContext ctxt
181
    in
182
    bindPatSigTyVars (rhs_sig_tys ++ pat_sig_tys)	$ 
183
184
185
186

	-- Note that we do a single bindLocalsRn for all the
	-- matches together, so that we spot the repeated variable in
	--	f x x = 1
187
    bindLocalsFVRn doc_pat (collectPatsBinders pats)	$ \ new_binders ->
188

189
    mapFvRn rnPat pats			`thenRn` \ (pats', pat_fvs) ->
190
    rnGRHSs grhss			`thenRn` \ (grhss', grhss_fvs) ->
191
    doptRn Opt_GlasgowExts		`thenRn` \ opt_GlasgowExts ->
192
193
    (case maybe_rhs_sig of
	Nothing -> returnRn (Nothing, emptyFVs)
194
	Just ty | opt_GlasgowExts -> rnHsTypeFVs doc_sig ty	`thenRn` \ (ty', ty_fvs) ->
195
196
197
198
				     returnRn (Just ty', ty_fvs)
		| otherwise	  -> addErrRn (patSigErr ty)	`thenRn_`
				     returnRn (Nothing, emptyFVs)
    )					`thenRn` \ (maybe_rhs_sig', ty_fvs) ->
199

200
201
    let
	binder_set     = mkNameSet new_binders
202
	unused_binders = nameSetToList (binder_set `minusNameSet` grhss_fvs)
203
	all_fvs	       = grhss_fvs `plusFV` pat_fvs `plusFV` ty_fvs
204
    in
205
206
    warnUnusedMatches unused_binders		`thenRn_`
    
207
    returnRn (Match pats' maybe_rhs_sig' grhss', all_fvs)
208
	-- The bindLocals and bindTyVars will remove the bound FVs
209
210
\end{code}

211

212
213
%************************************************************************
%*									*
214
\subsubsection{Guarded right-hand sides (GRHSs)}
215
216
217
218
%*									*
%************************************************************************

\begin{code}
219
rnGRHSs :: RdrNameGRHSs -> RnMS (RenamedGRHSs, FreeVars)
220

221
222
rnGRHSs (GRHSs grhss binds _)
  = rnBinds binds		$ \ binds' ->
223
    mapFvRn rnGRHS grhss	`thenRn` \ (grhss', fvGRHSs) ->
224
    returnRn (GRHSs grhss' binds' placeHolderType, fvGRHSs)
225

226
rnGRHS (GRHS guarded locn)
227
  = doptRn Opt_GlasgowExts		`thenRn` \ opt_GlasgowExts ->
228
    pushSrcLocRn locn $		    
229
    (if not (opt_GlasgowExts || is_standard_guard guarded) then
230
		addWarnRn (nonStdGuardErr guarded)
231
     else
sof's avatar
sof committed
232
		returnRn ()
233
    )		`thenRn_`
234

235
    rnStmts guarded	`thenRn` \ ((_, guarded'), fvs) ->
236
237
    returnRn (GRHS guarded' locn, fvs)
  where
sof's avatar
sof committed
238
239
240
	-- Standard Haskell 1.4 guards are just a single boolean
	-- expression, rather than a list of qualifiers as in the
	-- Glasgow extension
241
242
243
    is_standard_guard [ResultStmt _ _]                 = True
    is_standard_guard [ExprStmt _ _ _, ResultStmt _ _] = True
    is_standard_guard other	      		       = False
244
245
246
247
248
249
250
251
252
\end{code}

%************************************************************************
%*									*
\subsubsection{Expressions}
%*									*
%************************************************************************

\begin{code}
253
rnExprs :: [RdrNameHsExpr] -> RnMS ([RenamedHsExpr], FreeVars)
sof's avatar
sof committed
254
255
256
257
258
259
260
261
262
rnExprs ls = rnExprs' ls emptyUniqSet
 where
  rnExprs' [] acc = returnRn ([], acc)
  rnExprs' (expr:exprs) acc
   = rnExpr expr 	        `thenRn` \ (expr', fvExpr) ->

	-- Now we do a "seq" on the free vars because typically it's small
	-- or empty, especially in very long lists of constants
    let
263
	acc' = acc `plusFV` fvExpr
sof's avatar
sof committed
264
265
    in
    (grubby_seqNameSet acc' rnExprs') exprs acc'	`thenRn` \ (exprs', fvExprs) ->
266
    returnRn (expr':exprs', fvExprs)
sof's avatar
sof committed
267
268
269
270

-- Grubby little function to do "seq" on namesets; replace by proper seq when GHC can do seq
grubby_seqNameSet ns result | isNullUFM ns = result
			    | otherwise    = result
271
272
\end{code}

273
Variables. We look up the variable and return the resulting name. 
274
275

\begin{code}
276
rnExpr :: RdrNameHsExpr -> RnMS (RenamedHsExpr, FreeVars)
277
278

rnExpr (HsVar v)
279
  = lookupOccRn v	`thenRn` \ name ->
280
    if name `hasKey` assertIdKey then
281
	-- We expand it to (GHCerr.assert__ location)
282
        mkAssertExpr
283
284
    else
        -- The normal case
285
       returnRn (HsVar name, unitFV name)
286

287
rnExpr (HsIPVar v)
288
  = newIPName v			`thenRn` \ name ->
289
290
    let 
	fvs = case name of
chak's avatar
chak committed
291
		Linear _  -> mkFVs [splitName, fstName, sndName]
292
293
294
		Dupable _ -> emptyFVs 
    in   
    returnRn (HsIPVar name, fvs)
295

296
rnExpr (HsLit lit) 
297
  = litFVs lit		`thenRn` \ fvs -> 
298
    returnRn (HsLit lit, fvs)
299

300
301
302
303
rnExpr (HsOverLit lit) 
  = rnOverLit lit		`thenRn` \ (lit', fvs) ->
    returnRn (HsOverLit lit', fvs)

304
rnExpr (HsLam match)
305
  = rnMatch LambdaExpr match	`thenRn` \ (match', fvMatch) ->
306
307
308
309
310
    returnRn (HsLam match', fvMatch)

rnExpr (HsApp fun arg)
  = rnExpr fun		`thenRn` \ (fun',fvFun) ->
    rnExpr arg		`thenRn` \ (arg',fvArg) ->
311
    returnRn (HsApp fun' arg', fvFun `plusFV` fvArg)
312

313
rnExpr (OpApp e1 op _ e2) 
314
315
  = rnExpr e1				`thenRn` \ (e1', fv_e1) ->
    rnExpr e2				`thenRn` \ (e2', fv_e2) ->
316
    rnExpr op				`thenRn` \ (op'@(HsVar op_name), fv_op) ->
317

sof's avatar
sof committed
318
319
320
321
	-- Deal with fixity
	-- When renaming code synthesised from "deriving" declarations
	-- we're in Interface mode, and we should ignore fixity; assume
	-- that the deriving code generator got the association correct
322
	-- Don't even look up the fixity when in interface mode
323
    getModeRn				`thenRn` \ mode -> 
324
325
326
327
    (if isInterfaceMode mode
	then returnRn (OpApp e1' op' defaultFixity e2')
	else lookupFixityRn op_name		`thenRn` \ fixity ->
	     mkOpAppRn e1' op' fixity e2'
328
329
330
    )					`thenRn` \ final_e -> 

    returnRn (final_e,
331
	      fv_e1 `plusFV` fv_op `plusFV` fv_e2)
332

333
rnExpr (NegApp e neg_name)
334
  = rnExpr e			`thenRn` \ (e', fv_e) ->
335
336
337
    lookupSyntaxName neg_name	`thenRn` \ neg_name' ->
    mkNegAppRn e' neg_name'	`thenRn` \ final_e ->
    returnRn (final_e, fv_e `addOneFV` neg_name')
338
339
340
341
342

rnExpr (HsPar e)
  = rnExpr e 		`thenRn` \ (e', fvs_e) ->
    returnRn (HsPar e', fvs_e)

343
344
345
rnExpr section@(SectionL expr op)
  = rnExpr expr	 				`thenRn` \ (expr', fvs_expr) ->
    rnExpr op	 				`thenRn` \ (op', fvs_op) ->
346
    checkSectionPrec InfixL section op' expr' `thenRn_`
347
    returnRn (SectionL expr' op', fvs_op `plusFV` fvs_expr)
348

349
350
351
rnExpr section@(SectionR op expr)
  = rnExpr op	 				`thenRn` \ (op',   fvs_op) ->
    rnExpr expr	 				`thenRn` \ (expr', fvs_expr) ->
352
    checkSectionPrec InfixR section op' expr'	`thenRn_`
353
    returnRn (SectionR op' expr', fvs_op `plusFV` fvs_expr)
354

355
rnExpr (HsCCall fun args may_gc is_casm _)
356
	-- Check out the comment on RnIfaces.getNonWiredDataDecl about ccalls
357
  = lookupOrigNames []	`thenRn` \ implicit_fvs ->
358
    rnExprs args				`thenRn` \ (args', fvs_args) ->
359
    returnRn (HsCCall fun args' may_gc is_casm placeHolderType, 
360
361
362
	      fvs_args `plusFV` mkFVs [cCallableClassName, 
				       cReturnableClassName, 
				       ioDataConName])
363

364
rnExpr (HsSCC lbl expr)
365
  = rnExpr expr	 	`thenRn` \ (expr', fvs_expr) ->
366
    returnRn (HsSCC lbl expr', fvs_expr)
367
368
369

rnExpr (HsCase expr ms src_loc)
  = pushSrcLocRn src_loc $
370
371
    rnExpr expr		 		`thenRn` \ (new_expr, e_fvs) ->
    mapFvRn (rnMatch CaseAlt) ms	`thenRn` \ (new_ms, ms_fvs) ->
372
    returnRn (HsCase new_expr new_ms src_loc, e_fvs `plusFV` ms_fvs)
373
374

rnExpr (HsLet binds expr)
375
376
377
  = rnBinds binds		$ \ binds' ->
    rnExpr expr			 `thenRn` \ (expr',fvExpr) ->
    returnRn (HsLet binds' expr', fvExpr)
378

379
380
381
382
383
rnExpr (HsWith expr binds)
  = rnExpr expr			`thenRn` \ (expr',fvExpr) ->
    rnIPBinds binds		`thenRn` \ (binds',fvBinds) ->
    returnRn (HsWith expr' binds', fvExpr `plusFV` fvBinds)

384
rnExpr e@(HsDo do_or_lc stmts src_loc)
385
  = pushSrcLocRn src_loc $
386
    rnStmts stmts			`thenRn` \ ((_, stmts'), fvs) ->
387
388
	-- check the statement list ends in an expression
    case last stmts' of {
389
390
	ResultStmt _ _ -> returnRn () ;
	_              -> addErrRn (doStmtListErr e)
391
    }					`thenRn_`
392
393
    returnRn (HsDo do_or_lc stmts' src_loc, fvs `plusFV` implicit_fvs)
  where
chak's avatar
chak committed
394
395
396
397
398
    implicit_fvs = case do_or_lc of
      PArrComp -> mkFVs [replicatePName, mapPName, filterPName,
			 falseDataConName, trueDataConName, crossPName,
			 zipPName]
      _        -> mkFVs [foldrName, buildName, monadClassName]
399
400
401
402
	-- Monad stuff should not be necessary for a list comprehension
	-- but the typechecker looks up the bind and return Ids anyway
	-- Oh well.

403
rnExpr (ExplicitList _ exps)
404
  = rnExprs exps		 	`thenRn` \ (exps', fvs) ->
405
    returnRn  (ExplicitList placeHolderType exps', fvs `addOneFV` listTyCon_name)
406

chak's avatar
chak committed
407
408
409
410
411
rnExpr (ExplicitPArr _ exps)
  = rnExprs exps		 	`thenRn` \ (exps', fvs) ->
    returnRn  (ExplicitPArr placeHolderType exps', 
	       fvs `addOneFV` toPName `addOneFV` parrTyCon_name)

412
rnExpr (ExplicitTuple exps boxity)
413
  = rnExprs exps	 			`thenRn` \ (exps', fvs) ->
414
    returnRn (ExplicitTuple exps' boxity, fvs `addOneFV` tycon_name)
415
  where
416
    tycon_name = tupleTyCon_name boxity (length exps)
417

418
rnExpr (RecordCon con_id rbinds)
419
  = lookupOccRn con_id 			`thenRn` \ conname ->
420
    rnRbinds "construction" rbinds	`thenRn` \ (rbinds', fvRbinds) ->
421
    returnRn (RecordCon conname rbinds', fvRbinds `addOneFV` conname)
422
423
424
425

rnExpr (RecordUpd expr rbinds)
  = rnExpr expr			`thenRn` \ (expr', fvExpr) ->
    rnRbinds "update" rbinds	`thenRn` \ (rbinds', fvRbinds) ->
426
    returnRn (RecordUpd expr' rbinds', fvExpr `plusFV` fvRbinds)
427
428

rnExpr (ExprWithTySig expr pty)
429
430
  = rnExpr expr			 			   `thenRn` \ (expr', fvExpr) ->
    rnHsTypeFVs (text "an expression type signature") pty  `thenRn` \ (pty', fvTy) ->
431
    returnRn (ExprWithTySig expr' pty', fvExpr `plusFV` fvTy)
432
433
434
435
436
437

rnExpr (HsIf p b1 b2 src_loc)
  = pushSrcLocRn src_loc $
    rnExpr p		`thenRn` \ (p', fvP) ->
    rnExpr b1		`thenRn` \ (b1', fvB1) ->
    rnExpr b2		`thenRn` \ (b2', fvB2) ->
438
    returnRn (HsIf p' b1' b2' src_loc, plusFVs [fvP, fvB1, fvB2])
439

440
441
442
443
444
rnExpr (HsType a)
  = rnHsTypeFVs doc a	`thenRn` \ (t, fvT) -> 
    returnRn (HsType t, fvT)
  where 
    doc = text "renaming a type pattern"
445

446
rnExpr (ArithSeqIn seq)
447
448
  = rn_seq seq	 			`thenRn` \ (new_seq, fvs) ->
    returnRn (ArithSeqIn new_seq, fvs `addOneFV` enumClassName)
449
450
451
452
453
454
455
456
  where
    rn_seq (From expr)
     = rnExpr expr 	`thenRn` \ (expr', fvExpr) ->
       returnRn (From expr', fvExpr)

    rn_seq (FromThen expr1 expr2)
     = rnExpr expr1 	`thenRn` \ (expr1', fvExpr1) ->
       rnExpr expr2	`thenRn` \ (expr2', fvExpr2) ->
457
       returnRn (FromThen expr1' expr2', fvExpr1 `plusFV` fvExpr2)
458
459
460
461

    rn_seq (FromTo expr1 expr2)
     = rnExpr expr1	`thenRn` \ (expr1', fvExpr1) ->
       rnExpr expr2	`thenRn` \ (expr2', fvExpr2) ->
462
       returnRn (FromTo expr1' expr2', fvExpr1 `plusFV` fvExpr2)
463
464
465
466
467
468

    rn_seq (FromThenTo expr1 expr2 expr3)
     = rnExpr expr1	`thenRn` \ (expr1', fvExpr1) ->
       rnExpr expr2	`thenRn` \ (expr2', fvExpr2) ->
       rnExpr expr3	`thenRn` \ (expr3', fvExpr3) ->
       returnRn (FromThenTo expr1' expr2' expr3',
469
		  plusFVs [fvExpr1, fvExpr2, fvExpr3])
chak's avatar
chak committed
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491

rnExpr (PArrSeqIn seq)
  = rn_seq seq	 		       `thenRn` \ (new_seq, fvs) ->
    returnRn (PArrSeqIn new_seq, 
	      fvs `plusFV` mkFVs [enumFromToPName, enumFromThenToPName])
  where

    -- the parser shouldn't generate these two
    --
    rn_seq (From     _  ) = panic "RnExpr.rnExpr: Infinite parallel array!"
    rn_seq (FromThen _ _) = panic "RnExpr.rnExpr: Infinite parallel array!"

    rn_seq (FromTo expr1 expr2)
     = rnExpr expr1	`thenRn` \ (expr1', fvExpr1) ->
       rnExpr expr2	`thenRn` \ (expr2', fvExpr2) ->
       returnRn (FromTo expr1' expr2', fvExpr1 `plusFV` fvExpr2)
    rn_seq (FromThenTo expr1 expr2 expr3)
     = rnExpr expr1	`thenRn` \ (expr1', fvExpr1) ->
       rnExpr expr2	`thenRn` \ (expr2', fvExpr2) ->
       rnExpr expr3	`thenRn` \ (expr3', fvExpr3) ->
       returnRn (FromThenTo expr1' expr2' expr3',
		  plusFVs [fvExpr1, fvExpr2, fvExpr3])
492
\end{code}
493

494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
These three are pattern syntax appearing in expressions.
Since all the symbols are reservedops we can simply reject them.
We return a (bogus) EWildPat in each case.

\begin{code}
rnExpr e@EWildPat = addErrRn (patSynErr e)	`thenRn_`
		    returnRn (EWildPat, emptyFVs)

rnExpr e@(EAsPat _ _) = addErrRn (patSynErr e)	`thenRn_`
		        returnRn (EWildPat, emptyFVs)

rnExpr e@(ELazyPat _) = addErrRn (patSynErr e)	`thenRn_`
		        returnRn (EWildPat, emptyFVs)
\end{code}

509
510


511
512
513
514
515
516
517
518
%************************************************************************
%*									*
\subsubsection{@Rbinds@s and @Rpats@s: in record expressions}
%*									*
%************************************************************************

\begin{code}
rnRbinds str rbinds 
sof's avatar
sof committed
519
  = mapRn_ field_dup_err dup_fields	`thenRn_`
520
521
    mapFvRn rn_rbind rbinds		`thenRn` \ (rbinds', fvRbind) ->
    returnRn (rbinds', fvRbind)
522
  where
523
    (_, dup_fields) = removeDups compare [ f | (f,_,_) <- rbinds ]
524

525
    field_dup_err dups = addErrRn (dupFieldErr str dups)
526
527

    rn_rbind (field, expr, pun)
528
      = lookupGlobalOccRn field	`thenRn` \ fieldname ->
529
	rnExpr expr		`thenRn` \ (expr', fvExpr) ->
530
	returnRn ((fieldname, expr', pun), fvExpr `addOneFV` fieldname)
531
532

rnRpats rpats
sof's avatar
sof committed
533
  = mapRn_ field_dup_err dup_fields 	`thenRn_`
534
535
    mapFvRn rn_rpat rpats		`thenRn` \ (rpats', fvs) ->
    returnRn (rpats', fvs)
536
  where
537
    (_, dup_fields) = removeDups compare [ f | (f,_,_) <- rpats ]
538

539
    field_dup_err dups = addErrRn (dupFieldErr "pattern" dups)
540
541

    rn_rpat (field, pat, pun)
542
      = lookupGlobalOccRn field	`thenRn` \ fieldname ->
543
	rnPat pat		`thenRn` \ (pat', fvs) ->
544
	returnRn ((fieldname, pat', pun), fvs `addOneFV` fieldname)
545
546
\end{code}

547
548
549
550
551
552
553
554
555
%************************************************************************
%*									*
\subsubsection{@rnIPBinds@s: in implicit parameter bindings}		*
%*									*
%************************************************************************

\begin{code}
rnIPBinds [] = returnRn ([], emptyFVs)
rnIPBinds ((n, expr) : binds)
556
  = newIPName n			`thenRn` \ name ->
557
558
559
560
561
562
    rnExpr expr			`thenRn` \ (expr',fvExpr) ->
    rnIPBinds binds		`thenRn` \ (binds',fvBinds) ->
    returnRn ((name, expr') : binds', fvExpr `plusFV` fvBinds)

\end{code}

563
564
%************************************************************************
%*									*
565
\subsubsection{@Stmt@s: in @do@ expressions}
566
567
568
569
570
571
572
573
574
575
576
577
%*									*
%************************************************************************

Note that although some bound vars may appear in the free var set for
the first qual, these will eventually be removed by the caller. For
example, if we have @[p | r <- s, q <- r, p <- q]@, when doing
@[q <- r, p <- q]@, the free var set for @q <- r@ will
be @{r}@, and the free var set for the entire Quals will be @{r}@. This
@r@ will be removed only when we finally return from examining all the
Quals.

\begin{code}
578
rnStmts :: [RdrNameStmt]
579
	-> RnMS (([Name], [RenamedStmt]), FreeVars)
580

581
rnStmts []
582
  = returnRn (([], []), emptyFVs)
583

584
rnStmts (stmt:stmts)
585
  = getLocalNameEnv 		`thenRn` \ name_env ->
586
587
    rnStmt stmt				$ \ stmt' ->
    rnStmts stmts			`thenRn` \ ((binders, stmts'), fvs) ->
588
    returnRn ((binders, stmt' : stmts'), fvs)
589

590
rnStmt :: RdrNameStmt
591
592
       -> (RenamedStmt -> RnMS (([Name], a), FreeVars))
       -> RnMS (([Name], a), FreeVars)
593
594
595
-- The thing list of names returned is the list returned by the
-- thing_inside, plus the binders of the arguments stmt

sof's avatar
sof committed
596
-- Because of mutual recursion we have to pass in rnExpr.
597

598
599
rnStmt (ParStmt stmtss) thing_inside
  = mapFvRn rnStmts stmtss		`thenRn` \ (bndrstmtss, fv_stmtss) ->
600
    let binderss = map fst bndrstmtss
601
602
603
604
605
606
	checkBndrs all_bndrs bndrs
	  = checkRn (null (intersectBy eqOcc all_bndrs bndrs)) err `thenRn_`
	    returnRn (bndrs ++ all_bndrs)
	eqOcc n1 n2 = nameOccName n1 == nameOccName n2
	err = text "duplicate binding in parallel list comprehension"
    in
607
608
    foldlRn checkBndrs [] binderss	`thenRn` \ new_binders ->
    bindLocalNamesFV new_binders	$
609
    thing_inside (ParStmtOut bndrstmtss)`thenRn` \ ((rest_bndrs, result), fv_rest) ->
610
    returnRn ((new_binders ++ rest_bndrs, result), fv_stmtss `plusFV` fv_rest)
611

612
rnStmt (BindStmt pat expr src_loc) thing_inside
613
  = pushSrcLocRn src_loc $
614
    rnExpr expr					`thenRn` \ (expr', fv_expr) ->
615
    bindPatSigTyVars (collectSigTysFromPat pat)	$ 
616
    bindLocalsFVRn doc (collectPatBinders pat)	$ \ new_binders ->
617
618
    rnPat pat					`thenRn` \ (pat', fv_pat) ->
    thing_inside (BindStmt pat' expr' src_loc)	`thenRn` \ ((rest_binders, result), fvs) ->
619
    returnRn ((new_binders ++ rest_binders, result),
620
	      fv_expr `plusFV` fvs `plusFV` fv_pat)
621
  where
622
    doc = text "In a pattern in 'do' binding" 
623

624
rnStmt (ExprStmt expr _ src_loc) thing_inside
625
  = pushSrcLocRn src_loc $
626
627
    rnExpr expr 						`thenRn` \ (expr', fv_expr) ->
    thing_inside (ExprStmt expr' placeHolderType src_loc)	`thenRn` \ (result, fvs) ->
628
    returnRn (result, fv_expr `plusFV` fvs)
629

630
631
632
633
634
635
rnStmt (ResultStmt expr src_loc) thing_inside
  = pushSrcLocRn src_loc $
    rnExpr expr 				`thenRn` \ (expr', fv_expr) ->
    thing_inside (ResultStmt expr' src_loc)	`thenRn` \ (result, fvs) ->
    returnRn (result, fv_expr `plusFV` fvs)

636
rnStmt (LetStmt binds) thing_inside
637
  = rnBinds binds				$ \ binds' ->
638
639
640
    let new_binders = collectHsBinders binds' in
    thing_inside (LetStmt binds')    `thenRn` \ ((rest_binders, result), fvs) ->
    returnRn ((new_binders ++ rest_binders, result), fvs )
641
642
643
644
645
646
647
648
\end{code}

%************************************************************************
%*									*
\subsubsection{Precedence Parsing}
%*									*
%************************************************************************

649
650
651
652
653
654
655
@mkOpAppRn@ deals with operator fixities.  The argument expressions
are assumed to be already correctly arranged.  It needs the fixities
recorded in the OpApp nodes, because fixity info applies to the things
the programmer actually wrote, so you can't find it out from the Name.

Furthermore, the second argument is guaranteed not to be another
operator application.  Why? Because the parser parses all
656
657
operator appications left-associatively, EXCEPT negation, which
we need to handle specially.
658

659
\begin{code}
660
661
662
663
mkOpAppRn :: RenamedHsExpr			-- Left operand; already rearranged
	  -> RenamedHsExpr -> Fixity 		-- Operator and fixity
	  -> RenamedHsExpr			-- Right operand (not an OpApp, but might
						-- be a NegApp)
664
	  -> RnMS RenamedHsExpr
665

666
667
668
---------------------------
-- (e11 `op1` e12) `op2` e2
mkOpAppRn e1@(OpApp e11 op1 fix1 e12) op2 fix2 e2
669
  | nofix_error
670
  = addErrRn (precParseErr (ppr_op op1,fix1) (ppr_op op2,fix2))	`thenRn_`
671
672
    returnRn (OpApp e1 op2 fix2 e2)

673
  | associate_right
674
675
  = mkOpAppRn e12 op2 fix2 e2		`thenRn` \ new_e ->
    returnRn (OpApp e11 op1 fix1 new_e)
676
  where
677
    (nofix_error, associate_right) = compareFixity fix1 fix2
678

679
680
---------------------------
--	(- neg_arg) `op` e2
681
mkOpAppRn e1@(NegApp neg_arg neg_name) op2 fix2 e2
sof's avatar
sof committed
682
  | nofix_error
683
  = addErrRn (precParseErr (pp_prefix_minus,negateFixity) (ppr_op op2,fix2))	`thenRn_`
sof's avatar
sof committed
684
685
    returnRn (OpApp e1 op2 fix2 e2)

686
  | associate_right
687
  = mkOpAppRn neg_arg op2 fix2 e2	`thenRn` \ new_e ->
688
    returnRn (NegApp new_e neg_name)
sof's avatar
sof committed
689
  where
690
691
692
693
    (nofix_error, associate_right) = compareFixity negateFixity fix2

---------------------------
--	e1 `op` - neg_arg
694
695
mkOpAppRn e1 op1 fix1 e2@(NegApp neg_arg _)	-- NegApp can occur on the right
  | not associate_right				-- We *want* right association
696
  = addErrRn (precParseErr (ppr_op op1, fix1) (pp_prefix_minus, negateFixity))	`thenRn_`
697
698
    returnRn (OpApp e1 op1 fix1 e2)
  where
699
    (_, associate_right) = compareFixity fix1 negateFixity
700

701
702
---------------------------
--	Default case
703
mkOpAppRn e1 op fix e2 			-- Default case, no rearrangment
704
705
  = ASSERT2( right_op_ok fix e2,
	     ppr e1 $$ text "---" $$ ppr op $$ text "---" $$ ppr fix $$ text "---" $$ ppr e2
706
    )
707
708
709
710
711
712
713
714
715
716
717
    returnRn (OpApp e1 op fix e2)

-- Parser left-associates everything, but 
-- derived instances may have correctly-associated things to
-- in the right operarand.  So we just check that the right operand is OK
right_op_ok fix1 (OpApp _ _ fix2 _)
  = not error_please && associate_right
  where
    (error_please, associate_right) = compareFixity fix1 fix2
right_op_ok fix1 other
  = True
718

719
-- Parser initially makes negation bind more tightly than any other operator
720
mkNegAppRn neg_arg neg_name
sof's avatar
sof committed
721
722
723
724
725
  = 
#ifdef DEBUG
    getModeRn			`thenRn` \ mode ->
    ASSERT( not_op_app mode neg_arg )
#endif
726
    returnRn (NegApp neg_arg neg_name)
727

728
729
not_op_app SourceMode (OpApp _ _ _ _) = False
not_op_app mode other	 	      = True
730
\end{code}
731

732
\begin{code}
733
mkConOpPatRn :: RenamedPat -> Name -> Fixity -> RenamedPat
734
	     -> RnMS RenamedPat
735

736
737
738
mkConOpPatRn p1@(ConOpPatIn p11 op1 fix1 p12) 
	     op2 fix2 p2
  | nofix_error
739
  = addErrRn (precParseErr (ppr_op op1,fix1) (ppr_op op2,fix2))	`thenRn_`
740
    returnRn (ConOpPatIn p1 op2 fix2 p2)
741

742
  | associate_right
743
744
  = mkConOpPatRn p12 op2 fix2 p2		`thenRn` \ new_p ->
    returnRn (ConOpPatIn p11 op1 fix1 new_p)
745

746
  where
747
    (nofix_error, associate_right) = compareFixity fix1 fix2
748
749
750
751
752
753
754

mkConOpPatRn p1 op fix p2 			-- Default case, no rearrangment
  = ASSERT( not_op_pat p2 )
    returnRn (ConOpPatIn p1 op fix p2)

not_op_pat (ConOpPatIn _ _ _ _) = False
not_op_pat other   	        = True
755
756
\end{code}

757
\begin{code}
758
checkPrecMatch :: Bool -> Name -> RenamedMatch -> RnMS ()
759

760
checkPrecMatch False fn match
761
  = returnRn ()
762

763
checkPrecMatch True op (Match (p1:p2:_) _ _)
764
	-- True indicates an infix lhs
765
766
  = getModeRn 		`thenRn` \ mode ->
	-- See comments with rnExpr (OpApp ...)
767
768
769
770
    if isInterfaceMode mode
	then returnRn ()
	else checkPrec op p1 False	`thenRn_`
	     checkPrec op p2 True
771

772
checkPrecMatch True op _ = panic "checkPrecMatch"
773

774
checkPrec op (ConOpPatIn _ op1 _ _) right
775
776
  = lookupFixityRn op	`thenRn` \  op_fix@(Fixity op_prec  op_dir) ->
    lookupFixityRn op1	`thenRn` \ op1_fix@(Fixity op1_prec op1_dir) ->
777
778
    let
	inf_ok = op1_prec > op_prec || 
779
	         (op1_prec == op_prec &&
780
781
		  (op1_dir == InfixR && op_dir == InfixR && right ||
		   op1_dir == InfixL && op_dir == InfixL && not right))
782

783
784
	info  = (ppr_op op,  op_fix)
	info1 = (ppr_op op1, op1_fix)
785
786
	(infol, infor) = if right then (info, info1) else (info1, info)
    in
787
    checkRn inf_ok (precParseErr infol infor)
788
789
790

checkPrec op pat right
  = returnRn ()
791
792

-- Check precedence of (arg op) or (op arg) respectively
793
794
795
796
-- If arg is itself an operator application, then either
--   (a) its precedence must be higher than that of op
--   (b) its precedency & associativity must be the same as that of op
checkSectionPrec direction section op arg
797
798
  = case arg of
	OpApp _ op fix _ -> go_for_it (ppr_op op)     fix
799
	NegApp _ _	 -> go_for_it pp_prefix_minus negateFixity
800
801
802
	other		 -> returnRn ()
  where
    HsVar op_name = op
803
    go_for_it pp_arg_op arg_fix@(Fixity arg_prec assoc)
804
	= lookupFixityRn op_name	`thenRn` \ op_fix@(Fixity op_prec _) ->
805
806
807
808
	  checkRn (op_prec < arg_prec
		     || op_prec == arg_prec && direction == assoc)
		  (sectionPrecErr (ppr_op op_name, op_fix) 	
		  (pp_arg_op, arg_fix) section)
809
810
\end{code}

811
Consider
812
\begin{verbatim}
813
	a `op1` b `op2` c
814
815
\end{verbatim}
@(compareFixity op1 op2)@ tells which way to arrange appication, or
816
817
818
819
820
821
822
whether there's an error.

\begin{code}
compareFixity :: Fixity -> Fixity
	      -> (Bool,		-- Error please
		  Bool)		-- Associate to the right: a op1 (b op2 c)
compareFixity (Fixity prec1 dir1) (Fixity prec2 dir2)
823
824
825
826
  = case prec1 `compare` prec2 of
	GT -> left
	LT -> right
	EQ -> case (dir1, dir2) of
827
828
829
830
831
832
833
834
835
			(InfixR, InfixR) -> right
			(InfixL, InfixL) -> left
			_		 -> error_please
  where
    right	 = (False, True)
    left         = (False, False)
    error_please = (True,  False)
\end{code}

836
837
838
839
840
841
%************************************************************************
%*									*
\subsubsection{Literals}
%*									*
%************************************************************************

842
843
When literals occur we have to make sure
that the types and classes they involve
844
845
846
are made available.

\begin{code}
847
848
849
850
litFVs (HsChar c)
   = checkRn (inCharRange c) (bogusCharError c) `thenRn_`
     returnRn (unitFV charTyCon_name)

851
852
853
854
855
856
857
litFVs (HsCharPrim c)         = returnRn (unitFV (getName charPrimTyCon))
litFVs (HsString s)           = returnRn (mkFVs [listTyCon_name, charTyCon_name])
litFVs (HsStringPrim s)       = returnRn (unitFV (getName addrPrimTyCon))
litFVs (HsInt i)	      = returnRn (unitFV (getName intTyCon))
litFVs (HsIntPrim i)          = returnRn (unitFV (getName intPrimTyCon))
litFVs (HsFloatPrim f)        = returnRn (unitFV (getName floatPrimTyCon))
litFVs (HsDoublePrim d)       = returnRn (unitFV (getName doublePrimTyCon))
858
litFVs (HsLitLit l bogus_ty)  = returnRn (unitFV cCallableClassName)
859
860
861
litFVs lit		      = pprPanic "RnExpr.litFVs" (ppr lit)	-- HsInteger and HsRat only appear 
									-- in post-typechecker translations

862
863
864
865
rnOverLit (HsIntegral i from_integer_name)
  = lookupSyntaxName from_integer_name	`thenRn` \ from_integer_name' ->
    if inIntRange i then
	returnRn (HsIntegral i from_integer_name', unitFV from_integer_name')
866
867
    else let
	fvs = mkFVs [plusIntegerName, timesIntegerName]
868
869
870
871
872
	-- Big integer literals are built, using + and *, 
	-- out of small integers (DsUtils.mkIntegerLit)
	-- [NB: plusInteger, timesInteger aren't rebindable... 
	--	they are used to construct the argument to fromInteger, 
	--	which is the rebindable one.]
873
874
    in
    returnRn (HsIntegral i from_integer_name', fvs `addOneFV` from_integer_name')
875
876
877

rnOverLit (HsFractional i from_rat_name)
  = lookupSyntaxName from_rat_name						`thenRn` \ from_rat_name' ->
878
879
    let
	fvs = mkFVs [ratioDataConName, plusIntegerName, timesIntegerName]
sof's avatar
sof committed
880
881
	-- We have to make sure that the Ratio type is imported with
	-- its constructor, because literals of type Ratio t are
882
883
884
	-- built with that constructor.
	-- The Rational type is needed too, but that will come in
	-- when fractionalClass does.
885
886
	-- The plus/times integer operations may be needed to construct the numerator
	-- and denominator (see DsUtils.mkIntegerLit)
887
888
    in
    returnRn (HsFractional i from_rat_name', fvs `addOneFV` from_rat_name')
889
890
\end{code}

sof's avatar
sof committed
891
892
893
894
895
896
897
%************************************************************************
%*									*
\subsubsection{Assertion utils}
%*									*
%************************************************************************

\begin{code}
898
mkAssertExpr :: RnMS (RenamedHsExpr, FreeVars)
sof's avatar
sof committed
899
mkAssertExpr =
900
901
  lookupOrigName assertErr_RDR		`thenRn` \ name ->
  getSrcLocRn    			`thenRn` \ sloc ->
sof's avatar
sof committed
902
903
904
905
906
907
908
909
910
911

    -- if we're ignoring asserts, return (\ _ e -> e)
    -- if not, return (assertError "src-loc")

  if opt_IgnoreAsserts then
    getUniqRn				`thenRn` \ uniq ->
    let
     vname = mkSysLocalName uniq SLIT("v")
     expr  = HsLam ignorePredMatch
     loc   = nameSrcLoc vname
912
     ignorePredMatch = mkSimpleMatch [WildPatIn, VarPatIn vname] (HsVar vname) placeHolderType loc
sof's avatar
sof committed
913
    in
914
    returnRn (expr, unitFV name)
sof's avatar
sof committed
915
916
917
918
  else
    let
     expr = 
          HsApp (HsVar name)
sof's avatar
sof committed
919
	        (HsLit (HsString (_PK_ (showSDoc (ppr sloc)))))
sof's avatar
sof committed
920
921

    in
922
    returnRn (expr, unitFV name)
sof's avatar
sof committed
923

sof's avatar
sof committed
924
\end{code}
925
926
927
928
929
930
931

%************************************************************************
%*									*
\subsubsection{Errors}
%*									*
%************************************************************************

932
\begin{code}
933
934
935
936
ppr_op op = quotes (ppr op)	-- Here, op can be a Name or a (Var n), where n is a Name
ppr_opfix (pp_op, fixity) = pp_op <+> brackets (ppr fixity)
pp_prefix_minus = ptext SLIT("prefix `-'")

937
938
939
940
dupFieldErr str (dup:rest)
  = hsep [ptext SLIT("duplicate field name"), 
          quotes (ppr dup),
	  ptext SLIT("in record"), text str]
941

942
precParseErr op1 op2 
sof's avatar
sof committed
943
  = hang (ptext SLIT("precedence parsing error"))
944
945
      4 (hsep [ptext SLIT("cannot mix"), ppr_opfix op1, ptext SLIT("and"), 
	       ppr_opfix op2,
946
	       ptext SLIT("in the same infix expression")])
sof's avatar
sof committed
947

948
949
950
sectionPrecErr op arg_op section
 = vcat [ptext SLIT("The operator") <+> ppr_opfix op <+> ptext SLIT("of a section"),
	 nest 4 (ptext SLIT("must have lower precedence than the operand") <+> ppr_opfix arg_op),
rrt's avatar
rrt committed
951
	 nest 4 (ptext SLIT("in the section:") <+> quotes (ppr section))]
952

953
nonStdGuardErr guard
954
955
956
  = hang (ptext
    SLIT("accepting non-standard pattern guards (-fglasgow-exts to suppress this message)")
    ) 4 (ppr guard)
957

958
patSigErr ty
959
960
  =  (ptext SLIT("Illegal signature in pattern:") <+> ppr ty)
	$$ nest 4 (ptext SLIT("Use -fglasgow-exts to permit it"))
961

962
963
964
patSynErr e 
  = sep [ptext SLIT("Pattern syntax in expression context:"),
	 nest 4 (ppr e)]
965
966
967
968

doStmtListErr e
  = sep [ptext SLIT("`do' statements must end in expression:"),
	 nest 4 (ppr e)]
969
970
971

bogusCharError c
  = ptext SLIT("character literal out of range: '\\") <> int c <> char '\''
972
\end{code}