2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
4 \section[RnExpr]{Renaming of expressions}
6 Basically dependency analysis.
8 Handles @Match@, @GRHSsAndBinds@, @HsExpr@, and @Qual@ datatypes. In
9 general, all of these functions return a renamed thing, and a set of
13 #include "HsVersions.h"
16 rnMatch, rnGRHSsAndBinds, rnPat,
21 import RnLoop -- break the RnPass/RnExpr/RnBinds loops
28 import ErrUtils ( addErrLoc )
29 import Name ( isLocallyDefinedName, pprOp, Name, RdrName )
31 import UniqFM ( lookupUFM )
32 import UniqSet ( emptyUniqSet, unitUniqSet,
33 unionUniqSets, unionManyUniqSets,
35 import Util ( Ord3(..), panic )
39 *********************************************************
43 *********************************************************
46 rnPat :: RdrNamePat -> RnM_Fixes s RenamedPat
48 rnPat WildPatIn = returnRn WildPatIn
51 = lookupValue name `thenRn` \ vname ->
52 returnRn (VarPatIn vname)
54 rnPat (LitPatIn n) = returnRn (LitPatIn n)
57 = rnPat pat `thenRn` \ pat' ->
58 returnRn (LazyPatIn pat')
60 rnPat (AsPatIn name pat)
61 = rnPat pat `thenRn` \ pat' ->
62 lookupValue name `thenRn` \ vname ->
63 returnRn (AsPatIn vname pat')
65 rnPat (ConPatIn name pats)
66 = lookupValue name `thenRn` \ name' ->
67 mapRn rnPat pats `thenRn` \ patslist ->
68 returnRn (ConPatIn name' patslist)
70 rnPat (ConOpPatIn pat1 name pat2)
71 = lookupValue name `thenRn` \ name' ->
72 rnPat pat1 `thenRn` \ pat1' ->
73 rnPat pat2 `thenRn` \ pat2' ->
74 precParsePat (ConOpPatIn pat1' name' pat2')
76 rnPat neg@(NegPatIn pat)
77 = getSrcLocRn `thenRn` \ src_loc ->
78 addErrIfRn (not (valid_neg_pat pat)) (negPatErr neg src_loc)
80 rnPat pat `thenRn` \ pat' ->
81 returnRn (NegPatIn pat')
83 valid_neg_pat (LitPatIn (HsInt _)) = True
84 valid_neg_pat (LitPatIn (HsFrac _)) = True
85 valid_neg_pat _ = False
88 = rnPat pat `thenRn` \ pat' ->
89 returnRn (ParPatIn pat')
91 rnPat (ListPatIn pats)
92 = mapRn rnPat pats `thenRn` \ patslist ->
93 returnRn (ListPatIn patslist)
95 rnPat (TuplePatIn pats)
96 = mapRn rnPat pats `thenRn` \ patslist ->
97 returnRn (TuplePatIn patslist)
99 rnPat (RecPatIn con rpats)
100 = panic "rnPat:RecPatIn"
104 ************************************************************************
108 ************************************************************************
111 rnMatch :: RdrNameMatch -> RnM_Fixes s (RenamedMatch, FreeVars)
114 = getSrcLocRn `thenRn` \ src_loc ->
115 newLocalNames "variable in pattern"
116 (binders `zip` repeat src_loc) `thenRn` \ new_binders ->
117 extendSS2 new_binders (rnMatch_aux match)
119 binders = collect_binders match
121 collect_binders :: RdrNameMatch -> [RdrName]
123 collect_binders (GRHSMatch _) = []
124 collect_binders (PatMatch pat match)
125 = collectPatBinders pat ++ collect_binders match
127 rnMatch_aux (PatMatch pat match)
128 = rnPat pat `thenRn` \ pat' ->
129 rnMatch_aux match `thenRn` \ (match', fvMatch) ->
130 returnRn (PatMatch pat' match', fvMatch)
132 rnMatch_aux (GRHSMatch grhss_and_binds)
133 = rnGRHSsAndBinds grhss_and_binds `thenRn` \ (grhss_and_binds', fvs) ->
134 returnRn (GRHSMatch grhss_and_binds', fvs)
137 %************************************************************************
139 \subsubsection{Guarded right-hand sides (GRHSsAndBinds)}
141 %************************************************************************
144 rnGRHSsAndBinds :: RdrNameGRHSsAndBinds -> RnM_Fixes s (RenamedGRHSsAndBinds, FreeVars)
146 rnGRHSsAndBinds (GRHSsAndBindsIn grhss binds)
147 = rnBinds binds `thenRn` \ (binds', fvBinds, scope) ->
148 extendSS2 scope (rnGRHSs grhss) `thenRn` \ (grhss', fvGRHS) ->
149 returnRn (GRHSsAndBindsIn grhss' binds', fvBinds `unionUniqSets` fvGRHS)
151 rnGRHSs [] = returnRn ([], emptyUniqSet)
154 = rnGRHS grhs `thenRn` \ (grhs', fvs) ->
155 rnGRHSs grhss `thenRn` \ (grhss', fvss) ->
156 returnRn (grhs' : grhss', fvs `unionUniqSets` fvss)
158 rnGRHS (GRHS guard expr locn)
159 = pushSrcLocRn locn $
160 rnExpr guard `thenRn` \ (guard', fvsg) ->
161 rnExpr expr `thenRn` \ (expr', fvse) ->
162 returnRn (GRHS guard' expr' locn, fvsg `unionUniqSets` fvse)
164 rnGRHS (OtherwiseGRHS expr locn)
165 = pushSrcLocRn locn $
166 rnExpr expr `thenRn` \ (expr', fvs) ->
167 returnRn (OtherwiseGRHS expr' locn, fvs)
170 %************************************************************************
172 \subsubsection{Expressions}
174 %************************************************************************
177 rnExprs :: [RdrNameHsExpr] -> RnM_Fixes s ([RenamedHsExpr], FreeVars)
179 rnExprs [] = returnRn ([], emptyUniqSet)
182 = rnExpr expr `thenRn` \ (expr', fvExpr) ->
183 rnExprs exprs `thenRn` \ (exprs', fvExprs) ->
184 returnRn (expr':exprs', fvExpr `unionUniqSets` fvExprs)
187 Variables. We look up the variable and return the resulting name. The
188 interesting question is what the free-variable set should be. We
189 don't want to return imported or prelude things as free vars. So we
190 look at the RnName returned from the lookup, and make it part of the
191 free-var set iff if it's a LocallyDefined RnName.
193 ToDo: what about RnClassOps ???
197 rnExpr :: RdrNameHsExpr -> RnM_Fixes s (RenamedHsExpr, FreeVars)
200 = lookupValue v `thenRn` \ vname ->
201 returnRn (HsVar vname, fv_set vname)
203 fv_set vname@(RnName n)
204 | isLocallyDefinedName n = unitUniqSet vname
205 fv_set _ = emptyUniqSet
208 = returnRn (HsLit lit, emptyUniqSet)
211 = rnMatch match `thenRn` \ (match', fvMatch) ->
212 returnRn (HsLam match', fvMatch)
214 rnExpr (HsApp fun arg)
215 = rnExpr fun `thenRn` \ (fun',fvFun) ->
216 rnExpr arg `thenRn` \ (arg',fvArg) ->
217 returnRn (HsApp fun' arg', fvFun `unionUniqSets` fvArg)
219 rnExpr (OpApp e1 op e2)
220 = rnExpr e1 `thenRn` \ (e1', fvs_e1) ->
221 rnExpr op `thenRn` \ (op', fvs_op) ->
222 rnExpr e2 `thenRn` \ (e2', fvs_e2) ->
223 precParseExpr (OpApp e1' op' e2') `thenRn` \ exp ->
224 returnRn (exp, (fvs_op `unionUniqSets` fvs_e1) `unionUniqSets` fvs_e2)
227 = rnExpr e `thenRn` \ (e', fvs_e) ->
228 returnRn (NegApp e', fvs_e)
231 = rnExpr e `thenRn` \ (e', fvs_e) ->
232 returnRn (HsPar e', fvs_e)
234 rnExpr (SectionL expr op)
235 = rnExpr expr `thenRn` \ (expr', fvs_expr) ->
236 rnExpr op `thenRn` \ (op', fvs_op) ->
237 returnRn (SectionL expr' op', fvs_op `unionUniqSets` fvs_expr)
239 rnExpr (SectionR op expr)
240 = rnExpr op `thenRn` \ (op', fvs_op) ->
241 rnExpr expr `thenRn` \ (expr', fvs_expr) ->
242 returnRn (SectionR op' expr', fvs_op `unionUniqSets` fvs_expr)
244 rnExpr (CCall fun args may_gc is_casm fake_result_ty)
245 = rnExprs args `thenRn` \ (args', fvs_args) ->
246 returnRn (CCall fun args' may_gc is_casm fake_result_ty, fvs_args)
248 rnExpr (HsSCC label expr)
249 = rnExpr expr `thenRn` \ (expr', fvs_expr) ->
250 returnRn (HsSCC label expr', fvs_expr)
252 rnExpr (HsCase expr ms src_loc)
253 = pushSrcLocRn src_loc $
254 rnExpr expr `thenRn` \ (new_expr, e_fvs) ->
255 mapAndUnzipRn rnMatch ms `thenRn` \ (new_ms, ms_fvs) ->
256 returnRn (HsCase new_expr new_ms src_loc, unionManyUniqSets (e_fvs : ms_fvs))
258 rnExpr (HsLet binds expr)
259 = rnBinds binds `thenRn` \ (binds', fvBinds, new_binders) ->
260 extendSS2 new_binders (rnExpr expr) `thenRn` \ (expr',fvExpr) ->
261 returnRn (HsLet binds' expr', fvBinds `unionUniqSets` fvExpr)
263 rnExpr (HsDo stmts src_loc)
264 = pushSrcLocRn src_loc $
265 rnStmts stmts `thenRn` \ (stmts', fvStmts) ->
266 returnRn (HsDo stmts' src_loc, fvStmts)
268 rnExpr (ListComp expr quals)
269 = rnQuals quals `thenRn` \ ((quals', qual_binders), fvQuals) ->
270 extendSS2 qual_binders (rnExpr expr) `thenRn` \ (expr', fvExpr) ->
271 returnRn (ListComp expr' quals', fvExpr `unionUniqSets` fvQuals)
273 rnExpr (ExplicitList exps)
274 = rnExprs exps `thenRn` \ (exps', fvs) ->
275 returnRn (ExplicitList exps', fvs)
277 rnExpr (ExplicitTuple exps)
278 = rnExprs exps `thenRn` \ (exps', fvExps) ->
279 returnRn (ExplicitTuple exps', fvExps)
281 rnExpr (RecordCon con rbinds)
282 = panic "rnExpr:RecordCon"
283 rnExpr (RecordUpd exp rbinds)
284 = panic "rnExpr:RecordUpd"
286 rnExpr (ExprWithTySig expr pty)
287 = rnExpr expr `thenRn` \ (expr', fvExpr) ->
288 rnPolyType nullTyVarNamesEnv pty `thenRn` \ pty' ->
289 returnRn (ExprWithTySig expr' pty', fvExpr)
291 rnExpr (HsIf p b1 b2 src_loc)
292 = pushSrcLocRn src_loc $
293 rnExpr p `thenRn` \ (p', fvP) ->
294 rnExpr b1 `thenRn` \ (b1', fvB1) ->
295 rnExpr b2 `thenRn` \ (b2', fvB2) ->
296 returnRn (HsIf p' b1' b2' src_loc, unionManyUniqSets [fvP, fvB1, fvB2])
298 rnExpr (ArithSeqIn seq)
299 = rn_seq seq `thenRn` \ (new_seq, fvs) ->
300 returnRn (ArithSeqIn new_seq, fvs)
303 = rnExpr expr `thenRn` \ (expr', fvExpr) ->
304 returnRn (From expr', fvExpr)
306 rn_seq (FromThen expr1 expr2)
307 = rnExpr expr1 `thenRn` \ (expr1', fvExpr1) ->
308 rnExpr expr2 `thenRn` \ (expr2', fvExpr2) ->
309 returnRn (FromThen expr1' expr2', fvExpr1 `unionUniqSets` fvExpr2)
311 rn_seq (FromTo expr1 expr2)
312 = rnExpr expr1 `thenRn` \ (expr1', fvExpr1) ->
313 rnExpr expr2 `thenRn` \ (expr2', fvExpr2) ->
314 returnRn (FromTo expr1' expr2', fvExpr1 `unionUniqSets` fvExpr2)
316 rn_seq (FromThenTo expr1 expr2 expr3)
317 = rnExpr expr1 `thenRn` \ (expr1', fvExpr1) ->
318 rnExpr expr2 `thenRn` \ (expr2', fvExpr2) ->
319 rnExpr expr3 `thenRn` \ (expr3', fvExpr3) ->
320 returnRn (FromThenTo expr1' expr2' expr3',
321 unionManyUniqSets [fvExpr1, fvExpr2, fvExpr3])
325 %************************************************************************
327 \subsubsection{@Qual@s: in list comprehensions}
329 %************************************************************************
331 Note that although some bound vars may appear in the free var set for
332 the first qual, these will eventually be removed by the caller. For
333 example, if we have @[p | r <- s, q <- r, p <- q]@, when doing
334 @[q <- r, p <- q]@, the free var set for @q <- r@ will
335 be @{r}@, and the free var set for the entire Quals will be @{r}@. This
336 @r@ will be removed only when we finally return from examining all the
340 rnQuals :: [RdrNameQual]
341 -> RnM_Fixes s (([RenamedQual], -- renamed qualifiers
342 [RnName]), -- qualifiers' binders
343 FreeVars) -- free variables
345 rnQuals [qual] -- must be at least one qual
346 = rnQual qual `thenRn` \ ((new_qual, bs), fvs) ->
347 returnRn (([new_qual], bs), fvs)
349 rnQuals (qual: quals)
350 = rnQual qual `thenRn` \ ((qual', bs1), fvQuals1) ->
351 extendSS2 bs1 (rnQuals quals) `thenRn` \ ((quals', bs2), fvQuals2) ->
353 ((qual' : quals', bs2 ++ bs1), -- The ones on the right (bs2) shadow the
354 -- ones on the left (bs1)
355 fvQuals1 `unionUniqSets` fvQuals2)
357 rnQual (GeneratorQual pat expr)
358 = rnExpr expr `thenRn` \ (expr', fvExpr) ->
360 binders = collectPatBinders pat
362 getSrcLocRn `thenRn` \ src_loc ->
363 newLocalNames "variable in list-comprehension-generator pattern"
364 (binders `zip` repeat src_loc) `thenRn` \ new_binders ->
365 extendSS new_binders (rnPat pat) `thenRn` \ pat' ->
367 returnRn ((GeneratorQual pat' expr', new_binders), fvExpr)
369 rnQual (FilterQual expr)
370 = rnExpr expr `thenRn` \ (expr', fvs) ->
371 returnRn ((FilterQual expr', []), fvs)
373 rnQual (LetQual binds)
374 = rnBinds binds `thenRn` \ (binds', binds_fvs, new_binders) ->
375 returnRn ((LetQual binds', new_binders), binds_fvs)
379 %************************************************************************
381 \subsubsection{@Stmt@s: in @do@ expressions}
383 %************************************************************************
386 rnStmts :: [RdrNameStmt] -> RnM_Fixes s ([RenamedStmt], FreeVars)
388 rnStmts [stmt@(ExprStmt _ _)] -- last stmt must be ExprStmt
389 = rnStmt stmt `thenRn` \ ((stmt',[]), fvStmt) ->
390 returnRn ([stmt'], fvStmt)
393 = rnStmt stmt `thenRn` \ ((stmt',bs), fvStmt) ->
394 extendSS2 bs (rnStmts stmts) `thenRn` \ (stmts', fvStmts) ->
395 returnRn (stmt':stmts', fvStmt `unionUniqSets` fvStmts)
398 rnStmt (BindStmt pat expr src_loc)
399 = pushSrcLocRn src_loc $
400 rnExpr expr `thenRn` \ (expr', fvExpr) ->
402 binders = collectPatBinders pat
404 newLocalNames "variable in do binding"
405 (binders `zip` repeat src_loc) `thenRn` \ new_binders ->
406 extendSS new_binders (rnPat pat) `thenRn` \ pat' ->
408 returnRn ((BindStmt pat' expr' src_loc, new_binders), fvExpr)
410 rnStmt (ExprStmt expr src_loc)
412 rnExpr expr `thenRn` \ (expr', fvs) ->
413 returnRn ((ExprStmt expr' src_loc, []), fvs)
415 rnStmt (LetStmt binds)
416 = rnBinds binds `thenRn` \ (binds', binds_fvs, new_binders) ->
417 returnRn ((LetStmt binds', new_binders), binds_fvs)
421 %************************************************************************
423 \subsubsection{Precedence Parsing}
425 %************************************************************************
428 precParseExpr :: RenamedHsExpr -> RnM_Fixes s RenamedHsExpr
429 precParsePat :: RenamedPat -> RnM_Fixes s RenamedPat
431 precParseExpr exp@(OpApp (NegApp e1) (HsVar op) e2)
432 = lookupFixity op `thenRn` \ (op_fix, op_prec) ->
434 -- negate precedence 6 wired in
436 precParseExpr (OpApp e1 (HsVar op) e2) `thenRn` \ op_app ->
437 returnRn (NegApp op_app)
441 precParseExpr exp@(OpApp (OpApp e11 (HsVar op1) e12) (HsVar op) e2)
442 = lookupFixity op `thenRn` \ (op_fix, op_prec) ->
443 lookupFixity op1 `thenRn` \ (op1_fix, op1_prec) ->
444 case cmp op1_prec op_prec of
446 EQ_ -> case (op1_fix, op_fix) of
447 (INFIXR, INFIXR) -> rearrange
448 (INFIXL, INFIXL) -> returnRn exp
449 _ -> getSrcLocRn `thenRn` \ src_loc ->
450 failButContinueRn exp
451 (precParseErr (op1,op1_fix,op1_prec) (op,op_fix,op_prec) src_loc)
454 rearrange = precParseExpr (OpApp e12 (HsVar op) e2) `thenRn` \ e2' ->
455 returnRn (OpApp e11 (HsVar op1) e2')
457 precParseExpr exp = returnRn exp
460 precParsePat pat@(ConOpPatIn (NegPatIn e1) op e2)
461 = lookupFixity op `thenRn` \ (op_fix, op_prec) ->
463 -- negate precedence 6 wired in
464 getSrcLocRn `thenRn` \ src_loc ->
465 failButContinueRn pat (precParseNegPatErr (op,op_fix,op_prec) src_loc)
469 precParsePat pat@(ConOpPatIn (ConOpPatIn p11 op1 p12) op p2)
470 = lookupFixity op `thenRn` \ (op_fix, op_prec) ->
471 lookupFixity op1 `thenRn` \ (op1_fix, op1_prec) ->
472 case cmp op1_prec op_prec of
474 EQ_ -> case (op1_fix, op_fix) of
475 (INFIXR, INFIXR) -> rearrange
476 (INFIXL, INFIXL) -> returnRn pat
477 _ -> getSrcLocRn `thenRn` \ src_loc ->
478 failButContinueRn pat
479 (precParseErr (op1,op1_fix,op1_prec) (op,op_fix,op_prec) src_loc)
482 rearrange = precParsePat (ConOpPatIn p12 op p2) `thenRn` \ p2' ->
483 returnRn (ConOpPatIn p11 op1 p2')
485 precParsePat pat = returnRn pat
488 data INFIX = INFIXL | INFIXR | INFIXN deriving Eq
490 lookupFixity :: RnName -> RnM_Fixes s (INFIX, Int)
492 = getExtraRn `thenRn` \ fixity_fm ->
493 case lookupUFM fixity_fm op of
494 Nothing -> returnRn (INFIXL, 9)
495 Just (InfixL _ n) -> returnRn (INFIXL, n)
496 Just (InfixR _ n) -> returnRn (INFIXR, n)
497 Just (InfixN _ n) -> returnRn (INFIXN, n)
501 checkPrecMatch :: Bool -> RnName -> RenamedMatch -> RnM_Fixes s ()
503 checkPrecMatch False fn match
505 checkPrecMatch True op (PatMatch p1 (PatMatch p2 (GRHSMatch _)))
506 = checkPrec op p1 False `thenRn_`
508 checkPrecMatch True op _
509 = panic "checkPrecMatch"
511 checkPrec op (ConOpPatIn _ op1 _) right
512 = lookupFixity op `thenRn` \ (op_fix, op_prec) ->
513 lookupFixity op1 `thenRn` \ (op1_fix, op1_prec) ->
514 getSrcLocRn `thenRn` \ src_loc ->
516 inf_ok = op1_prec > op_prec ||
517 (op1_prec == op_prec &&
518 (op1_fix == INFIXR && op_fix == INFIXR && right ||
519 op1_fix == INFIXL && op_fix == INFIXL && not right))
521 info = (op,op_fix,op_prec)
522 info1 = (op1,op1_fix,op1_prec)
523 (infol, infor) = if right then (info, info1) else (info1, info)
525 addErrIfRn (not inf_ok) (precParseErr infol infor src_loc)
527 checkPrec op (NegPatIn _) right
528 = lookupFixity op `thenRn` \ (op_fix, op_prec) ->
529 getSrcLocRn `thenRn` \ src_loc ->
530 addErrIfRn (6 < op_prec) (precParseNegPatErr (op,op_fix,op_prec) src_loc)
532 checkPrec op pat right
537 negPatErr pat src_loc
538 = addErrLoc src_loc "prefix `-' not applied to literal in pattern" ( \sty ->
541 precParseNegPatErr op src_loc
542 = addErrLoc src_loc "precedence parsing error" (\ sty ->
543 ppBesides [ppStr "prefix `-' has lower precedence than ", pp_op sty op, ppStr " in pattern"])
545 precParseErr op1 op2 src_loc
546 = addErrLoc src_loc "precedence parsing error" (\ sty ->
547 ppBesides [ppStr "cannot mix ", pp_op sty op1, ppStr " and ", pp_op sty op2,
548 ppStr " in the same infix expression"])
550 pp_op sty (op, fix, prec) = ppBesides [pprOp sty op, ppLparen, pp_fix fix, ppSP, ppInt prec, ppRparen]
551 pp_fix INFIXL = ppStr "infixl"
552 pp_fix INFIXR = ppStr "infixr"
553 pp_fix INFIXN = ppStr "infix"