RnExpr.lhs 32.8 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
	rnLExpr, rnExpr, rnStmts
15
16
   ) where

17
18
#include "HsVersions.h"

19
20
21
import RnSource  ( rnSrcDecls, rnSplice, checkTH ) 
import RnBinds	 ( rnLocalBindsAndThen, rnValBinds,
		   rnMatchGroup, trimWith ) 
22
import HsSyn
23
import TcRnMonad
24
import RnEnv
25
import HscTypes         ( availNames )
26
import RnNames		( getLocalDeclBinders, extendRdrEnvRn )
27
import RnTypes		( rnHsTypeFVs, rnLPat, rnOverLit, rnPatsAndThen, rnLit,
28
29
30
31
			  mkOpFormRn, mkOpAppRn, mkNegAppRn, checkSectionPrec, 
			  dupFieldErr, checkTupSize )
import DynFlags		( DynFlag(..) )
import BasicTypes	( FixityDirection(..) )
32
import SrcLoc           ( SrcSpan )
33
import PrelNames	( thFAKE, hasKey, assertIdKey, assertErrorName,
34
			  loopAName, choiceAName, appAName, arrAName, composeAName, firstAName,
35
			  negateName, thenMName, bindMName, failMName )
mnislaih's avatar
mnislaih committed
36

37
import Name		( Name, nameOccName, nameIsLocalOrFrom )
38
import NameSet
39
import RdrName		( RdrName, extendLocalRdrEnv, lookupLocalRdrEnv, hideSomeUnquals )
Simon Marlow's avatar
Simon Marlow committed
40
import LoadIface	( loadInterfaceForName )
41
import UniqFM		( isNullUFM )
42
import UniqSet		( emptyUniqSet )
43
import List		( nub )
44
import Util		( isSingleton )
45
import ListSetOps	( removeDups )
46
import Maybes		( expectJust )
sof's avatar
sof committed
47
import Outputable
48
import SrcLoc		( Located(..), unLoc, getLoc, cmpLocated )
49
import FastString
50
51

import List		( unzip4 )
52
53
54
55
56
57
58
59
60
61
\end{code}


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

\begin{code}
62
rnExprs :: [LHsExpr RdrName] -> RnM ([LHsExpr Name], FreeVars)
sof's avatar
sof committed
63
64
rnExprs ls = rnExprs' ls emptyUniqSet
 where
65
  rnExprs' [] acc = returnM ([], acc)
sof's avatar
sof committed
66
  rnExprs' (expr:exprs) acc
67
   = rnLExpr expr 	        `thenM` \ (expr', fvExpr) ->
sof's avatar
sof committed
68
69
70
71

	-- Now we do a "seq" on the free vars because typically it's small
	-- or empty, especially in very long lists of constants
    let
72
	acc' = acc `plusFV` fvExpr
sof's avatar
sof committed
73
    in
74
75
    (grubby_seqNameSet acc' rnExprs') exprs acc'	`thenM` \ (exprs', fvExprs) ->
    returnM (expr':exprs', fvExprs)
sof's avatar
sof committed
76
77
78
79

-- 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
80
81
\end{code}

82
Variables. We look up the variable and return the resulting name. 
83
84

\begin{code}
85
86
87
88
rnLExpr :: LHsExpr RdrName -> RnM (LHsExpr Name, FreeVars)
rnLExpr = wrapLocFstM rnExpr

rnExpr :: HsExpr RdrName -> RnM (HsExpr Name, FreeVars)
89
90

rnExpr (HsVar v)
91
92
  = do name           <- lookupOccRn v
       ignore_asserts <- doptM Opt_IgnoreAsserts
93
94
95
96
97
98
99
100
       finish_var ignore_asserts name
  where
    finish_var ignore_asserts name
	| ignore_asserts || not (name `hasKey` assertIdKey)
	= return (HsVar name, unitFV name)
  	| otherwise
	= do { (e, fvs) <- mkAssertErrorExpr
             ; return (e, fvs `addOneFV` name) }
101

102
rnExpr (HsIPVar v)
103
104
  = newIPNameRn v		`thenM` \ name ->
    returnM (HsIPVar name, emptyFVs)
105

106
107
108
109
110
111
112
113
114
115
rnExpr (HsLit lit@(HsString s))
  = do {
         opt_OverloadedStrings <- doptM Opt_OverloadedStrings
       ; if opt_OverloadedStrings then
            rnExpr (HsOverLit (mkHsIsString s))
	 else -- Same as below
	    rnLit lit		`thenM_`
            returnM (HsLit lit, emptyFVs)
       }

116
rnExpr (HsLit lit) 
117
118
  = rnLit lit		`thenM_`
    returnM (HsLit lit, emptyFVs)
119

