2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
4 \section[RnExpr]{Renaming of expressions}
6 Basically dependency analysis.
8 Handles @Match@, @GRHSs@, @HsExpr@, and @Qualifier@ datatypes. In
9 general, all of these functions return a renamed thing, and a set of
14 rnMatch, rnGRHSs, rnPat, rnExpr, rnExprs,
18 #include "HsVersions.h"
20 import {-# SOURCE #-} RnBinds ( rnBinds )
21 import {-# SOURCE #-} RnSource ( rnHsTypeFVs )
28 import RnHiFiles ( lookupFixityRn )
29 import CmdLineOpts ( DynFlag(..), opt_IgnoreAsserts )
30 import Literal ( inIntRange )
31 import BasicTypes ( Fixity(..), FixityDirection(..), defaultFixity, negateFixity )
32 import PrelNames ( hasKey, assertIdKey,
33 eqClass_RDR, foldr_RDR, build_RDR, eqString_RDR,
34 cCallableClass_RDR, cReturnableClass_RDR,
35 monadClass_RDR, enumClass_RDR, ordClass_RDR,
36 ratioDataCon_RDR, negate_RDR, assertErr_RDR,
37 ioDataCon_RDR, plusInteger_RDR, timesInteger_RDR
39 import TysPrim ( charPrimTyCon, addrPrimTyCon, intPrimTyCon,
40 floatPrimTyCon, doublePrimTyCon
42 import TysWiredIn ( intTyCon )
43 import Name ( NamedThing(..), mkSysLocalName, nameSrcLoc )
45 import UniqFM ( isNullUFM )
46 import FiniteMap ( elemFM )
47 import UniqSet ( emptyUniqSet )
48 import List ( intersectBy )
49 import ListSetOps ( unionLists, removeDups )
50 import Maybes ( maybeToBool )
55 *********************************************************
59 *********************************************************
62 rnPat :: RdrNamePat -> RnMS (RenamedPat, FreeVars)
64 rnPat WildPatIn = returnRn (WildPatIn, emptyFVs)
67 = lookupBndrRn name `thenRn` \ vname ->
68 returnRn (VarPatIn vname, emptyFVs)
70 rnPat (SigPatIn pat ty)
71 = doptRn Opt_GlasgowExts `thenRn` \ glaExts ->
74 then rnPat pat `thenRn` \ (pat', fvs1) ->
75 rnHsTypeFVs doc ty `thenRn` \ (ty', fvs2) ->
76 returnRn (SigPatIn pat' ty', fvs1 `plusFV` fvs2)
78 else addErrRn (patSigErr ty) `thenRn_`
81 doc = text "a pattern type-signature"
83 rnPat (LitPatIn s@(HsString _))
84 = lookupOrigName eqString_RDR `thenRn` \ eq ->
85 returnRn (LitPatIn s, unitFV eq)
88 = litFVs lit `thenRn` \ fvs ->
89 returnRn (LitPatIn lit, fvs)
92 = rnOverLit lit `thenRn` \ (lit', fvs1) ->
93 lookupOrigName eqClass_RDR `thenRn` \ eq -> -- Needed to find equality on pattern
94 returnRn (NPatIn lit', fvs1 `addOneFV` eq)
96 rnPat (NPlusKPatIn name lit minus)
97 = rnOverLit lit `thenRn` \ (lit', fvs) ->
98 lookupOrigName ordClass_RDR `thenRn` \ ord ->
99 lookupBndrRn name `thenRn` \ name' ->
100 lookupOccRn minus `thenRn` \ minus' ->
101 returnRn (NPlusKPatIn name' lit' minus', fvs `addOneFV` ord `addOneFV` minus')
103 rnPat (LazyPatIn pat)
104 = rnPat pat `thenRn` \ (pat', fvs) ->
105 returnRn (LazyPatIn pat', fvs)
107 rnPat (AsPatIn name pat)
108 = rnPat pat `thenRn` \ (pat', fvs) ->
109 lookupBndrRn name `thenRn` \ vname ->
110 returnRn (AsPatIn vname pat', fvs)
112 rnPat (ConPatIn con pats)
113 = lookupOccRn con `thenRn` \ con' ->
114 mapFvRn rnPat pats `thenRn` \ (patslist, fvs) ->
115 returnRn (ConPatIn con' patslist, fvs `addOneFV` con')
117 rnPat (ConOpPatIn pat1 con _ pat2)
118 = rnPat pat1 `thenRn` \ (pat1', fvs1) ->
119 lookupOccRn con `thenRn` \ con' ->
120 rnPat pat2 `thenRn` \ (pat2', fvs2) ->
122 getModeRn `thenRn` \ mode ->
123 -- See comments with rnExpr (OpApp ...)
125 InterfaceMode -> returnRn (ConOpPatIn pat1' con' defaultFixity pat2')
126 SourceMode -> lookupFixityRn con' `thenRn` \ fixity ->
127 mkConOpPatRn pat1' con' fixity pat2'
129 returnRn (pat', fvs1 `plusFV` fvs2 `addOneFV` con')
132 = rnPat pat `thenRn` \ (pat', fvs) ->
133 returnRn (ParPatIn pat', fvs)
135 rnPat (ListPatIn pats)
136 = mapFvRn rnPat pats `thenRn` \ (patslist, fvs) ->
137 returnRn (ListPatIn patslist, fvs `addOneFV` listTyCon_name)
139 rnPat (TuplePatIn pats boxed)
140 = mapFvRn rnPat pats `thenRn` \ (patslist, fvs) ->
141 returnRn (TuplePatIn patslist boxed, fvs `addOneFV` tycon_name)
143 tycon_name = tupleTyCon_name boxed (length pats)
145 rnPat (RecPatIn con rpats)
146 = lookupOccRn con `thenRn` \ con' ->
147 rnRpats rpats `thenRn` \ (rpats', fvs) ->
148 returnRn (RecPatIn con' rpats', fvs `addOneFV` con')
149 rnPat (TypePatIn name) =
150 (rnHsTypeFVs (text "type pattern") name) `thenRn` \ (name', fvs) ->
151 returnRn (TypePatIn name', fvs)
154 ************************************************************************
158 ************************************************************************
161 rnMatch :: RdrNameMatch -> RnMS (RenamedMatch, FreeVars)
163 rnMatch match@(Match _ pats maybe_rhs_sig grhss)
164 = pushSrcLocRn (getMatchLoc match) $
166 -- Find the universally quantified type variables
167 -- in the pattern type signatures
168 getLocalNameEnv `thenRn` \ name_env ->
170 tyvars_in_sigs = rhs_sig_tyvars `unionLists` tyvars_in_pats
171 rhs_sig_tyvars = case maybe_rhs_sig of
173 Just ty -> extractHsTyRdrTyVars ty
174 tyvars_in_pats = extractPatsTyVars pats
175 forall_tyvars = filter (not . (`elemFM` name_env)) tyvars_in_sigs
176 doc_sig = text "a pattern type-signature"
177 doc_pats = text "a pattern match"
179 bindNakedTyVarsFVRn doc_sig forall_tyvars $ \ sig_tyvars ->
181 -- Note that we do a single bindLocalsRn for all the
182 -- matches together, so that we spot the repeated variable in
184 bindLocalsFVRn doc_pats (collectPatsBinders pats) $ \ new_binders ->
186 mapFvRn rnPat pats `thenRn` \ (pats', pat_fvs) ->
187 rnGRHSs grhss `thenRn` \ (grhss', grhss_fvs) ->
188 doptRn Opt_GlasgowExts `thenRn` \ opt_GlasgowExts ->
189 (case maybe_rhs_sig of
190 Nothing -> returnRn (Nothing, emptyFVs)
191 Just ty | opt_GlasgowExts -> rnHsTypeFVs doc_sig ty `thenRn` \ (ty', ty_fvs) ->
192 returnRn (Just ty', ty_fvs)
193 | otherwise -> addErrRn (patSigErr ty) `thenRn_`
194 returnRn (Nothing, emptyFVs)
195 ) `thenRn` \ (maybe_rhs_sig', ty_fvs) ->
198 binder_set = mkNameSet new_binders
199 unused_binders = nameSetToList (binder_set `minusNameSet` grhss_fvs)
200 all_fvs = grhss_fvs `plusFV` pat_fvs `plusFV` ty_fvs
202 warnUnusedMatches unused_binders `thenRn_`
204 returnRn (Match sig_tyvars pats' maybe_rhs_sig' grhss', all_fvs)
205 -- The bindLocals and bindTyVars will remove the bound FVs
208 %************************************************************************
210 \subsubsection{Guarded right-hand sides (GRHSs)}
212 %************************************************************************
215 rnGRHSs :: RdrNameGRHSs -> RnMS (RenamedGRHSs, FreeVars)
217 rnGRHSs (GRHSs grhss binds maybe_ty)
218 = ASSERT( not (maybeToBool maybe_ty) )
219 rnBinds binds $ \ binds' ->
220 mapFvRn rnGRHS grhss `thenRn` \ (grhss', fvGRHSs) ->
221 returnRn (GRHSs grhss' binds' Nothing, fvGRHSs)
223 rnGRHS (GRHS guarded locn)
224 = doptRn Opt_GlasgowExts `thenRn` \ opt_GlasgowExts ->
226 (if not (opt_GlasgowExts || is_standard_guard guarded) then
227 addWarnRn (nonStdGuardErr guarded)
232 rnStmts rnExpr guarded `thenRn` \ ((_, guarded'), fvs) ->
233 returnRn (GRHS guarded' locn, fvs)
235 -- Standard Haskell 1.4 guards are just a single boolean
236 -- expression, rather than a list of qualifiers as in the
238 is_standard_guard [ExprStmt _ _] = True
239 is_standard_guard [GuardStmt _ _, ExprStmt _ _] = True
240 is_standard_guard other = False
243 %************************************************************************
245 \subsubsection{Expressions}
247 %************************************************************************
250 rnExprs :: [RdrNameHsExpr] -> RnMS ([RenamedHsExpr], FreeVars)
251 rnExprs ls = rnExprs' ls emptyUniqSet
253 rnExprs' [] acc = returnRn ([], acc)
254 rnExprs' (expr:exprs) acc
255 = rnExpr expr `thenRn` \ (expr', fvExpr) ->
257 -- Now we do a "seq" on the free vars because typically it's small
258 -- or empty, especially in very long lists of constants
260 acc' = acc `plusFV` fvExpr
262 (grubby_seqNameSet acc' rnExprs') exprs acc' `thenRn` \ (exprs', fvExprs) ->
263 returnRn (expr':exprs', fvExprs)
265 -- Grubby little function to do "seq" on namesets; replace by proper seq when GHC can do seq
266 grubby_seqNameSet ns result | isNullUFM ns = result
270 Variables. We look up the variable and return the resulting name.
273 rnExpr :: RdrNameHsExpr -> RnMS (RenamedHsExpr, FreeVars)
276 = lookupOccRn v `thenRn` \ name ->
277 if name `hasKey` assertIdKey then
278 -- We expand it to (GHCerr.assert__ location)
282 returnRn (HsVar name, unitFV name)
285 = newIPName v `thenRn` \ name ->
286 returnRn (HsIPVar name, emptyFVs)
289 = litFVs lit `thenRn` \ fvs ->
290 returnRn (HsLit lit, fvs)
292 rnExpr (HsOverLit lit)
293 = rnOverLit lit `thenRn` \ (lit', fvs) ->
294 returnRn (HsOverLit lit', fvs)
297 = rnMatch match `thenRn` \ (match', fvMatch) ->
298 returnRn (HsLam match', fvMatch)
300 rnExpr (HsApp fun arg)
301 = rnExpr fun `thenRn` \ (fun',fvFun) ->
302 rnExpr arg `thenRn` \ (arg',fvArg) ->
303 returnRn (HsApp fun' arg', fvFun `plusFV` fvArg)
305 rnExpr (OpApp e1 op _ e2)
306 = rnExpr e1 `thenRn` \ (e1', fv_e1) ->
307 rnExpr e2 `thenRn` \ (e2', fv_e2) ->
308 rnExpr op `thenRn` \ (op'@(HsVar op_name), fv_op) ->
311 -- When renaming code synthesised from "deriving" declarations
312 -- we're in Interface mode, and we should ignore fixity; assume
313 -- that the deriving code generator got the association correct
314 -- Don't even look up the fixity when in interface mode
315 getModeRn `thenRn` \ mode ->
317 SourceMode -> lookupFixityRn op_name `thenRn` \ fixity ->
318 mkOpAppRn e1' op' fixity e2'
319 InterfaceMode -> returnRn (OpApp e1' op' defaultFixity e2')
320 ) `thenRn` \ final_e ->
323 fv_e1 `plusFV` fv_op `plusFV` fv_e2)
326 = rnExpr e `thenRn` \ (e', fv_e) ->
327 lookupOrigName negate_RDR `thenRn` \ neg ->
328 mkNegAppRn e' neg `thenRn` \ final_e ->
329 returnRn (final_e, fv_e `addOneFV` neg)
332 = rnExpr e `thenRn` \ (e', fvs_e) ->
333 returnRn (HsPar e', fvs_e)
335 rnExpr section@(SectionL expr op)
336 = rnExpr expr `thenRn` \ (expr', fvs_expr) ->
337 rnExpr op `thenRn` \ (op', fvs_op) ->
338 checkSectionPrec "left" section op' expr' `thenRn_`
339 returnRn (SectionL expr' op', fvs_op `plusFV` fvs_expr)
341 rnExpr section@(SectionR op expr)
342 = rnExpr op `thenRn` \ (op', fvs_op) ->
343 rnExpr expr `thenRn` \ (expr', fvs_expr) ->
344 checkSectionPrec "right" section op' expr' `thenRn_`
345 returnRn (SectionR op' expr', fvs_op `plusFV` fvs_expr)
347 rnExpr (HsCCall fun args may_gc is_casm fake_result_ty)
348 -- Check out the comment on RnIfaces.getNonWiredDataDecl about ccalls
349 = lookupOrigNames [cCallableClass_RDR,
350 cReturnableClass_RDR,
351 ioDataCon_RDR] `thenRn` \ implicit_fvs ->
352 rnExprs args `thenRn` \ (args', fvs_args) ->
353 returnRn (HsCCall fun args' may_gc is_casm fake_result_ty,
354 fvs_args `plusFV` implicit_fvs)
356 rnExpr (HsSCC lbl expr)
357 = rnExpr expr `thenRn` \ (expr', fvs_expr) ->
358 returnRn (HsSCC lbl expr', fvs_expr)
360 rnExpr (HsCase expr ms src_loc)
361 = pushSrcLocRn src_loc $
362 rnExpr expr `thenRn` \ (new_expr, e_fvs) ->
363 mapFvRn rnMatch ms `thenRn` \ (new_ms, ms_fvs) ->
364 returnRn (HsCase new_expr new_ms src_loc, e_fvs `plusFV` ms_fvs)
366 rnExpr (HsLet binds expr)
367 = rnBinds binds $ \ binds' ->
368 rnExpr expr `thenRn` \ (expr',fvExpr) ->
369 returnRn (HsLet binds' expr', fvExpr)
371 rnExpr (HsWith expr binds)
372 = rnExpr expr `thenRn` \ (expr',fvExpr) ->
373 rnIPBinds binds `thenRn` \ (binds',fvBinds) ->
374 returnRn (HsWith expr' binds', fvExpr `plusFV` fvBinds)
376 rnExpr e@(HsDo do_or_lc stmts src_loc)
377 = pushSrcLocRn src_loc $
378 lookupOrigNames implicit_rdr_names `thenRn` \ implicit_fvs ->
379 rnStmts rnExpr stmts `thenRn` \ ((_, stmts'), fvs) ->
380 -- check the statement list ends in an expression
381 case last stmts' of {
382 ExprStmt _ _ -> returnRn () ;
383 ReturnStmt _ -> returnRn () ; -- for list comprehensions
384 _ -> addErrRn (doStmtListErr e)
386 returnRn (HsDo do_or_lc stmts' src_loc, fvs `plusFV` implicit_fvs)
388 implicit_rdr_names = [foldr_RDR, build_RDR, monadClass_RDR]
389 -- Monad stuff should not be necessary for a list comprehension
390 -- but the typechecker looks up the bind and return Ids anyway
394 rnExpr (ExplicitList exps)
395 = rnExprs exps `thenRn` \ (exps', fvs) ->
396 returnRn (ExplicitList exps', fvs `addOneFV` listTyCon_name)
398 rnExpr (ExplicitTuple exps boxity)
399 = rnExprs exps `thenRn` \ (exps', fvs) ->
400 returnRn (ExplicitTuple exps' boxity, fvs `addOneFV` tycon_name)
402 tycon_name = tupleTyCon_name boxity (length exps)
404 rnExpr (RecordCon con_id rbinds)
405 = lookupOccRn con_id `thenRn` \ conname ->
406 rnRbinds "construction" rbinds `thenRn` \ (rbinds', fvRbinds) ->
407 returnRn (RecordCon conname rbinds', fvRbinds `addOneFV` conname)
409 rnExpr (RecordUpd expr rbinds)
410 = rnExpr expr `thenRn` \ (expr', fvExpr) ->
411 rnRbinds "update" rbinds `thenRn` \ (rbinds', fvRbinds) ->
412 returnRn (RecordUpd expr' rbinds', fvExpr `plusFV` fvRbinds)
414 rnExpr (ExprWithTySig expr pty)
415 = rnExpr expr `thenRn` \ (expr', fvExpr) ->
416 rnHsTypeFVs (text "an expression type signature") pty `thenRn` \ (pty', fvTy) ->
417 returnRn (ExprWithTySig expr' pty', fvExpr `plusFV` fvTy)
419 rnExpr (HsIf p b1 b2 src_loc)
420 = pushSrcLocRn src_loc $
421 rnExpr p `thenRn` \ (p', fvP) ->
422 rnExpr b1 `thenRn` \ (b1', fvB1) ->
423 rnExpr b2 `thenRn` \ (b2', fvB2) ->
424 returnRn (HsIf p' b1' b2' src_loc, plusFVs [fvP, fvB1, fvB2])
427 = rnHsTypeFVs doc a `thenRn` \ (t, fvT) ->
428 returnRn (HsType t, fvT)
430 doc = text "renaming a type pattern"
432 rnExpr (ArithSeqIn seq)
433 = lookupOrigName enumClass_RDR `thenRn` \ enum ->
434 rn_seq seq `thenRn` \ (new_seq, fvs) ->
435 returnRn (ArithSeqIn new_seq, fvs `addOneFV` enum)
438 = rnExpr expr `thenRn` \ (expr', fvExpr) ->
439 returnRn (From expr', fvExpr)
441 rn_seq (FromThen expr1 expr2)
442 = rnExpr expr1 `thenRn` \ (expr1', fvExpr1) ->
443 rnExpr expr2 `thenRn` \ (expr2', fvExpr2) ->
444 returnRn (FromThen expr1' expr2', fvExpr1 `plusFV` fvExpr2)
446 rn_seq (FromTo expr1 expr2)
447 = rnExpr expr1 `thenRn` \ (expr1', fvExpr1) ->
448 rnExpr expr2 `thenRn` \ (expr2', fvExpr2) ->
449 returnRn (FromTo expr1' expr2', fvExpr1 `plusFV` fvExpr2)
451 rn_seq (FromThenTo expr1 expr2 expr3)
452 = rnExpr expr1 `thenRn` \ (expr1', fvExpr1) ->
453 rnExpr expr2 `thenRn` \ (expr2', fvExpr2) ->
454 rnExpr expr3 `thenRn` \ (expr3', fvExpr3) ->
455 returnRn (FromThenTo expr1' expr2' expr3',
456 plusFVs [fvExpr1, fvExpr2, fvExpr3])
459 These three are pattern syntax appearing in expressions.
460 Since all the symbols are reservedops we can simply reject them.
461 We return a (bogus) EWildPat in each case.
464 rnExpr e@EWildPat = addErrRn (patSynErr e) `thenRn_`
465 returnRn (EWildPat, emptyFVs)
467 rnExpr e@(EAsPat _ _) = addErrRn (patSynErr e) `thenRn_`
468 returnRn (EWildPat, emptyFVs)
470 rnExpr e@(ELazyPat _) = addErrRn (patSynErr e) `thenRn_`
471 returnRn (EWildPat, emptyFVs)
476 %************************************************************************
478 \subsubsection{@Rbinds@s and @Rpats@s: in record expressions}
480 %************************************************************************
484 = mapRn_ field_dup_err dup_fields `thenRn_`
485 mapFvRn rn_rbind rbinds `thenRn` \ (rbinds', fvRbind) ->
486 returnRn (rbinds', fvRbind)
488 (_, dup_fields) = removeDups compare [ f | (f,_,_) <- rbinds ]
490 field_dup_err dups = addErrRn (dupFieldErr str dups)
492 rn_rbind (field, expr, pun)
493 = lookupGlobalOccRn field `thenRn` \ fieldname ->
494 rnExpr expr `thenRn` \ (expr', fvExpr) ->
495 returnRn ((fieldname, expr', pun), fvExpr `addOneFV` fieldname)
498 = mapRn_ field_dup_err dup_fields `thenRn_`
499 mapFvRn rn_rpat rpats `thenRn` \ (rpats', fvs) ->
500 returnRn (rpats', fvs)
502 (_, dup_fields) = removeDups compare [ f | (f,_,_) <- rpats ]
504 field_dup_err dups = addErrRn (dupFieldErr "pattern" dups)
506 rn_rpat (field, pat, pun)
507 = lookupGlobalOccRn field `thenRn` \ fieldname ->
508 rnPat pat `thenRn` \ (pat', fvs) ->
509 returnRn ((fieldname, pat', pun), fvs `addOneFV` fieldname)
512 %************************************************************************
514 \subsubsection{@rnIPBinds@s: in implicit parameter bindings} *
516 %************************************************************************
519 rnIPBinds [] = returnRn ([], emptyFVs)
520 rnIPBinds ((n, expr) : binds)
521 = newIPName n `thenRn` \ name ->
522 rnExpr expr `thenRn` \ (expr',fvExpr) ->
523 rnIPBinds binds `thenRn` \ (binds',fvBinds) ->
524 returnRn ((name, expr') : binds', fvExpr `plusFV` fvBinds)
528 %************************************************************************
530 \subsubsection{@Stmt@s: in @do@ expressions}
532 %************************************************************************
534 Note that although some bound vars may appear in the free var set for
535 the first qual, these will eventually be removed by the caller. For
536 example, if we have @[p | r <- s, q <- r, p <- q]@, when doing
537 @[q <- r, p <- q]@, the free var set for @q <- r@ will
538 be @{r}@, and the free var set for the entire Quals will be @{r}@. This
539 @r@ will be removed only when we finally return from examining all the
543 type RnExprTy = RdrNameHsExpr -> RnMS (RenamedHsExpr, FreeVars)
547 -> RnMS (([Name], [RenamedStmt]), FreeVars)
550 = returnRn (([], []), emptyFVs)
552 rnStmts rn_expr (stmt:stmts)
553 = getLocalNameEnv `thenRn` \ name_env ->
554 rnStmt rn_expr stmt $ \ stmt' ->
555 rnStmts rn_expr stmts `thenRn` \ ((binders, stmts'), fvs) ->
556 returnRn ((binders, stmt' : stmts'), fvs)
558 rnStmt :: RnExprTy -> RdrNameStmt
559 -> (RenamedStmt -> RnMS (([Name], a), FreeVars))
560 -> RnMS (([Name], a), FreeVars)
561 -- Because of mutual recursion we have to pass in rnExpr.
563 rnStmt rn_expr (ParStmt stmtss) thing_inside
564 = mapFvRn (rnStmts rn_expr) stmtss `thenRn` \ (bndrstmtss, fv_stmtss) ->
565 let binderss = map fst bndrstmtss
566 checkBndrs all_bndrs bndrs
567 = checkRn (null (intersectBy eqOcc all_bndrs bndrs)) err `thenRn_`
568 returnRn (bndrs ++ all_bndrs)
569 eqOcc n1 n2 = nameOccName n1 == nameOccName n2
570 err = text "duplicate binding in parallel list comprehension"
572 foldlRn checkBndrs [] binderss `thenRn` \ binders ->
573 bindLocalNamesFV binders $
574 thing_inside (ParStmtOut bndrstmtss)`thenRn` \ ((rest_bndrs, result), fv_rest) ->
575 returnRn ((rest_bndrs ++ binders, result), fv_stmtss `plusFV` fv_rest)
577 rnStmt rn_expr (BindStmt pat expr src_loc) thing_inside
578 = pushSrcLocRn src_loc $
579 rn_expr expr `thenRn` \ (expr', fv_expr) ->
580 bindLocalsFVRn doc binders $ \ new_binders ->
581 rnPat pat `thenRn` \ (pat', fv_pat) ->
582 thing_inside (BindStmt pat' expr' src_loc) `thenRn` \ ((rest_binders, result), fvs) ->
583 -- ZZ is shadowing handled correctly?
584 returnRn ((rest_binders ++ new_binders, result),
585 fv_expr `plusFV` fvs `plusFV` fv_pat)
587 binders = collectPatBinders pat
588 doc = text "a pattern in do binding"
590 rnStmt rn_expr (ExprStmt expr src_loc) thing_inside
591 = pushSrcLocRn src_loc $
592 rn_expr expr `thenRn` \ (expr', fv_expr) ->
593 thing_inside (ExprStmt expr' src_loc) `thenRn` \ (result, fvs) ->
594 returnRn (result, fv_expr `plusFV` fvs)
596 rnStmt rn_expr (GuardStmt expr src_loc) thing_inside
597 = pushSrcLocRn src_loc $
598 rn_expr expr `thenRn` \ (expr', fv_expr) ->
599 thing_inside (GuardStmt expr' src_loc) `thenRn` \ (result, fvs) ->
600 returnRn (result, fv_expr `plusFV` fvs)
602 rnStmt rn_expr (ReturnStmt expr) thing_inside
603 = rn_expr expr `thenRn` \ (expr', fv_expr) ->
604 thing_inside (ReturnStmt expr') `thenRn` \ (result, fvs) ->
605 returnRn (result, fv_expr `plusFV` fvs)
607 rnStmt rn_expr (LetStmt binds) thing_inside
608 = rnBinds binds $ \ binds' ->
609 thing_inside (LetStmt binds')
613 %************************************************************************
615 \subsubsection{Precedence Parsing}
617 %************************************************************************
619 @mkOpAppRn@ deals with operator fixities. The argument expressions
620 are assumed to be already correctly arranged. It needs the fixities
621 recorded in the OpApp nodes, because fixity info applies to the things
622 the programmer actually wrote, so you can't find it out from the Name.
624 Furthermore, the second argument is guaranteed not to be another
625 operator application. Why? Because the parser parses all
626 operator appications left-associatively, EXCEPT negation, which
627 we need to handle specially.
630 mkOpAppRn :: RenamedHsExpr -- Left operand; already rearranged
631 -> RenamedHsExpr -> Fixity -- Operator and fixity
632 -> RenamedHsExpr -- Right operand (not an OpApp, but might
634 -> RnMS RenamedHsExpr
636 ---------------------------
637 -- (e11 `op1` e12) `op2` e2
638 mkOpAppRn e1@(OpApp e11 op1 fix1 e12) op2 fix2 e2
640 = addErrRn (precParseErr (ppr_op op1,fix1) (ppr_op op2,fix2)) `thenRn_`
641 returnRn (OpApp e1 op2 fix2 e2)
644 = mkOpAppRn e12 op2 fix2 e2 `thenRn` \ new_e ->
645 returnRn (OpApp e11 op1 fix1 new_e)
647 (nofix_error, associate_right) = compareFixity fix1 fix2
649 ---------------------------
650 -- (- neg_arg) `op` e2
651 mkOpAppRn e1@(NegApp neg_arg neg_op) op2 fix2 e2
653 = addErrRn (precParseErr (pp_prefix_minus,negateFixity) (ppr_op op2,fix2)) `thenRn_`
654 returnRn (OpApp e1 op2 fix2 e2)
657 = mkOpAppRn neg_arg op2 fix2 e2 `thenRn` \ new_e ->
658 returnRn (NegApp new_e neg_op)
660 (nofix_error, associate_right) = compareFixity negateFixity fix2
662 ---------------------------
664 mkOpAppRn e1 op1 fix1 e2@(NegApp neg_arg neg_op) -- NegApp can occur on the right
665 | not associate_right -- We *want* right association
666 = addErrRn (precParseErr (ppr_op op1, fix1) (pp_prefix_minus, negateFixity)) `thenRn_`
667 returnRn (OpApp e1 op1 fix1 e2)
669 (_, associate_right) = compareFixity fix1 negateFixity
671 ---------------------------
673 mkOpAppRn e1 op fix e2 -- Default case, no rearrangment
674 = ASSERT2( right_op_ok fix e2,
675 ppr e1 $$ text "---" $$ ppr op $$ text "---" $$ ppr fix $$ text "---" $$ ppr e2
677 returnRn (OpApp e1 op fix e2)
679 -- Parser left-associates everything, but
680 -- derived instances may have correctly-associated things to
681 -- in the right operarand. So we just check that the right operand is OK
682 right_op_ok fix1 (OpApp _ _ fix2 _)
683 = not error_please && associate_right
685 (error_please, associate_right) = compareFixity fix1 fix2
686 right_op_ok fix1 other
689 -- Parser initially makes negation bind more tightly than any other operator
690 mkNegAppRn neg_arg neg_op
693 getModeRn `thenRn` \ mode ->
694 ASSERT( not_op_app mode neg_arg )
696 returnRn (NegApp neg_arg neg_op)
698 not_op_app SourceMode (OpApp _ _ _ _) = False
699 not_op_app mode other = True
703 mkConOpPatRn :: RenamedPat -> Name -> Fixity -> RenamedPat
706 mkConOpPatRn p1@(ConOpPatIn p11 op1 fix1 p12)
709 = addErrRn (precParseErr (ppr_op op1,fix1) (ppr_op op2,fix2)) `thenRn_`
710 returnRn (ConOpPatIn p1 op2 fix2 p2)
713 = mkConOpPatRn p12 op2 fix2 p2 `thenRn` \ new_p ->
714 returnRn (ConOpPatIn p11 op1 fix1 new_p)
717 (nofix_error, associate_right) = compareFixity fix1 fix2
719 mkConOpPatRn p1 op fix p2 -- Default case, no rearrangment
720 = ASSERT( not_op_pat p2 )
721 returnRn (ConOpPatIn p1 op fix p2)
723 not_op_pat (ConOpPatIn _ _ _ _) = False
724 not_op_pat other = True
728 checkPrecMatch :: Bool -> Name -> RenamedMatch -> RnMS ()
730 checkPrecMatch False fn match
733 checkPrecMatch True op (Match _ (p1:p2:_) _ _)
734 -- True indicates an infix lhs
735 = getModeRn `thenRn` \ mode ->
736 -- See comments with rnExpr (OpApp ...)
738 InterfaceMode -> returnRn ()
739 SourceMode -> checkPrec op p1 False `thenRn_`
742 checkPrecMatch True op _ = panic "checkPrecMatch"
744 checkPrec op (ConOpPatIn _ op1 _ _) right
745 = lookupFixityRn op `thenRn` \ op_fix@(Fixity op_prec op_dir) ->
746 lookupFixityRn op1 `thenRn` \ op1_fix@(Fixity op1_prec op1_dir) ->
748 inf_ok = op1_prec > op_prec ||
749 (op1_prec == op_prec &&
750 (op1_dir == InfixR && op_dir == InfixR && right ||
751 op1_dir == InfixL && op_dir == InfixL && not right))
753 info = (ppr_op op, op_fix)
754 info1 = (ppr_op op1, op1_fix)
755 (infol, infor) = if right then (info, info1) else (info1, info)
757 checkRn inf_ok (precParseErr infol infor)
759 checkPrec op pat right
762 -- Check precedence of (arg op) or (op arg) respectively
763 -- If arg is itself an operator application, its precedence should
764 -- be higher than that of op
765 checkSectionPrec left_or_right section op arg
767 OpApp _ op fix _ -> go_for_it (ppr_op op) fix
768 NegApp _ _ -> go_for_it pp_prefix_minus negateFixity
772 go_for_it pp_arg_op arg_fix@(Fixity arg_prec _)
773 = lookupFixityRn op_name `thenRn` \ op_fix@(Fixity op_prec _) ->
774 checkRn (op_prec < arg_prec)
775 (sectionPrecErr (ppr_op op_name, op_fix) (pp_arg_op, arg_fix) section)
782 @(compareFixity op1 op2)@ tells which way to arrange appication, or
783 whether there's an error.
786 compareFixity :: Fixity -> Fixity
787 -> (Bool, -- Error please
788 Bool) -- Associate to the right: a op1 (b op2 c)
789 compareFixity (Fixity prec1 dir1) (Fixity prec2 dir2)
790 = case prec1 `compare` prec2 of
793 EQ -> case (dir1, dir2) of
794 (InfixR, InfixR) -> right
795 (InfixL, InfixL) -> left
798 right = (False, True)
799 left = (False, False)
800 error_please = (True, False)
803 %************************************************************************
805 \subsubsection{Literals}
807 %************************************************************************
809 When literals occur we have to make sure
810 that the types and classes they involve
814 litFVs (HsChar c) = returnRn (unitFV charTyCon_name)
815 litFVs (HsCharPrim c) = returnRn (unitFV (getName charPrimTyCon))
816 litFVs (HsString s) = returnRn (mkFVs [listTyCon_name, charTyCon_name])
817 litFVs (HsStringPrim s) = returnRn (unitFV (getName addrPrimTyCon))
818 litFVs (HsInt i) = returnRn (unitFV (getName intTyCon))
819 litFVs (HsIntPrim i) = returnRn (unitFV (getName intPrimTyCon))
820 litFVs (HsFloatPrim f) = returnRn (unitFV (getName floatPrimTyCon))
821 litFVs (HsDoublePrim d) = returnRn (unitFV (getName doublePrimTyCon))
822 litFVs (HsLitLit l bogus_ty) = lookupOrigName cCallableClass_RDR `thenRn` \ cc ->
824 litFVs lit = pprPanic "RnExpr.litFVs" (ppr lit) -- HsInteger and HsRat only appear
825 -- in post-typechecker translations
827 rnOverLit (HsIntegral i from_integer)
828 = lookupOccRn from_integer `thenRn` \ from_integer' ->
829 (if inIntRange i then
832 lookupOrigNames [plusInteger_RDR, timesInteger_RDR]
834 returnRn (HsIntegral i from_integer', ns `addOneFV` from_integer')
836 rnOverLit (HsFractional i n)
837 = lookupOccRn n `thenRn` \ n' ->
838 lookupOrigNames [ratioDataCon_RDR, plusInteger_RDR, timesInteger_RDR] `thenRn` \ ns' ->
839 -- We have to make sure that the Ratio type is imported with
840 -- its constructor, because literals of type Ratio t are
841 -- built with that constructor.
842 -- The Rational type is needed too, but that will come in
843 -- when fractionalClass does.
844 -- The plus/times integer operations may be needed to construct the numerator
845 -- and denominator (see DsUtils.mkIntegerLit)
846 returnRn (HsFractional i n', ns' `addOneFV` n')
849 %************************************************************************
851 \subsubsection{Assertion utils}
853 %************************************************************************
856 mkAssertExpr :: RnMS (RenamedHsExpr, FreeVars)
858 lookupOrigName assertErr_RDR `thenRn` \ name ->
859 getSrcLocRn `thenRn` \ sloc ->
861 -- if we're ignoring asserts, return (\ _ e -> e)
862 -- if not, return (assertError "src-loc")
864 if opt_IgnoreAsserts then
865 getUniqRn `thenRn` \ uniq ->
867 vname = mkSysLocalName uniq SLIT("v")
868 expr = HsLam ignorePredMatch
869 loc = nameSrcLoc vname
870 ignorePredMatch = Match [] [WildPatIn, VarPatIn vname] Nothing
871 (GRHSs [GRHS [ExprStmt (HsVar vname) loc] loc]
874 returnRn (expr, unitFV name)
879 (HsLit (HsString (_PK_ (showSDoc (ppr sloc)))))
882 returnRn (expr, unitFV name)
886 %************************************************************************
888 \subsubsection{Errors}
890 %************************************************************************
893 ppr_op op = quotes (ppr op) -- Here, op can be a Name or a (Var n), where n is a Name
894 ppr_opfix (pp_op, fixity) = pp_op <+> brackets (ppr fixity)
895 pp_prefix_minus = ptext SLIT("prefix `-'")
897 dupFieldErr str (dup:rest)
898 = hsep [ptext SLIT("duplicate field name"),
900 ptext SLIT("in record"), text str]
903 = hang (ptext SLIT("precedence parsing error"))
904 4 (hsep [ptext SLIT("cannot mix"), ppr_opfix op1, ptext SLIT("and"),
906 ptext SLIT("in the same infix expression")])
908 sectionPrecErr op arg_op section
909 = vcat [ptext SLIT("The operator") <+> ppr_opfix op <+> ptext SLIT("of a section"),
910 nest 4 (ptext SLIT("must have lower precedence than the operand") <+> ppr_opfix arg_op),
911 nest 4 (ptext SLIT("In the section:") <+> quotes (ppr section))]
915 SLIT("accepting non-standard pattern guards (-fglasgow-exts to suppress this message)")
919 = (ptext SLIT("Illegal signature in pattern:") <+> ppr ty)
920 $$ nest 4 (ptext SLIT("Use -fglasgow-exts to permit it"))
923 = sep [ptext SLIT("Pattern syntax in expression context:"),
927 = sep [ptext SLIT("`do' statements must end in expression:"),