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
13 #include "HsVersions.h"
16 rnMatch, rnGRHSsAndBinds, rnPat,
21 #if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ <= 201
22 IMPORT_DELOOPER(RnLoop) -- break the RnPass/RnExpr/RnBinds loops
24 import {-# SOURCE #-} RnBinds
25 import {-# SOURCE #-} RnSource ( rnHsSigType )
33 import CmdLineOpts ( opt_GlasgowExts )
34 import BasicTypes ( Fixity(..), FixityDirection(..) )
35 import PrelInfo ( numClass_RDR, fractionalClass_RDR, eqClass_RDR, ccallableClass_RDR,
36 creturnableClass_RDR, monadZeroClass_RDR, enumClass_RDR, ordClass_RDR,
37 ratioDataCon_RDR, negate_RDR
39 import TysPrim ( charPrimTyCon, addrPrimTyCon, intPrimTyCon,
40 floatPrimTyCon, doublePrimTyCon
42 import TyCon ( TyCon )
44 import ErrUtils ( addErrLoc, addShortErrLocLine )
47 import UniqFM ( lookupUFM, {- ToDo:rm-} isNullUFM )
48 import UniqSet ( emptyUniqSet, unitUniqSet,
49 unionUniqSets, unionManyUniqSets,
52 import Util ( Ord3(..), removeDups, panic, pprPanic, assertPanic )
58 *********************************************************
62 *********************************************************
65 rnPat :: RdrNamePat -> RnMS s RenamedPat
67 rnPat WildPatIn = returnRn WildPatIn
70 = lookupBndrRn name `thenRn` \ vname ->
71 returnRn (VarPatIn vname)
74 = litOccurrence lit `thenRn_`
75 lookupImplicitOccRn eqClass_RDR `thenRn_` -- Needed to find equality on pattern
76 returnRn (LitPatIn lit)
79 = rnPat pat `thenRn` \ pat' ->
80 returnRn (LazyPatIn pat')
82 rnPat (AsPatIn name pat)
83 = rnPat pat `thenRn` \ pat' ->
84 lookupBndrRn name `thenRn` \ vname ->
85 returnRn (AsPatIn vname pat')
87 rnPat (ConPatIn con pats)
88 = lookupOccRn con `thenRn` \ con' ->
89 mapRn rnPat pats `thenRn` \ patslist ->
90 returnRn (ConPatIn con' patslist)
92 rnPat (ConOpPatIn pat1 con _ pat2)
93 = rnPat pat1 `thenRn` \ pat1' ->
94 lookupOccRn con `thenRn` \ con' ->
95 lookupFixity con `thenRn` \ fixity ->
96 rnPat pat2 `thenRn` \ pat2' ->
97 mkConOpPatRn pat1' con' fixity pat2'
99 -- Negated patters can only be literals, and they are dealt with
100 -- by negating the literal at compile time, not by using the negation
101 -- operation in Num. So we don't need to make an implicit reference
103 rnPat neg@(NegPatIn pat)
104 = checkRn (valid_neg_pat pat) (negPatErr neg)
106 rnPat pat `thenRn` \ pat' ->
107 returnRn (NegPatIn pat')
109 valid_neg_pat (LitPatIn (HsInt _)) = True
110 valid_neg_pat (LitPatIn (HsFrac _)) = True
111 valid_neg_pat _ = False
114 = rnPat pat `thenRn` \ pat' ->
115 returnRn (ParPatIn pat')
117 rnPat (NPlusKPatIn name lit)
118 = litOccurrence lit `thenRn_`
119 lookupImplicitOccRn ordClass_RDR `thenRn_`
120 lookupBndrRn name `thenRn` \ name' ->
121 returnRn (NPlusKPatIn name' lit)
123 rnPat (ListPatIn pats)
124 = addImplicitOccRn listType_name `thenRn_`
125 mapRn rnPat pats `thenRn` \ patslist ->
126 returnRn (ListPatIn patslist)
128 rnPat (TuplePatIn pats)
129 = addImplicitOccRn (tupleType_name (length pats)) `thenRn_`
130 mapRn rnPat pats `thenRn` \ patslist ->
131 returnRn (TuplePatIn patslist)
133 rnPat (RecPatIn con rpats)
134 = lookupOccRn con `thenRn` \ con' ->
135 rnRpats rpats `thenRn` \ rpats' ->
136 returnRn (RecPatIn con' rpats')
139 ************************************************************************
143 ************************************************************************
146 rnMatch, rnMatch1 :: RdrNameMatch -> RnMS s (RenamedMatch, FreeVars)
148 -- The only tricky bit here is that we want to do a single
149 -- bindLocalsRn for all the matches together, so that we spot
150 -- the repeated variable in
154 = bindLocalsRn "pattern" (get_binders match) $ \ new_binders ->
155 rnMatch1 match `thenRn` \ (match', fvs) ->
156 returnRn (match', fvs `minusNameSet` mkNameSet new_binders)
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 rnGRHS (OtherwiseGRHS expr locn)
209 = pushSrcLocRn locn $
210 rnExpr expr `thenRn` \ (expr', fvs) ->
211 returnRn (GRHS [] expr' locn, fvs)
213 -- Standard Haskell 1.4 guards are just a single boolean
214 -- expression, rather than a list of qualifiers as in the
216 is_standard_guard [GuardStmt _ _] = True
217 is_standard_guard other = False
220 %************************************************************************
222 \subsubsection{Expressions}
224 %************************************************************************
227 rnExprs :: [RdrNameHsExpr] -> RnMS s ([RenamedHsExpr], FreeVars)
228 rnExprs ls = rnExprs' ls emptyUniqSet
230 rnExprs' [] acc = returnRn ([], acc)
231 rnExprs' (expr:exprs) acc
232 = rnExpr expr `thenRn` \ (expr', fvExpr) ->
234 -- Now we do a "seq" on the free vars because typically it's small
235 -- or empty, especially in very long lists of constants
237 acc' = acc `unionNameSets` fvExpr
239 (grubby_seqNameSet acc' rnExprs') exprs acc' `thenRn` \ (exprs', fvExprs) ->
240 returnRn (expr':exprs', fvExprs)
242 -- Grubby little function to do "seq" on namesets; replace by proper seq when GHC can do seq
243 grubby_seqNameSet ns result | isNullUFM ns = result
247 Variables. We look up the variable and return the resulting name. The
248 interesting question is what the free-variable set should be. We
249 don't want to return imported or prelude things as free vars. So we
250 look at the Name returned from the lookup, and make it part of the
251 free-var set iff if it's a LocallyDefined Name.
255 rnExpr :: RdrNameHsExpr -> RnMS s (RenamedHsExpr, FreeVars)
258 = lookupOccRn v `thenRn` \ vname ->
259 returnRn (HsVar vname, if isLocallyDefined vname
260 then unitNameSet vname
264 = litOccurrence lit `thenRn_`
265 returnRn (HsLit lit, emptyNameSet)
268 = rnMatch match `thenRn` \ (match', fvMatch) ->
269 returnRn (HsLam match', fvMatch)
271 rnExpr (HsApp fun arg)
272 = rnExpr fun `thenRn` \ (fun',fvFun) ->
273 rnExpr arg `thenRn` \ (arg',fvArg) ->
274 returnRn (HsApp fun' arg', fvFun `unionNameSets` fvArg)
276 rnExpr (OpApp e1 op@(HsVar op_name) _ e2)
277 = rnExpr e1 `thenRn` \ (e1', fv_e1) ->
278 rnExpr e2 `thenRn` \ (e2', fv_e2) ->
279 rnExpr op `thenRn` \ (op', fv_op) ->
282 -- When renaming code synthesised from "deriving" declarations
283 -- we're in Interface mode, and we should ignore fixity; assume
284 -- that the deriving code generator got the association correct
285 lookupFixity op_name `thenRn` \ fixity ->
286 getModeRn `thenRn` \ mode ->
288 SourceMode -> mkOpAppRn e1' op' fixity e2'
289 InterfaceMode _ -> returnRn (OpApp e1' op' fixity e2')
290 ) `thenRn` \ final_e ->
293 fv_e1 `unionNameSets` fv_op `unionNameSets` fv_e2)
296 = rnExpr e `thenRn` \ (e', fv_e) ->
297 lookupImplicitOccRn negate_RDR `thenRn` \ neg ->
298 mkNegAppRn e' (HsVar neg) `thenRn` \ final_e ->
299 returnRn (final_e, fv_e)
302 = rnExpr e `thenRn` \ (e', fvs_e) ->
303 returnRn (HsPar e', fvs_e)
305 rnExpr (SectionL expr op)
306 = rnExpr expr `thenRn` \ (expr', fvs_expr) ->
307 rnExpr op `thenRn` \ (op', fvs_op) ->
308 returnRn (SectionL expr' op', fvs_op `unionNameSets` fvs_expr)
310 rnExpr (SectionR op expr)
311 = rnExpr op `thenRn` \ (op', fvs_op) ->
312 rnExpr expr `thenRn` \ (expr', fvs_expr) ->
313 returnRn (SectionR op' expr', fvs_op `unionNameSets` fvs_expr)
315 rnExpr (CCall fun args may_gc is_casm fake_result_ty)
316 = lookupImplicitOccRn ccallableClass_RDR `thenRn_`
317 lookupImplicitOccRn creturnableClass_RDR `thenRn_`
318 rnExprs args `thenRn` \ (args', fvs_args) ->
319 returnRn (CCall fun args' may_gc is_casm fake_result_ty, fvs_args)
321 rnExpr (HsSCC label expr)
322 = rnExpr expr `thenRn` \ (expr', fvs_expr) ->
323 returnRn (HsSCC label expr', fvs_expr)
325 rnExpr (HsCase expr ms src_loc)
326 = pushSrcLocRn src_loc $
327 rnExpr expr `thenRn` \ (new_expr, e_fvs) ->
328 mapAndUnzipRn rnMatch ms `thenRn` \ (new_ms, ms_fvs) ->
329 returnRn (HsCase new_expr new_ms src_loc, unionManyNameSets (e_fvs : ms_fvs))
331 rnExpr (HsLet binds expr)
332 = rnBinds binds $ \ binds' ->
333 rnExpr expr `thenRn` \ (expr',fvExpr) ->
334 returnRn (HsLet binds' expr', fvExpr)
336 rnExpr (HsDo do_or_lc stmts src_loc)
337 = pushSrcLocRn src_loc $
338 lookupImplicitOccRn monadZeroClass_RDR `thenRn_` -- Forces Monad to come too
339 (rnStmts rnExpr stmts $ \ stmts' ->
340 returnRn (HsDo do_or_lc stmts' src_loc, emptyNameSet))
342 rnExpr (ExplicitList exps)
343 = addImplicitOccRn listType_name `thenRn_`
344 rnExprs exps `thenRn` \ (exps', fvs) ->
345 returnRn (ExplicitList exps', fvs)
347 rnExpr (ExplicitTuple exps)
348 = addImplicitOccRn (tupleType_name (length exps)) `thenRn_`
349 rnExprs exps `thenRn` \ (exps', fvExps) ->
350 returnRn (ExplicitTuple exps', fvExps)
352 rnExpr (RecordCon (HsVar con) rbinds)
353 = lookupOccRn con `thenRn` \ conname ->
354 rnRbinds "construction" rbinds `thenRn` \ (rbinds', fvRbinds) ->
355 returnRn (RecordCon (HsVar conname) rbinds', fvRbinds)
357 rnExpr (RecordUpd expr rbinds)
358 = rnExpr expr `thenRn` \ (expr', fvExpr) ->
359 rnRbinds "update" rbinds `thenRn` \ (rbinds', fvRbinds) ->
360 returnRn (RecordUpd expr' rbinds', fvExpr `unionNameSets` fvRbinds)
362 rnExpr (ExprWithTySig expr pty)
363 = rnExpr expr `thenRn` \ (expr', fvExpr) ->
364 rnHsSigType (\ sty -> text "an expression") pty `thenRn` \ pty' ->
365 returnRn (ExprWithTySig expr' pty', fvExpr)
367 rnExpr (HsIf p b1 b2 src_loc)
368 = pushSrcLocRn src_loc $
369 rnExpr p `thenRn` \ (p', fvP) ->
370 rnExpr b1 `thenRn` \ (b1', fvB1) ->
371 rnExpr b2 `thenRn` \ (b2', fvB2) ->
372 returnRn (HsIf p' b1' b2' src_loc, unionManyNameSets [fvP, fvB1, fvB2])
374 rnExpr (ArithSeqIn seq)
375 = lookupImplicitOccRn enumClass_RDR `thenRn_`
376 rn_seq seq `thenRn` \ (new_seq, fvs) ->
377 returnRn (ArithSeqIn new_seq, fvs)
380 = rnExpr expr `thenRn` \ (expr', fvExpr) ->
381 returnRn (From expr', fvExpr)
383 rn_seq (FromThen expr1 expr2)
384 = rnExpr expr1 `thenRn` \ (expr1', fvExpr1) ->
385 rnExpr expr2 `thenRn` \ (expr2', fvExpr2) ->
386 returnRn (FromThen expr1' expr2', fvExpr1 `unionNameSets` fvExpr2)
388 rn_seq (FromTo expr1 expr2)
389 = rnExpr expr1 `thenRn` \ (expr1', fvExpr1) ->
390 rnExpr expr2 `thenRn` \ (expr2', fvExpr2) ->
391 returnRn (FromTo expr1' expr2', fvExpr1 `unionNameSets` fvExpr2)
393 rn_seq (FromThenTo expr1 expr2 expr3)
394 = rnExpr expr1 `thenRn` \ (expr1', fvExpr1) ->
395 rnExpr expr2 `thenRn` \ (expr2', fvExpr2) ->
396 rnExpr expr3 `thenRn` \ (expr3', fvExpr3) ->
397 returnRn (FromThenTo expr1' expr2' expr3',
398 unionManyNameSets [fvExpr1, fvExpr2, fvExpr3])
401 %************************************************************************
403 \subsubsection{@Rbinds@s and @Rpats@s: in record expressions}
405 %************************************************************************
409 = mapRn field_dup_err dup_fields `thenRn_`
410 mapAndUnzipRn rn_rbind rbinds `thenRn` \ (rbinds', fvRbind_s) ->
411 returnRn (rbinds', unionManyNameSets fvRbind_s)
413 (_, dup_fields) = removeDups cmp [ f | (f,_,_) <- rbinds ]
415 field_dup_err dups = addErrRn (dupFieldErr str dups)
417 rn_rbind (field, expr, pun)
418 = lookupGlobalOccRn field `thenRn` \ fieldname ->
419 rnExpr expr `thenRn` \ (expr', fvExpr) ->
420 returnRn ((fieldname, expr', pun), fvExpr)
423 = mapRn field_dup_err dup_fields `thenRn_`
426 (_, dup_fields) = removeDups cmp [ f | (f,_,_) <- rpats ]
428 field_dup_err dups = addErrRn (dupFieldErr "pattern" dups)
430 rn_rpat (field, pat, pun)
431 = lookupGlobalOccRn field `thenRn` \ fieldname ->
432 rnPat pat `thenRn` \ pat' ->
433 returnRn (fieldname, pat', pun)
436 %************************************************************************
438 \subsubsection{@Stmt@s: in @do@ expressions}
440 %************************************************************************
442 Note that although some bound vars may appear in the free var set for
443 the first qual, these will eventually be removed by the caller. For
444 example, if we have @[p | r <- s, q <- r, p <- q]@, when doing
445 @[q <- r, p <- q]@, the free var set for @q <- r@ will
446 be @{r}@, and the free var set for the entire Quals will be @{r}@. This
447 @r@ will be removed only when we finally return from examining all the
451 type RnExprTy s = RdrNameHsExpr -> RnMS s (RenamedHsExpr, FreeVars)
453 rnStmts :: RnExprTy s
455 -> ([RenamedStmt] -> RnMS s (a, FreeVars))
456 -> RnMS s (a, FreeVars)
458 rnStmts rn_expr [] thing_inside
461 rnStmts rn_expr (stmt:stmts) thing_inside
462 = rnStmt rn_expr stmt $ \ stmt' ->
463 rnStmts rn_expr stmts $ \ stmts' ->
464 thing_inside (stmt' : stmts')
466 rnStmt :: RnExprTy s -> RdrNameStmt -> (RenamedStmt -> RnMS s (a, FreeVars)) -> RnMS s (a, FreeVars)
467 -- Because of mutual recursion we have to pass in rnExpr.
469 rnStmt rn_expr (BindStmt pat expr src_loc) thing_inside
470 = pushSrcLocRn src_loc $
471 rn_expr expr `thenRn` \ (expr', fv_expr) ->
472 bindLocalsRn "pattern in do binding" binders $ \ new_binders ->
473 rnPat pat `thenRn` \ pat' ->
475 thing_inside (BindStmt pat' expr' src_loc) `thenRn` \ (result, fvs) ->
476 returnRn (result, fv_expr `unionNameSets` (fvs `minusNameSet` mkNameSet new_binders))
478 binders = collectPatBinders pat
480 rnStmt rn_expr (ExprStmt expr src_loc) thing_inside
481 = pushSrcLocRn src_loc $
482 rn_expr expr `thenRn` \ (expr', fv_expr) ->
483 thing_inside (ExprStmt expr' src_loc) `thenRn` \ (result, fvs) ->
484 returnRn (result, fv_expr `unionNameSets` fvs)
486 rnStmt rn_expr (GuardStmt expr src_loc) thing_inside
487 = pushSrcLocRn src_loc $
488 rn_expr expr `thenRn` \ (expr', fv_expr) ->
489 thing_inside (GuardStmt expr' src_loc) `thenRn` \ (result, fvs) ->
490 returnRn (result, fv_expr `unionNameSets` fvs)
492 rnStmt rn_expr (ReturnStmt expr) thing_inside
493 = rn_expr expr `thenRn` \ (expr', fv_expr) ->
494 thing_inside (ReturnStmt expr') `thenRn` \ (result, fvs) ->
495 returnRn (result, fv_expr `unionNameSets` fvs)
497 rnStmt rn_expr (LetStmt binds) thing_inside
498 = rnBinds binds $ \ binds' ->
499 thing_inside (LetStmt binds')
502 %************************************************************************
504 \subsubsection{Precedence Parsing}
506 %************************************************************************
508 @mkOpAppRn@ deals with operator fixities. The argument expressions
509 are assumed to be already correctly arranged. It needs the fixities
510 recorded in the OpApp nodes, because fixity info applies to the things
511 the programmer actually wrote, so you can't find it out from the Name.
513 Furthermore, the second argument is guaranteed not to be another
514 operator application. Why? Because the parser parses all
515 operator appications left-associatively.
518 mkOpAppRn :: RenamedHsExpr -> RenamedHsExpr -> Fixity -> RenamedHsExpr
519 -> RnMS s RenamedHsExpr
521 mkOpAppRn e1@(OpApp e11 op1 fix1 e12)
524 = addErrRn (precParseErr (get op1,fix1) (get op2,fix2)) `thenRn_`
525 returnRn (OpApp e1 op2 fix2 e2)
528 = mkOpAppRn e12 op2 fix2 e2 `thenRn` \ new_e ->
529 returnRn (OpApp e11 op1 fix1 new_e)
531 (nofix_error, rearrange_me) = compareFixity fix1 fix2
533 mkOpAppRn e1@(NegApp neg_arg neg_op)
535 fix2@(Fixity prec2 dir2)
538 = addErrRn (precParseErr (get neg_op,fix_neg) (get op2,fix2)) `thenRn_`
539 returnRn (OpApp e1 op2 fix2 e2)
542 = mkOpAppRn neg_arg op2 fix2 e2 `thenRn` \ new_e ->
543 returnRn (NegApp new_e neg_op)
545 fix_neg = Fixity 6 InfixL -- Precedence of unary negate is wired in as infixl 6!
546 (nofix_error, rearrange_me) = compareFixity fix_neg fix2
548 mkOpAppRn e1 op fix e2 -- Default case, no rearrangment
549 = ASSERT( right_op_ok fix e2 )
550 returnRn (OpApp e1 op fix e2)
554 -- Parser left-associates everything, but
555 -- derived instances may have correctly-associated things to
556 -- in the right operarand. So we just check that the right operand is OK
557 right_op_ok fix1 (OpApp _ _ fix2 _)
558 = not error_please && associate_right
560 (error_please, associate_right) = compareFixity fix1 fix2
561 right_op_ok fix1 other
564 -- Parser initially makes negation bind more tightly than any other operator
565 mkNegAppRn neg_arg neg_op
568 getModeRn `thenRn` \ mode ->
569 ASSERT( not_op_app mode neg_arg )
571 returnRn (NegApp neg_arg neg_op)
573 not_op_app SourceMode (OpApp _ _ _ _) = False
574 not_op_app mode other = True
578 mkConOpPatRn :: RenamedPat -> Name -> Fixity -> RenamedPat
581 mkConOpPatRn p1@(ConOpPatIn p11 op1 fix1 p12)
584 = addErrRn (precParseErr (op1,fix1) (op2,fix2)) `thenRn_`
585 returnRn (ConOpPatIn p1 op2 fix2 p2)
588 = mkConOpPatRn p12 op2 fix2 p2 `thenRn` \ new_p ->
589 returnRn (ConOpPatIn p11 op1 fix1 new_p)
592 (nofix_error, rearrange_me) = compareFixity fix1 fix2
594 mkConOpPatRn p1@(NegPatIn neg_arg)
596 fix2@(Fixity prec2 dir2)
598 | prec2 > 6 -- Precedence of unary - is wired in as 6!
599 = addErrRn (precParseNegPatErr (op2,fix2)) `thenRn_`
600 returnRn (ConOpPatIn p1 op2 fix2 p2)
602 mkConOpPatRn p1 op fix p2 -- Default case, no rearrangment
603 = ASSERT( not_op_pat p2 )
604 returnRn (ConOpPatIn p1 op fix p2)
606 not_op_pat (ConOpPatIn _ _ _ _) = False
607 not_op_pat other = True
611 checkPrecMatch :: Bool -> RdrName -> RdrNameMatch -> RnMS s ()
613 checkPrecMatch False fn match
615 checkPrecMatch True op (PatMatch p1 (PatMatch p2 (GRHSMatch _)))
616 = checkPrec op p1 False `thenRn_`
618 checkPrecMatch True op _
619 = panic "checkPrecMatch"
621 checkPrec op (ConOpPatIn _ op1 _ _) right
622 = lookupFixity op `thenRn` \ op_fix@(Fixity op_prec op_dir) ->
623 lookupFixity op1 `thenRn` \ op1_fix@(Fixity op1_prec op1_dir) ->
625 inf_ok = op1_prec > op_prec ||
626 (op1_prec == op_prec &&
627 (op1_dir == InfixR && op_dir == InfixR && right ||
628 op1_dir == InfixL && op_dir == InfixL && not right))
631 info1 = (op1,op1_fix)
632 (infol, infor) = if right then (info, info1) else (info1, info)
634 checkRn inf_ok (precParseErr infol infor)
636 checkPrec op (NegPatIn _) right
637 = lookupFixity op `thenRn` \ op_fix@(Fixity op_prec op_dir) ->
638 checkRn (op_prec <= 6) (precParseNegPatErr (op,op_fix))
640 checkPrec op pat right
647 (compareFixity op1 op2) tells which way to arrange appication, or
648 whether there's an error.
651 compareFixity :: Fixity -> Fixity
652 -> (Bool, -- Error please
653 Bool) -- Associate to the right: a op1 (b op2 c)
654 compareFixity (Fixity prec1 dir1) (Fixity prec2 dir2)
655 = case prec1 `cmp` prec2 of
658 EQ_ -> case (dir1, dir2) of
659 (InfixR, InfixR) -> right
660 (InfixL, InfixL) -> left
663 right = (False, True)
664 left = (False, False)
665 error_please = (True, False)
668 %************************************************************************
670 \subsubsection{Literals}
672 %************************************************************************
674 When literals occur we have to make sure that the types and classes they involve
678 litOccurrence (HsChar _)
679 = addImplicitOccRn charType_name
681 litOccurrence (HsCharPrim _)
682 = addImplicitOccRn (getName charPrimTyCon)
684 litOccurrence (HsString _)
685 = addImplicitOccRn listType_name `thenRn_`
686 addImplicitOccRn charType_name
688 litOccurrence (HsStringPrim _)
689 = addImplicitOccRn (getName addrPrimTyCon)
691 litOccurrence (HsInt _)
692 = lookupImplicitOccRn numClass_RDR -- Int and Integer are forced in by Num
694 litOccurrence (HsFrac _)
695 = lookupImplicitOccRn fractionalClass_RDR `thenRn_`
696 lookupImplicitOccRn ratioDataCon_RDR
697 -- We have to make sure that the Ratio type is imported with
698 -- its constructor, because literals of type Ratio t are
699 -- built with that constructor.
701 litOccurrence (HsIntPrim _)
702 = addImplicitOccRn (getName intPrimTyCon)
704 litOccurrence (HsFloatPrim _)
705 = addImplicitOccRn (getName floatPrimTyCon)
707 litOccurrence (HsDoublePrim _)
708 = addImplicitOccRn (getName doublePrimTyCon)
710 litOccurrence (HsLitLit _)
711 = lookupImplicitOccRn ccallableClass_RDR
715 %************************************************************************
717 \subsubsection{Errors}
719 %************************************************************************
722 dupFieldErr str (dup:rest) sty
723 = hcat [ptext SLIT("duplicate field name `"),
725 ptext SLIT("' in record "), text str]
728 = sep [ptext SLIT("prefix `-' not applied to literal in pattern"), ppr sty pat]
730 precParseNegPatErr op sty
731 = hang (ptext SLIT("precedence parsing error"))
732 4 (hcat [ptext SLIT("prefix `-' has lower precedence than "),
734 ptext SLIT(" in pattern")])
736 precParseErr op1 op2 sty
737 = hang (ptext SLIT("precedence parsing error"))
738 4 (hcat [ptext SLIT("cannot mix "), pp_op sty op1, ptext SLIT(" and "), pp_op sty op2,
739 ptext SLIT(" in the same infix expression")])
741 nonStdGuardErr guard sty
742 = hang (ptext SLIT("accepting non-standard pattern guards (-fglasgow-exts to suppress this message)"))
745 pp_op sty (op, fix) = hcat [ppr sty op, space, parens (ppr sty fix)]