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, rnStmt,
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, inCharRange )
31 import BasicTypes ( Fixity(..), FixityDirection(..), defaultFixity, negateFixity )
32 import PrelNames ( hasKey, assertIdKey, minusName, negateName, fromIntegerName,
33 eqClass_RDR, foldr_RDR, build_RDR, eqString_RDR,
34 cCallableClass_RDR, cReturnableClass_RDR,
35 monadClass_RDR, enumClass_RDR, ordClass_RDR,
36 ratioDataCon_RDR, assertErr_RDR,
37 ioDataCon_RDR, plusInteger_RDR, timesInteger_RDR,
38 fromInteger_RDR, fromRational_RDR,
40 import TysPrim ( charPrimTyCon, addrPrimTyCon, intPrimTyCon,
41 floatPrimTyCon, doublePrimTyCon
43 import TysWiredIn ( intTyCon )
44 import Name ( NamedThing(..), mkSysLocalName, nameSrcLoc )
46 import UniqFM ( isNullUFM )
47 import FiniteMap ( elemFM )
48 import UniqSet ( emptyUniqSet )
49 import List ( intersectBy )
50 import ListSetOps ( unionLists, removeDups )
51 import Maybes ( maybeToBool )
56 *********************************************************
60 *********************************************************
63 rnPat :: RdrNamePat -> RnMS (RenamedPat, FreeVars)
65 rnPat WildPatIn = returnRn (WildPatIn, emptyFVs)
68 = lookupBndrRn name `thenRn` \ vname ->
69 returnRn (VarPatIn vname, emptyFVs)
71 rnPat (SigPatIn pat ty)
72 = doptRn Opt_GlasgowExts `thenRn` \ glaExts ->
75 then rnPat pat `thenRn` \ (pat', fvs1) ->
76 rnHsTypeFVs doc ty `thenRn` \ (ty', fvs2) ->
77 returnRn (SigPatIn pat' ty', fvs1 `plusFV` fvs2)
79 else addErrRn (patSigErr ty) `thenRn_`
82 doc = text "a pattern type-signature"
84 rnPat (LitPatIn s@(HsString _))
85 = lookupOrigName eqString_RDR `thenRn` \ eq ->
86 returnRn (LitPatIn s, unitFV eq)
89 = litFVs lit `thenRn` \ fvs ->
90 returnRn (LitPatIn lit, fvs)
93 = rnOverLit lit `thenRn` \ (lit', fvs1) ->
94 lookupOrigName eqClass_RDR `thenRn` \ eq -> -- Needed to find equality on pattern
95 returnRn (NPatIn lit', fvs1 `addOneFV` eq)
97 rnPat (NPlusKPatIn name lit)
98 = rnOverLit lit `thenRn` \ (lit', fvs) ->
99 lookupOrigName ordClass_RDR `thenRn` \ ord ->
100 lookupBndrRn name `thenRn` \ name' ->
101 returnRn (NPlusKPatIn name' lit', fvs `addOneFV` ord `addOneFV` minusName)
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 ...)
124 (if isInterfaceMode mode
125 then returnRn (ConOpPatIn pat1' con' defaultFixity pat2')
126 else 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 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 [ResultStmt _ _] = True
239 is_standard_guard [ExprStmt _ _, ResultStmt _ _] = 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 ->
316 (if isInterfaceMode mode
317 then returnRn (OpApp e1' op' defaultFixity e2')
318 else lookupFixityRn op_name `thenRn` \ fixity ->
319 mkOpAppRn e1' op' fixity e2'
320 ) `thenRn` \ final_e ->
323 fv_e1 `plusFV` fv_op `plusFV` fv_e2)
326 = rnExpr e `thenRn` \ (e', fv_e) ->
327 mkNegAppRn e' `thenRn` \ final_e ->
328 returnRn (final_e, fv_e `addOneFV` negateName)
331 = rnExpr e `thenRn` \ (e', fvs_e) ->
332 returnRn (HsPar e', fvs_e)
334 rnExpr section@(SectionL expr op)
335 = rnExpr expr `thenRn` \ (expr', fvs_expr) ->
336 rnExpr op `thenRn` \ (op', fvs_op) ->
337 checkSectionPrec "left" section op' expr' `thenRn_`
338 returnRn (SectionL expr' op', fvs_op `plusFV` fvs_expr)
340 rnExpr section@(SectionR op expr)
341 = rnExpr op `thenRn` \ (op', fvs_op) ->
342 rnExpr expr `thenRn` \ (expr', fvs_expr) ->
343 checkSectionPrec "right" section op' expr' `thenRn_`
344 returnRn (SectionR op' expr', fvs_op `plusFV` fvs_expr)
346 rnExpr (HsCCall fun args may_gc is_casm fake_result_ty)
347 -- Check out the comment on RnIfaces.getNonWiredDataDecl about ccalls
348 = lookupOrigNames [cCallableClass_RDR,
349 cReturnableClass_RDR,
350 ioDataCon_RDR] `thenRn` \ implicit_fvs ->
351 rnExprs args `thenRn` \ (args', fvs_args) ->
352 returnRn (HsCCall fun args' may_gc is_casm fake_result_ty,
353 fvs_args `plusFV` implicit_fvs)
355 rnExpr (HsSCC lbl expr)
356 = rnExpr expr `thenRn` \ (expr', fvs_expr) ->
357 returnRn (HsSCC lbl expr', fvs_expr)
359 rnExpr (HsCase expr ms src_loc)
360 = pushSrcLocRn src_loc $
361 rnExpr expr `thenRn` \ (new_expr, e_fvs) ->
362 mapFvRn rnMatch ms `thenRn` \ (new_ms, ms_fvs) ->
363 returnRn (HsCase new_expr new_ms src_loc, e_fvs `plusFV` ms_fvs)
365 rnExpr (HsLet binds expr)
366 = rnBinds binds $ \ binds' ->
367 rnExpr expr `thenRn` \ (expr',fvExpr) ->
368 returnRn (HsLet binds' expr', fvExpr)
370 rnExpr (HsWith expr binds)
371 = rnExpr expr `thenRn` \ (expr',fvExpr) ->
372 rnIPBinds binds `thenRn` \ (binds',fvBinds) ->
373 returnRn (HsWith expr' binds', fvExpr `plusFV` fvBinds)
375 rnExpr e@(HsDo do_or_lc stmts src_loc)
376 = pushSrcLocRn src_loc $
377 lookupOrigNames implicit_rdr_names `thenRn` \ implicit_fvs ->
378 rnStmts stmts `thenRn` \ ((_, stmts'), fvs) ->
379 -- check the statement list ends in an expression
380 case last stmts' of {
381 ResultStmt _ _ -> returnRn () ;
382 _ -> addErrRn (doStmtListErr e)
384 returnRn (HsDo do_or_lc stmts' src_loc, fvs `plusFV` implicit_fvs)
386 implicit_rdr_names = [foldr_RDR, build_RDR, monadClass_RDR]
387 -- Monad stuff should not be necessary for a list comprehension
388 -- but the typechecker looks up the bind and return Ids anyway
392 rnExpr (ExplicitList exps)
393 = rnExprs exps `thenRn` \ (exps', fvs) ->
394 returnRn (ExplicitList exps', fvs `addOneFV` listTyCon_name)
396 rnExpr (ExplicitTuple exps boxity)
397 = rnExprs exps `thenRn` \ (exps', fvs) ->
398 returnRn (ExplicitTuple exps' boxity, fvs `addOneFV` tycon_name)
400 tycon_name = tupleTyCon_name boxity (length exps)
402 rnExpr (RecordCon con_id rbinds)
403 = lookupOccRn con_id `thenRn` \ conname ->
404 rnRbinds "construction" rbinds `thenRn` \ (rbinds', fvRbinds) ->
405 returnRn (RecordCon conname rbinds', fvRbinds `addOneFV` conname)
407 rnExpr (RecordUpd expr rbinds)
408 = rnExpr expr `thenRn` \ (expr', fvExpr) ->
409 rnRbinds "update" rbinds `thenRn` \ (rbinds', fvRbinds) ->
410 returnRn (RecordUpd expr' rbinds', fvExpr `plusFV` fvRbinds)
412 rnExpr (ExprWithTySig expr pty)
413 = rnExpr expr `thenRn` \ (expr', fvExpr) ->
414 rnHsTypeFVs (text "an expression type signature") pty `thenRn` \ (pty', fvTy) ->
415 returnRn (ExprWithTySig expr' pty', fvExpr `plusFV` fvTy)
417 rnExpr (HsIf p b1 b2 src_loc)
418 = pushSrcLocRn src_loc $
419 rnExpr p `thenRn` \ (p', fvP) ->
420 rnExpr b1 `thenRn` \ (b1', fvB1) ->
421 rnExpr b2 `thenRn` \ (b2', fvB2) ->
422 returnRn (HsIf p' b1' b2' src_loc, plusFVs [fvP, fvB1, fvB2])
425 = rnHsTypeFVs doc a `thenRn` \ (t, fvT) ->
426 returnRn (HsType t, fvT)
428 doc = text "renaming a type pattern"
430 rnExpr (ArithSeqIn seq)
431 = lookupOrigName enumClass_RDR `thenRn` \ enum ->
432 rn_seq seq `thenRn` \ (new_seq, fvs) ->
433 returnRn (ArithSeqIn new_seq, fvs `addOneFV` enum)
436 = rnExpr expr `thenRn` \ (expr', fvExpr) ->
437 returnRn (From expr', fvExpr)
439 rn_seq (FromThen expr1 expr2)
440 = rnExpr expr1 `thenRn` \ (expr1', fvExpr1) ->
441 rnExpr expr2 `thenRn` \ (expr2', fvExpr2) ->
442 returnRn (FromThen expr1' expr2', fvExpr1 `plusFV` fvExpr2)
444 rn_seq (FromTo expr1 expr2)
445 = rnExpr expr1 `thenRn` \ (expr1', fvExpr1) ->
446 rnExpr expr2 `thenRn` \ (expr2', fvExpr2) ->
447 returnRn (FromTo expr1' expr2', fvExpr1 `plusFV` fvExpr2)
449 rn_seq (FromThenTo expr1 expr2 expr3)
450 = rnExpr expr1 `thenRn` \ (expr1', fvExpr1) ->
451 rnExpr expr2 `thenRn` \ (expr2', fvExpr2) ->
452 rnExpr expr3 `thenRn` \ (expr3', fvExpr3) ->
453 returnRn (FromThenTo expr1' expr2' expr3',
454 plusFVs [fvExpr1, fvExpr2, fvExpr3])
457 These three are pattern syntax appearing in expressions.
458 Since all the symbols are reservedops we can simply reject them.
459 We return a (bogus) EWildPat in each case.
462 rnExpr e@EWildPat = addErrRn (patSynErr e) `thenRn_`
463 returnRn (EWildPat, emptyFVs)
465 rnExpr e@(EAsPat _ _) = addErrRn (patSynErr e) `thenRn_`
466 returnRn (EWildPat, emptyFVs)
468 rnExpr e@(ELazyPat _) = addErrRn (patSynErr e) `thenRn_`
469 returnRn (EWildPat, emptyFVs)
474 %************************************************************************
476 \subsubsection{@Rbinds@s and @Rpats@s: in record expressions}
478 %************************************************************************
482 = mapRn_ field_dup_err dup_fields `thenRn_`
483 mapFvRn rn_rbind rbinds `thenRn` \ (rbinds', fvRbind) ->
484 returnRn (rbinds', fvRbind)
486 (_, dup_fields) = removeDups compare [ f | (f,_,_) <- rbinds ]
488 field_dup_err dups = addErrRn (dupFieldErr str dups)
490 rn_rbind (field, expr, pun)
491 = lookupGlobalOccRn field `thenRn` \ fieldname ->
492 rnExpr expr `thenRn` \ (expr', fvExpr) ->
493 returnRn ((fieldname, expr', pun), fvExpr `addOneFV` fieldname)
496 = mapRn_ field_dup_err dup_fields `thenRn_`
497 mapFvRn rn_rpat rpats `thenRn` \ (rpats', fvs) ->
498 returnRn (rpats', fvs)
500 (_, dup_fields) = removeDups compare [ f | (f,_,_) <- rpats ]
502 field_dup_err dups = addErrRn (dupFieldErr "pattern" dups)
504 rn_rpat (field, pat, pun)
505 = lookupGlobalOccRn field `thenRn` \ fieldname ->
506 rnPat pat `thenRn` \ (pat', fvs) ->
507 returnRn ((fieldname, pat', pun), fvs `addOneFV` fieldname)
510 %************************************************************************
512 \subsubsection{@rnIPBinds@s: in implicit parameter bindings} *
514 %************************************************************************
517 rnIPBinds [] = returnRn ([], emptyFVs)
518 rnIPBinds ((n, expr) : binds)
519 = newIPName n `thenRn` \ name ->
520 rnExpr expr `thenRn` \ (expr',fvExpr) ->
521 rnIPBinds binds `thenRn` \ (binds',fvBinds) ->
522 returnRn ((name, expr') : binds', fvExpr `plusFV` fvBinds)
526 %************************************************************************
528 \subsubsection{@Stmt@s: in @do@ expressions}
530 %************************************************************************
532 Note that although some bound vars may appear in the free var set for
533 the first qual, these will eventually be removed by the caller. For
534 example, if we have @[p | r <- s, q <- r, p <- q]@, when doing
535 @[q <- r, p <- q]@, the free var set for @q <- r@ will
536 be @{r}@, and the free var set for the entire Quals will be @{r}@. This
537 @r@ will be removed only when we finally return from examining all the
541 rnStmts :: [RdrNameStmt]
542 -> RnMS (([Name], [RenamedStmt]), FreeVars)
545 = returnRn (([], []), emptyFVs)
548 = getLocalNameEnv `thenRn` \ name_env ->
549 rnStmt stmt $ \ stmt' ->
550 rnStmts stmts `thenRn` \ ((binders, stmts'), fvs) ->
551 returnRn ((binders, stmt' : stmts'), fvs)
553 rnStmt :: RdrNameStmt
554 -> (RenamedStmt -> RnMS (([Name], a), FreeVars))
555 -> RnMS (([Name], a), FreeVars)
556 -- The thing list of names returned is the list returned by the
557 -- thing_inside, plus the binders of the arguments stmt
559 -- Because of mutual recursion we have to pass in rnExpr.
561 rnStmt (ParStmt stmtss) thing_inside
562 = mapFvRn rnStmts stmtss `thenRn` \ (bndrstmtss, fv_stmtss) ->
563 let binderss = map fst bndrstmtss
564 checkBndrs all_bndrs bndrs
565 = checkRn (null (intersectBy eqOcc all_bndrs bndrs)) err `thenRn_`
566 returnRn (bndrs ++ all_bndrs)
567 eqOcc n1 n2 = nameOccName n1 == nameOccName n2
568 err = text "duplicate binding in parallel list comprehension"
570 foldlRn checkBndrs [] binderss `thenRn` \ new_binders ->
571 bindLocalNamesFV new_binders $
572 thing_inside (ParStmtOut bndrstmtss)`thenRn` \ ((rest_bndrs, result), fv_rest) ->
573 returnRn ((new_binders ++ rest_bndrs, result), fv_stmtss `plusFV` fv_rest)
575 rnStmt (BindStmt pat expr src_loc) thing_inside
576 = pushSrcLocRn src_loc $
577 rnExpr expr `thenRn` \ (expr', fv_expr) ->
578 bindLocalsFVRn doc binders $ \ new_binders ->
579 rnPat pat `thenRn` \ (pat', fv_pat) ->
580 thing_inside (BindStmt pat' expr' src_loc) `thenRn` \ ((rest_binders, result), fvs) ->
581 -- ZZ is shadowing handled correctly?
582 returnRn ((new_binders ++ rest_binders, result),
583 fv_expr `plusFV` fvs `plusFV` fv_pat)
585 binders = collectPatBinders pat
586 doc = text "a pattern in do binding"
588 rnStmt (ExprStmt expr src_loc) thing_inside
589 = pushSrcLocRn src_loc $
590 rnExpr expr `thenRn` \ (expr', fv_expr) ->
591 thing_inside (ExprStmt expr' src_loc) `thenRn` \ (result, fvs) ->
592 returnRn (result, fv_expr `plusFV` fvs)
594 rnStmt (ResultStmt expr src_loc) thing_inside
595 = pushSrcLocRn src_loc $
596 rnExpr expr `thenRn` \ (expr', fv_expr) ->
597 thing_inside (ResultStmt expr' src_loc) `thenRn` \ (result, fvs) ->
598 returnRn (result, fv_expr `plusFV` fvs)
600 rnStmt (LetStmt binds) thing_inside
601 = rnBinds binds $ \ binds' ->
602 let new_binders = collectHsBinders binds' in
603 thing_inside (LetStmt binds') `thenRn` \ ((rest_binders, result), fvs) ->
604 returnRn ((new_binders ++ rest_binders, result), fvs )
607 %************************************************************************
609 \subsubsection{Precedence Parsing}
611 %************************************************************************
613 @mkOpAppRn@ deals with operator fixities. The argument expressions
614 are assumed to be already correctly arranged. It needs the fixities
615 recorded in the OpApp nodes, because fixity info applies to the things
616 the programmer actually wrote, so you can't find it out from the Name.
618 Furthermore, the second argument is guaranteed not to be another
619 operator application. Why? Because the parser parses all
620 operator appications left-associatively, EXCEPT negation, which
621 we need to handle specially.
624 mkOpAppRn :: RenamedHsExpr -- Left operand; already rearranged
625 -> RenamedHsExpr -> Fixity -- Operator and fixity
626 -> RenamedHsExpr -- Right operand (not an OpApp, but might
628 -> RnMS RenamedHsExpr
630 ---------------------------
631 -- (e11 `op1` e12) `op2` e2
632 mkOpAppRn e1@(OpApp e11 op1 fix1 e12) op2 fix2 e2
634 = addErrRn (precParseErr (ppr_op op1,fix1) (ppr_op op2,fix2)) `thenRn_`
635 returnRn (OpApp e1 op2 fix2 e2)
638 = mkOpAppRn e12 op2 fix2 e2 `thenRn` \ new_e ->
639 returnRn (OpApp e11 op1 fix1 new_e)
641 (nofix_error, associate_right) = compareFixity fix1 fix2
643 ---------------------------
644 -- (- neg_arg) `op` e2
645 mkOpAppRn e1@(NegApp neg_arg) op2 fix2 e2
647 = addErrRn (precParseErr (pp_prefix_minus,negateFixity) (ppr_op op2,fix2)) `thenRn_`
648 returnRn (OpApp e1 op2 fix2 e2)
651 = mkOpAppRn neg_arg op2 fix2 e2 `thenRn` \ new_e ->
652 returnRn (NegApp new_e)
654 (nofix_error, associate_right) = compareFixity negateFixity fix2
656 ---------------------------
658 mkOpAppRn e1 op1 fix1 e2@(NegApp neg_arg) -- NegApp can occur on the right
659 | not associate_right -- We *want* right association
660 = addErrRn (precParseErr (ppr_op op1, fix1) (pp_prefix_minus, negateFixity)) `thenRn_`
661 returnRn (OpApp e1 op1 fix1 e2)
663 (_, associate_right) = compareFixity fix1 negateFixity
665 ---------------------------
667 mkOpAppRn e1 op fix e2 -- Default case, no rearrangment
668 = ASSERT2( right_op_ok fix e2,
669 ppr e1 $$ text "---" $$ ppr op $$ text "---" $$ ppr fix $$ text "---" $$ ppr e2
671 returnRn (OpApp e1 op fix e2)
673 -- Parser left-associates everything, but
674 -- derived instances may have correctly-associated things to
675 -- in the right operarand. So we just check that the right operand is OK
676 right_op_ok fix1 (OpApp _ _ fix2 _)
677 = not error_please && associate_right
679 (error_please, associate_right) = compareFixity fix1 fix2
680 right_op_ok fix1 other
683 -- Parser initially makes negation bind more tightly than any other operator
687 getModeRn `thenRn` \ mode ->
688 ASSERT( not_op_app mode neg_arg )
690 returnRn (NegApp neg_arg)
692 not_op_app SourceMode (OpApp _ _ _ _) = False
693 not_op_app mode other = True
697 mkConOpPatRn :: RenamedPat -> Name -> Fixity -> RenamedPat
700 mkConOpPatRn p1@(ConOpPatIn p11 op1 fix1 p12)
703 = addErrRn (precParseErr (ppr_op op1,fix1) (ppr_op op2,fix2)) `thenRn_`
704 returnRn (ConOpPatIn p1 op2 fix2 p2)
707 = mkConOpPatRn p12 op2 fix2 p2 `thenRn` \ new_p ->
708 returnRn (ConOpPatIn p11 op1 fix1 new_p)
711 (nofix_error, associate_right) = compareFixity fix1 fix2
713 mkConOpPatRn p1 op fix p2 -- Default case, no rearrangment
714 = ASSERT( not_op_pat p2 )
715 returnRn (ConOpPatIn p1 op fix p2)
717 not_op_pat (ConOpPatIn _ _ _ _) = False
718 not_op_pat other = True
722 checkPrecMatch :: Bool -> Name -> RenamedMatch -> RnMS ()
724 checkPrecMatch False fn match
727 checkPrecMatch True op (Match _ (p1:p2:_) _ _)
728 -- True indicates an infix lhs
729 = getModeRn `thenRn` \ mode ->
730 -- See comments with rnExpr (OpApp ...)
731 if isInterfaceMode mode
733 else checkPrec op p1 False `thenRn_`
736 checkPrecMatch True op _ = panic "checkPrecMatch"
738 checkPrec op (ConOpPatIn _ op1 _ _) right
739 = lookupFixityRn op `thenRn` \ op_fix@(Fixity op_prec op_dir) ->
740 lookupFixityRn op1 `thenRn` \ op1_fix@(Fixity op1_prec op1_dir) ->
742 inf_ok = op1_prec > op_prec ||
743 (op1_prec == op_prec &&
744 (op1_dir == InfixR && op_dir == InfixR && right ||
745 op1_dir == InfixL && op_dir == InfixL && not right))
747 info = (ppr_op op, op_fix)
748 info1 = (ppr_op op1, op1_fix)
749 (infol, infor) = if right then (info, info1) else (info1, info)
751 checkRn inf_ok (precParseErr infol infor)
753 checkPrec op pat right
756 -- Check precedence of (arg op) or (op arg) respectively
757 -- If arg is itself an operator application, its precedence should
758 -- be higher than that of op
759 checkSectionPrec left_or_right section op arg
761 OpApp _ op fix _ -> go_for_it (ppr_op op) fix
762 NegApp _ -> go_for_it pp_prefix_minus negateFixity
766 go_for_it pp_arg_op arg_fix@(Fixity arg_prec _)
767 = lookupFixityRn op_name `thenRn` \ op_fix@(Fixity op_prec _) ->
768 checkRn (op_prec < arg_prec)
769 (sectionPrecErr (ppr_op op_name, op_fix) (pp_arg_op, arg_fix) section)
776 @(compareFixity op1 op2)@ tells which way to arrange appication, or
777 whether there's an error.
780 compareFixity :: Fixity -> Fixity
781 -> (Bool, -- Error please
782 Bool) -- Associate to the right: a op1 (b op2 c)
783 compareFixity (Fixity prec1 dir1) (Fixity prec2 dir2)
784 = case prec1 `compare` prec2 of
787 EQ -> case (dir1, dir2) of
788 (InfixR, InfixR) -> right
789 (InfixL, InfixL) -> left
792 right = (False, True)
793 left = (False, False)
794 error_please = (True, False)
797 %************************************************************************
799 \subsubsection{Literals}
801 %************************************************************************
803 When literals occur we have to make sure
804 that the types and classes they involve
809 = checkRn (inCharRange c) (bogusCharError c) `thenRn_`
810 returnRn (unitFV charTyCon_name)
812 litFVs (HsCharPrim c) = returnRn (unitFV (getName charPrimTyCon))
813 litFVs (HsString s) = returnRn (mkFVs [listTyCon_name, charTyCon_name])
814 litFVs (HsStringPrim s) = returnRn (unitFV (getName addrPrimTyCon))
815 litFVs (HsInt i) = returnRn (unitFV (getName intTyCon))
816 litFVs (HsIntPrim i) = returnRn (unitFV (getName intPrimTyCon))
817 litFVs (HsFloatPrim f) = returnRn (unitFV (getName floatPrimTyCon))
818 litFVs (HsDoublePrim d) = returnRn (unitFV (getName doublePrimTyCon))
819 litFVs (HsLitLit l bogus_ty) = lookupOrigName cCallableClass_RDR `thenRn` \ cc ->
821 litFVs lit = pprPanic "RnExpr.litFVs" (ppr lit) -- HsInteger and HsRat only appear
822 -- in post-typechecker translations
824 rnOverLit (HsIntegral i)
826 = returnRn (HsIntegral i, unitFV fromIntegerName)
828 = lookupOrigNames [fromInteger_RDR, plusInteger_RDR, timesInteger_RDR] `thenRn` \ ns ->
829 -- Big integers are built, using + and *, out of small integers
830 -- [No particular reason why we use fromIntegerName in one case can
831 -- fromInteger_RDR in the other; but plusInteger_RDR means we
832 -- can get away without plusIntegerName altogether.]
833 returnRn (HsIntegral i, ns)
835 rnOverLit (HsFractional i)
836 = lookupOrigNames [fromRational_RDR, ratioDataCon_RDR,
837 plusInteger_RDR, timesInteger_RDR] `thenRn` \ ns ->
838 -- We have to make sure that the Ratio type is imported with
839 -- its constructor, because literals of type Ratio t are
840 -- built with that constructor.
841 -- The Rational type is needed too, but that will come in
842 -- when fractionalClass does.
843 -- The plus/times integer operations may be needed to construct the numerator
844 -- and denominator (see DsUtils.mkIntegerLit)
845 returnRn (HsFractional i, ns)
848 %************************************************************************
850 \subsubsection{Assertion utils}
852 %************************************************************************
855 mkAssertExpr :: RnMS (RenamedHsExpr, FreeVars)
857 lookupOrigName assertErr_RDR `thenRn` \ name ->
858 getSrcLocRn `thenRn` \ sloc ->
860 -- if we're ignoring asserts, return (\ _ e -> e)
861 -- if not, return (assertError "src-loc")
863 if opt_IgnoreAsserts then
864 getUniqRn `thenRn` \ uniq ->
866 vname = mkSysLocalName uniq SLIT("v")
867 expr = HsLam ignorePredMatch
868 loc = nameSrcLoc vname
869 ignorePredMatch = mkSimpleMatch [WildPatIn, VarPatIn vname] (HsVar vname) Nothing loc
871 returnRn (expr, unitFV name)
876 (HsLit (HsString (_PK_ (showSDoc (ppr sloc)))))
879 returnRn (expr, unitFV name)
883 %************************************************************************
885 \subsubsection{Errors}
887 %************************************************************************
890 ppr_op op = quotes (ppr op) -- Here, op can be a Name or a (Var n), where n is a Name
891 ppr_opfix (pp_op, fixity) = pp_op <+> brackets (ppr fixity)
892 pp_prefix_minus = ptext SLIT("prefix `-'")
894 dupFieldErr str (dup:rest)
895 = hsep [ptext SLIT("duplicate field name"),
897 ptext SLIT("in record"), text str]
900 = hang (ptext SLIT("precedence parsing error"))
901 4 (hsep [ptext SLIT("cannot mix"), ppr_opfix op1, ptext SLIT("and"),
903 ptext SLIT("in the same infix expression")])
905 sectionPrecErr op arg_op section
906 = vcat [ptext SLIT("The operator") <+> ppr_opfix op <+> ptext SLIT("of a section"),
907 nest 4 (ptext SLIT("must have lower precedence than the operand") <+> ppr_opfix arg_op),
908 nest 4 (ptext SLIT("In the section:") <+> quotes (ppr section))]
912 SLIT("accepting non-standard pattern guards (-fglasgow-exts to suppress this message)")
916 = (ptext SLIT("Illegal signature in pattern:") <+> ppr ty)
917 $$ nest 4 (ptext SLIT("Use -fglasgow-exts to permit it"))
920 = sep [ptext SLIT("Pattern syntax in expression context:"),
924 = sep [ptext SLIT("`do' statements must end in expression:"),
928 = ptext SLIT("character literal out of range: '\\") <> int c <> char '\''