120
rnExpr (HsOverLit lit) 
121
122
  = rnOverLit lit		`thenM` \ (lit', fvs) ->
    returnM (HsOverLit lit', fvs)
123

124
rnExpr (HsApp fun arg)
125
126
  = rnLExpr fun		`thenM` \ (fun',fvFun) ->
    rnLExpr arg		`thenM` \ (arg',fvArg) ->
127
    returnM (HsApp fun' arg', fvFun `plusFV` fvArg)
128

129
rnExpr (OpApp e1 op _ e2) 
130
131
132
  = rnLExpr e1				`thenM` \ (e1', fv_e1) ->
    rnLExpr e2				`thenM` \ (e2', fv_e2) ->
    rnLExpr op				`thenM` \ (op'@(L _ (HsVar op_name)), fv_op) ->
133

sof's avatar
sof committed
134
135
	-- Deal with fixity
	-- When renaming code synthesised from "deriving" declarations
136
137
138
139
140
	-- we used to avoid fixity stuff, but we can't easily tell any
	-- more, so I've removed the test.  Adding HsPars in TcGenDeriv
	-- should prevent bad things happening.
    lookupFixityRn op_name		`thenM` \ fixity ->
    mkOpAppRn e1' op' fixity e2'	`thenM` \ final_e -> 
141

142
    returnM (final_e,
143
	      fv_e1 `plusFV` fv_op `plusFV` fv_e2)
144

145
rnExpr (NegApp e _)
146
  = rnLExpr e			`thenM` \ (e', fv_e) ->
147
148
149
    lookupSyntaxName negateName	`thenM` \ (neg_name, fv_neg) ->
    mkNegAppRn e' neg_name	`thenM` \ final_e ->
    returnM (final_e, fv_e `plusFV` fv_neg)
150
151

rnExpr (HsPar e)
152
  = rnLExpr e 		`thenM` \ (e', fvs_e) ->
153
154
155
    returnM (HsPar e', fvs_e)

-- Template Haskell extensions
156
157
-- Don't ifdef-GHCI them because we want to fail gracefully
-- (not with an rnExpr crash) in a stage-1 compiler.
158
159
rnExpr e@(HsBracket br_body)
  = checkTH e "bracket"		`thenM_`
160
    rnBracket br_body		`thenM` \ (body', fvs_e) ->
161
    returnM (HsBracket body', fvs_e)
162

163
164
165
rnExpr e@(HsSpliceE splice)
  = rnSplice splice 		`thenM` \ (splice', fvs) ->
    returnM (HsSpliceE splice', fvs)
166

167
rnExpr section@(SectionL expr op)
168
169
  = rnLExpr expr	 	`thenM` \ (expr', fvs_expr) ->
    rnLExpr op	 		`thenM` \ (op', fvs_op) ->
170
171
    checkSectionPrec InfixL section op' expr' `thenM_`
    returnM (SectionL expr' op', fvs_op `plusFV` fvs_expr)
172

173
rnExpr section@(SectionR op expr)
174
175
  = rnLExpr op	 				`thenM` \ (op',   fvs_op) ->
    rnLExpr expr	 				`thenM` \ (expr', fvs_expr) ->
176
177
    checkSectionPrec InfixR section op' expr'	`thenM_`
    returnM (SectionR op' expr', fvs_op `plusFV` fvs_expr)
178

179
rnExpr (HsCoreAnn ann expr)
180
  = rnLExpr expr `thenM` \ (expr', fvs_expr) ->
181
182
    returnM (HsCoreAnn ann expr', fvs_expr)

183
rnExpr (HsSCC lbl expr)
184
  = rnLExpr expr	 	`thenM` \ (expr', fvs_expr) ->
185
    returnM (HsSCC lbl expr', fvs_expr)
andy@galois.com's avatar
andy@galois.com committed
186
187
188
rnExpr (HsTickPragma info expr)
  = rnLExpr expr	 	`thenM` \ (expr', fvs_expr) ->
    returnM (HsTickPragma info expr', fvs_expr)
189

190
191
192
193
194
rnExpr (HsLam matches)
  = rnMatchGroup LambdaExpr matches	`thenM` \ (matches', fvMatch) ->
    returnM (HsLam matches', fvMatch)

rnExpr (HsCase expr matches)
195
  = rnLExpr expr		 	`thenM` \ (new_expr, e_fvs) ->
196
197
    rnMatchGroup CaseAlt matches	`thenM` \ (new_matches, ms_fvs) ->
    returnM (HsCase new_expr new_matches, e_fvs `plusFV` ms_fvs)
198
199

rnExpr (HsLet binds expr)
200
  = rnLocalBindsAndThen binds		$ \ binds' ->
201
    rnLExpr expr			 `thenM` \ (expr',fvExpr) ->
202
    returnM (HsLet binds' expr', fvExpr)
203

204
205
206
207
rnExpr e@(HsDo do_or_lc stmts body _)
  = do 	{ ((stmts', body'), fvs) <- rnStmts do_or_lc stmts $
				    rnLExpr body
	; return (HsDo do_or_lc stmts' body' placeHolderType, fvs) }
208

209
rnExpr (ExplicitList _ exps)
210
  = rnExprs exps		 	`thenM` \ (exps', fvs) ->
211
    returnM  (ExplicitList placeHolderType exps', fvs)
212

chak's avatar
chak committed
213
rnExpr (ExplicitPArr _ exps)
214
  = rnExprs exps		 	`thenM` \ (exps', fvs) ->
215
    returnM  (ExplicitPArr placeHolderType exps', fvs)
chak's avatar
chak committed
216

217
rnExpr e@(ExplicitTuple exps boxity)
218
  = checkTupSize (length exps)			`thenM_`
219
    rnExprs exps	 			`thenM` \ (exps', fvs) ->
220
    returnM (ExplicitTuple exps' boxity, fvs)
221

222
rnExpr (RecordCon con_id _ (HsRecordBinds rbinds))
223
  = lookupLocatedOccRn con_id		`thenM` \ conname ->
224
    rnRbinds "construction" rbinds	`thenM` \ (rbinds', fvRbinds) ->
225
    returnM (RecordCon conname noPostTcExpr (HsRecordBinds rbinds'), 
226
	     fvRbinds `addOneFV` unLoc conname)
227

228
rnExpr (RecordUpd expr (HsRecordBinds rbinds) _ _ _)
229
  = rnLExpr expr		`thenM` \ (expr', fvExpr) ->
230
    rnRbinds "update" rbinds	`thenM` \ (rbinds', fvRbinds) ->
231
    returnM (RecordUpd expr' (HsRecordBinds rbinds') [] [] [], 
232
	     fvExpr `plusFV` fvRbinds)
233
234

rnExpr (ExprWithTySig expr pty)
235
236
237
238
  = do	{ (pty', fvTy) <- rnHsTypeFVs doc pty
	; (expr', fvExpr) <- bindSigTyVarsFV (hsExplicitTvs pty') $
		  	     rnLExpr expr
	; return (ExprWithTySig expr' pty', fvExpr `plusFV` fvTy) }
239
240
  where 
    doc = text "In an expression type signature"
241

242
243
244
245
246
rnExpr (HsIf p b1 b2)
  = rnLExpr p		`thenM` \ (p', fvP) ->
    rnLExpr b1		`thenM` \ (b1', fvB1) ->
    rnLExpr b2		`thenM` \ (b2', fvB2) ->
    returnM (HsIf p' b1' b2', plusFVs [fvP, fvB1, fvB2])
247

248
rnExpr (HsType a)
249
250
  = rnHsTypeFVs doc a	`thenM` \ (t, fvT) -> 
    returnM (HsType t, fvT)
251
  where 
252
    doc = text "In a type argument"
253

254
rnExpr (ArithSeq _ seq)
255
  = rnArithSeq seq	 `thenM` \ (new_seq, fvs) ->
256
    returnM (ArithSeq noPostTcExpr new_seq, fvs)
chak's avatar
chak committed
257

258
rnExpr (PArrSeq _ seq)
259
  = rnArithSeq seq	 `thenM` \ (new_seq, fvs) ->
260
    returnM (PArrSeq noPostTcExpr new_seq, fvs)
261
\end{code}
262

263
264
265
266
267
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}
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
268
269
270
rnExpr e@EWildPat      = patSynErr e
rnExpr e@(EAsPat {})   = patSynErr e
rnExpr e@(ELazyPat {}) = patSynErr e
271
272
\end{code}

273
274
275
276
277
278
279
%************************************************************************
%*									*
	Arrow notation
%*									*
%************************************************************************

\begin{code}
280
rnExpr (HsProc pat body)
ross's avatar
ross committed
281
  = newArrowScope $
282
283
    rnPatsAndThen ProcExpr [pat] $ \ [pat'] ->
    rnCmdTop body	         `thenM` \ (body',fvBody) ->
284
    returnM (HsProc pat' body', fvBody)
285

286
rnExpr (HsArrApp arrow arg _ ho rtl)
ross's avatar
ross committed
287
288
  = select_arrow_scope (rnLExpr arrow)	`thenM` \ (arrow',fvArrow) ->
    rnLExpr arg				`thenM` \ (arg',fvArg) ->
289
    returnM (HsArrApp arrow' arg' placeHolderType ho rtl,
290
	     fvArrow `plusFV` fvArg)
ross's avatar
ross committed
291
292
293
294
  where
    select_arrow_scope tc = case ho of
        HsHigherOrderApp -> tc
        HsFirstOrderApp  -> escapeArrowScope tc
295
296

-- infix form
297
rnExpr (HsArrForm op (Just _) [arg1, arg2])
ross's avatar
ross committed
298
299
  = escapeArrowScope (rnLExpr op)
			`thenM` \ (op'@(L _ (HsVar op_name)),fv_op) ->
300
301
302
303
304
305
306
307
308
309
310
    rnCmdTop arg1	`thenM` \ (arg1',fv_arg1) ->
    rnCmdTop arg2	`thenM` \ (arg2',fv_arg2) ->

	-- Deal with fixity

    lookupFixityRn op_name		`thenM` \ fixity ->
    mkOpFormRn arg1' op' fixity arg2'	`thenM` \ final_e -> 

    returnM (final_e,
	      fv_arg1 `plusFV` fv_op `plusFV` fv_arg2)

311
rnExpr (HsArrForm op fixity cmds)
ross's avatar
ross committed
312
313
  = escapeArrowScope (rnLExpr op)	`thenM` \ (op',fvOp) ->
    rnCmdArgs cmds			`thenM` \ (cmds',fvCmds) ->
314
    returnM (HsArrForm op' fixity cmds', fvOp `plusFV` fvCmds)
315

316
rnExpr other = pprPanic "rnExpr: unexpected expression" (ppr other)
317
	-- HsWrap
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
\end{code}


%************************************************************************
%*									*
	Arrow commands
%*									*
%************************************************************************

\begin{code}
rnCmdArgs [] = returnM ([], emptyFVs)
rnCmdArgs (arg:args)
  = rnCmdTop arg	`thenM` \ (arg',fvArg) ->
    rnCmdArgs args	`thenM` \ (args',fvArgs) ->
    returnM (arg':args', fvArg `plusFV` fvArgs)

334
335
336
337
338
339

rnCmdTop = wrapLocFstM rnCmdTop'
 where
  rnCmdTop' (HsCmdTop cmd _ _ _) 
   = rnLExpr (convertOpFormsLCmd cmd) `thenM` \ (cmd', fvCmd) ->
     let 
340
	cmd_names = [arrAName, composeAName, firstAName] ++
341
342
		    nameSetToList (methodNamesCmd (unLoc cmd'))
     in
343
	-- Generate the rebindable syntax for the monad
344
     lookupSyntaxTable cmd_names	`thenM` \ (cmd_names', cmd_fvs) ->
345

346
     returnM (HsCmdTop cmd' [] placeHolderType cmd_names', 
347
348
349
350
351
	     fvCmd `plusFV` cmd_fvs)

---------------------------------------------------
-- convert OpApp's in a command context to HsArrForm's

352
353
354
convertOpFormsLCmd :: LHsCmd id -> LHsCmd id
convertOpFormsLCmd = fmap convertOpFormsCmd

355
356
convertOpFormsCmd :: HsCmd id -> HsCmd id

357
convertOpFormsCmd (HsApp c e) = HsApp (convertOpFormsLCmd c) e
358
359
360
convertOpFormsCmd (HsLam match) = HsLam (convertOpFormsMatch match)
convertOpFormsCmd (OpApp c1 op fixity c2)
  = let
361
362
	arg1 = L (getLoc c1) $ HsCmdTop (convertOpFormsLCmd c1) [] placeHolderType []
	arg2 = L (getLoc c2) $ HsCmdTop (convertOpFormsLCmd c2) [] placeHolderType []
363
    in
364
    HsArrForm op (Just fixity) [arg1, arg2]
365

366
convertOpFormsCmd (HsPar c) = HsPar (convertOpFormsLCmd c)
367

368
-- gaw 2004
369
convertOpFormsCmd (HsCase exp matches)
370
  = HsCase exp (convertOpFormsMatch matches)
371

372
373
convertOpFormsCmd (HsIf exp c1 c2)
  = HsIf exp (convertOpFormsLCmd c1) (convertOpFormsLCmd c2)
374
375

convertOpFormsCmd (HsLet binds cmd)
376
  = HsLet binds (convertOpFormsLCmd cmd)
377

378
379
380
convertOpFormsCmd (HsDo ctxt stmts body ty)
  = HsDo ctxt (map (fmap convertOpFormsStmt) stmts)
	      (convertOpFormsLCmd body) ty
381
382
383
384
385
386

-- Anything else is unchanged.  This includes HsArrForm (already done),
-- things with no sub-commands, and illegal commands (which will be
-- caught by the type checker)
convertOpFormsCmd c = c

387
388
389
390
391
392
convertOpFormsStmt (BindStmt pat cmd _ _)
  = BindStmt pat (convertOpFormsLCmd cmd) noSyntaxExpr noSyntaxExpr
convertOpFormsStmt (ExprStmt cmd _ _)
  = ExprStmt (convertOpFormsLCmd cmd) noSyntaxExpr placeHolderType
convertOpFormsStmt (RecStmt stmts lvs rvs es binds)
  = RecStmt (map (fmap convertOpFormsStmt) stmts) lvs rvs es binds
393
394
convertOpFormsStmt stmt = stmt

395
396
convertOpFormsMatch (MatchGroup ms ty)
  = MatchGroup (map (fmap convert) ms) ty
397
398
 where convert (Match pat mty grhss)
	  = Match pat mty (convertOpFormsGRHSs grhss)
399

400
401
convertOpFormsGRHSs (GRHSs grhss binds)
  = GRHSs (map convertOpFormsGRHS grhss) binds
402

403
convertOpFormsGRHS = fmap convert
404
405
 where 
   convert (GRHS stmts cmd) = GRHS stmts (convertOpFormsLCmd cmd)
406
407
408
409
410
411

---------------------------------------------------
type CmdNeeds = FreeVars	-- Only inhabitants are 
				-- 	appAName, choiceAName, loopAName

-- find what methods the Cmd needs (loop, choice, apply)
412
413
414
methodNamesLCmd :: LHsCmd Name -> CmdNeeds
methodNamesLCmd = methodNamesCmd . unLoc

415
416
methodNamesCmd :: HsCmd Name -> CmdNeeds

417
methodNamesCmd cmd@(HsArrApp _arrow _arg _ HsFirstOrderApp _rtl)
418
  = emptyFVs
419
methodNamesCmd cmd@(HsArrApp _arrow _arg _ HsHigherOrderApp _rtl)
420
421
422
  = unitFV appAName
methodNamesCmd cmd@(HsArrForm {}) = emptyFVs

423
methodNamesCmd (HsPar c) = methodNamesLCmd c
424

425
426
methodNamesCmd (HsIf p c1 c2)
  = methodNamesLCmd c1 `plusFV` methodNamesLCmd c2 `addOneFV` choiceAName
427

428
methodNamesCmd (HsLet b c) = methodNamesLCmd c
429

430
431
methodNamesCmd (HsDo sc stmts body ty) 
  = methodNamesStmts stmts `plusFV` methodNamesLCmd body
432

433
methodNamesCmd (HsApp c e) = methodNamesLCmd c
ross's avatar
ross committed
434

435
436
methodNamesCmd (HsLam match) = methodNamesMatch match

437
methodNamesCmd (HsCase scrut matches)
438
  = methodNamesMatch matches `addOneFV` choiceAName
439
440
441
442
443
444
445

methodNamesCmd other = emptyFVs
   -- Other forms can't occur in commands, but it's not convenient 
   -- to error here so we just do what's convenient.
   -- The type checker will complain later

---------------------------------------------------
446
methodNamesMatch (MatchGroup ms _)
447
448
449
  = plusFVs (map do_one ms)
 where 
    do_one (L _ (Match pats sig_ty grhss)) = methodNamesGRHSs grhss
450
451

-------------------------------------------------
452
453
-- gaw 2004
methodNamesGRHSs (GRHSs grhss binds) = plusFVs (map methodNamesGRHS grhss)
454
455

-------------------------------------------------
456
methodNamesGRHS (L _ (GRHS stmts rhs)) = methodNamesLCmd rhs
457
458

---------------------------------------------------
459
methodNamesStmts stmts = plusFVs (map methodNamesLStmt stmts)
460
461

---------------------------------------------------
462
463
methodNamesLStmt = methodNamesStmt . unLoc

464
465
466
methodNamesStmt (ExprStmt cmd _ _)     = methodNamesLCmd cmd
methodNamesStmt (BindStmt pat cmd _ _) = methodNamesLCmd cmd
methodNamesStmt (RecStmt stmts _ _ _ _)
467
468
469
470
471
472
473
474
  = methodNamesStmts stmts `addOneFV` loopAName
methodNamesStmt (LetStmt b)  = emptyFVs
methodNamesStmt (ParStmt ss) = emptyFVs
   -- ParStmt can't occur in commands, but it's not convenient to error 
   -- here so we just do what's convenient
\end{code}


475
476
477
478
479
480
481
482
%************************************************************************
%*									*
	Arithmetic sequences
%*									*
%************************************************************************

\begin{code}
rnArithSeq (From expr)
483
 = rnLExpr expr 	`thenM` \ (expr', fvExpr) ->
484
485
486
   returnM (From expr', fvExpr)

rnArithSeq (FromThen expr1 expr2)
487
488
 = rnLExpr expr1 	`thenM` \ (expr1', fvExpr1) ->
   rnLExpr expr2	`thenM` \ (expr2', fvExpr2) ->
489
490
491
   returnM (FromThen expr1' expr2', fvExpr1 `plusFV` fvExpr2)

rnArithSeq (FromTo expr1 expr2)
492
493
 = rnLExpr expr1	`thenM` \ (expr1', fvExpr1) ->
   rnLExpr expr2	`thenM` \ (expr2', fvExpr2) ->
494
495
496
   returnM (FromTo expr1' expr2', fvExpr1 `plusFV` fvExpr2)

rnArithSeq (FromThenTo expr1 expr2 expr3)
497
498
499
 = rnLExpr expr1	`thenM` \ (expr1', fvExpr1) ->
   rnLExpr expr2	`thenM` \ (expr2', fvExpr2) ->
   rnLExpr expr3	`thenM` \ (expr3', fvExpr3) ->
500
501
502
   returnM (FromThenTo expr1' expr2' expr3',
	    plusFVs [fvExpr1, fvExpr2, fvExpr3])
\end{code}
503
504


505
506
507
508
509
510
511
512
%************************************************************************
%*									*
\subsubsection{@Rbinds@s and @Rpats@s: in record expressions}
%*									*
%************************************************************************

\begin{code}
rnRbinds str rbinds 
513
514
515
  = mappM_ field_dup_err dup_fields	`thenM_`
    mapFvRn rn_rbind rbinds		`thenM` \ (rbinds', fvRbind) ->
    returnM (rbinds', fvRbind)
516
  where
517
    (_, dup_fields) = removeDups cmpLocated [ f | (f,_) <- rbinds ]
518

519
    field_dup_err dups = mappM_ (\f -> addLocErr f (dupFieldErr str)) dups
520

521
    rn_rbind (field, expr)
522
523
524
      = lookupLocatedGlobalOccRn field	`thenM` \ fieldname ->
	rnLExpr expr			`thenM` \ (expr', fvExpr) ->
	returnM ((fieldname, expr'), fvExpr `addOneFV` unLoc fieldname)
525
526
\end{code}

527
528
529
530
531
%************************************************************************
%*									*
	Template Haskell brackets
%*									*
%************************************************************************
532

533
\begin{code}
534
rnBracket (VarBr n) = do { name <- lookupOccRn n
535
536
			 ; this_mod <- getModule
			 ; checkM (nameIsLocalOrFrom this_mod name) $	-- Reason: deprecation checking asumes the
Simon Marlow's avatar
Simon Marlow committed
537
			   do { loadInterfaceForName msg name		-- home interface is loaded, and this is the
538
			      ; return () }				-- only way that is going to happen
539
540
541
542
543
544
545
546
547
548
			 ; returnM (VarBr name, unitFV name) }
		    where
		      msg = ptext SLIT("Need interface for Template Haskell quoted Name")

rnBracket (ExpBr e) = do { (e', fvs) <- rnLExpr e
			 ; return (ExpBr e', fvs) }
rnBracket (PatBr p) = do { (p', fvs) <- rnLPat p
			 ; return (PatBr p', fvs) }
rnBracket (TypBr t) = do { (t', fvs) <- rnHsTypeFVs doc t
			 ; return (TypBr t', fvs) }
549
550
		    where
		      doc = ptext SLIT("In a Template-Haskell quoted type")
551
rnBracket (DecBr group) 
552
553
  = do 	{ gbl_env  <- getGblEnv

554
555
556
557
558
559
	; let gbl_env1 = gbl_env { tcg_mod = thFAKE }
	-- Note the thFAKE.  The top-level names from the bracketed 
	-- declarations will go into the name cache, and we don't want them to 
	-- confuse the Names for the current module.  
	-- By using a pretend module, thFAKE, we keep them safely out of the way.

560
561
	; avails <- getLocalDeclBinders gbl_env1 group
        ; let names = concatMap availNames avails
562
563
564
565

	; let new_occs = map nameOccName names
	      trimmed_rdr_env = hideSomeUnquals (tcg_rdr_env gbl_env) new_occs

566
	; rdr_env' <- extendRdrEnvRn trimmed_rdr_env avails
567
	-- In this situation we want to *shadow* top-level bindings.
568
569
	--	foo = 1
	--	bar = [d| foo = 1|]
570
571
572
573
574
575
576
577
578
579
	-- If we don't shadow, we'll get an ambiguity complaint when we do 
	-- a lookupTopBndrRn (which uses lookupGreLocalRn) on the binder of the 'foo'
	--
	-- Furthermore, arguably if the splice does define foo, that should hide
	-- any foo's further out
	--
	-- The shadowing is acheived by the call to hideSomeUnquals, which removes
	-- the unqualified bindings of things defined by the bracket

	; setGblEnv (gbl_env { tcg_rdr_env = rdr_env',
580
581
582
583
584
585
			       tcg_dus = emptyDUs }) $ do
		-- The emptyDUs is so that we just collect uses for this group alone

	{ (tcg_env, group') <- rnSrcDecls group
		-- Discard the tcg_env; it contains only extra info about fixity
	; return (DecBr group', allUses (tcg_dus tcg_env)) } }
586
587
\end{code}

588
589
%************************************************************************
%*									*
590
\subsubsection{@Stmt@s: in @do@ expressions}
591
592
593
594
%*									*
%************************************************************************

\begin{code}
595
596
597
rnStmts :: HsStmtContext Name -> [LStmt RdrName] 
	-> RnM (thing, FreeVars)
	-> RnM (([LStmt Name], thing), FreeVars)
598

599
600
rnStmts (MDoExpr _) = rnMDoStmts
rnStmts ctxt        = rnNormalStmts ctxt
601

602
603
604
rnNormalStmts :: HsStmtContext Name -> [LStmt RdrName]
	      -> RnM (thing, FreeVars)
	      -> RnM (([LStmt Name], thing), FreeVars)	
605
606
607
-- Used for cases *other* than recursive mdo
-- Implements nested scopes

608
609
610
rnNormalStmts ctxt [] thing_inside 
  = do	{ (thing, fvs) <- thing_inside
	; return (([],thing), fvs) } 
611

612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
rnNormalStmts ctxt (L loc stmt : stmts) thing_inside
  = do	{ ((stmt', (stmts', thing)), fvs) 
		<- rnStmt ctxt stmt 	$
		   rnNormalStmts ctxt stmts thing_inside
	; return (((L loc stmt' : stmts'), thing), fvs) }
    
rnStmt :: HsStmtContext Name -> Stmt RdrName
       -> RnM (thing, FreeVars)
       -> RnM ((Stmt Name, thing), FreeVars)

rnStmt ctxt (ExprStmt expr _ _) thing_inside
  = do	{ (expr', fv_expr) <- rnLExpr expr
	; (then_op, fvs1)  <- lookupSyntaxName thenMName
	; (thing, fvs2)    <- thing_inside
	; return ((ExprStmt expr' then_op placeHolderType, thing),
		  fv_expr `plusFV` fvs1 `plusFV` fvs2) }

rnStmt ctxt (BindStmt pat expr _ _) thing_inside
  = do	{ (expr', fv_expr) <- rnLExpr expr
		-- The binders do not scope over the expression
	; (bind_op, fvs1) <- lookupSyntaxName bindMName
	; (fail_op, fvs2) <- lookupSyntaxName failMName
634
	; rnPatsAndThen (StmtCtxt ctxt) [pat] $ \ [pat'] -> do
635
636
637
	{ (thing, fvs3) <- thing_inside
	; return ((BindStmt pat' expr' bind_op fail_op, thing),
		  fv_expr `plusFV` fvs1 `plusFV` fvs2 `plusFV` fvs3) }}
638
639
	-- fv_expr shouldn't really be filtered by the rnPatsAndThen
	-- but it does not matter because the names are unique
640
641

rnStmt ctxt (LetStmt binds) thing_inside
642
643
644
  = do	{ checkErr (ok ctxt binds) 
		   (badIpBinds (ptext SLIT("a parallel list comprehension:")) binds)
	; rnLocalBindsAndThen binds		$ \ binds' -> do
645
646
	{ (thing, fvs) <- thing_inside
	; return ((LetStmt binds', thing), fvs) }}
647
648
649
  where
	-- We do not allow implicit-parameter bindings in a parallel
	-- list comprehension.  I'm not sure what it might mean.
650
651
    ok (ParStmtCtxt _) (HsIPBinds _) = False
    ok _	       _	     = True
652

653
rnStmt ctxt (RecStmt rec_stmts _ _ _ _) thing_inside
654
655
  = bindLocatedLocalsRn doc (collectLStmtsBinders rec_stmts)	$ \ bndrs ->
    rn_rec_stmts bndrs rec_stmts	`thenM` \ segs ->
656
    thing_inside 			`thenM` \ (thing, fvs) ->
657
658
659
660
661
662
    let
	segs_w_fwd_refs     	 = addFwdRefs segs
	(ds, us, fs, rec_stmts') = unzip4 segs_w_fwd_refs
	later_vars = nameSetToList (plusFVs ds `intersectNameSet` fvs)
	fwd_vars   = nameSetToList (plusFVs fs)
	uses	   = plusFVs us
663
	rec_stmt   = RecStmt rec_stmts' later_vars fwd_vars [] emptyLHsBinds
664
    in	
665
    returnM ((rec_stmt, thing), uses `plusFV` fvs)
666
667
  where
    doc = text "In a recursive do statement"
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692

rnStmt ctxt (ParStmt segs) thing_inside
  = do	{ opt_GlasgowExts <- doptM Opt_GlasgowExts
	; checkM opt_GlasgowExts parStmtErr
 	; orig_lcl_env <- getLocalRdrEnv
	; ((segs',thing), fvs) <- go orig_lcl_env [] segs
	; return ((ParStmt segs', thing), fvs) }
  where
--  type ParSeg id = [([LStmt id], [id])]
--  go :: NameSet -> [ParSeg RdrName]
--       -> RnM (([ParSeg Name], thing), FreeVars)

    go orig_lcl_env bndrs [] 
	= do { let { (bndrs', dups) = removeDups cmpByOcc bndrs
		   ; inner_env = extendLocalRdrEnv orig_lcl_env bndrs' }
	     ; mappM dupErr dups
	     ; (thing, fvs) <- setLocalRdrEnv inner_env thing_inside
	     ; return (([], thing), fvs) }

    go orig_lcl_env bndrs_so_far ((stmts, _) : segs)
	= do { ((stmts', (bndrs, segs', thing)), fvs)
		  <- rnNormalStmts par_ctxt stmts $ do
		     { 	-- Find the Names that are bound by stmts
		       lcl_env <- getLocalRdrEnv
		     ; let { rdr_bndrs = collectLStmtsBinders stmts
693
		     	   ; bndrs = map ( expectJust "rnStmt"
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
		     		         . lookupLocalRdrEnv lcl_env
		     		         . unLoc) rdr_bndrs
		           ; new_bndrs = nub bndrs ++ bndrs_so_far 
				-- The nub is because there might be shadowing
				--	x <- e1; x <- e2
				-- So we'll look up (Unqual x) twice, getting
				-- the second binding both times, which is the
			}	-- one we want

			-- Typecheck the thing inside, passing on all
			-- the Names bound, but separately; revert the envt
		     ; ((segs', thing), fvs) <- setLocalRdrEnv orig_lcl_env $
						go orig_lcl_env new_bndrs segs

			-- Figure out which of the bound names are used
		     ; let used_bndrs = filter (`elemNameSet` fvs) bndrs
		     ; return ((used_bndrs, segs', thing), fvs) }

	     ; let seg' = (stmts', bndrs)
	     ; return (((seg':segs'), thing), 
		       delListFromNameSet fvs bndrs) }

    par_ctxt = ParStmtCtxt ctxt

    cmpByOcc n1 n2 = nameOccName n1 `compare` nameOccName n2
    dupErr vs = addErr (ptext SLIT("Duplicate binding in parallel list comprehension for:")
		        <+> quotes (ppr (head vs)))
721
722
723
724
725
\end{code}


%************************************************************************
%*									*
726
\subsubsection{mdo expressions}
727
728
%*									*
%************************************************************************
729

730
\begin{code}
731
type FwdRefs = NameSet
732
733
734
type Segment stmts = (Defs,
		      Uses, 	-- May include defs
		      FwdRefs,	-- A subset of uses that are 
735
736
				--   (a) used before they are bound in this segment, or 
				--   (b) used here, and bound in subsequent segments
737
738
		      stmts)	-- Either Stmt or [Stmt]

739

740
----------------------------------------------------
741
742
743
744
rnMDoStmts :: [LStmt RdrName]
	   -> RnM (thing, FreeVars)
	   -> RnM (([LStmt Name], thing), FreeVars)	
rnMDoStmts stmts thing_inside
745
  = 	-- Step1: bring all the binders of the mdo into scope
746
747
	-- Remember that this also removes the binders from the
	-- finally-returned free-vars
748
    bindLocatedLocalsRn doc (collectLStmtsBinders stmts)	$ \ bndrs ->
749
    do	{ 
750
751
752
753
	-- Step 2: Rename each individual stmt, making a
	--	   singleton segment.  At this stage the FwdRefs field
	--	   isn't finished: it's empty for all except a BindStmt
	--	   for which it's the fwd refs within the bind itself
754
755
	-- 	   (This set may not be empty, because we're in a recursive 
	--	    context.)
756
	  segs <- rn_rec_stmts bndrs stmts
757
758
759
760

	; (thing, fvs_later) <- thing_inside

	; let
761
762
763
764
	-- Step 3: Fill in the fwd refs.
	-- 	   The segments are all singletons, but their fwd-ref
	--	   field mentions all the things used by the segment
	--	   that are bound after their use
765
	    segs_w_fwd_refs = addFwdRefs segs
766
767
768
769

	-- Step 4: Group together the segments to make bigger segments
	--	   Invariant: in the result, no segment uses a variable
	--	   	      bound in a later segment
770
	    grouped_segs = glomSegments segs_w_fwd_refs
771
772
773
774
775
776

	-- Step 5: Turn the segments into Stmts
	--	   Use RecStmt when and only when there are fwd refs
	--	   Also gather up the uses from the end towards the
	--	   start, so we can tell the RecStmt which things are
	--	   used 'after' the RecStmt
777
	    (stmts', fvs) = segsToStmts grouped_segs fvs_later
778

779
780
	; return ((stmts', thing), fvs) }
  where
781
    doc = text "In a recursive mdo-expression"
782

783
784
785
786
---------------------------------------------
rn_rec_stmts :: [Name] -> [LStmt RdrName] -> RnM [Segment (LStmt Name)]
rn_rec_stmts bndrs stmts = mappM (rn_rec_stmt bndrs) stmts	`thenM` \ segs_s ->
		   	   returnM (concat segs_s)
787

788
----------------------------------------------------
789
rn_rec_stmt :: [Name] -> LStmt RdrName -> RnM [Segment (LStmt Name)]
790
	-- Rename a Stmt that is inside a RecStmt (or mdo)
791
792
793
	-- Assumes all binders are already in scope
	-- Turns each stmt into a singleton Stmt

794
rn_rec_stmt all_bndrs (L loc (ExprStmt expr _ _))
795
  = rnLExpr expr 		`thenM` \ (expr', fvs) ->
796
797
798
    lookupSyntaxName thenMName	`thenM` \ (then_op, fvs1) ->
    returnM [(emptyNameSet, fvs `plusFV` fvs1, emptyNameSet,
	      L loc (ExprStmt expr' then_op placeHolderType))]
799

800
rn_rec_stmt all_bndrs (L loc (BindStmt pat expr _ _))
801
  = rnLExpr expr		`thenM` \ (expr', fv_expr) ->
802
803
804
    rnLPat pat			`thenM` \ (pat', fv_pat) ->
    lookupSyntaxName bindMName	`thenM` \ (bind_op, fvs1) ->
    lookupSyntaxName failMName	`thenM` \ (fail_op, fvs2) ->
805
806
    let
	bndrs = mkNameSet (collectPatBinders pat')
807
	fvs   = fv_expr `plusFV` fv_pat `plusFV` fvs1 `plusFV` fvs2
808
    in
809
    returnM [(bndrs, fvs, bndrs `intersectNameSet` fvs,
810
	      L loc (BindStmt pat' expr' bind_op fail_op))]
811

812
813
814
815
816
817
rn_rec_stmt all_bndrs (L loc (LetStmt binds@(HsIPBinds _)))
  = do	{ addErr (badIpBinds (ptext SLIT("an mdo expression")) binds)
	; failM }

rn_rec_stmt all_bndrs (L loc (LetStmt (HsValBinds binds)))
  = rnValBinds (trimWith all_bndrs) binds	`thenM` \ (binds', du_binds) ->
818
    returnM [(duDefs du_binds, duUses du_binds, 
819
	      emptyNameSet, L loc (LetStmt (HsValBinds binds')))]
820

821
822
rn_rec_stmt all_bndrs (L loc (RecStmt stmts _ _ _ _))	-- Flatten Rec inside Rec
  = rn_rec_stmts all_bndrs stmts
823

824
rn_rec_stmt all_bndrs stmt@(L _ (ParStmt _))	-- Syntactically illegal in mdo
825
  = pprPanic "rn_rec_stmt" (ppr stmt)
826

827
828
---------------------------------------------
addFwdRefs :: [Segment a] -> [Segment a]
829
830
831
832
833
834
835
-- So far the segments only have forward refs *within* the Stmt
-- 	(which happens for bind:  x <- ...x...)
-- This function adds the cross-seg fwd ref info

addFwdRefs pairs 
  = fst (foldr mk_seg ([], emptyNameSet) pairs)
  where
836
    mk_seg (defs, uses, fwds, stmts) (segs, later_defs)
837
838
839
	= (new_seg : segs, all_defs)
	where
	  new_seg = (defs, uses, new_fwds, stmts)
840
841
	  all_defs = later_defs `unionNameSets` defs
	  new_fwds = fwds `unionNameSets` (uses `intersectNameSet` later_defs)
842
843
844
		-- Add the downstream fwd refs here

----------------------------------------------------
845
846
847
848
849
-- 	Glomming the singleton segments of an mdo into 
--	minimal recursive groups.
--
-- At first I thought this was just strongly connected components, but
-- there's an important constraint: the order of the stmts must not change.
850
851
852
853
854
855
856
857
858
--
-- Consider
--	mdo { x <- ...y...
--	      p <- z
--	      y <- ...x...
--	      q <- x
--	      z <- y
--	      r <- x }
--
859
860
861
862
863
-- Here, the first stmt mention 'y', which is bound in the third.  
-- But that means that the innocent second stmt (p <- z) gets caught
-- up in the recursion.  And that in turn means that the binding for
-- 'z' has to be included... and so on.
--
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
-- Start at the tail { r <- x }
-- Now add the next one { z <- y ; r <- x }
-- Now add one more     { q <- x ; z <- y ; r <- x }
-- Now one more... but this time we have to group a bunch into rec
--	{ rec { y <- ...x... ; q <- x ; z <- y } ; r <- x }
-- Now one more, which we can add on without a rec
--	{ p <- z ; 
--	  rec { y <- ...x... ; q <- x ; z <- y } ; 
-- 	  r <- x }
-- Finally we add the last one; since it mentions y we have to
-- glom it togeher with the first two groups
--	{ rec { x <- ...y...; p <- z ; y <- ...x... ; 
--		q <- x ; z <- y } ; 
-- 	  r <- x }

879
glomSegments :: [Segment (LStmt Name)] -> [Segment [LStmt Name]]
880

881
882
glomSegments [] = []
glomSegments ((defs,uses,fwds,stmt) : segs)
883
884
885
886
887
888
889
890
891
892
	-- Actually stmts will always be a singleton
  = (seg_defs, seg_uses, seg_fwds, seg_stmts)  : others
  where
    segs'	     = glomSegments segs
    (extras, others) = grab uses segs'
    (ds, us, fs, ss) = unzip4 extras
    
    seg_defs  = plusFVs ds `plusFV` defs
    seg_uses  = plusFVs us `plusFV` uses
    seg_fwds  = plusFVs fs `plusFV` fwds
893
    seg_stmts = stmt : concat ss
894
895

    grab :: NameSet	 	-- The client
896
897
898
	 -> [Segment a]
	 -> ([Segment a],	-- Needed by the 'client'
	     [Segment a])	-- Not needed by the client
899
900
901
902
903
904
905
906
907
	-- The result is simply a split of the input
    grab uses dus 
	= (reverse yeses, reverse noes)
	where
	  (noes, yeses) 	  = span not_needed (reverse dus)
	  not_needed (defs,_,_,_) = not (intersectsNameSet defs uses)


----------------------------------------------------
908
909
910
segsToStmts :: [Segment [LStmt Name]] 
	    -> FreeVars			-- Free vars used 'later'
	    -> ([LStmt Name], FreeVars)
911

912
913
segsToStmts [] fvs_later = ([], fvs_later)
segsToStmts ((defs, uses, fwds, ss) : segs) fvs_later
914
915
  = ASSERT( not (null ss) )
    (new_stmt : later_stmts, later_uses `plusFV` uses)
916
  where
917
    (later_stmts, later_uses) = segsToStmts segs fvs_later
918
    new_stmt | non_rec	 = head ss
919
	     | otherwise = L (getLoc (head ss)) $ 
920
921
			   RecStmt ss (nameSetToList used_later) (nameSetToList fwds) 
				      [] emptyLHsBinds
922
	     where
923
924
925
	       non_rec    = isSingleton ss && isEmptyNameSet fwds
	       used_later = defs `intersectNameSet` later_uses
				-- The ones needed after the RecStmt
926
927
\end{code}

928
929
%************************************************************************
%*									*
mnislaih's avatar
mnislaih committed
930
\subsubsection{Assertion utils}
931
932
933
934
%*									*
%************************************************************************

\begin{code}
935
936
srcSpanPrimLit :: SrcSpan -> HsExpr Name
srcSpanPrimLit span = HsLit (HsStringPrim (mkFastString (showSDoc (ppr span))))
937

938
mkAssertErrorExpr :: RnM (HsExpr Name, FreeVars)
939
940
-- Return an expression for (assertError "Foo.hs:27")
mkAssertErrorExpr
941
  = getSrcSpanM    			`thenM` \ sloc ->
942
    let
943
	expr = HsApp (L sloc (HsVar assertErrorName)) 
944
		     (L sloc (srcSpanPrimLit sloc))
945
    in
946
    returnM (expr, emptyFVs)
sof's avatar
sof committed
947
\end{code}
948
949
950
951
952
953
954

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

955
\begin{code}
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
956
957
958
patSynErr e = do { addErr (sep [ptext SLIT("Pattern syntax in expression context:"),
			 	nest 4 (ppr e)])
		 ; return (EWildPat, emptyFVs) }
959

sof's avatar
sof committed
960
parStmtErr = addErr (ptext SLIT("Illegal parallel list comprehension: use -fglasgow-exts"))
961

962
963
964
badIpBinds what binds
  = hang (ptext SLIT("Implicit-parameter bindings illegal in") <+> what)
	 2 (ppr binds)
965
\end{code}
mnislaih's avatar
mnislaih committed
966
967