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,
36 ccallableClass_RDR, creturnableClass_RDR,
37 monadZeroClass_RDR, enumClass_RDR, ordClass_RDR,
38 ratioDataCon_RDR, negate_RDR,
39 ioDataCon_RDR, ioOkDataCon_RDR
41 import TysPrim ( charPrimTyCon, addrPrimTyCon, intPrimTyCon,
42 floatPrimTyCon, doublePrimTyCon
44 import TyCon ( TyCon )
46 import ErrUtils ( addErrLoc, addShortErrLocLine )
49 import UniqFM ( lookupUFM, {- ToDo:rm-} isNullUFM )
50 import UniqSet ( emptyUniqSet, unitUniqSet,
51 unionUniqSets, unionManyUniqSets,
54 import Util ( Ord3(..), removeDups, panic, pprPanic, assertPanic )
60 *********************************************************
64 *********************************************************
67 rnPat :: RdrNamePat -> RnMS s RenamedPat
69 rnPat WildPatIn = returnRn WildPatIn
72 = lookupBndrRn name `thenRn` \ vname ->
73 returnRn (VarPatIn vname)
76 = litOccurrence lit `thenRn_`
77 lookupImplicitOccRn eqClass_RDR `thenRn_` -- Needed to find equality on pattern
78 returnRn (LitPatIn lit)
81 = rnPat pat `thenRn` \ pat' ->
82 returnRn (LazyPatIn pat')
84 rnPat (AsPatIn name pat)
85 = rnPat pat `thenRn` \ pat' ->
86 lookupBndrRn name `thenRn` \ vname ->
87 returnRn (AsPatIn vname pat')
89 rnPat (ConPatIn con pats)
90 = lookupOccRn con `thenRn` \ con' ->
91 mapRn rnPat pats `thenRn` \ patslist ->
92 returnRn (ConPatIn con' patslist)
94 rnPat (ConOpPatIn pat1 con _ pat2)
95 = rnPat pat1 `thenRn` \ pat1' ->
96 lookupOccRn con `thenRn` \ con' ->
97 lookupFixity con `thenRn` \ fixity ->
98 rnPat pat2 `thenRn` \ pat2' ->
99 mkConOpPatRn pat1' con' fixity pat2'
101 -- Negated patters can only be literals, and they are dealt with
102 -- by negating the literal at compile time, not by using the negation
103 -- operation in Num. So we don't need to make an implicit reference
105 rnPat neg@(NegPatIn pat)
106 = checkRn (valid_neg_pat pat) (negPatErr neg)
108 rnPat pat `thenRn` \ pat' ->
109 returnRn (NegPatIn pat')
111 valid_neg_pat (LitPatIn (HsInt _)) = True
112 valid_neg_pat (LitPatIn (HsFrac _)) = True
113 valid_neg_pat _ = False
116 = rnPat pat `thenRn` \ pat' ->
117 returnRn (ParPatIn pat')
119 rnPat (NPlusKPatIn name lit)
120 = litOccurrence lit `thenRn_`
121 lookupImplicitOccRn ordClass_RDR `thenRn_`
122 lookupBndrRn name `thenRn` \ name' ->
123 returnRn (NPlusKPatIn name' lit)
125 rnPat (ListPatIn pats)
126 = addImplicitOccRn listType_name `thenRn_`
127 mapRn rnPat pats `thenRn` \ patslist ->
128 returnRn (ListPatIn patslist)
130 rnPat (TuplePatIn pats)
131 = addImplicitOccRn (tupleType_name (length pats)) `thenRn_`
132 mapRn rnPat pats `thenRn` \ patslist ->
133 returnRn (TuplePatIn patslist)
135 rnPat (RecPatIn con rpats)
136 = lookupOccRn con `thenRn` \ con' ->
137 rnRpats rpats `thenRn` \ rpats' ->
138 returnRn (RecPatIn con' rpats')
141 ************************************************************************
145 ************************************************************************
148 rnMatch, rnMatch1 :: RdrNameMatch -> RnMS s (RenamedMatch, FreeVars)
150 -- The only tricky bit here is that we want to do a single
151 -- bindLocalsRn for all the matches together, so that we spot
152 -- the repeated variable in
156 = bindLocalsRn "pattern" (get_binders match) $ \ new_binders ->
157 rnMatch1 match `thenRn` \ (match', fvs) ->
158 returnRn (match', fvs `minusNameSet` mkNameSet new_binders)
160 get_binders (GRHSMatch _) = []
161 get_binders (PatMatch pat match) = collectPatBinders pat ++ get_binders match
163 rnMatch1 (PatMatch pat match)
164 = rnPat pat `thenRn` \ pat' ->
165 rnMatch1 match `thenRn` \ (match', fvs) ->
166 returnRn (PatMatch pat' match', fvs)
168 rnMatch1 (GRHSMatch grhss_and_binds)
169 = rnGRHSsAndBinds grhss_and_binds `thenRn` \ (grhss_and_binds', fvs) ->
170 returnRn (GRHSMatch grhss_and_binds', fvs)
173 %************************************************************************
175 \subsubsection{Guarded right-hand sides (GRHSsAndBinds)}
177 %************************************************************************
180 rnGRHSsAndBinds :: RdrNameGRHSsAndBinds -> RnMS s (RenamedGRHSsAndBinds, FreeVars)
182 rnGRHSsAndBinds (GRHSsAndBindsIn grhss binds)
183 = rnBinds binds $ \ binds' ->
184 rnGRHSs grhss `thenRn` \ (grhss', fvGRHS) ->
185 returnRn (GRHSsAndBindsIn grhss' binds', fvGRHS)
187 rnGRHSs [] = returnRn ([], emptyNameSet)
190 = rnGRHS grhs `thenRn` \ (grhs', fvs) ->
191 rnGRHSs grhss `thenRn` \ (grhss', fvss) ->
192 returnRn (grhs' : grhss', fvs `unionNameSets` fvss)
194 rnGRHS (GRHS guard expr locn)
195 = pushSrcLocRn locn $
196 (if not (opt_GlasgowExts || is_standard_guard guard) then
197 addWarnRn (nonStdGuardErr guard)
202 (rnStmts rnExpr guard $ \ guard' ->
203 -- This nested thing deals with scope and
204 -- the free vars of the guard, and knocking off the
205 -- free vars of the rhs that are bound by the guard
207 rnExpr expr `thenRn` \ (expr', fvse) ->
208 returnRn (GRHS guard' expr' locn, fvse))
210 rnGRHS (OtherwiseGRHS expr locn)
211 = pushSrcLocRn locn $
212 rnExpr expr `thenRn` \ (expr', fvs) ->
213 returnRn (GRHS [] expr' locn, fvs)
215 -- Standard Haskell 1.4 guards are just a single boolean
216 -- expression, rather than a list of qualifiers as in the
218 is_standard_guard [GuardStmt _ _] = True
219 is_standard_guard other = False
222 %************************************************************************
224 \subsubsection{Expressions}
226 %************************************************************************
229 rnExprs :: [RdrNameHsExpr] -> RnMS s ([RenamedHsExpr], FreeVars)
230 rnExprs ls = rnExprs' ls emptyUniqSet
232 rnExprs' [] acc = returnRn ([], acc)
233 rnExprs' (expr:exprs) acc
234 = rnExpr expr `thenRn` \ (expr', fvExpr) ->
236 -- Now we do a "seq" on the free vars because typically it's small
237 -- or empty, especially in very long lists of constants
239 acc' = acc `unionNameSets` fvExpr
241 (grubby_seqNameSet acc' rnExprs') exprs acc' `thenRn` \ (exprs', fvExprs) ->
242 returnRn (expr':exprs', fvExprs)
244 -- Grubby little function to do "seq" on namesets; replace by proper seq when GHC can do seq
245 grubby_seqNameSet ns result | isNullUFM ns = result
249 Variables. We look up the variable and return the resulting name. The
250 interesting question is what the free-variable set should be. We
251 don't want to return imported or prelude things as free vars. So we
252 look at the Name returned from the lookup, and make it part of the
253 free-var set iff if it's a LocallyDefined Name.
257 rnExpr :: RdrNameHsExpr -> RnMS s (RenamedHsExpr, FreeVars)
260 = lookupOccRn v `thenRn` \ vname ->
261 returnRn (HsVar vname, if isLocallyDefined vname
262 then unitNameSet vname
266 = litOccurrence lit `thenRn_`
267 returnRn (HsLit lit, emptyNameSet)
270 = rnMatch match `thenRn` \ (match', fvMatch) ->
271 returnRn (HsLam match', fvMatch)
273 rnExpr (HsApp fun arg)
274 = rnExpr fun `thenRn` \ (fun',fvFun) ->
275 rnExpr arg `thenRn` \ (arg',fvArg) ->
276 returnRn (HsApp fun' arg', fvFun `unionNameSets` fvArg)
278 rnExpr (OpApp e1 op@(HsVar op_name) _ e2)
279 = rnExpr e1 `thenRn` \ (e1', fv_e1) ->
280 rnExpr e2 `thenRn` \ (e2', fv_e2) ->
281 rnExpr op `thenRn` \ (op', fv_op) ->
284 -- When renaming code synthesised from "deriving" declarations
285 -- we're in Interface mode, and we should ignore fixity; assume
286 -- that the deriving code generator got the association correct
287 lookupFixity op_name `thenRn` \ fixity ->
288 getModeRn `thenRn` \ mode ->
290 SourceMode -> mkOpAppRn e1' op' fixity e2'
291 InterfaceMode _ -> returnRn (OpApp e1' op' fixity e2')
292 ) `thenRn` \ final_e ->
295 fv_e1 `unionNameSets` fv_op `unionNameSets` fv_e2)
298 = rnExpr e `thenRn` \ (e', fv_e) ->
299 lookupImplicitOccRn negate_RDR `thenRn` \ neg ->
300 mkNegAppRn e' (HsVar neg) `thenRn` \ final_e ->
301 returnRn (final_e, fv_e)
304 = rnExpr e `thenRn` \ (e', fvs_e) ->
305 returnRn (HsPar e', fvs_e)
307 rnExpr (SectionL expr op)
308 = rnExpr expr `thenRn` \ (expr', fvs_expr) ->
309 rnExpr op `thenRn` \ (op', fvs_op) ->
310 returnRn (SectionL expr' op', fvs_op `unionNameSets` fvs_expr)
312 rnExpr (SectionR op expr)
313 = rnExpr op `thenRn` \ (op', fvs_op) ->
314 rnExpr expr `thenRn` \ (expr', fvs_expr) ->
315 returnRn (SectionR op' expr', fvs_op `unionNameSets` fvs_expr)
317 rnExpr (CCall fun args may_gc is_casm fake_result_ty)
318 = lookupImplicitOccRn ccallableClass_RDR `thenRn_`
319 lookupImplicitOccRn creturnableClass_RDR `thenRn_`
320 lookupImplicitOccRn ioDataCon_RDR `thenRn_`
321 lookupImplicitOccRn ioOkDataCon_RDR `thenRn_`
322 rnExprs args `thenRn` \ (args', fvs_args) ->
323 returnRn (CCall fun args' may_gc is_casm fake_result_ty, fvs_args)
325 rnExpr (HsSCC label expr)
326 = rnExpr expr `thenRn` \ (expr', fvs_expr) ->
327 returnRn (HsSCC label expr', fvs_expr)
329 rnExpr (HsCase expr ms src_loc)
330 = pushSrcLocRn src_loc $
331 rnExpr expr `thenRn` \ (new_expr, e_fvs) ->
332 mapAndUnzipRn rnMatch ms `thenRn` \ (new_ms, ms_fvs) ->
333 returnRn (HsCase new_expr new_ms src_loc, unionManyNameSets (e_fvs : ms_fvs))
335 rnExpr (HsLet binds expr)
336 = rnBinds binds $ \ binds' ->
337 rnExpr expr `thenRn` \ (expr',fvExpr) ->
338 returnRn (HsLet binds' expr', fvExpr)
340 rnExpr (HsDo do_or_lc stmts src_loc)
341 = pushSrcLocRn src_loc $
342 lookupImplicitOccRn monadZeroClass_RDR `thenRn_` -- Forces Monad to come too
343 (rnStmts rnExpr stmts $ \ stmts' ->
344 returnRn (HsDo do_or_lc stmts' src_loc, emptyNameSet))
346 rnExpr (ExplicitList exps)
347 = addImplicitOccRn listType_name `thenRn_`
348 rnExprs exps `thenRn` \ (exps', fvs) ->
349 returnRn (ExplicitList exps', fvs)
351 rnExpr (ExplicitTuple exps)
352 = addImplicitOccRn (tupleType_name (length exps)) `thenRn_`
353 rnExprs exps `thenRn` \ (exps', fvExps) ->
354 returnRn (ExplicitTuple exps', fvExps)
356 rnExpr (RecordCon con rbinds)
357 = lookupOccRn con `thenRn` \ conname ->
358 rnRbinds "construction" rbinds `thenRn` \ (rbinds', fvRbinds) ->
359 returnRn (RecordCon conname rbinds', fvRbinds)
361 rnExpr (RecordUpd expr rbinds)
362 = rnExpr expr `thenRn` \ (expr', fvExpr) ->
363 rnRbinds "update" rbinds `thenRn` \ (rbinds', fvRbinds) ->
364 returnRn (RecordUpd expr' rbinds', fvExpr `unionNameSets` fvRbinds)
366 rnExpr (ExprWithTySig expr pty)
367 = rnExpr expr `thenRn` \ (expr', fvExpr) ->
368 rnHsSigType (\ sty -> text "an expression") pty `thenRn` \ pty' ->
369 returnRn (ExprWithTySig expr' pty', fvExpr)
371 rnExpr (HsIf p b1 b2 src_loc)
372 = pushSrcLocRn src_loc $
373 rnExpr p `thenRn` \ (p', fvP) ->
374 rnExpr b1 `thenRn` \ (b1', fvB1) ->
375 rnExpr b2 `thenRn` \ (b2', fvB2) ->
376 returnRn (HsIf p' b1' b2' src_loc, unionManyNameSets [fvP, fvB1, fvB2])
378 rnExpr (ArithSeqIn seq)
379 = lookupImplicitOccRn enumClass_RDR `thenRn_`
380 rn_seq seq `thenRn` \ (new_seq, fvs) ->
381 returnRn (ArithSeqIn new_seq, fvs)
384 = rnExpr expr `thenRn` \ (expr', fvExpr) ->
385 returnRn (From expr', fvExpr)
387 rn_seq (FromThen expr1 expr2)
388 = rnExpr expr1 `thenRn` \ (expr1', fvExpr1) ->
389 rnExpr expr2 `thenRn` \ (expr2', fvExpr2) ->
390 returnRn (FromThen expr1' expr2', fvExpr1 `unionNameSets` fvExpr2)
392 rn_seq (FromTo expr1 expr2)
393 = rnExpr expr1 `thenRn` \ (expr1', fvExpr1) ->
394 rnExpr expr2 `thenRn` \ (expr2', fvExpr2) ->
395 returnRn (FromTo expr1' expr2', fvExpr1 `unionNameSets` fvExpr2)
397 rn_seq (FromThenTo expr1 expr2 expr3)
398 = rnExpr expr1 `thenRn` \ (expr1', fvExpr1) ->
399 rnExpr expr2 `thenRn` \ (expr2', fvExpr2) ->
400 rnExpr expr3 `thenRn` \ (expr3', fvExpr3) ->
401 returnRn (FromThenTo expr1' expr2' expr3',
402 unionManyNameSets [fvExpr1, fvExpr2, fvExpr3])
405 %************************************************************************
407 \subsubsection{@Rbinds@s and @Rpats@s: in record expressions}
409 %************************************************************************
413 = mapRn field_dup_err dup_fields `thenRn_`
414 mapAndUnzipRn rn_rbind rbinds `thenRn` \ (rbinds', fvRbind_s) ->
415 returnRn (rbinds', unionManyNameSets fvRbind_s)
417 (_, dup_fields) = removeDups cmp [ f | (f,_,_) <- rbinds ]
419 field_dup_err dups = addErrRn (dupFieldErr str dups)
421 rn_rbind (field, expr, pun)
422 = lookupGlobalOccRn field `thenRn` \ fieldname ->
423 rnExpr expr `thenRn` \ (expr', fvExpr) ->
424 returnRn ((fieldname, expr', pun), fvExpr)
427 = mapRn field_dup_err dup_fields `thenRn_`
430 (_, dup_fields) = removeDups cmp [ f | (f,_,_) <- rpats ]
432 field_dup_err dups = addErrRn (dupFieldErr "pattern" dups)
434 rn_rpat (field, pat, pun)
435 = lookupGlobalOccRn field `thenRn` \ fieldname ->
436 rnPat pat `thenRn` \ pat' ->
437 returnRn (fieldname, pat', pun)
440 %************************************************************************
442 \subsubsection{@Stmt@s: in @do@ expressions}
444 %************************************************************************
446 Note that although some bound vars may appear in the free var set for
447 the first qual, these will eventually be removed by the caller. For
448 example, if we have @[p | r <- s, q <- r, p <- q]@, when doing
449 @[q <- r, p <- q]@, the free var set for @q <- r@ will
450 be @{r}@, and the free var set for the entire Quals will be @{r}@. This
451 @r@ will be removed only when we finally return from examining all the
455 type RnExprTy s = RdrNameHsExpr -> RnMS s (RenamedHsExpr, FreeVars)
457 rnStmts :: RnExprTy s
459 -> ([RenamedStmt] -> RnMS s (a, FreeVars))
460 -> RnMS s (a, FreeVars)
462 rnStmts rn_expr [] thing_inside
465 rnStmts rn_expr (stmt:stmts) thing_inside
466 = rnStmt rn_expr stmt $ \ stmt' ->
467 rnStmts rn_expr stmts $ \ stmts' ->
468 thing_inside (stmt' : stmts')
470 rnStmt :: RnExprTy s -> RdrNameStmt -> (RenamedStmt -> RnMS s (a, FreeVars)) -> RnMS s (a, FreeVars)
471 -- Because of mutual recursion we have to pass in rnExpr.
473 rnStmt rn_expr (BindStmt pat expr src_loc) thing_inside
474 = pushSrcLocRn src_loc $
475 rn_expr expr `thenRn` \ (expr', fv_expr) ->
476 bindLocalsRn "pattern in do binding" binders $ \ new_binders ->
477 rnPat pat `thenRn` \ pat' ->
479 thing_inside (BindStmt pat' expr' src_loc) `thenRn` \ (result, fvs) ->
480 returnRn (result, fv_expr `unionNameSets` (fvs `minusNameSet` mkNameSet new_binders))
482 binders = collectPatBinders pat
484 rnStmt rn_expr (ExprStmt expr src_loc) thing_inside
485 = pushSrcLocRn src_loc $
486 rn_expr expr `thenRn` \ (expr', fv_expr) ->
487 thing_inside (ExprStmt expr' src_loc) `thenRn` \ (result, fvs) ->
488 returnRn (result, fv_expr `unionNameSets` fvs)
490 rnStmt rn_expr (GuardStmt expr src_loc) thing_inside
491 = pushSrcLocRn src_loc $
492 rn_expr expr `thenRn` \ (expr', fv_expr) ->
493 thing_inside (GuardStmt expr' src_loc) `thenRn` \ (result, fvs) ->
494 returnRn (result, fv_expr `unionNameSets` fvs)
496 rnStmt rn_expr (ReturnStmt expr) thing_inside
497 = rn_expr expr `thenRn` \ (expr', fv_expr) ->
498 thing_inside (ReturnStmt expr') `thenRn` \ (result, fvs) ->
499 returnRn (result, fv_expr `unionNameSets` fvs)
501 rnStmt rn_expr (LetStmt binds) thing_inside
502 = rnBinds binds $ \ binds' ->
503 thing_inside (LetStmt binds')
506 %************************************************************************
508 \subsubsection{Precedence Parsing}
510 %************************************************************************
512 @mkOpAppRn@ deals with operator fixities. The argument expressions
513 are assumed to be already correctly arranged. It needs the fixities
514 recorded in the OpApp nodes, because fixity info applies to the things
515 the programmer actually wrote, so you can't find it out from the Name.
517 Furthermore, the second argument is guaranteed not to be another
518 operator application. Why? Because the parser parses all
519 operator appications left-associatively.
522 mkOpAppRn :: RenamedHsExpr -> RenamedHsExpr -> Fixity -> RenamedHsExpr
523 -> RnMS s RenamedHsExpr
525 mkOpAppRn e1@(OpApp e11 op1 fix1 e12)
528 = addErrRn (precParseErr (get op1,fix1) (get op2,fix2)) `thenRn_`
529 returnRn (OpApp e1 op2 fix2 e2)
532 = mkOpAppRn e12 op2 fix2 e2 `thenRn` \ new_e ->
533 returnRn (OpApp e11 op1 fix1 new_e)
535 (nofix_error, rearrange_me) = compareFixity fix1 fix2
537 mkOpAppRn e1@(NegApp neg_arg neg_op)
539 fix2@(Fixity prec2 dir2)
542 = addErrRn (precParseErr (get neg_op,fix_neg) (get op2,fix2)) `thenRn_`
543 returnRn (OpApp e1 op2 fix2 e2)
546 = mkOpAppRn neg_arg op2 fix2 e2 `thenRn` \ new_e ->
547 returnRn (NegApp new_e neg_op)
549 fix_neg = Fixity 6 InfixL -- Precedence of unary negate is wired in as infixl 6!
550 (nofix_error, rearrange_me) = compareFixity fix_neg fix2
552 mkOpAppRn e1 op fix e2 -- Default case, no rearrangment
553 = ASSERT( right_op_ok fix e2 )
554 returnRn (OpApp e1 op fix e2)
558 -- Parser left-associates everything, but
559 -- derived instances may have correctly-associated things to
560 -- in the right operarand. So we just check that the right operand is OK
561 right_op_ok fix1 (OpApp _ _ fix2 _)
562 = not error_please && associate_right
564 (error_please, associate_right) = compareFixity fix1 fix2
565 right_op_ok fix1 other
568 -- Parser initially makes negation bind more tightly than any other operator
569 mkNegAppRn neg_arg neg_op
572 getModeRn `thenRn` \ mode ->
573 ASSERT( not_op_app mode neg_arg )
575 returnRn (NegApp neg_arg neg_op)
577 not_op_app SourceMode (OpApp _ _ _ _) = False
578 not_op_app mode other = True
582 mkConOpPatRn :: RenamedPat -> Name -> Fixity -> RenamedPat
585 mkConOpPatRn p1@(ConOpPatIn p11 op1 fix1 p12)
588 = addErrRn (precParseErr (op1,fix1) (op2,fix2)) `thenRn_`
589 returnRn (ConOpPatIn p1 op2 fix2 p2)
592 = mkConOpPatRn p12 op2 fix2 p2 `thenRn` \ new_p ->
593 returnRn (ConOpPatIn p11 op1 fix1 new_p)
596 (nofix_error, rearrange_me) = compareFixity fix1 fix2
598 mkConOpPatRn p1@(NegPatIn neg_arg)
600 fix2@(Fixity prec2 dir2)
602 | prec2 > 6 -- Precedence of unary - is wired in as 6!
603 = addErrRn (precParseNegPatErr (op2,fix2)) `thenRn_`
604 returnRn (ConOpPatIn p1 op2 fix2 p2)
606 mkConOpPatRn p1 op fix p2 -- Default case, no rearrangment
607 = ASSERT( not_op_pat p2 )
608 returnRn (ConOpPatIn p1 op fix p2)
610 not_op_pat (ConOpPatIn _ _ _ _) = False
611 not_op_pat other = True
615 checkPrecMatch :: Bool -> RdrName -> RdrNameMatch -> RnMS s ()
617 checkPrecMatch False fn match
619 checkPrecMatch True op (PatMatch p1 (PatMatch p2 (GRHSMatch _)))
620 = checkPrec op p1 False `thenRn_`
622 checkPrecMatch True op _
623 = panic "checkPrecMatch"
625 checkPrec op (ConOpPatIn _ op1 _ _) right
626 = lookupFixity op `thenRn` \ op_fix@(Fixity op_prec op_dir) ->
627 lookupFixity op1 `thenRn` \ op1_fix@(Fixity op1_prec op1_dir) ->
629 inf_ok = op1_prec > op_prec ||
630 (op1_prec == op_prec &&
631 (op1_dir == InfixR && op_dir == InfixR && right ||
632 op1_dir == InfixL && op_dir == InfixL && not right))
635 info1 = (op1,op1_fix)
636 (infol, infor) = if right then (info, info1) else (info1, info)
638 checkRn inf_ok (precParseErr infol infor)
640 checkPrec op (NegPatIn _) right
641 = lookupFixity op `thenRn` \ op_fix@(Fixity op_prec op_dir) ->
642 checkRn (op_prec <= 6) (precParseNegPatErr (op,op_fix))
644 checkPrec op pat right
651 (compareFixity op1 op2) tells which way to arrange appication, or
652 whether there's an error.
655 compareFixity :: Fixity -> Fixity
656 -> (Bool, -- Error please
657 Bool) -- Associate to the right: a op1 (b op2 c)
658 compareFixity (Fixity prec1 dir1) (Fixity prec2 dir2)
659 = case prec1 `cmp` prec2 of
662 EQ_ -> case (dir1, dir2) of
663 (InfixR, InfixR) -> right
664 (InfixL, InfixL) -> left
667 right = (False, True)
668 left = (False, False)
669 error_please = (True, False)
672 %************************************************************************
674 \subsubsection{Literals}
676 %************************************************************************
678 When literals occur we have to make sure that the types and classes they involve
682 litOccurrence (HsChar _)
683 = addImplicitOccRn charType_name
685 litOccurrence (HsCharPrim _)
686 = addImplicitOccRn (getName charPrimTyCon)
688 litOccurrence (HsString _)
689 = addImplicitOccRn listType_name `thenRn_`
690 addImplicitOccRn charType_name
692 litOccurrence (HsStringPrim _)
693 = addImplicitOccRn (getName addrPrimTyCon)
695 litOccurrence (HsInt _)
696 = lookupImplicitOccRn numClass_RDR -- Int and Integer are forced in by Num
698 litOccurrence (HsFrac _)
699 = lookupImplicitOccRn fractionalClass_RDR `thenRn_`
700 lookupImplicitOccRn ratioDataCon_RDR
701 -- We have to make sure that the Ratio type is imported with
702 -- its constructor, because literals of type Ratio t are
703 -- built with that constructor.
705 litOccurrence (HsIntPrim _)
706 = addImplicitOccRn (getName intPrimTyCon)
708 litOccurrence (HsFloatPrim _)
709 = addImplicitOccRn (getName floatPrimTyCon)
711 litOccurrence (HsDoublePrim _)
712 = addImplicitOccRn (getName doublePrimTyCon)
714 litOccurrence (HsLitLit _)
715 = lookupImplicitOccRn ccallableClass_RDR
719 %************************************************************************
721 \subsubsection{Errors}
723 %************************************************************************
726 dupFieldErr str (dup:rest) sty
727 = hcat [ptext SLIT("duplicate field name `"),
729 ptext SLIT("' in record "), text str]
732 = sep [ptext SLIT("prefix `-' not applied to literal in pattern"), ppr sty pat]
734 precParseNegPatErr op sty
735 = hang (ptext SLIT("precedence parsing error"))
736 4 (hcat [ptext SLIT("prefix `-' has lower precedence than "),
738 ptext SLIT(" in pattern")])
740 precParseErr op1 op2 sty
741 = hang (ptext SLIT("precedence parsing error"))
742 4 (hcat [ptext SLIT("cannot mix "), pp_op sty op1, ptext SLIT(" and "), pp_op sty op2,
743 ptext SLIT(" in the same infix expression")])
745 nonStdGuardErr guard sty
746 = hang (ptext SLIT("accepting non-standard pattern guards (-fglasgow-exts to suppress this message)"))
749 pp_op sty (op, fix) = hcat [ppr sty op, space, parens (ppr sty fix)]