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 @Qualifier@ datatypes. In
9 general, all of these functions return a renamed thing, and a set of
14 rnMatch, rnGRHSsAndBinds, rnPat,
18 #include "HsVersions.h"
20 import {-# SOURCE #-} RnBinds
21 import {-# SOURCE #-} RnSource ( rnHsSigType )
28 import CmdLineOpts ( opt_GlasgowExts )
29 import BasicTypes ( Fixity(..), FixityDirection(..) )
30 import PrelInfo ( numClass_RDR, fractionalClass_RDR, eqClass_RDR,
31 ccallableClass_RDR, creturnableClass_RDR,
32 monadZeroClass_RDR, enumClass_RDR, ordClass_RDR,
33 ratioDataCon_RDR, negate_RDR,
34 ioDataCon_RDR, ioOkDataCon_RDR
36 import TysPrim ( charPrimTyCon, addrPrimTyCon, intPrimTyCon,
37 floatPrimTyCon, doublePrimTyCon
40 import UniqFM ( lookupUFM, {- ToDo:rm-} isNullUFM )
41 import UniqSet ( emptyUniqSet, unitUniqSet,
42 unionUniqSets, unionManyUniqSets,
45 import Util ( removeDups )
50 *********************************************************
54 *********************************************************
57 rnPat :: RdrNamePat -> RnMS s RenamedPat
59 rnPat WildPatIn = returnRn WildPatIn
62 = lookupBndrRn name `thenRn` \ vname ->
63 returnRn (VarPatIn vname)
66 = litOccurrence lit `thenRn_`
67 lookupImplicitOccRn eqClass_RDR `thenRn_` -- Needed to find equality on pattern
68 returnRn (LitPatIn lit)
71 = rnPat pat `thenRn` \ pat' ->
72 returnRn (LazyPatIn pat')
74 rnPat (AsPatIn name pat)
75 = rnPat pat `thenRn` \ pat' ->
76 lookupBndrRn name `thenRn` \ vname ->
77 returnRn (AsPatIn vname pat')
79 rnPat (ConPatIn con pats)
80 = lookupOccRn con `thenRn` \ con' ->
81 mapRn rnPat pats `thenRn` \ patslist ->
82 returnRn (ConPatIn con' patslist)
84 rnPat (ConOpPatIn pat1 con _ pat2)
85 = rnPat pat1 `thenRn` \ pat1' ->
86 lookupOccRn con `thenRn` \ con' ->
87 lookupFixity con `thenRn` \ fixity ->
88 rnPat pat2 `thenRn` \ pat2' ->
89 mkConOpPatRn pat1' con' fixity pat2'
91 -- Negated patters can only be literals, and they are dealt with
92 -- by negating the literal at compile time, not by using the negation
93 -- operation in Num. So we don't need to make an implicit reference
95 rnPat neg@(NegPatIn pat)
96 = checkRn (valid_neg_pat pat) (negPatErr neg)
98 rnPat pat `thenRn` \ pat' ->
99 returnRn (NegPatIn pat')
101 valid_neg_pat (LitPatIn (HsInt _)) = True
102 valid_neg_pat (LitPatIn (HsFrac _)) = True
103 valid_neg_pat _ = False
106 = rnPat pat `thenRn` \ pat' ->
107 returnRn (ParPatIn pat')
109 rnPat (NPlusKPatIn name lit)
110 = litOccurrence lit `thenRn_`
111 lookupImplicitOccRn ordClass_RDR `thenRn_`
112 lookupBndrRn name `thenRn` \ name' ->
113 returnRn (NPlusKPatIn name' lit)
115 rnPat (ListPatIn pats)
116 = addImplicitOccRn listType_name `thenRn_`
117 mapRn rnPat pats `thenRn` \ patslist ->
118 returnRn (ListPatIn patslist)
120 rnPat (TuplePatIn pats)
121 = addImplicitOccRn (tupleType_name (length pats)) `thenRn_`
122 mapRn rnPat pats `thenRn` \ patslist ->
123 returnRn (TuplePatIn patslist)
125 rnPat (RecPatIn con rpats)
126 = lookupOccRn con `thenRn` \ con' ->
127 rnRpats rpats `thenRn` \ rpats' ->
128 returnRn (RecPatIn con' rpats')
131 ************************************************************************
135 ************************************************************************
138 rnMatch, rnMatch1 :: RdrNameMatch -> RnMS s (RenamedMatch, FreeVars)
140 -- The only tricky bit here is that we want to do a single
141 -- bindLocalsRn for all the matches together, so that we spot
142 -- the repeated variable in
146 = pushSrcLocRn (getMatchLoc match) $
147 bindLocalsRn "pattern" (get_binders match) $ \ new_binders ->
148 rnMatch1 match `thenRn` \ (match', fvs) ->
150 binder_set = mkNameSet new_binders
151 unused_binders = binder_set `minusNameSet` fvs
152 net_fvs = fvs `minusNameSet` binder_set
154 warnUnusedMatches unused_binders `thenRn_`
156 returnRn (match', net_fvs)
158 get_binders (GRHSMatch _) = []
159 get_binders (PatMatch pat match) = collectPatBinders pat ++ get_binders match
161 rnMatch1 (PatMatch pat match)
162 = rnPat pat `thenRn` \ pat' ->
163 rnMatch1 match `thenRn` \ (match', fvs) ->
164 returnRn (PatMatch pat' match', fvs)
166 rnMatch1 (GRHSMatch grhss_and_binds)
167 = rnGRHSsAndBinds grhss_and_binds `thenRn` \ (grhss_and_binds', fvs) ->
168 returnRn (GRHSMatch grhss_and_binds', fvs)
171 %************************************************************************
173 \subsubsection{Guarded right-hand sides (GRHSsAndBinds)}
175 %************************************************************************
178 rnGRHSsAndBinds :: RdrNameGRHSsAndBinds -> RnMS s (RenamedGRHSsAndBinds, FreeVars)
180 rnGRHSsAndBinds (GRHSsAndBindsIn grhss binds)
181 = rnBinds binds $ \ binds' ->
182 rnGRHSs grhss `thenRn` \ (grhss', fvGRHS) ->
183 returnRn (GRHSsAndBindsIn grhss' binds', fvGRHS)
185 rnGRHSs [] = returnRn ([], emptyNameSet)
188 = rnGRHS grhs `thenRn` \ (grhs', fvs) ->
189 rnGRHSs grhss `thenRn` \ (grhss', fvss) ->
190 returnRn (grhs' : grhss', fvs `unionNameSets` fvss)
192 rnGRHS (GRHS guard expr locn)
193 = pushSrcLocRn locn $
194 (if not (opt_GlasgowExts || is_standard_guard guard) then
195 addWarnRn (nonStdGuardErr guard)
200 (rnStmts rnExpr guard $ \ guard' ->
201 -- This nested thing deals with scope and
202 -- the free vars of the guard, and knocking off the
203 -- free vars of the rhs that are bound by the guard
205 rnExpr expr `thenRn` \ (expr', fvse) ->
206 returnRn (GRHS guard' expr' locn, fvse))
208 -- Standard Haskell 1.4 guards are just a single boolean
209 -- expression, rather than a list of qualifiers as in the
211 is_standard_guard [] = True
212 is_standard_guard [GuardStmt _ _] = True
213 is_standard_guard other = False
216 %************************************************************************
218 \subsubsection{Expressions}
220 %************************************************************************
223 rnExprs :: [RdrNameHsExpr] -> RnMS s ([RenamedHsExpr], FreeVars)
224 rnExprs ls = rnExprs' ls emptyUniqSet
226 rnExprs' [] acc = returnRn ([], acc)
227 rnExprs' (expr:exprs) acc
228 = rnExpr expr `thenRn` \ (expr', fvExpr) ->
230 -- Now we do a "seq" on the free vars because typically it's small
231 -- or empty, especially in very long lists of constants
233 acc' = acc `unionNameSets` fvExpr
235 (grubby_seqNameSet acc' rnExprs') exprs acc' `thenRn` \ (exprs', fvExprs) ->
236 returnRn (expr':exprs', fvExprs)
238 -- Grubby little function to do "seq" on namesets; replace by proper seq when GHC can do seq
239 grubby_seqNameSet ns result | isNullUFM ns = result
243 Variables. We look up the variable and return the resulting name. The
244 interesting question is what the free-variable set should be. We
245 don't want to return imported or prelude things as free vars. So we
246 look at the Name returned from the lookup, and make it part of the
247 free-var set iff if it's a LocallyDefined Name.
251 rnExpr :: RdrNameHsExpr -> RnMS s (RenamedHsExpr, FreeVars)
254 = lookupOccRn v `thenRn` \ vname ->
255 returnRn (HsVar vname, if isLocallyDefined vname
256 then unitNameSet vname
260 = litOccurrence lit `thenRn_`
261 returnRn (HsLit lit, emptyNameSet)
264 = rnMatch match `thenRn` \ (match', fvMatch) ->
265 returnRn (HsLam match', fvMatch)
267 rnExpr (HsApp fun arg)
268 = rnExpr fun `thenRn` \ (fun',fvFun) ->
269 rnExpr arg `thenRn` \ (arg',fvArg) ->
270 returnRn (HsApp fun' arg', fvFun `unionNameSets` fvArg)
272 rnExpr (OpApp e1 op@(HsVar op_name) _ e2)
273 = rnExpr e1 `thenRn` \ (e1', fv_e1) ->
274 rnExpr e2 `thenRn` \ (e2', fv_e2) ->
275 rnExpr op `thenRn` \ (op', fv_op) ->
278 -- When renaming code synthesised from "deriving" declarations
279 -- we're in Interface mode, and we should ignore fixity; assume
280 -- that the deriving code generator got the association correct
281 lookupFixity op_name `thenRn` \ fixity ->
282 getModeRn `thenRn` \ mode ->
284 SourceMode -> mkOpAppRn e1' op' fixity e2'
285 InterfaceMode _ _ -> returnRn (OpApp e1' op' fixity e2')
286 ) `thenRn` \ final_e ->
289 fv_e1 `unionNameSets` fv_op `unionNameSets` fv_e2)
292 = rnExpr e `thenRn` \ (e', fv_e) ->
293 lookupImplicitOccRn negate_RDR `thenRn` \ neg ->
294 mkNegAppRn e' (HsVar neg) `thenRn` \ final_e ->
295 returnRn (final_e, fv_e)
298 = rnExpr e `thenRn` \ (e', fvs_e) ->
299 returnRn (HsPar e', fvs_e)
301 rnExpr (SectionL expr op)
302 = rnExpr expr `thenRn` \ (expr', fvs_expr) ->
303 rnExpr op `thenRn` \ (op', fvs_op) ->
304 returnRn (SectionL expr' op', fvs_op `unionNameSets` fvs_expr)
306 rnExpr (SectionR op expr)
307 = rnExpr op `thenRn` \ (op', fvs_op) ->
308 rnExpr expr `thenRn` \ (expr', fvs_expr) ->
309 returnRn (SectionR op' expr', fvs_op `unionNameSets` fvs_expr)
311 rnExpr (CCall fun args may_gc is_casm fake_result_ty)
312 -- Check out the comment on RnIfaces.getNonWiredDataDecl about ccalls
313 = lookupImplicitOccRn ccallableClass_RDR `thenRn_`
314 lookupImplicitOccRn creturnableClass_RDR `thenRn_`
315 lookupImplicitOccRn ioDataCon_RDR `thenRn_`
316 lookupImplicitOccRn ioOkDataCon_RDR `thenRn_`
317 rnExprs args `thenRn` \ (args', fvs_args) ->
318 returnRn (CCall fun args' may_gc is_casm fake_result_ty, fvs_args)
320 rnExpr (HsSCC label expr)
321 = rnExpr expr `thenRn` \ (expr', fvs_expr) ->
322 returnRn (HsSCC label expr', fvs_expr)
324 rnExpr (HsCase expr ms src_loc)
325 = pushSrcLocRn src_loc $
326 rnExpr expr `thenRn` \ (new_expr, e_fvs) ->
327 mapAndUnzipRn rnMatch ms `thenRn` \ (new_ms, ms_fvs) ->
328 returnRn (HsCase new_expr new_ms src_loc, unionManyNameSets (e_fvs : ms_fvs))
330 rnExpr (HsLet binds expr)
331 = rnBinds binds $ \ binds' ->
332 rnExpr expr `thenRn` \ (expr',fvExpr) ->
333 returnRn (HsLet binds' expr', fvExpr)
335 rnExpr (HsDo do_or_lc stmts src_loc)
336 = pushSrcLocRn src_loc $
337 lookupImplicitOccRn monadZeroClass_RDR `thenRn_` -- Forces Monad to come too
338 (rnStmts rnExpr stmts $ \ stmts' ->
339 returnRn (HsDo do_or_lc stmts' src_loc, emptyNameSet))
341 rnExpr (ExplicitList exps)
342 = addImplicitOccRn listType_name `thenRn_`
343 rnExprs exps `thenRn` \ (exps', fvs) ->
344 returnRn (ExplicitList exps', fvs)
346 rnExpr (ExplicitTuple exps)
347 = addImplicitOccRn (tupleType_name (length exps)) `thenRn_`
348 rnExprs exps `thenRn` \ (exps', fvExps) ->
349 returnRn (ExplicitTuple exps', fvExps)
351 rnExpr (RecordCon con_id _ rbinds)
352 = lookupOccRn con_id `thenRn` \ conname ->
353 rnRbinds "construction" rbinds `thenRn` \ (rbinds', fvRbinds) ->
354 returnRn (RecordCon conname (error "rnExpr:RecordCon") rbinds', fvRbinds)
356 rnExpr (RecordUpd expr rbinds)
357 = rnExpr expr `thenRn` \ (expr', fvExpr) ->
358 rnRbinds "update" rbinds `thenRn` \ (rbinds', fvRbinds) ->
359 returnRn (RecordUpd expr' rbinds', fvExpr `unionNameSets` fvRbinds)
361 rnExpr (ExprWithTySig expr pty)
362 = rnExpr expr `thenRn` \ (expr', fvExpr) ->
363 rnHsSigType (text "an expression") pty `thenRn` \ pty' ->
364 returnRn (ExprWithTySig expr' pty', fvExpr)
366 rnExpr (HsIf p b1 b2 src_loc)
367 = pushSrcLocRn src_loc $
368 rnExpr p `thenRn` \ (p', fvP) ->
369 rnExpr b1 `thenRn` \ (b1', fvB1) ->
370 rnExpr b2 `thenRn` \ (b2', fvB2) ->
371 returnRn (HsIf p' b1' b2' src_loc, unionManyNameSets [fvP, fvB1, fvB2])
373 rnExpr (ArithSeqIn seq)
374 = lookupImplicitOccRn enumClass_RDR `thenRn_`
375 rn_seq seq `thenRn` \ (new_seq, fvs) ->
376 returnRn (ArithSeqIn new_seq, fvs)
379 = rnExpr expr `thenRn` \ (expr', fvExpr) ->
380 returnRn (From expr', fvExpr)
382 rn_seq (FromThen expr1 expr2)
383 = rnExpr expr1 `thenRn` \ (expr1', fvExpr1) ->
384 rnExpr expr2 `thenRn` \ (expr2', fvExpr2) ->
385 returnRn (FromThen expr1' expr2', fvExpr1 `unionNameSets` fvExpr2)
387 rn_seq (FromTo expr1 expr2)
388 = rnExpr expr1 `thenRn` \ (expr1', fvExpr1) ->
389 rnExpr expr2 `thenRn` \ (expr2', fvExpr2) ->
390 returnRn (FromTo expr1' expr2', fvExpr1 `unionNameSets` fvExpr2)
392 rn_seq (FromThenTo expr1 expr2 expr3)
393 = rnExpr expr1 `thenRn` \ (expr1', fvExpr1) ->
394 rnExpr expr2 `thenRn` \ (expr2', fvExpr2) ->
395 rnExpr expr3 `thenRn` \ (expr3', fvExpr3) ->
396 returnRn (FromThenTo expr1' expr2' expr3',
397 unionManyNameSets [fvExpr1, fvExpr2, fvExpr3])
400 %************************************************************************
402 \subsubsection{@Rbinds@s and @Rpats@s: in record expressions}
404 %************************************************************************
408 = mapRn field_dup_err dup_fields `thenRn_`
409 mapAndUnzipRn rn_rbind rbinds `thenRn` \ (rbinds', fvRbind_s) ->
410 returnRn (rbinds', unionManyNameSets fvRbind_s)
412 (_, dup_fields) = removeDups compare [ f | (f,_,_) <- rbinds ]
414 field_dup_err dups = addErrRn (dupFieldErr str dups)
416 rn_rbind (field, expr, pun)
417 = lookupGlobalOccRn field `thenRn` \ fieldname ->
418 rnExpr expr `thenRn` \ (expr', fvExpr) ->
419 returnRn ((fieldname, expr', pun), fvExpr)
422 = mapRn field_dup_err dup_fields `thenRn_`
425 (_, dup_fields) = removeDups compare [ f | (f,_,_) <- rpats ]
427 field_dup_err dups = addErrRn (dupFieldErr "pattern" dups)
429 rn_rpat (field, pat, pun)
430 = lookupGlobalOccRn field `thenRn` \ fieldname ->
431 rnPat pat `thenRn` \ pat' ->
432 returnRn (fieldname, pat', pun)
435 %************************************************************************
437 \subsubsection{@Stmt@s: in @do@ expressions}
439 %************************************************************************
441 Note that although some bound vars may appear in the free var set for
442 the first qual, these will eventually be removed by the caller. For
443 example, if we have @[p | r <- s, q <- r, p <- q]@, when doing
444 @[q <- r, p <- q]@, the free var set for @q <- r@ will
445 be @{r}@, and the free var set for the entire Quals will be @{r}@. This
446 @r@ will be removed only when we finally return from examining all the
450 type RnExprTy s = RdrNameHsExpr -> RnMS s (RenamedHsExpr, FreeVars)
452 rnStmts :: RnExprTy s
454 -> ([RenamedStmt] -> RnMS s (a, FreeVars))
455 -> RnMS s (a, FreeVars)
457 rnStmts rn_expr [] thing_inside
460 rnStmts rn_expr (stmt:stmts) thing_inside
461 = rnStmt rn_expr stmt $ \ stmt' ->
462 rnStmts rn_expr stmts $ \ stmts' ->
463 thing_inside (stmt' : stmts')
465 rnStmt :: RnExprTy s -> RdrNameStmt -> (RenamedStmt -> RnMS s (a, FreeVars)) -> RnMS s (a, FreeVars)
466 -- Because of mutual recursion we have to pass in rnExpr.
468 rnStmt rn_expr (BindStmt pat expr src_loc) thing_inside
469 = pushSrcLocRn src_loc $
470 rn_expr expr `thenRn` \ (expr', fv_expr) ->
471 bindLocalsRn "pattern in do binding" binders $ \ new_binders ->
472 rnPat pat `thenRn` \ pat' ->
474 thing_inside (BindStmt pat' expr' src_loc) `thenRn` \ (result, fvs) ->
475 returnRn (result, fv_expr `unionNameSets` (fvs `minusNameSet` mkNameSet new_binders))
477 binders = collectPatBinders pat
479 rnStmt rn_expr (ExprStmt expr src_loc) thing_inside
480 = pushSrcLocRn src_loc $
481 rn_expr expr `thenRn` \ (expr', fv_expr) ->
482 thing_inside (ExprStmt expr' src_loc) `thenRn` \ (result, fvs) ->
483 returnRn (result, fv_expr `unionNameSets` fvs)
485 rnStmt rn_expr (GuardStmt expr src_loc) thing_inside
486 = pushSrcLocRn src_loc $
487 rn_expr expr `thenRn` \ (expr', fv_expr) ->
488 thing_inside (GuardStmt expr' src_loc) `thenRn` \ (result, fvs) ->
489 returnRn (result, fv_expr `unionNameSets` fvs)
491 rnStmt rn_expr (ReturnStmt expr) thing_inside
492 = rn_expr expr `thenRn` \ (expr', fv_expr) ->
493 thing_inside (ReturnStmt expr') `thenRn` \ (result, fvs) ->
494 returnRn (result, fv_expr `unionNameSets` fvs)
496 rnStmt rn_expr (LetStmt binds) thing_inside
497 = rnBinds binds $ \ binds' ->
498 thing_inside (LetStmt binds')
501 %************************************************************************
503 \subsubsection{Precedence Parsing}
505 %************************************************************************
507 @mkOpAppRn@ deals with operator fixities. The argument expressions
508 are assumed to be already correctly arranged. It needs the fixities
509 recorded in the OpApp nodes, because fixity info applies to the things
510 the programmer actually wrote, so you can't find it out from the Name.
512 Furthermore, the second argument is guaranteed not to be another
513 operator application. Why? Because the parser parses all
514 operator appications left-associatively.
517 mkOpAppRn :: RenamedHsExpr -> RenamedHsExpr -> Fixity -> RenamedHsExpr
518 -> RnMS s RenamedHsExpr
520 mkOpAppRn e1@(OpApp e11 op1 fix1 e12)
523 = addErrRn (precParseErr (get op1,fix1) (get op2,fix2)) `thenRn_`
524 returnRn (OpApp e1 op2 fix2 e2)
527 = mkOpAppRn e12 op2 fix2 e2 `thenRn` \ new_e ->
528 returnRn (OpApp e11 op1 fix1 new_e)
530 (nofix_error, rearrange_me) = compareFixity fix1 fix2
532 mkOpAppRn e1@(NegApp neg_arg neg_op)
534 fix2@(Fixity prec2 dir2)
537 = addErrRn (precParseErr (get neg_op,fix_neg) (get op2,fix2)) `thenRn_`
538 returnRn (OpApp e1 op2 fix2 e2)
541 = mkOpAppRn neg_arg op2 fix2 e2 `thenRn` \ new_e ->
542 returnRn (NegApp new_e neg_op)
544 fix_neg = Fixity 6 InfixL -- Precedence of unary negate is wired in as infixl 6!
545 (nofix_error, rearrange_me) = compareFixity fix_neg fix2
547 mkOpAppRn e1 op fix e2 -- Default case, no rearrangment
548 = ASSERT( if right_op_ok fix e2 then True
549 else pprPanic "mkOpAppRn" (vcat [ppr e1, text "---", ppr op, text "---", ppr fix, text "---", ppr e2])
551 returnRn (OpApp e1 op fix e2)
555 -- Parser left-associates everything, but
556 -- derived instances may have correctly-associated things to
557 -- in the right operarand. So we just check that the right operand is OK
558 right_op_ok fix1 (OpApp _ _ fix2 _)
559 = not error_please && associate_right
561 (error_please, associate_right) = compareFixity fix1 fix2
562 right_op_ok fix1 other
565 -- Parser initially makes negation bind more tightly than any other operator
566 mkNegAppRn neg_arg neg_op
569 getModeRn `thenRn` \ mode ->
570 ASSERT( not_op_app mode neg_arg )
572 returnRn (NegApp neg_arg neg_op)
574 not_op_app SourceMode (OpApp _ _ _ _) = False
575 not_op_app mode other = True
579 mkConOpPatRn :: RenamedPat -> Name -> Fixity -> RenamedPat
582 mkConOpPatRn p1@(ConOpPatIn p11 op1 fix1 p12)
585 = addErrRn (precParseErr (op1,fix1) (op2,fix2)) `thenRn_`
586 returnRn (ConOpPatIn p1 op2 fix2 p2)
589 = mkConOpPatRn p12 op2 fix2 p2 `thenRn` \ new_p ->
590 returnRn (ConOpPatIn p11 op1 fix1 new_p)
593 (nofix_error, rearrange_me) = compareFixity fix1 fix2
595 mkConOpPatRn p1@(NegPatIn neg_arg)
597 fix2@(Fixity prec2 dir2)
599 | prec2 > 6 -- Precedence of unary - is wired in as 6!
600 = addErrRn (precParseNegPatErr (op2,fix2)) `thenRn_`
601 returnRn (ConOpPatIn p1 op2 fix2 p2)
603 mkConOpPatRn p1 op fix p2 -- Default case, no rearrangment
604 = ASSERT( not_op_pat p2 )
605 returnRn (ConOpPatIn p1 op fix p2)
607 not_op_pat (ConOpPatIn _ _ _ _) = False
608 not_op_pat other = True
612 checkPrecMatch :: Bool -> RdrName -> RdrNameMatch -> RnMS s ()
614 checkPrecMatch False fn match
616 checkPrecMatch True op (PatMatch p1 (PatMatch p2 (GRHSMatch _)))
617 = checkPrec op p1 False `thenRn_`
619 checkPrecMatch True op _
620 = panic "checkPrecMatch"
622 checkPrec op (ConOpPatIn _ op1 _ _) right
623 = lookupFixity op `thenRn` \ op_fix@(Fixity op_prec op_dir) ->
624 lookupFixity op1 `thenRn` \ op1_fix@(Fixity op1_prec op1_dir) ->
626 inf_ok = op1_prec > op_prec ||
627 (op1_prec == op_prec &&
628 (op1_dir == InfixR && op_dir == InfixR && right ||
629 op1_dir == InfixL && op_dir == InfixL && not right))
632 info1 = (op1,op1_fix)
633 (infol, infor) = if right then (info, info1) else (info1, info)
635 checkRn inf_ok (precParseErr infol infor)
637 checkPrec op (NegPatIn _) right
638 = lookupFixity op `thenRn` \ op_fix@(Fixity op_prec op_dir) ->
639 checkRn (op_prec <= 6) (precParseNegPatErr (op,op_fix))
641 checkPrec op pat right
648 (compareFixity op1 op2) tells which way to arrange appication, or
649 whether there's an error.
652 compareFixity :: Fixity -> Fixity
653 -> (Bool, -- Error please
654 Bool) -- Associate to the right: a op1 (b op2 c)
655 compareFixity (Fixity prec1 dir1) (Fixity prec2 dir2)
656 = case prec1 `compare` prec2 of
659 EQ -> case (dir1, dir2) of
660 (InfixR, InfixR) -> right
661 (InfixL, InfixL) -> left
664 right = (False, True)
665 left = (False, False)
666 error_please = (True, False)
669 %************************************************************************
671 \subsubsection{Literals}
673 %************************************************************************
675 When literals occur we have to make sure that the types and classes they involve
679 litOccurrence (HsChar _)
680 = addImplicitOccRn charType_name
682 litOccurrence (HsCharPrim _)
683 = addImplicitOccRn (getName charPrimTyCon)
685 litOccurrence (HsString _)
686 = addImplicitOccRn listType_name `thenRn_`
687 addImplicitOccRn charType_name
689 litOccurrence (HsStringPrim _)
690 = addImplicitOccRn (getName addrPrimTyCon)
692 litOccurrence (HsInt _)
693 = lookupImplicitOccRn numClass_RDR -- Int and Integer are forced in by Num
695 litOccurrence (HsFrac _)
696 = lookupImplicitOccRn fractionalClass_RDR `thenRn_`
697 lookupImplicitOccRn ratioDataCon_RDR
698 -- We have to make sure that the Ratio type is imported with
699 -- its constructor, because literals of type Ratio t are
700 -- built with that constructor.
701 -- The Rational type is needed too, but that will come in
702 -- when fractionalClass does.
704 litOccurrence (HsIntPrim _)
705 = addImplicitOccRn (getName intPrimTyCon)
707 litOccurrence (HsFloatPrim _)
708 = addImplicitOccRn (getName floatPrimTyCon)
710 litOccurrence (HsDoublePrim _)
711 = addImplicitOccRn (getName doublePrimTyCon)
713 litOccurrence (HsLitLit _)
714 = lookupImplicitOccRn ccallableClass_RDR
718 %************************************************************************
720 \subsubsection{Errors}
722 %************************************************************************
725 dupFieldErr str (dup:rest)
726 = hsep [ptext SLIT("duplicate field name"),
728 ptext SLIT("in record"), text str]
731 = sep [ptext SLIT("prefix `-' not applied to literal in pattern"), quotes (ppr pat)]
733 precParseNegPatErr op
734 = hang (ptext SLIT("precedence parsing error"))
735 4 (hsep [ptext SLIT("prefix `-' has lower precedence than"),
737 ptext SLIT("in pattern")])
740 = hang (ptext SLIT("precedence parsing error"))
741 4 (hsep [ptext SLIT("cannot mix"), quotes (pp_op op1), ptext SLIT("and"),
743 ptext SLIT("in the same infix expression")])
746 = hang (ptext SLIT("accepting non-standard pattern guards (-fglasgow-exts to suppress this message)"))
749 pp_op (op, fix) = hcat [ppr op, space, parens (ppr fix)]