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, addShortErrLocLine )
29 import Name ( isLocallyDefinedName, pprSym, Name, RdrName )
31 import UniqFM ( lookupUFM )
32 import UniqSet ( emptyUniqSet, unitUniqSet,
33 unionUniqSets, unionManyUniqSets,
35 import Util ( Ord3(..), removeDups, 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 con pats)
66 = lookupConstr con `thenRn` \ con' ->
67 mapRn rnPat pats `thenRn` \ patslist ->
68 returnRn (ConPatIn con' patslist)
70 rnPat (ConOpPatIn pat1 con pat2)
71 = lookupConstr con `thenRn` \ con' ->
72 rnPat pat1 `thenRn` \ pat1' ->
73 rnPat pat2 `thenRn` \ pat2' ->
74 precParsePat (ConOpPatIn pat1' con' 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 = lookupConstr con `thenRn` \ con' ->
101 rnRpats rpats `thenRn` \ rpats' ->
102 returnRn (RecPatIn con' rpats')
105 ************************************************************************
109 ************************************************************************
112 rnMatch :: RdrNameMatch -> RnM_Fixes s (RenamedMatch, FreeVars)
115 = getSrcLocRn `thenRn` \ src_loc ->
116 newLocalNames "variable in pattern"
117 (binders `zip` repeat src_loc) `thenRn` \ new_binders ->
118 extendSS2 new_binders (rnMatch_aux match)
120 binders = collect_binders match
122 collect_binders :: RdrNameMatch -> [RdrName]
124 collect_binders (GRHSMatch _) = []
125 collect_binders (PatMatch pat match)
126 = collectPatBinders pat ++ collect_binders match
128 rnMatch_aux (PatMatch pat match)
129 = rnPat pat `thenRn` \ pat' ->
130 rnMatch_aux match `thenRn` \ (match', fvMatch) ->
131 returnRn (PatMatch pat' match', fvMatch)
133 rnMatch_aux (GRHSMatch grhss_and_binds)
134 = rnGRHSsAndBinds grhss_and_binds `thenRn` \ (grhss_and_binds', fvs) ->
135 returnRn (GRHSMatch grhss_and_binds', fvs)
138 %************************************************************************
140 \subsubsection{Guarded right-hand sides (GRHSsAndBinds)}
142 %************************************************************************
145 rnGRHSsAndBinds :: RdrNameGRHSsAndBinds -> RnM_Fixes s (RenamedGRHSsAndBinds, FreeVars)
147 rnGRHSsAndBinds (GRHSsAndBindsIn grhss binds)
148 = rnBinds binds `thenRn` \ (binds', fvBinds, scope) ->
149 extendSS2 scope (rnGRHSs grhss) `thenRn` \ (grhss', fvGRHS) ->
150 returnRn (GRHSsAndBindsIn grhss' binds', fvBinds `unionUniqSets` fvGRHS)
152 rnGRHSs [] = returnRn ([], emptyUniqSet)
155 = rnGRHS grhs `thenRn` \ (grhs', fvs) ->
156 rnGRHSs grhss `thenRn` \ (grhss', fvss) ->
157 returnRn (grhs' : grhss', fvs `unionUniqSets` fvss)
159 rnGRHS (GRHS guard expr locn)
160 = pushSrcLocRn locn $
161 rnExpr guard `thenRn` \ (guard', fvsg) ->
162 rnExpr expr `thenRn` \ (expr', fvse) ->
163 returnRn (GRHS guard' expr' locn, fvsg `unionUniqSets` fvse)
165 rnGRHS (OtherwiseGRHS expr locn)
166 = pushSrcLocRn locn $
167 rnExpr expr `thenRn` \ (expr', fvs) ->
168 returnRn (OtherwiseGRHS expr' locn, fvs)
171 %************************************************************************
173 \subsubsection{Expressions}
175 %************************************************************************
178 rnExprs :: [RdrNameHsExpr] -> RnM_Fixes s ([RenamedHsExpr], FreeVars)
180 rnExprs [] = returnRn ([], emptyUniqSet)
183 = rnExpr expr `thenRn` \ (expr', fvExpr) ->
184 rnExprs exprs `thenRn` \ (exprs', fvExprs) ->
185 returnRn (expr':exprs', fvExpr `unionUniqSets` fvExprs)
188 Variables. We look up the variable and return the resulting name. The
189 interesting question is what the free-variable set should be. We
190 don't want to return imported or prelude things as free vars. So we
191 look at the RnName returned from the lookup, and make it part of the
192 free-var set iff if it's a LocallyDefined RnName.
194 ToDo: what about RnClassOps ???
198 fv_set vname@(RnName n) | isLocallyDefinedName n
200 fv_set _ = emptyUniqSet
203 rnExpr :: RdrNameHsExpr -> RnM_Fixes s (RenamedHsExpr, FreeVars)
206 = lookupValue v `thenRn` \ vname ->
207 returnRn (HsVar vname, fv_set vname)
210 = returnRn (HsLit lit, emptyUniqSet)
213 = rnMatch match `thenRn` \ (match', fvMatch) ->
214 returnRn (HsLam match', fvMatch)
216 rnExpr (HsApp fun arg)
217 = rnExpr fun `thenRn` \ (fun',fvFun) ->
218 rnExpr arg `thenRn` \ (arg',fvArg) ->
219 returnRn (HsApp fun' arg', fvFun `unionUniqSets` fvArg)
221 rnExpr (OpApp e1 op e2)
222 = rnExpr e1 `thenRn` \ (e1', fvs_e1) ->
223 rnExpr op `thenRn` \ (op', fvs_op) ->
224 rnExpr e2 `thenRn` \ (e2', fvs_e2) ->
225 precParseExpr (OpApp e1' op' e2') `thenRn` \ exp ->
226 returnRn (exp, (fvs_op `unionUniqSets` fvs_e1) `unionUniqSets` fvs_e2)
229 = rnExpr e `thenRn` \ (e', fvs_e) ->
230 lookupValue n `thenRn` \ nname ->
231 returnRn (NegApp e' nname, fvs_e `unionUniqSets` fv_set nname)
234 = rnExpr e `thenRn` \ (e', fvs_e) ->
235 returnRn (HsPar e', fvs_e)
237 rnExpr (SectionL expr op)
238 = rnExpr expr `thenRn` \ (expr', fvs_expr) ->
239 rnExpr op `thenRn` \ (op', fvs_op) ->
240 returnRn (SectionL expr' op', fvs_op `unionUniqSets` fvs_expr)
242 rnExpr (SectionR op expr)
243 = rnExpr op `thenRn` \ (op', fvs_op) ->
244 rnExpr expr `thenRn` \ (expr', fvs_expr) ->
245 returnRn (SectionR op' expr', fvs_op `unionUniqSets` fvs_expr)
247 rnExpr (CCall fun args may_gc is_casm fake_result_ty)
248 = rnExprs args `thenRn` \ (args', fvs_args) ->
249 returnRn (CCall fun args' may_gc is_casm fake_result_ty, fvs_args)
251 rnExpr (HsSCC label expr)
252 = rnExpr expr `thenRn` \ (expr', fvs_expr) ->
253 returnRn (HsSCC label expr', fvs_expr)
255 rnExpr (HsCase expr ms src_loc)
256 = pushSrcLocRn src_loc $
257 rnExpr expr `thenRn` \ (new_expr, e_fvs) ->
258 mapAndUnzipRn rnMatch ms `thenRn` \ (new_ms, ms_fvs) ->
259 returnRn (HsCase new_expr new_ms src_loc, unionManyUniqSets (e_fvs : ms_fvs))
261 rnExpr (HsLet binds expr)
262 = rnBinds binds `thenRn` \ (binds', fvBinds, new_binders) ->
263 extendSS2 new_binders (rnExpr expr) `thenRn` \ (expr',fvExpr) ->
264 returnRn (HsLet binds' expr', fvBinds `unionUniqSets` fvExpr)
266 rnExpr (HsDo stmts src_loc)
267 = pushSrcLocRn src_loc $
268 rnStmts stmts `thenRn` \ (stmts', fvStmts) ->
269 returnRn (HsDo stmts' src_loc, fvStmts)
271 rnExpr (ListComp expr quals)
272 = rnQuals quals `thenRn` \ ((quals', qual_binders), fvQuals) ->
273 extendSS2 qual_binders (rnExpr expr) `thenRn` \ (expr', fvExpr) ->
274 returnRn (ListComp expr' quals', fvExpr `unionUniqSets` fvQuals)
276 rnExpr (ExplicitList exps)
277 = rnExprs exps `thenRn` \ (exps', fvs) ->
278 returnRn (ExplicitList exps', fvs)
280 rnExpr (ExplicitTuple exps)
281 = rnExprs exps `thenRn` \ (exps', fvExps) ->
282 returnRn (ExplicitTuple exps', fvExps)
284 rnExpr (RecordCon (HsVar con) rbinds)
285 = lookupConstr con `thenRn` \ conname ->
286 rnRbinds "construction" rbinds `thenRn` \ (rbinds', fvRbinds) ->
287 returnRn (RecordCon (HsVar conname) rbinds', fvRbinds)
289 rnExpr (RecordUpd expr rbinds)
290 = rnExpr expr `thenRn` \ (expr', fvExpr) ->
291 rnRbinds "update" rbinds `thenRn` \ (rbinds', fvRbinds) ->
292 returnRn (RecordUpd expr' rbinds', fvExpr `unionUniqSets` fvRbinds)
294 rnExpr (ExprWithTySig expr pty)
295 = rnExpr expr `thenRn` \ (expr', fvExpr) ->
296 rnPolyType nullTyVarNamesEnv pty `thenRn` \ pty' ->
297 returnRn (ExprWithTySig expr' pty', fvExpr)
299 rnExpr (HsIf p b1 b2 src_loc)
300 = pushSrcLocRn src_loc $
301 rnExpr p `thenRn` \ (p', fvP) ->
302 rnExpr b1 `thenRn` \ (b1', fvB1) ->
303 rnExpr b2 `thenRn` \ (b2', fvB2) ->
304 returnRn (HsIf p' b1' b2' src_loc, unionManyUniqSets [fvP, fvB1, fvB2])
306 rnExpr (ArithSeqIn seq)
307 = rn_seq seq `thenRn` \ (new_seq, fvs) ->
308 returnRn (ArithSeqIn new_seq, fvs)
311 = rnExpr expr `thenRn` \ (expr', fvExpr) ->
312 returnRn (From expr', fvExpr)
314 rn_seq (FromThen expr1 expr2)
315 = rnExpr expr1 `thenRn` \ (expr1', fvExpr1) ->
316 rnExpr expr2 `thenRn` \ (expr2', fvExpr2) ->
317 returnRn (FromThen expr1' expr2', fvExpr1 `unionUniqSets` fvExpr2)
319 rn_seq (FromTo expr1 expr2)
320 = rnExpr expr1 `thenRn` \ (expr1', fvExpr1) ->
321 rnExpr expr2 `thenRn` \ (expr2', fvExpr2) ->
322 returnRn (FromTo expr1' expr2', fvExpr1 `unionUniqSets` fvExpr2)
324 rn_seq (FromThenTo expr1 expr2 expr3)
325 = rnExpr expr1 `thenRn` \ (expr1', fvExpr1) ->
326 rnExpr expr2 `thenRn` \ (expr2', fvExpr2) ->
327 rnExpr expr3 `thenRn` \ (expr3', fvExpr3) ->
328 returnRn (FromThenTo expr1' expr2' expr3',
329 unionManyUniqSets [fvExpr1, fvExpr2, fvExpr3])
332 %************************************************************************
334 \subsubsection{@Rbinds@s and @Rpats@s: in record expressions}
336 %************************************************************************
340 = mapRn field_dup_err dup_fields `thenRn_`
341 mapAndUnzipRn rn_rbind rbinds `thenRn` \ (rbinds', fvRbind_s) ->
342 returnRn (rbinds', unionManyUniqSets fvRbind_s)
344 (_, dup_fields) = removeDups cmp [ f | (f,_,_) <- rbinds ]
346 field_dup_err dups = getSrcLocRn `thenRn` \ src_loc ->
347 addErrRn (dupFieldErr str src_loc dups)
349 rn_rbind (field, expr, pun)
350 = lookupField field `thenRn` \ fieldname ->
351 rnExpr expr `thenRn` \ (expr', fvExpr) ->
352 returnRn ((fieldname, expr', pun), fvExpr)
355 = mapRn field_dup_err dup_fields `thenRn_`
358 (_, dup_fields) = removeDups cmp [ f | (f,_,_) <- rpats ]
360 field_dup_err dups = getSrcLocRn `thenRn` \ src_loc ->
361 addErrRn (dupFieldErr "pattern" src_loc dups)
363 rn_rpat (field, pat, pun)
364 = lookupField field `thenRn` \ fieldname ->
365 rnPat pat `thenRn` \ pat' ->
366 returnRn (fieldname, pat', pun)
369 %************************************************************************
371 \subsubsection{@Qual@s: in list comprehensions}
373 %************************************************************************
375 Note that although some bound vars may appear in the free var set for
376 the first qual, these will eventually be removed by the caller. For
377 example, if we have @[p | r <- s, q <- r, p <- q]@, when doing
378 @[q <- r, p <- q]@, the free var set for @q <- r@ will
379 be @{r}@, and the free var set for the entire Quals will be @{r}@. This
380 @r@ will be removed only when we finally return from examining all the
384 rnQuals :: [RdrNameQual]
385 -> RnM_Fixes s (([RenamedQual], -- renamed qualifiers
386 [RnName]), -- qualifiers' binders
387 FreeVars) -- free variables
389 rnQuals [qual] -- must be at least one qual
390 = rnQual qual `thenRn` \ ((new_qual, bs), fvs) ->
391 returnRn (([new_qual], bs), fvs)
393 rnQuals (qual: quals)
394 = rnQual qual `thenRn` \ ((qual', bs1), fvQuals1) ->
395 extendSS2 bs1 (rnQuals quals) `thenRn` \ ((quals', bs2), fvQuals2) ->
397 ((qual' : quals', bs1 ++ bs2), -- The ones on the right (bs2) shadow the
398 -- ones on the left (bs1)
399 fvQuals1 `unionUniqSets` fvQuals2)
401 rnQual (GeneratorQual pat expr)
402 = rnExpr expr `thenRn` \ (expr', fvExpr) ->
404 binders = collectPatBinders pat
406 getSrcLocRn `thenRn` \ src_loc ->
407 newLocalNames "variable in list-comprehension-generator pattern"
408 (binders `zip` repeat src_loc) `thenRn` \ new_binders ->
409 extendSS new_binders (rnPat pat) `thenRn` \ pat' ->
411 returnRn ((GeneratorQual pat' expr', new_binders), fvExpr)
413 rnQual (FilterQual expr)
414 = rnExpr expr `thenRn` \ (expr', fvs) ->
415 returnRn ((FilterQual expr', []), fvs)
417 rnQual (LetQual binds)
418 = rnBinds binds `thenRn` \ (binds', binds_fvs, new_binders) ->
419 returnRn ((LetQual binds', new_binders), binds_fvs)
423 %************************************************************************
425 \subsubsection{@Stmt@s: in @do@ expressions}
427 %************************************************************************
430 rnStmts :: [RdrNameStmt] -> RnM_Fixes s ([RenamedStmt], FreeVars)
432 rnStmts [stmt@(ExprStmt _ _)] -- last stmt must be ExprStmt
433 = rnStmt stmt `thenRn` \ ((stmt',[]), fvStmt) ->
434 returnRn ([stmt'], fvStmt)
437 = rnStmt stmt `thenRn` \ ((stmt',bs), fvStmt) ->
438 extendSS2 bs (rnStmts stmts) `thenRn` \ (stmts', fvStmts) ->
439 returnRn (stmt':stmts', fvStmt `unionUniqSets` fvStmts)
442 rnStmt (BindStmt pat expr src_loc)
443 = pushSrcLocRn src_loc $
444 rnExpr expr `thenRn` \ (expr', fvExpr) ->
446 binders = collectPatBinders pat
448 newLocalNames "variable in do binding"
449 (binders `zip` repeat src_loc) `thenRn` \ new_binders ->
450 extendSS new_binders (rnPat pat) `thenRn` \ pat' ->
452 returnRn ((BindStmt pat' expr' src_loc, new_binders), fvExpr)
454 rnStmt (ExprStmt expr src_loc)
456 rnExpr expr `thenRn` \ (expr', fvs) ->
457 returnRn ((ExprStmt expr' src_loc, []), fvs)
459 rnStmt (LetStmt binds)
460 = rnBinds binds `thenRn` \ (binds', binds_fvs, new_binders) ->
461 returnRn ((LetStmt binds', new_binders), binds_fvs)
465 %************************************************************************
467 \subsubsection{Precedence Parsing}
469 %************************************************************************
472 precParseExpr :: RenamedHsExpr -> RnM_Fixes s RenamedHsExpr
473 precParsePat :: RenamedPat -> RnM_Fixes s RenamedPat
475 precParseExpr exp@(OpApp (NegApp e1 n) (HsVar op) e2)
476 = lookupFixity op `thenRn` \ (op_fix, op_prec) ->
478 -- negate precedence 6 wired in
480 precParseExpr (OpApp e1 (HsVar op) e2) `thenRn` \ op_app ->
481 returnRn (NegApp op_app n)
485 precParseExpr exp@(OpApp (OpApp e11 (HsVar op1) e12) (HsVar op) e2)
486 = lookupFixity op `thenRn` \ (op_fix, op_prec) ->
487 lookupFixity op1 `thenRn` \ (op1_fix, op1_prec) ->
488 case cmp op1_prec op_prec of
490 EQ_ -> case (op1_fix, op_fix) of
491 (INFIXR, INFIXR) -> rearrange
492 (INFIXL, INFIXL) -> returnRn exp
493 _ -> getSrcLocRn `thenRn` \ src_loc ->
494 failButContinueRn exp
495 (precParseErr (op1,op1_fix,op1_prec) (op,op_fix,op_prec) src_loc)
498 rearrange = precParseExpr (OpApp e12 (HsVar op) e2) `thenRn` \ e2' ->
499 returnRn (OpApp e11 (HsVar op1) e2')
501 precParseExpr exp = returnRn exp
504 precParsePat pat@(ConOpPatIn (NegPatIn e1) op e2)
505 = lookupFixity op `thenRn` \ (op_fix, op_prec) ->
507 -- negate precedence 6 wired in
508 getSrcLocRn `thenRn` \ src_loc ->
509 failButContinueRn pat (precParseNegPatErr (op,op_fix,op_prec) src_loc)
513 precParsePat pat@(ConOpPatIn (ConOpPatIn p11 op1 p12) op p2)
514 = lookupFixity op `thenRn` \ (op_fix, op_prec) ->
515 lookupFixity op1 `thenRn` \ (op1_fix, op1_prec) ->
516 case cmp op1_prec op_prec of
518 EQ_ -> case (op1_fix, op_fix) of
519 (INFIXR, INFIXR) -> rearrange
520 (INFIXL, INFIXL) -> returnRn pat
521 _ -> getSrcLocRn `thenRn` \ src_loc ->
522 failButContinueRn pat
523 (precParseErr (op1,op1_fix,op1_prec) (op,op_fix,op_prec) src_loc)
526 rearrange = precParsePat (ConOpPatIn p12 op p2) `thenRn` \ p2' ->
527 returnRn (ConOpPatIn p11 op1 p2')
529 precParsePat pat = returnRn pat
532 data INFIX = INFIXL | INFIXR | INFIXN deriving Eq
534 lookupFixity :: RnName -> RnM_Fixes s (INFIX, Int)
536 = getExtraRn `thenRn` \ fixity_fm ->
537 case lookupUFM fixity_fm op of
538 Nothing -> returnRn (INFIXL, 9)
539 Just (InfixL _ n) -> returnRn (INFIXL, n)
540 Just (InfixR _ n) -> returnRn (INFIXR, n)
541 Just (InfixN _ n) -> returnRn (INFIXN, n)
545 checkPrecMatch :: Bool -> RnName -> RenamedMatch -> RnM_Fixes s ()
547 checkPrecMatch False fn match
549 checkPrecMatch True op (PatMatch p1 (PatMatch p2 (GRHSMatch _)))
550 = checkPrec op p1 False `thenRn_`
552 checkPrecMatch True op _
553 = panic "checkPrecMatch"
555 checkPrec op (ConOpPatIn _ op1 _) right
556 = lookupFixity op `thenRn` \ (op_fix, op_prec) ->
557 lookupFixity op1 `thenRn` \ (op1_fix, op1_prec) ->
558 getSrcLocRn `thenRn` \ src_loc ->
560 inf_ok = op1_prec > op_prec ||
561 (op1_prec == op_prec &&
562 (op1_fix == INFIXR && op_fix == INFIXR && right ||
563 op1_fix == INFIXL && op_fix == INFIXL && not right))
565 info = (op,op_fix,op_prec)
566 info1 = (op1,op1_fix,op1_prec)
567 (infol, infor) = if right then (info, info1) else (info1, info)
569 addErrIfRn (not inf_ok) (precParseErr infol infor src_loc)
571 checkPrec op (NegPatIn _) right
572 = lookupFixity op `thenRn` \ (op_fix, op_prec) ->
573 getSrcLocRn `thenRn` \ src_loc ->
574 addErrIfRn (6 < op_prec) (precParseNegPatErr (op,op_fix,op_prec) src_loc)
576 checkPrec op pat right
581 dupFieldErr str src_loc (dup:rest)
582 = addShortErrLocLine src_loc (\ sty ->
583 ppBesides [ppStr "duplicate field name `", ppr sty dup, ppStr "' in record ", ppStr str])
585 negPatErr pat src_loc
586 = addShortErrLocLine src_loc (\ sty ->
587 ppSep [ppStr "prefix `-' not applied to literal in pattern", ppr sty pat])
589 precParseNegPatErr op src_loc
590 = addErrLoc src_loc "precedence parsing error" (\ sty ->
591 ppBesides [ppStr "prefix `-' has lower precedence than ", pp_op sty op, ppStr " in pattern"])
593 precParseErr op1 op2 src_loc
594 = addErrLoc src_loc "precedence parsing error" (\ sty ->
595 ppBesides [ppStr "cannot mix ", pp_op sty op1, ppStr " and ", pp_op sty op2,
596 ppStr " in the same infix expression"])
598 pp_op sty (op, fix, prec) = ppBesides [pprSym sty op, ppLparen, pp_fix fix, ppSP, ppInt prec, ppRparen]
599 pp_fix INFIXL = ppStr "infixl"
600 pp_fix INFIXR = ppStr "infixr"
601 pp_fix INFIXN = ppStr "infix"