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{-, ufmToList ToDo:rm-} )
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 :: RdrNameMatch -> RnMS s (RenamedMatch, FreeVars)
148 rnMatch (PatMatch pat match)
149 = bindLocalsRn "pattern" binders $ \ new_binders ->
150 rnPat pat `thenRn` \ pat' ->
151 rnMatch match `thenRn` \ (match', fvMatch) ->
152 returnRn (PatMatch pat' match', fvMatch `minusNameSet` mkNameSet new_binders)
154 binders = collectPatBinders pat
156 rnMatch (GRHSMatch grhss_and_binds)
157 = rnGRHSsAndBinds grhss_and_binds `thenRn` \ (grhss_and_binds', fvs) ->
158 returnRn (GRHSMatch grhss_and_binds', fvs)
161 %************************************************************************
163 \subsubsection{Guarded right-hand sides (GRHSsAndBinds)}
165 %************************************************************************
168 rnGRHSsAndBinds :: RdrNameGRHSsAndBinds -> RnMS s (RenamedGRHSsAndBinds, FreeVars)
170 rnGRHSsAndBinds (GRHSsAndBindsIn grhss binds)
171 = rnBinds binds $ \ binds' ->
172 rnGRHSs grhss `thenRn` \ (grhss', fvGRHS) ->
173 returnRn (GRHSsAndBindsIn grhss' binds', fvGRHS)
175 rnGRHSs [] = returnRn ([], emptyNameSet)
178 = rnGRHS grhs `thenRn` \ (grhs', fvs) ->
179 rnGRHSs grhss `thenRn` \ (grhss', fvss) ->
180 returnRn (grhs' : grhss', fvs `unionNameSets` fvss)
182 rnGRHS (GRHS guard expr locn)
183 = pushSrcLocRn locn $
184 (if not (opt_GlasgowExts || is_standard_guard guard) then
185 addWarnRn (nonStdGuardErr guard)
190 (rnStmts rnExpr guard $ \ guard' ->
191 -- This nested thing deals with scope and
192 -- the free vars of the guard, and knocking off the
193 -- free vars of the rhs that are bound by the guard
195 rnExpr expr `thenRn` \ (expr', fvse) ->
196 returnRn (GRHS guard' expr' locn, fvse))
198 rnGRHS (OtherwiseGRHS expr locn)
199 = pushSrcLocRn locn $
200 rnExpr expr `thenRn` \ (expr', fvs) ->
201 returnRn (GRHS [] expr' locn, fvs)
203 -- Standard Haskell 1.4 guards are just a single boolean
204 -- expression, rather than a list of qualifiers as in the
206 is_standard_guard [GuardStmt _ _] = True
207 is_standard_guard other = False
210 %************************************************************************
212 \subsubsection{Expressions}
214 %************************************************************************
217 rnExprs :: [RdrNameHsExpr] -> RnMS s ([RenamedHsExpr], FreeVars)
219 rnExprs' ls [] `thenRn` \ (exprs, fvExprs) ->
220 returnRn (exprs, unionManyNameSets fvExprs)
222 rnExprs' [] acc = returnRn ([], acc)
223 rnExprs' (expr:exprs) acc
224 = rnExpr expr `thenRn` \ (expr', fvExpr) ->
225 rnExprs' exprs (fvExpr:acc) `thenRn` \ (exprs', fvExprs) ->
226 returnRn (expr':exprs', fvExprs)
229 Variables. We look up the variable and return the resulting name. The
230 interesting question is what the free-variable set should be. We
231 don't want to return imported or prelude things as free vars. So we
232 look at the Name returned from the lookup, and make it part of the
233 free-var set iff if it's a LocallyDefined Name.
237 rnExpr :: RdrNameHsExpr -> RnMS s (RenamedHsExpr, FreeVars)
240 = lookupOccRn v `thenRn` \ vname ->
241 returnRn (HsVar vname, if isLocallyDefined vname
242 then unitNameSet vname
246 = litOccurrence lit `thenRn_`
247 returnRn (HsLit lit, emptyNameSet)
250 = rnMatch match `thenRn` \ (match', fvMatch) ->
251 returnRn (HsLam match', fvMatch)
253 rnExpr (HsApp fun arg)
254 = rnExpr fun `thenRn` \ (fun',fvFun) ->
255 rnExpr arg `thenRn` \ (arg',fvArg) ->
256 returnRn (HsApp fun' arg', fvFun `unionNameSets` fvArg)
258 rnExpr (OpApp e1 op@(HsVar op_name) _ e2)
259 = rnExpr e1 `thenRn` \ (e1', fv_e1) ->
260 rnExpr e2 `thenRn` \ (e2', fv_e2) ->
261 rnExpr op `thenRn` \ (op', fv_op) ->
264 -- When renaming code synthesised from "deriving" declarations
265 -- we're in Interface mode, and we should ignore fixity; assume
266 -- that the deriving code generator got the association correct
267 lookupFixity op_name `thenRn` \ fixity ->
268 getModeRn `thenRn` \ mode ->
270 SourceMode -> mkOpAppRn e1' op' fixity e2'
271 InterfaceMode _ -> returnRn (OpApp e1' op' fixity e2')
272 ) `thenRn` \ final_e ->
275 fv_e1 `unionNameSets` fv_op `unionNameSets` fv_e2)
278 = rnExpr e `thenRn` \ (e', fv_e) ->
279 lookupImplicitOccRn negate_RDR `thenRn` \ neg ->
280 mkNegAppRn e' (HsVar neg) `thenRn` \ final_e ->
281 returnRn (final_e, fv_e)
284 = rnExpr e `thenRn` \ (e', fvs_e) ->
285 returnRn (HsPar e', fvs_e)
287 rnExpr (SectionL expr op)
288 = rnExpr expr `thenRn` \ (expr', fvs_expr) ->
289 rnExpr op `thenRn` \ (op', fvs_op) ->
290 returnRn (SectionL expr' op', fvs_op `unionNameSets` fvs_expr)
292 rnExpr (SectionR op expr)
293 = rnExpr op `thenRn` \ (op', fvs_op) ->
294 rnExpr expr `thenRn` \ (expr', fvs_expr) ->
295 returnRn (SectionR op' expr', fvs_op `unionNameSets` fvs_expr)
297 rnExpr (CCall fun args may_gc is_casm fake_result_ty)
298 = lookupImplicitOccRn ccallableClass_RDR `thenRn_`
299 lookupImplicitOccRn creturnableClass_RDR `thenRn_`
300 rnExprs args `thenRn` \ (args', fvs_args) ->
301 returnRn (CCall fun args' may_gc is_casm fake_result_ty, fvs_args)
303 rnExpr (HsSCC label expr)
304 = rnExpr expr `thenRn` \ (expr', fvs_expr) ->
305 returnRn (HsSCC label expr', fvs_expr)
307 rnExpr (HsCase expr ms src_loc)
308 = pushSrcLocRn src_loc $
309 rnExpr expr `thenRn` \ (new_expr, e_fvs) ->
310 mapAndUnzipRn rnMatch ms `thenRn` \ (new_ms, ms_fvs) ->
311 returnRn (HsCase new_expr new_ms src_loc, unionManyNameSets (e_fvs : ms_fvs))
313 rnExpr (HsLet binds expr)
314 = rnBinds binds $ \ binds' ->
315 rnExpr expr `thenRn` \ (expr',fvExpr) ->
316 returnRn (HsLet binds' expr', fvExpr)
318 rnExpr (HsDo do_or_lc stmts src_loc)
319 = pushSrcLocRn src_loc $
320 lookupImplicitOccRn monadZeroClass_RDR `thenRn_` -- Forces Monad to come too
321 (rnStmts rnExpr stmts $ \ stmts' ->
322 returnRn (HsDo do_or_lc stmts' src_loc, emptyNameSet))
324 rnExpr (ExplicitList exps)
325 = addImplicitOccRn listType_name `thenRn_`
326 rnExprs exps `thenRn` \ (exps', fvs) ->
327 returnRn (ExplicitList exps', fvs)
329 rnExpr (ExplicitTuple exps)
330 = addImplicitOccRn (tupleType_name (length exps)) `thenRn_`
331 rnExprs exps `thenRn` \ (exps', fvExps) ->
332 returnRn (ExplicitTuple exps', fvExps)
334 rnExpr (RecordCon (HsVar con) rbinds)
335 = lookupOccRn con `thenRn` \ conname ->
336 rnRbinds "construction" rbinds `thenRn` \ (rbinds', fvRbinds) ->
337 returnRn (RecordCon (HsVar conname) rbinds', fvRbinds)
339 rnExpr (RecordUpd expr rbinds)
340 = rnExpr expr `thenRn` \ (expr', fvExpr) ->
341 rnRbinds "update" rbinds `thenRn` \ (rbinds', fvRbinds) ->
342 returnRn (RecordUpd expr' rbinds', fvExpr `unionNameSets` fvRbinds)
344 rnExpr (ExprWithTySig expr pty)
345 = rnExpr expr `thenRn` \ (expr', fvExpr) ->
346 rnHsSigType (\ sty -> text "an expression") pty `thenRn` \ pty' ->
347 returnRn (ExprWithTySig expr' pty', fvExpr)
349 rnExpr (HsIf p b1 b2 src_loc)
350 = pushSrcLocRn src_loc $
351 rnExpr p `thenRn` \ (p', fvP) ->
352 rnExpr b1 `thenRn` \ (b1', fvB1) ->
353 rnExpr b2 `thenRn` \ (b2', fvB2) ->
354 returnRn (HsIf p' b1' b2' src_loc, unionManyNameSets [fvP, fvB1, fvB2])
356 rnExpr (ArithSeqIn seq)
357 = lookupImplicitOccRn enumClass_RDR `thenRn_`
358 rn_seq seq `thenRn` \ (new_seq, fvs) ->
359 returnRn (ArithSeqIn new_seq, fvs)
362 = rnExpr expr `thenRn` \ (expr', fvExpr) ->
363 returnRn (From expr', fvExpr)
365 rn_seq (FromThen expr1 expr2)
366 = rnExpr expr1 `thenRn` \ (expr1', fvExpr1) ->
367 rnExpr expr2 `thenRn` \ (expr2', fvExpr2) ->
368 returnRn (FromThen expr1' expr2', fvExpr1 `unionNameSets` fvExpr2)
370 rn_seq (FromTo expr1 expr2)
371 = rnExpr expr1 `thenRn` \ (expr1', fvExpr1) ->
372 rnExpr expr2 `thenRn` \ (expr2', fvExpr2) ->
373 returnRn (FromTo expr1' expr2', fvExpr1 `unionNameSets` fvExpr2)
375 rn_seq (FromThenTo expr1 expr2 expr3)
376 = rnExpr expr1 `thenRn` \ (expr1', fvExpr1) ->
377 rnExpr expr2 `thenRn` \ (expr2', fvExpr2) ->
378 rnExpr expr3 `thenRn` \ (expr3', fvExpr3) ->
379 returnRn (FromThenTo expr1' expr2' expr3',
380 unionManyNameSets [fvExpr1, fvExpr2, fvExpr3])
383 %************************************************************************
385 \subsubsection{@Rbinds@s and @Rpats@s: in record expressions}
387 %************************************************************************
391 = mapRn field_dup_err dup_fields `thenRn_`
392 mapAndUnzipRn rn_rbind rbinds `thenRn` \ (rbinds', fvRbind_s) ->
393 returnRn (rbinds', unionManyNameSets fvRbind_s)
395 (_, dup_fields) = removeDups cmp [ f | (f,_,_) <- rbinds ]
397 field_dup_err dups = addErrRn (dupFieldErr str dups)
399 rn_rbind (field, expr, pun)
400 = lookupGlobalOccRn field `thenRn` \ fieldname ->
401 rnExpr expr `thenRn` \ (expr', fvExpr) ->
402 returnRn ((fieldname, expr', pun), fvExpr)
405 = mapRn field_dup_err dup_fields `thenRn_`
408 (_, dup_fields) = removeDups cmp [ f | (f,_,_) <- rpats ]
410 field_dup_err dups = addErrRn (dupFieldErr "pattern" dups)
412 rn_rpat (field, pat, pun)
413 = lookupGlobalOccRn field `thenRn` \ fieldname ->
414 rnPat pat `thenRn` \ pat' ->
415 returnRn (fieldname, pat', pun)
418 %************************************************************************
420 \subsubsection{@Stmt@s: in @do@ expressions}
422 %************************************************************************
424 Note that although some bound vars may appear in the free var set for
425 the first qual, these will eventually be removed by the caller. For
426 example, if we have @[p | r <- s, q <- r, p <- q]@, when doing
427 @[q <- r, p <- q]@, the free var set for @q <- r@ will
428 be @{r}@, and the free var set for the entire Quals will be @{r}@. This
429 @r@ will be removed only when we finally return from examining all the
433 type RnExprTy s = RdrNameHsExpr -> RnMS s (RenamedHsExpr, FreeVars)
435 rnStmts :: RnExprTy s
437 -> ([RenamedStmt] -> RnMS s (a, FreeVars))
438 -> RnMS s (a, FreeVars)
440 rnStmts rn_expr [] thing_inside
443 rnStmts rn_expr (stmt:stmts) thing_inside
444 = rnStmt rn_expr stmt $ \ stmt' ->
445 rnStmts rn_expr stmts $ \ stmts' ->
446 thing_inside (stmt' : stmts')
448 rnStmt :: RnExprTy s -> RdrNameStmt -> (RenamedStmt -> RnMS s (a, FreeVars)) -> RnMS s (a, FreeVars)
449 -- Because of mutual recursion we have to pass in rnExpr.
451 rnStmt rn_expr (BindStmt pat expr src_loc) thing_inside
452 = pushSrcLocRn src_loc $
453 rn_expr expr `thenRn` \ (expr', fv_expr) ->
454 bindLocalsRn "pattern in do binding" binders $ \ new_binders ->
455 rnPat pat `thenRn` \ pat' ->
457 thing_inside (BindStmt pat' expr' src_loc) `thenRn` \ (result, fvs) ->
458 returnRn (result, fv_expr `unionNameSets` (fvs `minusNameSet` mkNameSet new_binders))
460 binders = collectPatBinders pat
462 rnStmt rn_expr (ExprStmt expr src_loc) thing_inside
463 = pushSrcLocRn src_loc $
464 rn_expr expr `thenRn` \ (expr', fv_expr) ->
465 thing_inside (ExprStmt expr' src_loc) `thenRn` \ (result, fvs) ->
466 returnRn (result, fv_expr `unionNameSets` fvs)
468 rnStmt rn_expr (GuardStmt expr src_loc) thing_inside
469 = pushSrcLocRn src_loc $
470 rn_expr expr `thenRn` \ (expr', fv_expr) ->
471 thing_inside (GuardStmt expr' src_loc) `thenRn` \ (result, fvs) ->
472 returnRn (result, fv_expr `unionNameSets` fvs)
474 rnStmt rn_expr (ReturnStmt expr) thing_inside
475 = rn_expr expr `thenRn` \ (expr', fv_expr) ->
476 thing_inside (ReturnStmt expr') `thenRn` \ (result, fvs) ->
477 returnRn (result, fv_expr `unionNameSets` fvs)
479 rnStmt rn_expr (LetStmt binds) thing_inside
480 = rnBinds binds $ \ binds' ->
481 thing_inside (LetStmt binds')
484 %************************************************************************
486 \subsubsection{Precedence Parsing}
488 %************************************************************************
490 @mkOpAppRn@ deals with operator fixities. The argument expressions
491 are assumed to be already correctly arranged. It needs the fixities
492 recorded in the OpApp nodes, because fixity info applies to the things
493 the programmer actually wrote, so you can't find it out from the Name.
495 Furthermore, the second argument is guaranteed not to be another
496 operator application. Why? Because the parser parses all
497 operator appications left-associatively.
500 mkOpAppRn :: RenamedHsExpr -> RenamedHsExpr -> Fixity -> RenamedHsExpr
501 -> RnMS s RenamedHsExpr
503 mkOpAppRn e1@(OpApp e11 op1 fix1 e12)
506 = addErrRn (precParseErr (get op1,fix1) (get op2,fix2)) `thenRn_`
507 returnRn (OpApp e1 op2 fix2 e2)
510 = mkOpAppRn e12 op2 fix2 e2 `thenRn` \ new_e ->
511 returnRn (OpApp e11 op1 fix1 new_e)
513 (nofix_error, rearrange_me) = compareFixity fix1 fix2
515 mkOpAppRn e1@(NegApp neg_arg neg_op)
517 fix2@(Fixity prec2 dir2)
520 = addErrRn (precParseErr (get neg_op,fix_neg) (get op2,fix2)) `thenRn_`
521 returnRn (OpApp e1 op2 fix2 e2)
524 = mkOpAppRn neg_arg op2 fix2 e2 `thenRn` \ new_e ->
525 returnRn (NegApp new_e neg_op)
527 fix_neg = Fixity 6 InfixL -- Precedence of unary negate is wired in as infixl 6!
528 (nofix_error, rearrange_me) = compareFixity fix_neg fix2
530 mkOpAppRn e1 op fix e2 -- Default case, no rearrangment
531 = ASSERT( right_op_ok fix e2 )
532 returnRn (OpApp e1 op fix e2)
536 -- Parser left-associates everything, but
537 -- derived instances may have correctly-associated things to
538 -- in the right operarand. So we just check that the right operand is OK
539 right_op_ok fix1 (OpApp _ _ fix2 _)
540 = not error_please && associate_right
542 (error_please, associate_right) = compareFixity fix1 fix2
543 right_op_ok fix1 other
546 -- Parser initially makes negation bind more tightly than any other operator
547 mkNegAppRn neg_arg neg_op
550 getModeRn `thenRn` \ mode ->
551 ASSERT( not_op_app mode neg_arg )
553 returnRn (NegApp neg_arg neg_op)
555 not_op_app SourceMode (OpApp _ _ _ _) = False
556 not_op_app mode other = True
560 mkConOpPatRn :: RenamedPat -> Name -> Fixity -> RenamedPat
563 mkConOpPatRn p1@(ConOpPatIn p11 op1 fix1 p12)
566 = addErrRn (precParseErr (op1,fix1) (op2,fix2)) `thenRn_`
567 returnRn (ConOpPatIn p1 op2 fix2 p2)
570 = mkConOpPatRn p12 op2 fix2 p2 `thenRn` \ new_p ->
571 returnRn (ConOpPatIn p11 op1 fix1 new_p)
574 (nofix_error, rearrange_me) = compareFixity fix1 fix2
576 mkConOpPatRn p1@(NegPatIn neg_arg)
578 fix2@(Fixity prec2 dir2)
580 | prec2 > 6 -- Precedence of unary - is wired in as 6!
581 = addErrRn (precParseNegPatErr (op2,fix2)) `thenRn_`
582 returnRn (ConOpPatIn p1 op2 fix2 p2)
584 mkConOpPatRn p1 op fix p2 -- Default case, no rearrangment
585 = ASSERT( not_op_pat p2 )
586 returnRn (ConOpPatIn p1 op fix p2)
588 not_op_pat (ConOpPatIn _ _ _ _) = False
589 not_op_pat other = True
593 checkPrecMatch :: Bool -> RdrName -> RdrNameMatch -> RnMS s ()
595 checkPrecMatch False fn match
597 checkPrecMatch True op (PatMatch p1 (PatMatch p2 (GRHSMatch _)))
598 = checkPrec op p1 False `thenRn_`
600 checkPrecMatch True op _
601 = panic "checkPrecMatch"
603 checkPrec op (ConOpPatIn _ op1 _ _) right
604 = lookupFixity op `thenRn` \ op_fix@(Fixity op_prec op_dir) ->
605 lookupFixity op1 `thenRn` \ op1_fix@(Fixity op1_prec op1_dir) ->
607 inf_ok = op1_prec > op_prec ||
608 (op1_prec == op_prec &&
609 (op1_dir == InfixR && op_dir == InfixR && right ||
610 op1_dir == InfixL && op_dir == InfixL && not right))
613 info1 = (op1,op1_fix)
614 (infol, infor) = if right then (info, info1) else (info1, info)
616 checkRn inf_ok (precParseErr infol infor)
618 checkPrec op (NegPatIn _) right
619 = lookupFixity op `thenRn` \ op_fix@(Fixity op_prec op_dir) ->
620 checkRn (op_prec <= 6) (precParseNegPatErr (op,op_fix))
622 checkPrec op pat right
629 (compareFixity op1 op2) tells which way to arrange appication, or
630 whether there's an error.
633 compareFixity :: Fixity -> Fixity
634 -> (Bool, -- Error please
635 Bool) -- Associate to the right: a op1 (b op2 c)
636 compareFixity (Fixity prec1 dir1) (Fixity prec2 dir2)
637 = case prec1 `cmp` prec2 of
640 EQ_ -> case (dir1, dir2) of
641 (InfixR, InfixR) -> right
642 (InfixL, InfixL) -> left
645 right = (False, True)
646 left = (False, False)
647 error_please = (True, False)
650 %************************************************************************
652 \subsubsection{Literals}
654 %************************************************************************
656 When literals occur we have to make sure that the types and classes they involve
660 litOccurrence (HsChar _)
661 = addImplicitOccRn charType_name
663 litOccurrence (HsCharPrim _)
664 = addImplicitOccRn (getName charPrimTyCon)
666 litOccurrence (HsString _)
667 = addImplicitOccRn listType_name `thenRn_`
668 addImplicitOccRn charType_name
670 litOccurrence (HsStringPrim _)
671 = addImplicitOccRn (getName addrPrimTyCon)
673 litOccurrence (HsInt _)
674 = lookupImplicitOccRn numClass_RDR -- Int and Integer are forced in by Num
676 litOccurrence (HsFrac _)
677 = lookupImplicitOccRn fractionalClass_RDR `thenRn_`
678 lookupImplicitOccRn ratioDataCon_RDR
679 -- We have to make sure that the Ratio type is imported with
680 -- its constructor, because literals of type Ratio t are
681 -- built with that constructor.
683 litOccurrence (HsIntPrim _)
684 = addImplicitOccRn (getName intPrimTyCon)
686 litOccurrence (HsFloatPrim _)
687 = addImplicitOccRn (getName floatPrimTyCon)
689 litOccurrence (HsDoublePrim _)
690 = addImplicitOccRn (getName doublePrimTyCon)
692 litOccurrence (HsLitLit _)
693 = lookupImplicitOccRn ccallableClass_RDR
697 %************************************************************************
699 \subsubsection{Errors}
701 %************************************************************************
704 dupFieldErr str (dup:rest) sty
705 = hcat [ptext SLIT("duplicate field name `"),
707 ptext SLIT("' in record "), text str]
710 = sep [ptext SLIT("prefix `-' not applied to literal in pattern"), ppr sty pat]
712 precParseNegPatErr op sty
713 = hang (ptext SLIT("precedence parsing error"))
714 4 (hcat [ptext SLIT("prefix `-' has lower precedence than "),
716 ptext SLIT(" in pattern")])
718 precParseErr op1 op2 sty
719 = hang (ptext SLIT("precedence parsing error"))
720 4 (hcat [ptext SLIT("cannot mix "), pp_op sty op1, ptext SLIT(" and "), pp_op sty op2,
721 ptext SLIT(" in the same infix expression")])
723 nonStdGuardErr guard sty
724 = hang (ptext SLIT("accepting non-standard pattern guards (-fglasgow-exts to suppress this message)"))
727 pp_op sty (op, fix) = hcat [ppr sty op, space, parens (ppr sty fix)]