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 ( rnHsSigType, rnHsType )
28 import RnIfaces ( lookupFixityRn )
29 import CmdLineOpts ( opt_GlasgowExts, 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, integerTyCon )
43 import Name ( NamedThing(..), mkSysLocalName, nameSrcLoc )
45 import UniqFM ( isNullUFM )
46 import FiniteMap ( elemFM )
47 import UniqSet ( emptyUniqSet )
48 import Util ( removeDups )
49 import ListSetOps ( unionLists )
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)
72 = rnPat pat `thenRn` \ (pat', fvs1) ->
73 rnHsType doc ty `thenRn` \ (ty', fvs2) ->
74 returnRn (SigPatIn pat' ty', fvs1 `plusFV` fvs2)
77 = addErrRn (patSigErr ty) `thenRn_`
80 doc = text "a pattern type-signature"
82 rnPat (LitPatIn s@(HsString _))
83 = lookupOrigName eqString_RDR `thenRn` \ eq ->
84 returnRn (LitPatIn s, unitFV eq)
87 = litFVs lit `thenRn` \ fvs ->
88 returnRn (LitPatIn lit, fvs)
91 = rnOverLit lit `thenRn` \ (lit', fvs1) ->
92 lookupOrigName eqClass_RDR `thenRn` \ eq -> -- Needed to find equality on pattern
93 returnRn (NPatIn lit', fvs1 `addOneFV` eq)
95 rnPat (NPlusKPatIn name lit minus)
96 = rnOverLit lit `thenRn` \ (lit', fvs) ->
97 lookupOrigName ordClass_RDR `thenRn` \ ord ->
98 lookupBndrRn name `thenRn` \ name' ->
99 lookupOccRn minus `thenRn` \ minus' ->
100 returnRn (NPlusKPatIn name' lit' minus', fvs `addOneFV` ord `addOneFV` minus')
102 rnPat (LazyPatIn pat)
103 = rnPat pat `thenRn` \ (pat', fvs) ->
104 returnRn (LazyPatIn pat', fvs)
106 rnPat (AsPatIn name pat)
107 = rnPat pat `thenRn` \ (pat', fvs) ->
108 lookupBndrRn name `thenRn` \ vname ->
109 returnRn (AsPatIn vname pat', fvs)
111 rnPat (ConPatIn con pats)
112 = lookupOccRn con `thenRn` \ con' ->
113 mapFvRn rnPat pats `thenRn` \ (patslist, fvs) ->
114 returnRn (ConPatIn con' patslist, fvs `addOneFV` con')
116 rnPat (ConOpPatIn pat1 con _ pat2)
117 = rnPat pat1 `thenRn` \ (pat1', fvs1) ->
118 lookupOccRn con `thenRn` \ con' ->
119 rnPat pat2 `thenRn` \ (pat2', fvs2) ->
121 getModeRn `thenRn` \ mode ->
122 -- See comments with rnExpr (OpApp ...)
124 InterfaceMode -> returnRn (ConOpPatIn pat1' con' defaultFixity pat2')
125 SourceMode -> lookupFixityRn con' `thenRn` \ fixity ->
126 mkConOpPatRn pat1' con' fixity pat2'
128 returnRn (pat', fvs1 `plusFV` fvs2 `addOneFV` con')
131 = rnPat pat `thenRn` \ (pat', fvs) ->
132 returnRn (ParPatIn pat', fvs)
134 rnPat (ListPatIn pats)
135 = mapFvRn rnPat pats `thenRn` \ (patslist, fvs) ->
136 returnRn (ListPatIn patslist, fvs `addOneFV` listTyCon_name)
138 rnPat (TuplePatIn pats boxed)
139 = mapFvRn rnPat pats `thenRn` \ (patslist, fvs) ->
140 returnRn (TuplePatIn patslist boxed, fvs `addOneFV` tycon_name)
142 tycon_name = tupleTyCon_name boxed (length pats)
144 rnPat (RecPatIn con rpats)
145 = lookupOccRn con `thenRn` \ con' ->
146 rnRpats rpats `thenRn` \ (rpats', fvs) ->
147 returnRn (RecPatIn con' rpats', fvs `addOneFV` con')
150 ************************************************************************
154 ************************************************************************
157 rnMatch :: RdrNameMatch -> RnMS (RenamedMatch, FreeVars)
159 rnMatch match@(Match _ pats maybe_rhs_sig grhss)
160 = pushSrcLocRn (getMatchLoc match) $
162 -- Find the universally quantified type variables
163 -- in the pattern type signatures
164 getLocalNameEnv `thenRn` \ name_env ->
166 tyvars_in_sigs = rhs_sig_tyvars `unionLists` tyvars_in_pats
167 rhs_sig_tyvars = case maybe_rhs_sig of
169 Just ty -> extractHsTyRdrTyVars ty
170 tyvars_in_pats = extractPatsTyVars pats
171 forall_tyvars = filter (not . (`elemFM` name_env)) tyvars_in_sigs
172 doc_sig = text "a pattern type-signature"
173 doc_pats = text "in a pattern match"
175 bindTyVarsFVRn doc_sig (map UserTyVar forall_tyvars) $ \ sig_tyvars ->
177 -- Note that we do a single bindLocalsRn for all the
178 -- matches together, so that we spot the repeated variable in
180 bindLocalsFVRn doc_pats (collectPatsBinders pats) $ \ new_binders ->
182 mapFvRn rnPat pats `thenRn` \ (pats', pat_fvs) ->
183 rnGRHSs grhss `thenRn` \ (grhss', grhss_fvs) ->
184 (case maybe_rhs_sig of
185 Nothing -> returnRn (Nothing, emptyFVs)
186 Just ty | opt_GlasgowExts -> rnHsType doc_sig ty `thenRn` \ (ty', ty_fvs) ->
187 returnRn (Just ty', ty_fvs)
188 | otherwise -> addErrRn (patSigErr ty) `thenRn_`
189 returnRn (Nothing, emptyFVs)
190 ) `thenRn` \ (maybe_rhs_sig', ty_fvs) ->
193 binder_set = mkNameSet new_binders
194 unused_binders = nameSetToList (binder_set `minusNameSet` grhss_fvs)
195 all_fvs = grhss_fvs `plusFV` pat_fvs `plusFV` ty_fvs
197 warnUnusedMatches unused_binders `thenRn_`
199 returnRn (Match sig_tyvars pats' maybe_rhs_sig' grhss', all_fvs)
200 -- The bindLocals and bindTyVars will remove the bound FVs
203 %************************************************************************
205 \subsubsection{Guarded right-hand sides (GRHSs)}
207 %************************************************************************
210 rnGRHSs :: RdrNameGRHSs -> RnMS (RenamedGRHSs, FreeVars)
212 rnGRHSs (GRHSs grhss binds maybe_ty)
213 = ASSERT( not (maybeToBool maybe_ty) )
214 rnBinds binds $ \ binds' ->
215 mapFvRn rnGRHS grhss `thenRn` \ (grhss', fvGRHSs) ->
216 returnRn (GRHSs grhss' binds' Nothing, fvGRHSs)
218 rnGRHS (GRHS guarded locn)
219 = pushSrcLocRn locn $
220 (if not (opt_GlasgowExts || is_standard_guard guarded) then
221 addWarnRn (nonStdGuardErr guarded)
226 rnStmts rnExpr guarded `thenRn` \ (guarded', fvs) ->
227 returnRn (GRHS guarded' locn, fvs)
229 -- Standard Haskell 1.4 guards are just a single boolean
230 -- expression, rather than a list of qualifiers as in the
232 is_standard_guard [ExprStmt _ _] = True
233 is_standard_guard [GuardStmt _ _, ExprStmt _ _] = True
234 is_standard_guard other = False
237 %************************************************************************
239 \subsubsection{Expressions}
241 %************************************************************************
244 rnExprs :: [RdrNameHsExpr] -> RnMS ([RenamedHsExpr], FreeVars)
245 rnExprs ls = rnExprs' ls emptyUniqSet
247 rnExprs' [] acc = returnRn ([], acc)
248 rnExprs' (expr:exprs) acc
249 = rnExpr expr `thenRn` \ (expr', fvExpr) ->
251 -- Now we do a "seq" on the free vars because typically it's small
252 -- or empty, especially in very long lists of constants
254 acc' = acc `plusFV` fvExpr
256 (grubby_seqNameSet acc' rnExprs') exprs acc' `thenRn` \ (exprs', fvExprs) ->
257 returnRn (expr':exprs', fvExprs)
259 -- Grubby little function to do "seq" on namesets; replace by proper seq when GHC can do seq
260 grubby_seqNameSet ns result | isNullUFM ns = result
264 Variables. We look up the variable and return the resulting name.
267 rnExpr :: RdrNameHsExpr -> RnMS (RenamedHsExpr, FreeVars)
270 = lookupOccRn v `thenRn` \ name ->
271 if name `hasKey` assertIdKey then
272 -- We expand it to (GHCerr.assert__ location)
276 returnRn (HsVar name, unitFV name)
279 = newIPName v `thenRn` \ name ->
280 returnRn (HsIPVar name, emptyFVs)
283 = litFVs lit `thenRn` \ fvs ->
284 returnRn (HsLit lit, fvs)
286 rnExpr (HsOverLit lit)
287 = rnOverLit lit `thenRn` \ (lit', fvs) ->
288 returnRn (HsOverLit lit', fvs)
291 = rnMatch match `thenRn` \ (match', fvMatch) ->
292 returnRn (HsLam match', fvMatch)
294 rnExpr (HsApp fun arg)
295 = rnExpr fun `thenRn` \ (fun',fvFun) ->
296 rnExpr arg `thenRn` \ (arg',fvArg) ->
297 returnRn (HsApp fun' arg', fvFun `plusFV` fvArg)
299 rnExpr (OpApp e1 op _ e2)
300 = rnExpr e1 `thenRn` \ (e1', fv_e1) ->
301 rnExpr e2 `thenRn` \ (e2', fv_e2) ->
302 rnExpr op `thenRn` \ (op'@(HsVar op_name), fv_op) ->
305 -- When renaming code synthesised from "deriving" declarations
306 -- we're in Interface mode, and we should ignore fixity; assume
307 -- that the deriving code generator got the association correct
308 -- Don't even look up the fixity when in interface mode
309 getModeRn `thenRn` \ mode ->
311 SourceMode -> lookupFixityRn op_name `thenRn` \ fixity ->
312 mkOpAppRn e1' op' fixity e2'
313 InterfaceMode -> returnRn (OpApp e1' op' defaultFixity e2')
314 ) `thenRn` \ final_e ->
317 fv_e1 `plusFV` fv_op `plusFV` fv_e2)
320 = rnExpr e `thenRn` \ (e', fv_e) ->
321 lookupOrigName negate_RDR `thenRn` \ neg ->
322 mkNegAppRn e' neg `thenRn` \ final_e ->
323 returnRn (final_e, fv_e `addOneFV` neg)
326 = rnExpr e `thenRn` \ (e', fvs_e) ->
327 returnRn (HsPar e', fvs_e)
329 rnExpr section@(SectionL expr op)
330 = rnExpr expr `thenRn` \ (expr', fvs_expr) ->
331 rnExpr op `thenRn` \ (op', fvs_op) ->
332 checkSectionPrec "left" section op' expr' `thenRn_`
333 returnRn (SectionL expr' op', fvs_op `plusFV` fvs_expr)
335 rnExpr section@(SectionR op expr)
336 = rnExpr op `thenRn` \ (op', fvs_op) ->
337 rnExpr expr `thenRn` \ (expr', fvs_expr) ->
338 checkSectionPrec "right" section op' expr' `thenRn_`
339 returnRn (SectionR op' expr', fvs_op `plusFV` fvs_expr)
341 rnExpr (HsCCall fun args may_gc is_casm fake_result_ty)
342 -- Check out the comment on RnIfaces.getNonWiredDataDecl about ccalls
343 = lookupOrigNames [ccallableClass_RDR,
344 creturnableClass_RDR,
345 ioDataCon_RDR] `thenRn` \ implicit_fvs ->
346 rnExprs args `thenRn` \ (args', fvs_args) ->
347 returnRn (HsCCall fun args' may_gc is_casm fake_result_ty,
348 fvs_args `plusFV` implicit_fvs)
350 rnExpr (HsSCC lbl expr)
351 = rnExpr expr `thenRn` \ (expr', fvs_expr) ->
352 returnRn (HsSCC lbl expr', fvs_expr)
354 rnExpr (HsCase expr ms src_loc)
355 = pushSrcLocRn src_loc $
356 rnExpr expr `thenRn` \ (new_expr, e_fvs) ->
357 mapFvRn rnMatch ms `thenRn` \ (new_ms, ms_fvs) ->
358 returnRn (HsCase new_expr new_ms src_loc, e_fvs `plusFV` ms_fvs)
360 rnExpr (HsLet binds expr)
361 = rnBinds binds $ \ binds' ->
362 rnExpr expr `thenRn` \ (expr',fvExpr) ->
363 returnRn (HsLet binds' expr', fvExpr)
365 rnExpr (HsWith expr binds)
366 = rnExpr expr `thenRn` \ (expr',fvExpr) ->
367 rnIPBinds binds `thenRn` \ (binds',fvBinds) ->
368 returnRn (HsWith expr' binds', fvExpr `plusFV` fvBinds)
370 rnExpr e@(HsDo do_or_lc stmts src_loc)
371 = pushSrcLocRn src_loc $
372 lookupOrigNames implicit_rdr_names `thenRn` \ implicit_fvs ->
373 rnStmts rnExpr stmts `thenRn` \ (stmts', fvs) ->
374 -- check the statement list ends in an expression
375 case last stmts' of {
376 ExprStmt _ _ -> returnRn () ;
377 ReturnStmt _ -> returnRn () ; -- for list comprehensions
378 _ -> addErrRn (doStmtListErr e)
380 returnRn (HsDo do_or_lc stmts' src_loc, fvs `plusFV` implicit_fvs)
382 implicit_rdr_names = [foldr_RDR, build_RDR, monadClass_RDR]
383 -- Monad stuff should not be necessary for a list comprehension
384 -- but the typechecker looks up the bind and return Ids anyway
388 rnExpr (ExplicitList exps)
389 = rnExprs exps `thenRn` \ (exps', fvs) ->
390 returnRn (ExplicitList exps', fvs `addOneFV` listTyCon_name)
392 rnExpr (ExplicitTuple exps boxity)
393 = rnExprs exps `thenRn` \ (exps', fvs) ->
394 returnRn (ExplicitTuple exps' boxity, fvs `addOneFV` tycon_name)
396 tycon_name = tupleTyCon_name boxity (length exps)
398 rnExpr (RecordCon con_id rbinds)
399 = lookupOccRn con_id `thenRn` \ conname ->
400 rnRbinds "construction" rbinds `thenRn` \ (rbinds', fvRbinds) ->
401 returnRn (RecordCon conname rbinds', fvRbinds `addOneFV` conname)
403 rnExpr (RecordUpd expr rbinds)
404 = rnExpr expr `thenRn` \ (expr', fvExpr) ->
405 rnRbinds "update" rbinds `thenRn` \ (rbinds', fvRbinds) ->
406 returnRn (RecordUpd expr' rbinds', fvExpr `plusFV` fvRbinds)
408 rnExpr (ExprWithTySig expr pty)
409 = rnExpr expr `thenRn` \ (expr', fvExpr) ->
410 rnHsSigType (text "an expression") pty `thenRn` \ (pty', fvTy) ->
411 returnRn (ExprWithTySig expr' pty', fvExpr `plusFV` fvTy)
413 rnExpr (HsIf p b1 b2 src_loc)
414 = pushSrcLocRn src_loc $
415 rnExpr p `thenRn` \ (p', fvP) ->
416 rnExpr b1 `thenRn` \ (b1', fvB1) ->
417 rnExpr b2 `thenRn` \ (b2', fvB2) ->
418 returnRn (HsIf p' b1' b2' src_loc, plusFVs [fvP, fvB1, fvB2])
420 rnExpr (ArithSeqIn seq)
421 = lookupOrigName enumClass_RDR `thenRn` \ enum ->
422 rn_seq seq `thenRn` \ (new_seq, fvs) ->
423 returnRn (ArithSeqIn new_seq, fvs `addOneFV` enum)
426 = rnExpr expr `thenRn` \ (expr', fvExpr) ->
427 returnRn (From expr', fvExpr)
429 rn_seq (FromThen expr1 expr2)
430 = rnExpr expr1 `thenRn` \ (expr1', fvExpr1) ->
431 rnExpr expr2 `thenRn` \ (expr2', fvExpr2) ->
432 returnRn (FromThen expr1' expr2', fvExpr1 `plusFV` fvExpr2)
434 rn_seq (FromTo expr1 expr2)
435 = rnExpr expr1 `thenRn` \ (expr1', fvExpr1) ->
436 rnExpr expr2 `thenRn` \ (expr2', fvExpr2) ->
437 returnRn (FromTo expr1' expr2', fvExpr1 `plusFV` fvExpr2)
439 rn_seq (FromThenTo expr1 expr2 expr3)
440 = rnExpr expr1 `thenRn` \ (expr1', fvExpr1) ->
441 rnExpr expr2 `thenRn` \ (expr2', fvExpr2) ->
442 rnExpr expr3 `thenRn` \ (expr3', fvExpr3) ->
443 returnRn (FromThenTo expr1' expr2' expr3',
444 plusFVs [fvExpr1, fvExpr2, fvExpr3])
447 These three are pattern syntax appearing in expressions.
448 Since all the symbols are reservedops we can simply reject them.
449 We return a (bogus) EWildPat in each case.
452 rnExpr e@EWildPat = addErrRn (patSynErr e) `thenRn_`
453 returnRn (EWildPat, emptyFVs)
455 rnExpr e@(EAsPat _ _) = addErrRn (patSynErr e) `thenRn_`
456 returnRn (EWildPat, emptyFVs)
458 rnExpr e@(ELazyPat _) = addErrRn (patSynErr e) `thenRn_`
459 returnRn (EWildPat, emptyFVs)
464 %************************************************************************
466 \subsubsection{@Rbinds@s and @Rpats@s: in record expressions}
468 %************************************************************************
472 = mapRn_ field_dup_err dup_fields `thenRn_`
473 mapFvRn rn_rbind rbinds `thenRn` \ (rbinds', fvRbind) ->
474 returnRn (rbinds', fvRbind)
476 (_, dup_fields) = removeDups compare [ f | (f,_,_) <- rbinds ]
478 field_dup_err dups = addErrRn (dupFieldErr str dups)
480 rn_rbind (field, expr, pun)
481 = lookupGlobalOccRn field `thenRn` \ fieldname ->
482 rnExpr expr `thenRn` \ (expr', fvExpr) ->
483 returnRn ((fieldname, expr', pun), fvExpr `addOneFV` fieldname)
486 = mapRn_ field_dup_err dup_fields `thenRn_`
487 mapFvRn rn_rpat rpats `thenRn` \ (rpats', fvs) ->
488 returnRn (rpats', fvs)
490 (_, dup_fields) = removeDups compare [ f | (f,_,_) <- rpats ]
492 field_dup_err dups = addErrRn (dupFieldErr "pattern" dups)
494 rn_rpat (field, pat, pun)
495 = lookupGlobalOccRn field `thenRn` \ fieldname ->
496 rnPat pat `thenRn` \ (pat', fvs) ->
497 returnRn ((fieldname, pat', pun), fvs `addOneFV` fieldname)
500 %************************************************************************
502 \subsubsection{@rnIPBinds@s: in implicit parameter bindings} *
504 %************************************************************************
507 rnIPBinds [] = returnRn ([], emptyFVs)
508 rnIPBinds ((n, expr) : binds)
509 = newIPName n `thenRn` \ name ->
510 rnExpr expr `thenRn` \ (expr',fvExpr) ->
511 rnIPBinds binds `thenRn` \ (binds',fvBinds) ->
512 returnRn ((name, expr') : binds', fvExpr `plusFV` fvBinds)
516 %************************************************************************
518 \subsubsection{@Stmt@s: in @do@ expressions}
520 %************************************************************************
522 Note that although some bound vars may appear in the free var set for
523 the first qual, these will eventually be removed by the caller. For
524 example, if we have @[p | r <- s, q <- r, p <- q]@, when doing
525 @[q <- r, p <- q]@, the free var set for @q <- r@ will
526 be @{r}@, and the free var set for the entire Quals will be @{r}@. This
527 @r@ will be removed only when we finally return from examining all the
531 type RnExprTy = RdrNameHsExpr -> RnMS (RenamedHsExpr, FreeVars)
535 -> RnMS ([RenamedStmt], FreeVars)
538 = returnRn ([], emptyFVs)
540 rnStmts rn_expr (stmt:stmts)
541 = rnStmt rn_expr stmt $ \ stmt' ->
542 rnStmts rn_expr stmts `thenRn` \ (stmts', fvs) ->
543 returnRn (stmt' : stmts', fvs)
545 rnStmt :: RnExprTy -> RdrNameStmt
546 -> (RenamedStmt -> RnMS (a, FreeVars))
547 -> RnMS (a, FreeVars)
548 -- Because of mutual recursion we have to pass in rnExpr.
550 rnStmt rn_expr (BindStmt pat expr src_loc) thing_inside
551 = pushSrcLocRn src_loc $
552 rn_expr expr `thenRn` \ (expr', fv_expr) ->
553 bindLocalsFVRn doc binders $ \ new_binders ->
554 rnPat pat `thenRn` \ (pat', fv_pat) ->
555 thing_inside (BindStmt pat' expr' src_loc) `thenRn` \ (result, fvs) ->
556 returnRn (result, fv_expr `plusFV` fvs `plusFV` fv_pat)
558 binders = collectPatBinders pat
559 doc = text "a pattern in do binding"
561 rnStmt rn_expr (ExprStmt expr src_loc) thing_inside
562 = pushSrcLocRn src_loc $
563 rn_expr expr `thenRn` \ (expr', fv_expr) ->
564 thing_inside (ExprStmt expr' src_loc) `thenRn` \ (result, fvs) ->
565 returnRn (result, fv_expr `plusFV` fvs)
567 rnStmt rn_expr (GuardStmt expr src_loc) thing_inside
568 = pushSrcLocRn src_loc $
569 rn_expr expr `thenRn` \ (expr', fv_expr) ->
570 thing_inside (GuardStmt expr' src_loc) `thenRn` \ (result, fvs) ->
571 returnRn (result, fv_expr `plusFV` fvs)
573 rnStmt rn_expr (ReturnStmt expr) thing_inside
574 = rn_expr expr `thenRn` \ (expr', fv_expr) ->
575 thing_inside (ReturnStmt expr') `thenRn` \ (result, fvs) ->
576 returnRn (result, fv_expr `plusFV` fvs)
578 rnStmt rn_expr (LetStmt binds) thing_inside
579 = rnBinds binds $ \ binds' ->
580 thing_inside (LetStmt binds')
583 %************************************************************************
585 \subsubsection{Precedence Parsing}
587 %************************************************************************
589 @mkOpAppRn@ deals with operator fixities. The argument expressions
590 are assumed to be already correctly arranged. It needs the fixities
591 recorded in the OpApp nodes, because fixity info applies to the things
592 the programmer actually wrote, so you can't find it out from the Name.
594 Furthermore, the second argument is guaranteed not to be another
595 operator application. Why? Because the parser parses all
596 operator appications left-associatively, EXCEPT negation, which
597 we need to handle specially.
600 mkOpAppRn :: RenamedHsExpr -- Left operand; already rearranged
601 -> RenamedHsExpr -> Fixity -- Operator and fixity
602 -> RenamedHsExpr -- Right operand (not an OpApp, but might
604 -> RnMS RenamedHsExpr
606 ---------------------------
607 -- (e11 `op1` e12) `op2` e2
608 mkOpAppRn e1@(OpApp e11 op1 fix1 e12) op2 fix2 e2
610 = addErrRn (precParseErr (ppr_op op1,fix1) (ppr_op op2,fix2)) `thenRn_`
611 returnRn (OpApp e1 op2 fix2 e2)
614 = mkOpAppRn e12 op2 fix2 e2 `thenRn` \ new_e ->
615 returnRn (OpApp e11 op1 fix1 new_e)
617 (nofix_error, associate_right) = compareFixity fix1 fix2
619 ---------------------------
620 -- (- neg_arg) `op` e2
621 mkOpAppRn e1@(NegApp neg_arg neg_op) op2 fix2 e2
623 = addErrRn (precParseErr (pp_prefix_minus,negateFixity) (ppr_op op2,fix2)) `thenRn_`
624 returnRn (OpApp e1 op2 fix2 e2)
627 = mkOpAppRn neg_arg op2 fix2 e2 `thenRn` \ new_e ->
628 returnRn (NegApp new_e neg_op)
630 (nofix_error, associate_right) = compareFixity negateFixity fix2
632 ---------------------------
634 mkOpAppRn e1 op1 fix1 e2@(NegApp neg_arg neg_op) -- NegApp can occur on the right
635 | not associate_right -- We *want* right association
636 = addErrRn (precParseErr (ppr_op op1, fix1) (pp_prefix_minus, negateFixity)) `thenRn_`
637 returnRn (OpApp e1 op1 fix1 e2)
639 (_, associate_right) = compareFixity fix1 negateFixity
641 ---------------------------
643 mkOpAppRn e1 op fix e2 -- Default case, no rearrangment
644 = ASSERT2( right_op_ok fix e2,
645 ppr e1 $$ text "---" $$ ppr op $$ text "---" $$ ppr fix $$ text "---" $$ ppr e2
647 returnRn (OpApp e1 op fix e2)
649 -- Parser left-associates everything, but
650 -- derived instances may have correctly-associated things to
651 -- in the right operarand. So we just check that the right operand is OK
652 right_op_ok fix1 (OpApp _ _ fix2 _)
653 = not error_please && associate_right
655 (error_please, associate_right) = compareFixity fix1 fix2
656 right_op_ok fix1 other
659 -- Parser initially makes negation bind more tightly than any other operator
660 mkNegAppRn neg_arg neg_op
663 getModeRn `thenRn` \ mode ->
664 ASSERT( not_op_app mode neg_arg )
666 returnRn (NegApp neg_arg neg_op)
668 not_op_app SourceMode (OpApp _ _ _ _) = False
669 not_op_app mode other = True
673 mkConOpPatRn :: RenamedPat -> Name -> Fixity -> RenamedPat
676 mkConOpPatRn p1@(ConOpPatIn p11 op1 fix1 p12)
679 = addErrRn (precParseErr (ppr_op op1,fix1) (ppr_op op2,fix2)) `thenRn_`
680 returnRn (ConOpPatIn p1 op2 fix2 p2)
683 = mkConOpPatRn p12 op2 fix2 p2 `thenRn` \ new_p ->
684 returnRn (ConOpPatIn p11 op1 fix1 new_p)
687 (nofix_error, associate_right) = compareFixity fix1 fix2
689 mkConOpPatRn p1 op fix p2 -- Default case, no rearrangment
690 = ASSERT( not_op_pat p2 )
691 returnRn (ConOpPatIn p1 op fix p2)
693 not_op_pat (ConOpPatIn _ _ _ _) = False
694 not_op_pat other = True
698 checkPrecMatch :: Bool -> Name -> RenamedMatch -> RnMS ()
700 checkPrecMatch False fn match
703 checkPrecMatch True op (Match _ (p1:p2:_) _ _)
704 -- True indicates an infix lhs
705 = getModeRn `thenRn` \ mode ->
706 -- See comments with rnExpr (OpApp ...)
708 InterfaceMode -> returnRn ()
709 SourceMode -> checkPrec op p1 False `thenRn_`
712 checkPrecMatch True op _ = panic "checkPrecMatch"
714 checkPrec op (ConOpPatIn _ op1 _ _) right
715 = lookupFixityRn op `thenRn` \ op_fix@(Fixity op_prec op_dir) ->
716 lookupFixityRn op1 `thenRn` \ op1_fix@(Fixity op1_prec op1_dir) ->
718 inf_ok = op1_prec > op_prec ||
719 (op1_prec == op_prec &&
720 (op1_dir == InfixR && op_dir == InfixR && right ||
721 op1_dir == InfixL && op_dir == InfixL && not right))
723 info = (ppr_op op, op_fix)
724 info1 = (ppr_op op1, op1_fix)
725 (infol, infor) = if right then (info, info1) else (info1, info)
727 checkRn inf_ok (precParseErr infol infor)
729 checkPrec op pat right
732 -- Check precedence of (arg op) or (op arg) respectively
733 -- If arg is itself an operator application, its precedence should
734 -- be higher than that of op
735 checkSectionPrec left_or_right section op arg
737 OpApp _ op fix _ -> go_for_it (ppr_op op) fix
738 NegApp _ _ -> go_for_it pp_prefix_minus negateFixity
742 go_for_it pp_arg_op arg_fix@(Fixity arg_prec _)
743 = lookupFixityRn op_name `thenRn` \ op_fix@(Fixity op_prec _) ->
744 checkRn (op_prec < arg_prec)
745 (sectionPrecErr (ppr_op op_name, op_fix) (pp_arg_op, arg_fix) section)
752 @(compareFixity op1 op2)@ tells which way to arrange appication, or
753 whether there's an error.
756 compareFixity :: Fixity -> Fixity
757 -> (Bool, -- Error please
758 Bool) -- Associate to the right: a op1 (b op2 c)
759 compareFixity (Fixity prec1 dir1) (Fixity prec2 dir2)
760 = case prec1 `compare` prec2 of
763 EQ -> case (dir1, dir2) of
764 (InfixR, InfixR) -> right
765 (InfixL, InfixL) -> left
768 right = (False, True)
769 left = (False, False)
770 error_please = (True, False)
773 %************************************************************************
775 \subsubsection{Literals}
777 %************************************************************************
779 When literals occur we have to make sure
780 that the types and classes they involve
784 litFVs (HsChar c) = returnRn (unitFV charTyCon_name)
785 litFVs (HsCharPrim c) = returnRn (unitFV (getName charPrimTyCon))
786 litFVs (HsString s) = returnRn (mkFVs [listTyCon_name, charTyCon_name])
787 litFVs (HsStringPrim s) = returnRn (unitFV (getName addrPrimTyCon))
788 litFVs (HsInt i) = returnRn (unitFV (getName intTyCon))
789 litFVs (HsIntPrim i) = returnRn (unitFV (getName intPrimTyCon))
790 litFVs (HsFloatPrim f) = returnRn (unitFV (getName floatPrimTyCon))
791 litFVs (HsDoublePrim d) = returnRn (unitFV (getName doublePrimTyCon))
792 litFVs (HsLitLit l bogus_ty) = lookupOrigName ccallableClass_RDR `thenRn` \ cc ->
794 litFVs lit = pprPanic "RnExpr.litFVs" (ppr lit) -- HsInteger and HsRat only appear
795 -- in post-typechecker translations
797 rnOverLit (HsIntegral i from_integer)
798 = lookupOccRn from_integer `thenRn` \ from_integer' ->
799 (if inIntRange i then
802 lookupOrigNames [plusInteger_RDR, timesInteger_RDR]
804 returnRn (HsIntegral i from_integer', ns `addOneFV` from_integer')
806 rnOverLit (HsFractional i n)
807 = lookupOccRn n `thenRn` \ n' ->
808 lookupOrigNames [ratioDataCon_RDR, plusInteger_RDR, timesInteger_RDR] `thenRn` \ ns' ->
809 -- We have to make sure that the Ratio type is imported with
810 -- its constructor, because literals of type Ratio t are
811 -- built with that constructor.
812 -- The Rational type is needed too, but that will come in
813 -- when fractionalClass does.
814 -- The plus/times integer operations may be needed to construct the numerator
815 -- and denominator (see DsUtils.mkIntegerLit)
816 returnRn (HsFractional i n', ns' `addOneFV` n')
819 %************************************************************************
821 \subsubsection{Assertion utils}
823 %************************************************************************
826 mkAssertExpr :: RnMS (RenamedHsExpr, FreeVars)
828 lookupOrigName assertErr_RDR `thenRn` \ name ->
829 getSrcLocRn `thenRn` \ sloc ->
831 -- if we're ignoring asserts, return (\ _ e -> e)
832 -- if not, return (assertError "src-loc")
834 if opt_IgnoreAsserts then
835 getUniqRn `thenRn` \ uniq ->
837 vname = mkSysLocalName uniq SLIT("v")
838 expr = HsLam ignorePredMatch
839 loc = nameSrcLoc vname
840 ignorePredMatch = Match [] [WildPatIn, VarPatIn vname] Nothing
841 (GRHSs [GRHS [ExprStmt (HsVar vname) loc] loc]
844 returnRn (expr, unitFV name)
849 (HsLit (HsString (_PK_ (showSDoc (ppr sloc)))))
852 returnRn (expr, unitFV name)
856 %************************************************************************
858 \subsubsection{Errors}
860 %************************************************************************
863 ppr_op op = quotes (ppr op) -- Here, op can be a Name or a (Var n), where n is a Name
864 ppr_opfix (pp_op, fixity) = pp_op <+> brackets (ppr fixity)
865 pp_prefix_minus = ptext SLIT("prefix `-'")
867 dupFieldErr str (dup:rest)
868 = hsep [ptext SLIT("duplicate field name"),
870 ptext SLIT("in record"), text str]
873 = hang (ptext SLIT("precedence parsing error"))
874 4 (hsep [ptext SLIT("cannot mix"), ppr_opfix op1, ptext SLIT("and"),
876 ptext SLIT("in the same infix expression")])
878 sectionPrecErr op arg_op section
879 = vcat [ptext SLIT("The operator") <+> ppr_opfix op <+> ptext SLIT("of a section"),
880 nest 4 (ptext SLIT("must have lower precedence than the operand") <+> ppr_opfix arg_op),
881 nest 4 (ptext SLIT("In the section:") <+> quotes (ppr section))]
885 SLIT("accepting non-standard pattern guards (-fglasgow-exts to suppress this message)")
889 = (ptext SLIT("Illegal signature in pattern:") <+> ppr ty)
890 $$ nest 4 (ptext SLIT("Use -fglasgow-exts to permit it"))
893 = sep [ptext SLIT("Pattern syntax in expression context:"),
897 = sep [ptext SLIT("`do' statements must end in expression:"),