RnExpr.lhs 31.3 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
import {-# SOURCE #-} RnSource ( rnHsTypeFVs )
22
23
24
25
26

import HsSyn
import RdrHsSyn
import RnHsSyn
import RnMonad
27
import RnEnv
28
import RnHiFiles	( lookupFixityRn )
29
import CmdLineOpts	( DynFlag(..), opt_IgnoreAsserts )
30
import Literal		( inIntRange, inCharRange )
31
import BasicTypes	( Fixity(..), FixityDirection(..), defaultFixity, negateFixity )
32
import PrelNames	( hasKey, assertIdKey, minusName, negateName, fromIntegerName,
33
			  eqClass_RDR, foldr_RDR, build_RDR, eqString_RDR,
34
			  cCallableClass_RDR, cReturnableClass_RDR, 
sof's avatar
sof committed
35
			  monadClass_RDR, enumClass_RDR, ordClass_RDR,
36
37
38
			  ratioDataCon_RDR, assertErr_RDR,
			  ioDataCon_RDR, plusInteger_RDR, timesInteger_RDR,
			  fromInteger_RDR, fromRational_RDR,
39
40
41
42
			)
import TysPrim		( charPrimTyCon, addrPrimTyCon, intPrimTyCon, 
			  floatPrimTyCon, doublePrimTyCon
			)
43
import TysWiredIn	( intTyCon )
44
import Name		( NamedThing(..), mkSysLocalName, nameSrcLoc )
45
import NameSet
46
import UniqFM		( isNullUFM )
47
import FiniteMap	( elemFM )
48
import UniqSet		( emptyUniqSet )
49
import List		( intersectBy )
50
import ListSetOps	( unionLists, removeDups )
51
import Maybes		( maybeToBool )
sof's avatar
sof committed
52
import Outputable
53
54
55
56
57
58
59
60
61
62
\end{code}


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

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

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

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

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

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

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

rnPat (NPatIn lit) 
  = rnOverLit lit			`thenRn` \ (lit', fvs1) ->
    lookupOrigName eqClass_RDR		`thenRn` \ eq   ->	-- Needed to find equality on pattern
    returnRn (NPatIn lit', fvs1 `addOneFV` eq)

97
rnPat (NPlusKPatIn name lit)
98
99
100
  = rnOverLit lit			`thenRn` \ (lit', fvs) ->
    lookupOrigName ordClass_RDR		`thenRn` \ ord ->
    lookupBndrRn name			`thenRn` \ name' ->
101
    returnRn (NPlusKPatIn name' lit', fvs `addOneFV` ord `addOneFV` minusName)
102
103

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

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

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

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

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

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

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

139
rnPat (TuplePatIn pats boxed)
140
141
142
143
  = mapFvRn rnPat pats					   `thenRn` \ (patslist, fvs) ->
    returnRn (TuplePatIn patslist boxed, fvs `addOneFV` tycon_name)
  where
    tycon_name = tupleTyCon_name boxed (length pats)
144
145

rnPat (RecPatIn con rpats)
146
  = lookupOccRn con 	`thenRn` \ con' ->
147
148
    rnRpats rpats	`thenRn` \ (rpats', fvs) ->
    returnRn (RecPatIn con' rpats', fvs `addOneFV` con')
149

150
rnPat (TypePatIn name) =
151
    rnHsTypeFVs (text "type pattern") name	`thenRn` \ (name', fvs) ->
152
    returnRn (TypePatIn name', fvs)
153
154
155
156
157
158
159
160
161
\end{code}

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

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

164
rnMatch ctxt match@(Match _ pats maybe_rhs_sig grhss)
165
  = pushSrcLocRn (getMatchLoc match)	$
166

167
	-- Bind pattern-bound type variables
168
    let
169
	rhs_sig_tys =  case maybe_rhs_sig of
170
				Nothing -> []
171
172
				Just ty -> [ty]
	pat_sig_tys = collectSigTysFromPats pats
173
174
	doc_sig     = text "In a result type-signature"
 	doc_pat     = pprMatchContext ctxt
175
    in
176
    bindPatSigTyVars (rhs_sig_tys ++ pat_sig_tys)	$ \ sig_tyvars ->
177
178
179
180

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

183
    mapFvRn rnPat pats			`thenRn` \ (pats', pat_fvs) ->
184
    rnGRHSs grhss			`thenRn` \ (grhss', grhss_fvs) ->
185
    doptRn Opt_GlasgowExts		`thenRn` \ opt_GlasgowExts ->
186
187
    (case maybe_rhs_sig of
	Nothing -> returnRn (Nothing, emptyFVs)
188
	Just ty | opt_GlasgowExts -> rnHsTypeFVs doc_sig ty	`thenRn` \ (ty', ty_fvs) ->
189
190
191
192
				     returnRn (Just ty', ty_fvs)
		| otherwise	  -> addErrRn (patSigErr ty)	`thenRn_`
				     returnRn (Nothing, emptyFVs)
    )					`thenRn` \ (maybe_rhs_sig', ty_fvs) ->
193

194
195
    let
	binder_set     = mkNameSet new_binders
196
	unused_binders = nameSetToList (binder_set `minusNameSet` grhss_fvs)
197
	all_fvs	       = grhss_fvs `plusFV` pat_fvs `plusFV` ty_fvs
198
    in
199
200
    warnUnusedMatches unused_binders		`thenRn_`
    
201
202
    returnRn (Match sig_tyvars pats' maybe_rhs_sig' grhss', all_fvs)
	-- The bindLocals and bindTyVars will remove the bound FVs
203
204
205
206
207
208
209
210
211
212
213
214


bindPatSigTyVars :: [RdrNameHsType]
		 -> ([Name] -> RnMS (a, FreeVars))
	  	 -> RnMS (a, FreeVars)
  -- Find the type variables in the pattern type 
  -- signatures that must be brought into scope
bindPatSigTyVars tys thing_inside
  = getLocalNameEnv			`thenRn` \ name_env ->
    let
	tyvars_in_sigs = extractHsTysRdrTyVars tys
	forall_tyvars  = filter (not . (`elemFM` name_env)) tyvars_in_sigs
215
	doc_sig        = text "In a pattern type-signature"
216
217
    in
    bindNakedTyVarsFVRn doc_sig forall_tyvars thing_inside
218
219
220
221
\end{code}

%************************************************************************
%*									*
222
\subsubsection{Guarded right-hand sides (GRHSs)}
223
224
225
226
%*									*
%************************************************************************

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

229
230
231
rnGRHSs (GRHSs grhss binds maybe_ty)
  = ASSERT( not (maybeToBool maybe_ty) )
    rnBinds binds		$ \ binds' ->
232
233
    mapFvRn rnGRHS grhss	`thenRn` \ (grhss', fvGRHSs) ->
    returnRn (GRHSs grhss' binds' Nothing, fvGRHSs)
234

235
rnGRHS (GRHS guarded locn)
236
  = doptRn Opt_GlasgowExts		`thenRn` \ opt_GlasgowExts ->
237
    pushSrcLocRn locn $		    
238
    (if not (opt_GlasgowExts || is_standard_guard guarded) then
239
		addWarnRn (nonStdGuardErr guarded)
240
     else
sof's avatar
sof committed
241
		returnRn ()
242
    )		`thenRn_`
243

244
    rnStmts guarded	`thenRn` \ ((_, guarded'), fvs) ->
245
246
    returnRn (GRHS guarded' locn, fvs)
  where
sof's avatar
sof committed
247
248
249
	-- Standard Haskell 1.4 guards are just a single boolean
	-- expression, rather than a list of qualifiers as in the
	-- Glasgow extension
250
251
252
    is_standard_guard [ResultStmt _ _]               = True
    is_standard_guard [ExprStmt _ _, ResultStmt _ _] = True
    is_standard_guard other	      		     = False
253
254
255
256
257
258
259
260
261
\end{code}

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

\begin{code}
262
rnExprs :: [RdrNameHsExpr] -> RnMS ([RenamedHsExpr], FreeVars)
sof's avatar
sof committed
263
264
265
266
267
268
269
270
271
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
272
	acc' = acc `plusFV` fvExpr
sof's avatar
sof committed
273
274
    in
    (grubby_seqNameSet acc' rnExprs') exprs acc'	`thenRn` \ (exprs', fvExprs) ->
275
    returnRn (expr':exprs', fvExprs)
sof's avatar
sof committed
276
277
278
279

-- 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
280
281
\end{code}

282
Variables. We look up the variable and return the resulting name. 
283
284

\begin{code}
285
rnExpr :: RdrNameHsExpr -> RnMS (RenamedHsExpr, FreeVars)
286
287

rnExpr (HsVar v)
288
  = lookupOccRn v	`thenRn` \ name ->
289
    if name `hasKey` assertIdKey then
290
	-- We expand it to (GHCerr.assert__ location)
291
        mkAssertExpr
292
293
    else
        -- The normal case
294
       returnRn (HsVar name, unitFV name)
295

296
rnExpr (HsIPVar v)
297
  = newIPName v			`thenRn` \ name ->
298
299
    returnRn (HsIPVar name, emptyFVs)

300
rnExpr (HsLit lit) 
301
  = litFVs lit		`thenRn` \ fvs -> 
302
    returnRn (HsLit lit, fvs)
303

304
305
306
307
rnExpr (HsOverLit lit) 
  = rnOverLit lit		`thenRn` \ (lit', fvs) ->
    returnRn (HsOverLit lit', fvs)

308
rnExpr (HsLam match)
309
  = rnMatch LambdaExpr match	`thenRn` \ (match', fvMatch) ->
310
311
312
313
314
    returnRn (HsLam match', fvMatch)

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

317
rnExpr (OpApp e1 op _ e2) 
318
319
  = rnExpr e1				`thenRn` \ (e1', fv_e1) ->
    rnExpr e2				`thenRn` \ (e2', fv_e2) ->
320
    rnExpr op				`thenRn` \ (op'@(HsVar op_name), fv_op) ->
321

sof's avatar
sof committed
322
323
324
325
	-- 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
326
	-- Don't even look up the fixity when in interface mode
327
    getModeRn				`thenRn` \ mode -> 
328
329
330
331
    (if isInterfaceMode mode
	then returnRn (OpApp e1' op' defaultFixity e2')
	else lookupFixityRn op_name		`thenRn` \ fixity ->
	     mkOpAppRn e1' op' fixity e2'
332
333
334
    )					`thenRn` \ final_e -> 

    returnRn (final_e,
335
	      fv_e1 `plusFV` fv_op `plusFV` fv_e2)
336

337
rnExpr (NegApp e)
338
  = rnExpr e			`thenRn` \ (e', fv_e) ->
339
340
    mkNegAppRn e'		`thenRn` \ final_e ->
    returnRn (final_e, fv_e `addOneFV` negateName)
341
342
343
344
345

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

346
347
348
349
rnExpr section@(SectionL expr op)
  = rnExpr expr	 				`thenRn` \ (expr', fvs_expr) ->
    rnExpr op	 				`thenRn` \ (op', fvs_op) ->
    checkSectionPrec "left" section op' expr'	`thenRn_`
350
    returnRn (SectionL expr' op', fvs_op `plusFV` fvs_expr)
351

352
353
354
355
rnExpr section@(SectionR op expr)
  = rnExpr op	 				`thenRn` \ (op',   fvs_op) ->
    rnExpr expr	 				`thenRn` \ (expr', fvs_expr) ->
    checkSectionPrec "right" section op' expr'	`thenRn_`
356
    returnRn (SectionR op' expr', fvs_op `plusFV` fvs_expr)
357

358
rnExpr (HsCCall fun args may_gc is_casm fake_result_ty)
359
	-- Check out the comment on RnIfaces.getNonWiredDataDecl about ccalls
360
361
  = lookupOrigNames [cCallableClass_RDR, 
			  cReturnableClass_RDR, 
362
			  ioDataCon_RDR]	`thenRn` \ implicit_fvs ->
363
    rnExprs args				`thenRn` \ (args', fvs_args) ->
364
    returnRn (HsCCall fun args' may_gc is_casm fake_result_ty, 
365
	      fvs_args `plusFV` implicit_fvs)
366

367
rnExpr (HsSCC lbl expr)
368
  = rnExpr expr	 	`thenRn` \ (expr', fvs_expr) ->
369
    returnRn (HsSCC lbl expr', fvs_expr)
370
371
372

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

rnExpr (HsLet binds expr)
378
379
380
  = rnBinds binds		$ \ binds' ->
    rnExpr expr			 `thenRn` \ (expr',fvExpr) ->
    returnRn (HsLet binds' expr', fvExpr)
381

382
383
384
385
386
rnExpr (HsWith expr binds)
  = rnExpr expr			`thenRn` \ (expr',fvExpr) ->
    rnIPBinds binds		`thenRn` \ (binds',fvBinds) ->
    returnRn (HsWith expr' binds', fvExpr `plusFV` fvBinds)

387
rnExpr e@(HsDo do_or_lc stmts src_loc)
388
  = pushSrcLocRn src_loc $
389
    lookupOrigNames implicit_rdr_names	`thenRn` \ implicit_fvs ->
390
    rnStmts stmts			`thenRn` \ ((_, stmts'), fvs) ->
391
392
	-- check the statement list ends in an expression
    case last stmts' of {
393
394
	ResultStmt _ _ -> returnRn () ;
	_              -> addErrRn (doStmtListErr e)
395
    }					`thenRn_`
396
397
398
399
400
401
402
    returnRn (HsDo do_or_lc stmts' src_loc, fvs `plusFV` implicit_fvs)
  where
    implicit_rdr_names = [foldr_RDR, build_RDR, monadClass_RDR]
	-- Monad stuff should not be necessary for a list comprehension
	-- but the typechecker looks up the bind and return Ids anyway
	-- Oh well.

403
404

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

408
rnExpr (ExplicitTuple exps boxity)
409
  = rnExprs exps	 			`thenRn` \ (exps', fvs) ->
410
    returnRn (ExplicitTuple exps' boxity, fvs `addOneFV` tycon_name)
411
  where
412
    tycon_name = tupleTyCon_name boxity (length exps)
413

414
rnExpr (RecordCon con_id rbinds)
415
  = lookupOccRn con_id 			`thenRn` \ conname ->
416
    rnRbinds "construction" rbinds	`thenRn` \ (rbinds', fvRbinds) ->
417
    returnRn (RecordCon conname rbinds', fvRbinds `addOneFV` conname)
418
419
420
421

rnExpr (RecordUpd expr rbinds)
  = rnExpr expr			`thenRn` \ (expr', fvExpr) ->
    rnRbinds "update" rbinds	`thenRn` \ (rbinds', fvRbinds) ->
422
    returnRn (RecordUpd expr' rbinds', fvExpr `plusFV` fvRbinds)
423
424

rnExpr (ExprWithTySig expr pty)
425
426
  = rnExpr expr			 			   `thenRn` \ (expr', fvExpr) ->
    rnHsTypeFVs (text "an expression type signature") pty  `thenRn` \ (pty', fvTy) ->
427
    returnRn (ExprWithTySig expr' pty', fvExpr `plusFV` fvTy)
428
429
430
431
432
433

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) ->
434
    returnRn (HsIf p' b1' b2' src_loc, plusFVs [fvP, fvB1, fvB2])
435

436
437
438
439
440
rnExpr (HsType a)
  = rnHsTypeFVs doc a	`thenRn` \ (t, fvT) -> 
    returnRn (HsType t, fvT)
  where 
    doc = text "renaming a type pattern"
441

442
rnExpr (ArithSeqIn seq)
443
  = lookupOrigName enumClass_RDR	`thenRn` \ enum ->
444
    rn_seq seq	 			`thenRn` \ (new_seq, fvs) ->
445
    returnRn (ArithSeqIn new_seq, fvs `addOneFV` enum)
446
447
448
449
450
451
452
453
  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) ->
454
       returnRn (FromThen expr1' expr2', fvExpr1 `plusFV` fvExpr2)
455
456
457
458

    rn_seq (FromTo expr1 expr2)
     = rnExpr expr1	`thenRn` \ (expr1', fvExpr1) ->
       rnExpr expr2	`thenRn` \ (expr2', fvExpr2) ->
459
       returnRn (FromTo expr1' expr2', fvExpr1 `plusFV` fvExpr2)
460
461
462
463
464
465

    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',
466
		  plusFVs [fvExpr1, fvExpr2, fvExpr3])
467
\end{code}
468

469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
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}

484
485


486
487
488
489
490
491
492
493
%************************************************************************
%*									*
\subsubsection{@Rbinds@s and @Rpats@s: in record expressions}
%*									*
%************************************************************************

\begin{code}
rnRbinds str rbinds 
sof's avatar
sof committed
494
  = mapRn_ field_dup_err dup_fields	`thenRn_`
495
496
    mapFvRn rn_rbind rbinds		`thenRn` \ (rbinds', fvRbind) ->
    returnRn (rbinds', fvRbind)
497
  where
498
    (_, dup_fields) = removeDups compare [ f | (f,_,_) <- rbinds ]
499

500
    field_dup_err dups = addErrRn (dupFieldErr str dups)
501
502

    rn_rbind (field, expr, pun)
503
      = lookupGlobalOccRn field	`thenRn` \ fieldname ->
504
	rnExpr expr		`thenRn` \ (expr', fvExpr) ->
505
	returnRn ((fieldname, expr', pun), fvExpr `addOneFV` fieldname)
506
507

rnRpats rpats
sof's avatar
sof committed
508
  = mapRn_ field_dup_err dup_fields 	`thenRn_`
509
510
    mapFvRn rn_rpat rpats		`thenRn` \ (rpats', fvs) ->
    returnRn (rpats', fvs)
511
  where
512
    (_, dup_fields) = removeDups compare [ f | (f,_,_) <- rpats ]
513

514
    field_dup_err dups = addErrRn (dupFieldErr "pattern" dups)
515
516

    rn_rpat (field, pat, pun)
517
      = lookupGlobalOccRn field	`thenRn` \ fieldname ->
518
	rnPat pat		`thenRn` \ (pat', fvs) ->
519
	returnRn ((fieldname, pat', pun), fvs `addOneFV` fieldname)
520
521
\end{code}

522
523
524
525
526
527
528
529
530
%************************************************************************
%*									*
\subsubsection{@rnIPBinds@s: in implicit parameter bindings}		*
%*									*
%************************************************************************

\begin{code}
rnIPBinds [] = returnRn ([], emptyFVs)
rnIPBinds ((n, expr) : binds)
531
  = newIPName n			`thenRn` \ name ->
532
533
534
535
536
537
    rnExpr expr			`thenRn` \ (expr',fvExpr) ->
    rnIPBinds binds		`thenRn` \ (binds',fvBinds) ->
    returnRn ((name, expr') : binds', fvExpr `plusFV` fvBinds)

\end{code}

538
539
%************************************************************************
%*									*
540
\subsubsection{@Stmt@s: in @do@ expressions}
541
542
543
544
545
546
547
548
549
550
551
552
%*									*
%************************************************************************

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}
553
rnStmts :: [RdrNameStmt]
554
	-> RnMS (([Name], [RenamedStmt]), FreeVars)
555

556
rnStmts []
557
  = returnRn (([], []), emptyFVs)
558

559
rnStmts (stmt:stmts)
560
  = getLocalNameEnv 		`thenRn` \ name_env ->
561
562
    rnStmt stmt				$ \ stmt' ->
    rnStmts stmts			`thenRn` \ ((binders, stmts'), fvs) ->
563
    returnRn ((binders, stmt' : stmts'), fvs)
564

565
rnStmt :: RdrNameStmt
566
567
       -> (RenamedStmt -> RnMS (([Name], a), FreeVars))
       -> RnMS (([Name], a), FreeVars)
568
569
570
-- 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
571
-- Because of mutual recursion we have to pass in rnExpr.
572

573
574
rnStmt (ParStmt stmtss) thing_inside
  = mapFvRn rnStmts stmtss		`thenRn` \ (bndrstmtss, fv_stmtss) ->
575
    let binderss = map fst bndrstmtss
576
577
578
579
580
581
	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
582
583
    foldlRn checkBndrs [] binderss	`thenRn` \ new_binders ->
    bindLocalNamesFV new_binders	$
584
    thing_inside (ParStmtOut bndrstmtss)`thenRn` \ ((rest_bndrs, result), fv_rest) ->
585
    returnRn ((new_binders ++ rest_bndrs, result), fv_stmtss `plusFV` fv_rest)
586

587
rnStmt (BindStmt pat expr src_loc) thing_inside
588
  = pushSrcLocRn src_loc $
589
    rnExpr expr					`thenRn` \ (expr', fv_expr) ->
590
591
    bindPatSigTyVars (collectSigTysFromPat pat)	$ \ sig_tyvars ->
    bindLocalsFVRn doc (collectPatBinders pat)	$ \ new_binders ->
592
593
    rnPat pat					`thenRn` \ (pat', fv_pat) ->
    thing_inside (BindStmt pat' expr' src_loc)	`thenRn` \ ((rest_binders, result), fvs) ->
594
    returnRn ((new_binders ++ rest_binders, result),
595
	      fv_expr `plusFV` fvs `plusFV` fv_pat)
596
  where
597
    doc = text "In a pattern in 'do' binding" 
598

599
rnStmt (ExprStmt expr src_loc) thing_inside
600
  = pushSrcLocRn src_loc $
601
    rnExpr expr 				`thenRn` \ (expr', fv_expr) ->
602
    thing_inside (ExprStmt expr' src_loc)	`thenRn` \ (result, fvs) ->
603
    returnRn (result, fv_expr `plusFV` fvs)
604

605
606
607
608
609
610
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)

611
rnStmt (LetStmt binds) thing_inside
612
  = rnBinds binds				$ \ binds' ->
613
614
615
    let new_binders = collectHsBinders binds' in
    thing_inside (LetStmt binds')    `thenRn` \ ((rest_binders, result), fvs) ->
    returnRn ((new_binders ++ rest_binders, result), fvs )
616
617
618
619
620
621
622
623
\end{code}

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

624
625
626
627
628
629
630
@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
631
632
operator appications left-associatively, EXCEPT negation, which
we need to handle specially.
633

634
\begin{code}
635
636
637
638
mkOpAppRn :: RenamedHsExpr			-- Left operand; already rearranged
	  -> RenamedHsExpr -> Fixity 		-- Operator and fixity
	  -> RenamedHsExpr			-- Right operand (not an OpApp, but might
						-- be a NegApp)
639
	  -> RnMS RenamedHsExpr
640

641
642
643
---------------------------
-- (e11 `op1` e12) `op2` e2
mkOpAppRn e1@(OpApp e11 op1 fix1 e12) op2 fix2 e2
644
  | nofix_error
645
  = addErrRn (precParseErr (ppr_op op1,fix1) (ppr_op op2,fix2))	`thenRn_`
646
647
    returnRn (OpApp e1 op2 fix2 e2)

648
  | associate_right
649
650
  = mkOpAppRn e12 op2 fix2 e2		`thenRn` \ new_e ->
    returnRn (OpApp e11 op1 fix1 new_e)
651
  where
652
    (nofix_error, associate_right) = compareFixity fix1 fix2
653

654
655
---------------------------
--	(- neg_arg) `op` e2
656
mkOpAppRn e1@(NegApp neg_arg) op2 fix2 e2
sof's avatar
sof committed
657
  | nofix_error
658
  = addErrRn (precParseErr (pp_prefix_minus,negateFixity) (ppr_op op2,fix2))	`thenRn_`
sof's avatar
sof committed
659
660
    returnRn (OpApp e1 op2 fix2 e2)

661
  | associate_right
662
  = mkOpAppRn neg_arg op2 fix2 e2	`thenRn` \ new_e ->
663
    returnRn (NegApp new_e)
sof's avatar
sof committed
664
  where
665
666
667
668
    (nofix_error, associate_right) = compareFixity negateFixity fix2

---------------------------
--	e1 `op` - neg_arg
669
mkOpAppRn e1 op1 fix1 e2@(NegApp neg_arg)	-- NegApp can occur on the right
670
  | not associate_right					-- We *want* right association
671
  = addErrRn (precParseErr (ppr_op op1, fix1) (pp_prefix_minus, negateFixity))	`thenRn_`
672
673
    returnRn (OpApp e1 op1 fix1 e2)
  where
674
    (_, associate_right) = compareFixity fix1 negateFixity
675

676
677
---------------------------
--	Default case
678
mkOpAppRn e1 op fix e2 			-- Default case, no rearrangment
679
680
  = ASSERT2( right_op_ok fix e2,
	     ppr e1 $$ text "---" $$ ppr op $$ text "---" $$ ppr fix $$ text "---" $$ ppr e2
681
    )
682
683
684
685
686
687
688
689
690
691
692
    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
693

694
-- Parser initially makes negation bind more tightly than any other operator
695
mkNegAppRn neg_arg
sof's avatar
sof committed
696
697
698
699
700
  = 
#ifdef DEBUG
    getModeRn			`thenRn` \ mode ->
    ASSERT( not_op_app mode neg_arg )
#endif
701
    returnRn (NegApp neg_arg)
702

703
704
not_op_app SourceMode (OpApp _ _ _ _) = False
not_op_app mode other	 	      = True
705
\end{code}
706

707
\begin{code}
708
mkConOpPatRn :: RenamedPat -> Name -> Fixity -> RenamedPat
709
	     -> RnMS RenamedPat
710

711
712
713
mkConOpPatRn p1@(ConOpPatIn p11 op1 fix1 p12) 
	     op2 fix2 p2
  | nofix_error
714
  = addErrRn (precParseErr (ppr_op op1,fix1) (ppr_op op2,fix2))	`thenRn_`
715
    returnRn (ConOpPatIn p1 op2 fix2 p2)
716

717
  | associate_right
718
719
  = mkConOpPatRn p12 op2 fix2 p2		`thenRn` \ new_p ->
    returnRn (ConOpPatIn p11 op1 fix1 new_p)
720

721
  where
722
    (nofix_error, associate_right) = compareFixity fix1 fix2
723
724
725
726
727
728
729

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
730
731
\end{code}

732
\begin{code}
733
checkPrecMatch :: Bool -> Name -> RenamedMatch -> RnMS ()
734

735
checkPrecMatch False fn match
736
  = returnRn ()
737

738
739
checkPrecMatch True op (Match _ (p1:p2:_) _ _)
	-- True indicates an infix lhs
740
741
  = getModeRn 		`thenRn` \ mode ->
	-- See comments with rnExpr (OpApp ...)
742
743
744
745
    if isInterfaceMode mode
	then returnRn ()
	else checkPrec op p1 False	`thenRn_`
	     checkPrec op p2 True
746

747
checkPrecMatch True op _ = panic "checkPrecMatch"
748

749
checkPrec op (ConOpPatIn _ op1 _ _) right
750
751
  = lookupFixityRn op	`thenRn` \  op_fix@(Fixity op_prec  op_dir) ->
    lookupFixityRn op1	`thenRn` \ op1_fix@(Fixity op1_prec op1_dir) ->
752
753
    let
	inf_ok = op1_prec > op_prec || 
754
	         (op1_prec == op_prec &&
755
756
		  (op1_dir == InfixR && op_dir == InfixR && right ||
		   op1_dir == InfixL && op_dir == InfixL && not right))
757

758
759
	info  = (ppr_op op,  op_fix)
	info1 = (ppr_op op1, op1_fix)
760
761
	(infol, infor) = if right then (info, info1) else (info1, info)
    in
762
    checkRn inf_ok (precParseErr infol infor)
763
764
765

checkPrec op pat right
  = returnRn ()
766
767
768
769
770
771
772

-- Check precedence of (arg op) or (op arg) respectively
-- If arg is itself an operator application, its precedence should
-- be higher than that of op
checkSectionPrec left_or_right section op arg
  = case arg of
	OpApp _ op fix _ -> go_for_it (ppr_op op)     fix
773
	NegApp _	 -> go_for_it pp_prefix_minus negateFixity
774
775
776
777
	other		 -> returnRn ()
  where
    HsVar op_name = op
    go_for_it pp_arg_op arg_fix@(Fixity arg_prec _)
778
	= lookupFixityRn op_name	`thenRn` \ op_fix@(Fixity op_prec _) ->
779
780
	  checkRn (op_prec < arg_prec)
		  (sectionPrecErr (ppr_op op_name, op_fix) (pp_arg_op, arg_fix) section)
781
782
\end{code}

783
Consider
784
\begin{verbatim}
785
	a `op1` b `op2` c
786
787
\end{verbatim}
@(compareFixity op1 op2)@ tells which way to arrange appication, or
788
789
790
791
792
793
794
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)
795
796
797
798
  = case prec1 `compare` prec2 of
	GT -> left
	LT -> right
	EQ -> case (dir1, dir2) of
799
800
801
802
803
804
805
806
807
			(InfixR, InfixR) -> right
			(InfixL, InfixL) -> left
			_		 -> error_please
  where
    right	 = (False, True)
    left         = (False, False)
    error_please = (True,  False)
\end{code}

808
809
810
811
812
813
%************************************************************************
%*									*
\subsubsection{Literals}
%*									*
%************************************************************************

814
815
When literals occur we have to make sure
that the types and classes they involve
816
817
818
are made available.

\begin{code}
819
820
821
822
litFVs (HsChar c)
   = checkRn (inCharRange c) (bogusCharError c) `thenRn_`
     returnRn (unitFV charTyCon_name)

823
824
825
826
827
828
829
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))
830
litFVs (HsLitLit l bogus_ty)  = lookupOrigName cCallableClass_RDR	`thenRn` \ cc ->   
831
832
833
834
				returnRn (unitFV cc)
litFVs lit		      = pprPanic "RnExpr.litFVs" (ppr lit)	-- HsInteger and HsRat only appear 
									-- in post-typechecker translations

835
836
rnOverLit (HsIntegral i)
  | inIntRange i
837
  = returnRn (HsIntegral i, unitFV fromIntegerName)
838
839
840
  | otherwise
  = lookupOrigNames [fromInteger_RDR, plusInteger_RDR, timesInteger_RDR]	`thenRn` \ ns ->
	-- Big integers are built, using + and *, out of small integers
841
842
843
	-- [No particular reason why we use fromIntegerName in one case can 
	--  fromInteger_RDR in the other; but plusInteger_RDR means we 
	--  can get away without plusIntegerName altogether.]
844
845
846
847
848
    returnRn (HsIntegral i, ns)

rnOverLit (HsFractional i)
  = lookupOrigNames [fromRational_RDR, ratioDataCon_RDR, 
		     plusInteger_RDR, timesInteger_RDR]  `thenRn` \ ns ->
sof's avatar
sof committed
849
850
	-- We have to make sure that the Ratio type is imported with
	-- its constructor, because literals of type Ratio t are
851
852
853
	-- built with that constructor.
	-- The Rational type is needed too, but that will come in
	-- when fractionalClass does.
854
855
	-- The plus/times integer operations may be needed to construct the numerator
	-- and denominator (see DsUtils.mkIntegerLit)
856
    returnRn (HsFractional i, ns)
857
858
\end{code}

sof's avatar
sof committed
859
860
861
862
863
864
865
%************************************************************************
%*									*
\subsubsection{Assertion utils}
%*									*
%************************************************************************

\begin{code}
866
mkAssertExpr :: RnMS (RenamedHsExpr, FreeVars)
sof's avatar
sof committed
867
mkAssertExpr =
868
869
  lookupOrigName assertErr_RDR		`thenRn` \ name ->
  getSrcLocRn    			`thenRn` \ sloc ->
sof's avatar
sof committed
870
871
872
873
874
875
876
877
878
879

    -- 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
880
     ignorePredMatch = mkSimpleMatch [WildPatIn, VarPatIn vname] (HsVar vname) Nothing loc
sof's avatar
sof committed
881
    in
882
    returnRn (expr, unitFV name)
sof's avatar
sof committed
883
884
885
886
  else
    let
     expr = 
          HsApp (HsVar name)
sof's avatar
sof committed
887
	        (HsLit (HsString (_PK_ (showSDoc (ppr sloc)))))
sof's avatar
sof committed
888
889

    in
890
    returnRn (expr, unitFV name)
sof's avatar
sof committed
891

sof's avatar
sof committed
892
\end{code}
893
894
895
896
897
898
899

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

900
\begin{code}
901
902
903
904
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 `-'")

905
906
907
908
dupFieldErr str (dup:rest)
  = hsep [ptext SLIT("duplicate field name"), 
          quotes (ppr dup),
	  ptext SLIT("in record"), text str]
909

910
precParseErr op1 op2 
sof's avatar
sof committed
911
  = hang (ptext SLIT("precedence parsing error"))
912
913
      4 (hsep [ptext SLIT("cannot mix"), ppr_opfix op1, ptext SLIT("and"), 
	       ppr_opfix op2,
914
	       ptext SLIT("in the same infix expression")])
sof's avatar
sof committed
915

916
917
918
919
920
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),
	 nest 4 (ptext SLIT("In the section:") <+> quotes (ppr section))]

921
nonStdGuardErr guard
922
923
924
  = hang (ptext
    SLIT("accepting non-standard pattern guards (-fglasgow-exts to suppress this message)")
    ) 4 (ppr guard)
925

926
patSigErr ty
927
928
  =  (ptext SLIT("Illegal signature in pattern:") <+> ppr ty)
	$$ nest 4 (ptext SLIT("Use -fglasgow-exts to permit it"))
929

930
931
932
patSynErr e 
  = sep [ptext SLIT("Pattern syntax in expression context:"),
	 nest 4 (ppr e)]
933
934
935
936

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

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