2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1994
4 \section[RenameExpr]{Renaming of expressions}
6 Basically dependency analysis.
8 Handles @Match@, @GRHSsAndBinds@, @Expr@, and @Qual@ datatypes. In
9 general, all of these functions return a renamed thing, and a set of
13 #include "HsVersions.h"
16 rnMatch4, rnGRHSsAndBinds4, rnPat4,
18 -- and to make the interface self-sufficient...
19 Bag, GRHSsAndBinds, InPat, Name, Maybe,
20 ProtoName, GlobalNameFun(..), UniqSet(..), UniqFM, SrcLoc,
21 Unique, SplitUniqSupply,
22 Pretty(..), PprStyle, PrettyRep
26 import NameTypes ( FullName )
28 import ProtoName ( ProtoName(..) )
29 import Rename4 ( rnPolyType4 )
30 import RenameAuxFuns ( GlobalNameFuns(..) ) -- ToDo: rm this line
31 import RenameBinds4 ( rnBinds4, FreeVars(..) )
38 *********************************************************
42 *********************************************************
45 rnPat4 :: ProtoNamePat -> Rn4M RenamedPat
47 rnPat4 WildPatIn = returnRn4 WildPatIn
49 rnPat4 (VarPatIn name)
50 = lookupValue name `thenRn4` \ vname ->
51 returnRn4 (VarPatIn vname)
53 rnPat4 (LitPatIn n) = returnRn4 (LitPatIn n)
55 rnPat4 (LazyPatIn pat)
56 = rnPat4 pat `thenRn4` \ pat' ->
57 returnRn4 (LazyPatIn pat')
59 rnPat4 (AsPatIn name pat)
60 = rnPat4 pat `thenRn4` \ pat' ->
61 lookupValue name `thenRn4` \ vname ->
62 returnRn4 (AsPatIn vname pat')
64 rnPat4 (ConPatIn name pats)
65 = lookupValue name `thenRn4` \ name' ->
66 mapRn4 rnPat4 pats `thenRn4` \ patslist ->
67 returnRn4 (ConPatIn name' patslist)
69 rnPat4 (ConOpPatIn pat1 name pat2)
70 = lookupValue name `thenRn4` \ name' ->
71 rnPat4 pat1 `thenRn4` \ pat1' ->
72 rnPat4 pat2 `thenRn4` \ pat2' ->
73 returnRn4 (ConOpPatIn pat1' name' pat2')
75 rnPat4 (ListPatIn pats)
76 = mapRn4 rnPat4 pats `thenRn4` \ patslist ->
77 returnRn4 (ListPatIn patslist)
79 rnPat4 (TuplePatIn pats)
80 = mapRn4 rnPat4 pats `thenRn4` \ patslist ->
81 returnRn4 (TuplePatIn patslist)
83 rnPat4 (NPlusKPatIn name lit)
84 = lookupValue name `thenRn4` \ vname ->
85 returnRn4 (NPlusKPatIn vname lit)
88 rnPat4 (ProcessorPatIn pats pat)
89 = mapRn4 rnPat4 pats `thenRn4` \ pats' ->
90 rnPat4 pat `thenRn4` \ pat' ->
91 returnRn4 (ProcessorPatIn pats' pat')
92 #endif {- Data Parallel Haskell -}
95 ************************************************************************
99 ************************************************************************
102 rnMatch4 :: ProtoNameMatch -> Rn4M (RenamedMatch, FreeVars)
105 = getSrcLocRn4 `thenRn4` \ src_loc ->
106 namesFromProtoNames "variable in pattern"
107 (binders `zip` repeat src_loc) `thenRn4` \ new_binders ->
108 extendSS2 new_binders (rnMatch4_aux match)
110 binders = collect_binders match
112 collect_binders :: ProtoNameMatch -> [ProtoName]
114 collect_binders (GRHSMatch _) = []
115 collect_binders (PatMatch pat match)
116 = collectPatBinders pat ++ collect_binders match
118 rnMatch4_aux (PatMatch pat match)
119 = rnPat4 pat `thenRn4` \ pat' ->
120 rnMatch4_aux match `thenRn4` \ (match', fvMatch) ->
121 returnRn4 (PatMatch pat' match', fvMatch)
123 rnMatch4_aux (GRHSMatch grhss_and_binds)
124 = rnGRHSsAndBinds4 grhss_and_binds `thenRn4` \ (grhss_and_binds', fvs) ->
125 returnRn4 (GRHSMatch grhss_and_binds', fvs)
128 %************************************************************************
130 \subsubsection[dep-GRHSs]{Guarded right-hand sides (GRHSsAndBinds)}
132 %************************************************************************
135 rnGRHSsAndBinds4 :: ProtoNameGRHSsAndBinds -> Rn4M (RenamedGRHSsAndBinds, FreeVars)
137 rnGRHSsAndBinds4 (GRHSsAndBindsIn grhss binds)
138 = rnBinds4 binds `thenRn4` \ (binds', fvBinds, scope) ->
139 extendSS2 scope (rnGRHSs4 grhss) `thenRn4` \ (grhss', fvGRHS) ->
140 returnRn4 (GRHSsAndBindsIn grhss' binds', fvBinds `unionUniqSets` fvGRHS)
142 rnGRHSs4 [] = returnRn4 ([], emptyUniqSet)
144 rnGRHSs4 (grhs:grhss)
145 = rnGRHS4 grhs `thenRn4` \ (grhs', fvs) ->
146 rnGRHSs4 grhss `thenRn4` \ (grhss', fvss) ->
147 returnRn4 (grhs' : grhss', fvs `unionUniqSets` fvss)
149 rnGRHS4 (GRHS guard expr locn)
150 = pushSrcLocRn4 locn (
151 rnExpr4 guard `thenRn4` \ (guard', fvsg) ->
152 rnExpr4 expr `thenRn4` \ (expr', fvse) ->
153 returnRn4 (GRHS guard' expr' locn, fvsg `unionUniqSets` fvse)
156 rnGRHS4 (OtherwiseGRHS expr locn)
157 = pushSrcLocRn4 locn (
158 rnExpr4 expr `thenRn4` \ (expr', fvs) ->
159 returnRn4 (OtherwiseGRHS expr' locn, fvs)
163 %************************************************************************
165 \subsubsection[dep-Expr]{Expressions}
167 %************************************************************************
170 rnExprs4 :: [ProtoNameExpr] -> Rn4M ([RenamedExpr], FreeVars)
172 rnExprs4 [] = returnRn4 ([], emptyUniqSet)
174 rnExprs4 (expr:exprs)
175 = rnExpr4 expr `thenRn4` \ (expr', fvExpr) ->
176 rnExprs4 exprs `thenRn4` \ (exprs', fvExprs) ->
177 returnRn4 (expr':exprs', fvExpr `unionUniqSets` fvExprs)
180 Variables. We look up the variable and return the resulting name. The
181 interesting question is what the free-variable set should be. We
182 don't want to return imported or prelude things as free vars. So we
183 look at the Name returned from the lookup, and make it part of the
189 or it's an @OtherTopId@ and it's defined in this module
190 (this includes locally-defined constructrs, but that's too bad)
194 rnExpr4 :: ProtoNameExpr -> Rn4M (RenamedExpr, FreeVars)
197 = lookupValue v `thenRn4` \ vname ->
198 returnRn4 (Var vname, fv_set vname)
200 fv_set n@(Short uniq sname) = singletonUniqSet n
201 fv_set n@(OtherTopId uniq fname)
202 | isLocallyDefined fname
203 && not (isConop (getOccurrenceName fname))
205 fv_set other = emptyUniqSet
207 rnExpr4 (Lit lit) = returnRn4 (Lit lit, emptyUniqSet)
210 = rnMatch4 match `thenRn4` \ (match', fvMatch) ->
211 returnRn4 (Lam match', fvMatch)
213 rnExpr4 (App fun arg)
214 = rnExpr4 fun `thenRn4` \ (fun',fvFun) ->
215 rnExpr4 arg `thenRn4` \ (arg',fvArg) ->
216 returnRn4 (App fun' arg', fvFun `unionUniqSets` fvArg)
218 rnExpr4 (OpApp e1 op e2)
219 = rnExpr4 e1 `thenRn4` \ (e1', fvs_e1) ->
220 rnExpr4 op `thenRn4` \ (op', fvs_op) ->
221 rnExpr4 e2 `thenRn4` \ (e2', fvs_e2) ->
222 returnRn4 (OpApp e1' op' e2', (fvs_op `unionUniqSets` fvs_e1) `unionUniqSets` fvs_e2)
224 rnExpr4 (SectionL expr op)
225 = rnExpr4 expr `thenRn4` \ (expr', fvs_expr) ->
226 rnExpr4 op `thenRn4` \ (op', fvs_op) ->
227 returnRn4 (SectionL expr' op', fvs_op `unionUniqSets` fvs_expr)
229 rnExpr4 (SectionR op expr)
230 = rnExpr4 op `thenRn4` \ (op', fvs_op) ->
231 rnExpr4 expr `thenRn4` \ (expr', fvs_expr) ->
232 returnRn4 (SectionR op' expr', fvs_op `unionUniqSets` fvs_expr)
234 rnExpr4 (CCall fun args may_gc is_casm fake_result_ty)
235 = rnExprs4 args `thenRn4` \ (args', fvs_args) ->
236 returnRn4 (CCall fun args' may_gc is_casm fake_result_ty, fvs_args)
238 rnExpr4 (SCC label expr)
239 = rnExpr4 expr `thenRn4` \ (expr', fvs_expr) ->
240 returnRn4 (SCC label expr', fvs_expr)
242 rnExpr4 (Case expr ms)
243 = rnExpr4 expr `thenRn4` \ (new_expr, e_fvs) ->
244 mapAndUnzipRn4 rnMatch4 ms `thenRn4` \ (new_ms, ms_fvs) ->
245 returnRn4 (Case new_expr new_ms, unionManyUniqSets (e_fvs : ms_fvs))
247 rnExpr4 (ListComp expr quals)
248 = rnQuals4 quals `thenRn4` \ ((quals', qual_binders), fvQuals) ->
249 extendSS2 qual_binders (rnExpr4 expr) `thenRn4` \ (expr', fvExpr) ->
250 returnRn4 (ListComp expr' quals', fvExpr `unionUniqSets` fvQuals)
252 rnExpr4 (Let binds expr)
253 = rnBinds4 binds `thenRn4` \ (binds', fvBinds, new_binders) ->
254 extendSS2 new_binders (rnExpr4 expr) `thenRn4` \ (expr',fvExpr) ->
255 returnRn4 (Let binds' expr', fvBinds `unionUniqSets` fvExpr)
257 rnExpr4 (ExplicitList exps)
258 = rnExprs4 exps `thenRn4` \ (exps', fvs) ->
259 returnRn4 (ExplicitList exps', fvs)
261 rnExpr4 (ExplicitTuple exps)
262 = rnExprs4 exps `thenRn4` \ (exps', fvExps) ->
263 returnRn4 (ExplicitTuple exps', fvExps)
265 rnExpr4 (ExprWithTySig expr pty)
266 = rnExpr4 expr `thenRn4` \ (expr', fvExpr) ->
267 rnPolyType4 False True nullTyVarNamesEnv pty `thenRn4` \ pty' ->
268 returnRn4 (ExprWithTySig expr' pty', fvExpr)
271 = rnExpr4 p `thenRn4` \ (p', fvP) ->
272 rnExpr4 b1 `thenRn4` \ (b1', fvB1) ->
273 rnExpr4 b2 `thenRn4` \ (b2', fvB2) ->
274 returnRn4 (If p' b1' b2', unionManyUniqSets [fvP, fvB1, fvB2])
276 rnExpr4 (ArithSeqIn seq)
277 = rn_seq seq `thenRn4` \ (new_seq, fvs) ->
278 returnRn4 (ArithSeqIn new_seq, fvs)
281 = rnExpr4 expr `thenRn4` \ (expr', fvExpr) ->
282 returnRn4 (From expr', fvExpr)
284 rn_seq (FromThen expr1 expr2)
285 = rnExpr4 expr1 `thenRn4` \ (expr1', fvExpr1) ->
286 rnExpr4 expr2 `thenRn4` \ (expr2', fvExpr2) ->
287 returnRn4 (FromThen expr1' expr2', fvExpr1 `unionUniqSets` fvExpr2)
289 rn_seq (FromTo expr1 expr2)
290 = rnExpr4 expr1 `thenRn4` \ (expr1', fvExpr1) ->
291 rnExpr4 expr2 `thenRn4` \ (expr2', fvExpr2) ->
292 returnRn4 (FromTo expr1' expr2', fvExpr1 `unionUniqSets` fvExpr2)
294 rn_seq (FromThenTo expr1 expr2 expr3)
295 = rnExpr4 expr1 `thenRn4` \ (expr1', fvExpr1) ->
296 rnExpr4 expr2 `thenRn4` \ (expr2', fvExpr2) ->
297 rnExpr4 expr3 `thenRn4` \ (expr3', fvExpr3) ->
298 returnRn4 (FromThenTo expr1' expr2' expr3',
299 unionManyUniqSets [fvExpr1, fvExpr2, fvExpr3])
302 rnExpr4 (ParallelZF expr quals)
303 = rnParQuals4 quals `thenRn4` \ ((quals',binds),fvQuals)->
305 (rnExpr4 expr) `thenRn4` \ (expr', fvExpr ) ->
306 returnRn4 (ParallelZF expr' quals' , fvExpr `unionUniqSets` fvQuals)
308 rnExpr4 (ExplicitProcessor exprs expr)
309 = rnExprs4 exprs `thenRn4` \ (exprs',fvExprs) ->
310 rnExpr4 expr `thenRn4` \ (expr' ,fvExpr) ->
311 returnRn4 (ExplicitProcessor exprs' expr',fvExprs `unionUniqSets` fvExpr)
313 rnExpr4 (ExplicitPodIn exprs)
314 = rnExprs4 exprs `thenRn4` \ (exprs',fvExprs) ->
315 returnRn4 (ExplicitPodIn exprs',fvExprs)
317 -- ExplicitPodOut : not in ProtoNameExprs (pops out of typechecker :-)
319 #endif {- Data Parallel Haskell -}
321 -- ArithSeqOut: not in ProtoNameExprs
324 %************************************************************************
326 \subsubsection[dep-Quals]{@Qual@s: in list comprehensions}
328 %************************************************************************
330 Note that although some bound vars may appear in the free var set for
331 the first qual, these will eventually be removed by the caller. For
332 example, if we have @[p | r <- s, q <- r, p <- q]@, when doing
333 @(AndQuals (q <- r) (p <- q))@, the free var set for @(q <- r)@ will
334 be @[r]@, and the free var set for the entire Quals will be @[r]@. This
335 @r@ will be removed only when we finally return from examining all the
339 rnQuals4 :: [ProtoNameQual] -> Rn4M (([RenamedQual], [Name]), FreeVars)
342 = rnQual4 qual `thenRn4` \ ((new_qual, bs), fvs) ->
343 returnRn4 (([new_qual], bs), fvs)
345 rnQuals4 (qual: quals)
346 = rnQual4 qual `thenRn4` \ ((qual', bs1), fvQuals1) ->
347 extendSS2 bs1 (rnQuals4 quals) `thenRn4` \ ((quals', bs2), fvQuals2) ->
349 ((qual' : quals', bs2 ++ bs1), -- The ones on the right (bs2) shadow the
350 -- ones on the left (bs1)
351 fvQuals1 `unionUniqSets` fvQuals2)
353 rnQual4 (GeneratorQual pat expr)
354 = rnExpr4 expr `thenRn4` \ (expr', fvExpr) ->
356 binders = collectPatBinders pat
358 getSrcLocRn4 `thenRn4` \ src_loc ->
359 namesFromProtoNames "variable in list-comprehension-generator pattern"
360 (binders `zip` repeat src_loc) `thenRn4` \ new_binders ->
361 extendSS new_binders (rnPat4 pat) `thenRn4` \ pat' ->
363 returnRn4 ((GeneratorQual pat' expr', new_binders), fvExpr)
365 rnQual4 (FilterQual expr)
366 = rnExpr4 expr `thenRn4` \ (expr', fvs) ->
367 returnRn4 ((FilterQual expr', []), fvs)
370 %************************************************************************
372 %* Parallel Quals (in Parallel Zf expressions) *
374 %************************************************************************
375 \subsubsection[dep-ParQuals]{ParQuals}
379 rnPats4 :: [ProtoNamePat] -> Rn4M [RenamedPat]
380 rnPats4 [] = returnRn4 []
382 = (rnPat4 pat) `thenRn4` (\ pat' ->
383 (rnPats4 pats) `thenRn4` (\ pats' ->
384 returnRn4 (pat':pats') ))
386 rnParQuals4 :: ProtoNameParQuals -> Rn4M ((RenamedParQuals, [Name]), FreeVars)
388 rnParQuals4 (AndParQuals q1 q2)
389 = rnParQuals4 q1 `thenRn4` (\ ((quals1', bs1), fvQuals1) ->
390 extendSS2 bs1 (rnParQuals4 q2)
391 `thenRn4` (\ ((quals2', bs2), fvQuals2) ->
392 returnRn4 ((AndParQuals quals1' quals2', bs2 ++ bs1),
393 fvQuals1 `unionUniqSets` fvQuals2) ))
396 rnParQuals4 (DrawnGenIn pats pat expr)
397 = rnExpr4 expr `thenRn4` (\ (expr', fvExpr) ->
398 let_1_0 (concat (map collectPatBinders pats)) (\ binders1 ->
399 getSrcLocRn4 `thenRn4` (\ src_loc ->
400 namesFromProtoNames "variable in pattern"
401 (binders1 `zip` repeat src_loc)
402 `thenRn4` (\ binders1' ->
403 extendSS binders1' (rnPats4 pats)
404 `thenRn4` (\ pats' ->
405 let_1_0 (collectPatBinders pat) (\ binders2 ->
406 namesFromProtoNames "variable in pattern"
407 (binders2 `zip` repeat src_loc)
408 `thenRn4` (\ binders2' ->
409 extendSS binders2' (rnPat4 pat)
411 returnRn4 ((DrawnGenIn pats' pat' expr' , binders1' ++ binders2'),
414 rnParQuals4 (IndexGen exprs pat expr)
415 = rnExpr4 expr `thenRn4` (\ (expr', fvExpr) ->
416 rnExprs4 exprs `thenRn4` (\ (exprs', fvExprs) ->
417 let_1_0 (collectPatBinders pat) (\ binders ->
418 getSrcLocRn4 `thenRn4` (\ src_loc ->
419 namesFromProtoNames "variable in pattern"
420 (binders `zip` repeat src_loc)
421 `thenRn4` (\ binders' ->
422 extendSS binders' (rnPat4 pat)
424 returnRn4 ((IndexGen exprs' pat' expr' , binders'),
425 fvExpr `unionUniqSets` fvExprs) ))))))
427 rnParQuals4 (ParFilter expr)
428 = rnExpr4 expr `thenRn4` (\ (expr', fvExpr) ->
429 returnRn4 ((ParFilter expr', []), fvExpr) )
430 #endif {- Data Parallel Haskell -}