[project @ 1996-01-08 20:28:12 by partain]
[ghc.git] / ghc / compiler / rename / RenameExpr4.lhs
1 %
2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1994
3 %
4 \section[RenameExpr]{Renaming of expressions}
5
6 Basically dependency analysis.
7
8 Handles @Match@, @GRHSsAndBinds@, @Expr@, and @Qual@ datatypes.  In
9 general, all of these functions return a renamed thing, and a set of
10 free variables.
11
12 \begin{code}
13 #include "HsVersions.h"
14
15 module RenameExpr4 (
16         rnMatch4, rnGRHSsAndBinds4, rnPat4,
17         
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
23    ) where
24
25 import AbsSyn
26 import NameTypes        ( FullName )
27 import Outputable
28 import ProtoName        ( ProtoName(..) )
29 import Rename4          ( rnPolyType4 )
30 import RenameAuxFuns    ( GlobalNameFuns(..) ) -- ToDo: rm this line
31 import RenameBinds4     ( rnBinds4, FreeVars(..) )
32 import RenameMonad4
33 import UniqSet
34 import Util
35 \end{code}
36
37
38 *********************************************************
39 *                                                       *
40 \subsection{Patterns}
41 *                                                       *
42 *********************************************************
43
44 \begin{code}
45 rnPat4 ::  ProtoNamePat -> Rn4M RenamedPat
46
47 rnPat4  WildPatIn = returnRn4 WildPatIn
48
49 rnPat4 (VarPatIn name)
50   = lookupValue name    `thenRn4` \ vname ->
51     returnRn4 (VarPatIn vname)
52
53 rnPat4  (LitPatIn n) = returnRn4 (LitPatIn n)
54
55 rnPat4  (LazyPatIn pat)
56   = rnPat4  pat `thenRn4` \ pat' ->
57     returnRn4 (LazyPatIn pat')
58
59 rnPat4  (AsPatIn name pat)
60   = rnPat4  pat `thenRn4` \ pat' ->
61     lookupValue name    `thenRn4` \ vname ->
62     returnRn4 (AsPatIn vname pat')
63
64 rnPat4 (ConPatIn name pats)
65   = lookupValue name        `thenRn4` \ name' ->
66     mapRn4 rnPat4 pats  `thenRn4` \ patslist ->
67     returnRn4 (ConPatIn name' patslist)
68
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')
74
75 rnPat4  (ListPatIn pats)
76   = mapRn4 rnPat4 pats `thenRn4` \ patslist ->
77     returnRn4 (ListPatIn patslist)
78
79 rnPat4  (TuplePatIn pats)
80   = mapRn4 rnPat4 pats `thenRn4` \ patslist ->
81     returnRn4 (TuplePatIn patslist)
82
83 rnPat4  (NPlusKPatIn name lit)
84   = lookupValue name    `thenRn4` \ vname ->
85     returnRn4 (NPlusKPatIn vname lit)
86
87 #ifdef DPH
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 -}
93 \end{code}
94
95 ************************************************************************
96 *                                                                       *
97 \subsection{Match}
98 *                                                                       *
99 ************************************************************************
100
101 \begin{code}
102 rnMatch4 :: ProtoNameMatch -> Rn4M (RenamedMatch, FreeVars)
103
104 rnMatch4 match
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)
109   where
110     binders = collect_binders match
111
112     collect_binders :: ProtoNameMatch -> [ProtoName]
113
114     collect_binders (GRHSMatch _) = []
115     collect_binders (PatMatch pat match)
116       = collectPatBinders pat ++ collect_binders match
117
118 rnMatch4_aux (PatMatch pat match)
119   = rnPat4 pat          `thenRn4` \ pat' ->
120     rnMatch4_aux match  `thenRn4` \ (match', fvMatch) ->
121     returnRn4 (PatMatch pat' match', fvMatch)
122
123 rnMatch4_aux (GRHSMatch grhss_and_binds)
124   = rnGRHSsAndBinds4 grhss_and_binds `thenRn4` \ (grhss_and_binds', fvs) ->
125     returnRn4 (GRHSMatch grhss_and_binds', fvs)
126 \end{code}
127
128 %************************************************************************
129 %*                                                                      *
130 \subsubsection[dep-GRHSs]{Guarded right-hand sides (GRHSsAndBinds)}
131 %*                                                                      *
132 %************************************************************************
133
134 \begin{code}
135 rnGRHSsAndBinds4 :: ProtoNameGRHSsAndBinds -> Rn4M (RenamedGRHSsAndBinds, FreeVars)
136
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)
141   where
142     rnGRHSs4 [] = returnRn4 ([], emptyUniqSet)
143
144     rnGRHSs4 (grhs:grhss)
145       = rnGRHS4  grhs   `thenRn4` \ (grhs',  fvs) ->
146         rnGRHSs4 grhss  `thenRn4` \ (grhss', fvss) ->
147         returnRn4 (grhs' : grhss', fvs `unionUniqSets` fvss)
148
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)
154         )
155
156     rnGRHS4 (OtherwiseGRHS expr locn)
157       = pushSrcLocRn4 locn                                (
158         rnExpr4 expr    `thenRn4` \ (expr', fvs) ->
159         returnRn4 (OtherwiseGRHS expr' locn, fvs)
160         )
161 \end{code}
162
163 %************************************************************************
164 %*                                                                      *
165 \subsubsection[dep-Expr]{Expressions}
166 %*                                                                      *
167 %************************************************************************
168
169 \begin{code}
170 rnExprs4 :: [ProtoNameExpr] -> Rn4M ([RenamedExpr], FreeVars)
171
172 rnExprs4 [] = returnRn4 ([], emptyUniqSet)
173
174 rnExprs4 (expr:exprs)
175   = rnExpr4 expr        `thenRn4` \ (expr', fvExpr) ->
176     rnExprs4 exprs      `thenRn4` \ (exprs', fvExprs) ->
177     returnRn4 (expr':exprs', fvExpr `unionUniqSets` fvExprs)
178 \end{code}
179
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
184 free-var set iff:
185 \begin{itemize}
186 \item
187 if it's a @Short@,
188 \item
189 or it's an @OtherTopId@ and it's defined in this module
190 (this includes locally-defined constructrs, but that's too bad)
191 \end{itemize}
192
193 \begin{code}
194 rnExpr4 :: ProtoNameExpr -> Rn4M (RenamedExpr, FreeVars)
195
196 rnExpr4 (Var v)
197   = lookupValue v               `thenRn4` \ vname ->
198     returnRn4 (Var vname, fv_set vname)
199   where
200     fv_set n@(Short uniq sname)     = singletonUniqSet n
201     fv_set n@(OtherTopId uniq fname)
202           | isLocallyDefined fname
203           && not (isConop (getOccurrenceName fname))
204                                     = singletonUniqSet n
205     fv_set other                    = emptyUniqSet
206
207 rnExpr4 (Lit lit)  = returnRn4 (Lit lit, emptyUniqSet)
208
209 rnExpr4 (Lam match)
210   = rnMatch4 match      `thenRn4` \ (match', fvMatch) ->
211     returnRn4 (Lam match', fvMatch)
212
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)
217
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)
223
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)
228
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)
233
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)
237
238 rnExpr4 (SCC label expr)
239   = rnExpr4 expr         `thenRn4` \ (expr', fvs_expr) ->
240     returnRn4 (SCC label expr', fvs_expr)
241
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))
246
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)
251
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)
256
257 rnExpr4 (ExplicitList exps)
258   = rnExprs4 exps        `thenRn4` \ (exps', fvs) ->
259     returnRn4  (ExplicitList exps', fvs)
260
261 rnExpr4 (ExplicitTuple exps)
262   = rnExprs4 exps        `thenRn4` \ (exps', fvExps) ->
263     returnRn4 (ExplicitTuple exps', fvExps)
264
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)
269
270 rnExpr4 (If p b1 b2)
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])
275
276 rnExpr4 (ArithSeqIn seq)
277   = rn_seq seq `thenRn4` \ (new_seq, fvs) ->
278     returnRn4 (ArithSeqIn new_seq, fvs)
279   where
280     rn_seq (From expr)
281      = rnExpr4 expr      `thenRn4` \ (expr', fvExpr) ->
282        returnRn4 (From expr', fvExpr)
283
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)
288
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)
293
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])
300
301 #ifdef DPH
302 rnExpr4 (ParallelZF expr quals)
303   = rnParQuals4 quals     `thenRn4` \ ((quals',binds),fvQuals)->
304     extendSS2  binds 
305                 (rnExpr4 expr) `thenRn4` \ (expr', fvExpr ) ->
306     returnRn4 (ParallelZF expr' quals' , fvExpr `unionUniqSets` fvQuals)
307
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)
312
313 rnExpr4 (ExplicitPodIn exprs)
314   = rnExprs4 exprs      `thenRn4` \ (exprs',fvExprs) ->
315     returnRn4 (ExplicitPodIn exprs',fvExprs)
316
317 -- ExplicitPodOut : not in ProtoNameExprs (pops out of typechecker :-)
318
319 #endif {- Data Parallel Haskell -}
320
321 -- ArithSeqOut: not in ProtoNameExprs
322 \end{code}
323
324 %************************************************************************
325 %*                                                                      *
326 \subsubsection[dep-Quals]{@Qual@s: in list comprehensions}
327 %*                                                                      *
328 %************************************************************************
329
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
336 Quals.
337
338 \begin{code}
339 rnQuals4 :: [ProtoNameQual]  -> Rn4M (([RenamedQual], [Name]), FreeVars)
340
341 rnQuals4 [qual]
342   = rnQual4 qual `thenRn4` \ ((new_qual, bs), fvs) ->
343     returnRn4 (([new_qual], bs), fvs)
344
345 rnQuals4 (qual: quals)
346   = rnQual4 qual                        `thenRn4` \ ((qual',  bs1), fvQuals1) ->
347     extendSS2 bs1 (rnQuals4 quals)      `thenRn4` \ ((quals', bs2), fvQuals2) ->
348     returnRn4
349        ((qual' : quals', bs2 ++ bs1),   -- The ones on the right (bs2) shadow the
350                                         -- ones on the left (bs1)
351         fvQuals1 `unionUniqSets` fvQuals2)
352
353 rnQual4 (GeneratorQual pat expr)
354   = rnExpr4 expr                 `thenRn4` \ (expr', fvExpr) ->
355     let
356         binders = collectPatBinders pat
357     in
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' ->
362
363     returnRn4 ((GeneratorQual pat' expr', new_binders), fvExpr)
364
365 rnQual4 (FilterQual expr)
366   = rnExpr4 expr         `thenRn4` \ (expr', fvs) ->
367     returnRn4 ((FilterQual expr', []), fvs)
368 \end{code}
369
370 %************************************************************************
371 %*                                                                      *
372 %* Parallel Quals (in Parallel Zf expressions)                          *
373 %*                                                                      *
374 %************************************************************************
375 \subsubsection[dep-ParQuals]{ParQuals}
376
377 \begin{code}
378 #ifdef DPH
379 rnPats4 :: [ProtoNamePat] -> Rn4M [RenamedPat]
380 rnPats4 [] = returnRn4 []
381 rnPats4 (pat:pats)
382   = (rnPat4  pat)               `thenRn4` (\ pat'  ->
383     (rnPats4 pats)      `thenRn4` (\ pats' ->
384     returnRn4 (pat':pats') ))
385
386 rnParQuals4 :: ProtoNameParQuals  -> Rn4M ((RenamedParQuals, [Name]), FreeVars)
387
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) ))
394
395         
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)              
410                                 `thenRn4`               (\ pat' ->
411    returnRn4 ((DrawnGenIn pats' pat' expr' , binders1' ++ binders2'),
412                    fvExpr) ))))))))
413    
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)               
423                                 `thenRn4`       (\ pat' ->
424    returnRn4 ((IndexGen exprs' pat' expr' , binders'),
425                    fvExpr `unionUniqSets` fvExprs) ))))))
426
427 rnParQuals4 (ParFilter expr)
428  = rnExpr4 expr  `thenRn4` (\  (expr', fvExpr) ->
429    returnRn4         ((ParFilter expr', []), fvExpr) )
430 #endif {- Data Parallel Haskell -}
431 \end{code}