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(..), IfaceFlavour(..) )
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, assert_RDR,
34 ioDataCon_RDR, ioOkDataCon_RDR
36 import TysPrim ( charPrimTyCon, addrPrimTyCon, intPrimTyCon,
37 floatPrimTyCon, doublePrimTyCon
40 import UniqFM ( isNullUFM )
41 import UniqSet ( emptyUniqSet, unionManyUniqSets, UniqSet )
42 import Util ( removeDups )
47 *********************************************************
51 *********************************************************
54 rnPat :: RdrNamePat -> RnMS s RenamedPat
56 rnPat WildPatIn = returnRn WildPatIn
59 = lookupBndrRn name `thenRn` \ vname ->
60 returnRn (VarPatIn vname)
63 = litOccurrence lit `thenRn_`
64 lookupImplicitOccRn eqClass_RDR `thenRn_` -- Needed to find equality on pattern
65 returnRn (LitPatIn lit)
68 = rnPat pat `thenRn` \ pat' ->
69 returnRn (LazyPatIn pat')
71 rnPat (AsPatIn name pat)
72 = rnPat pat `thenRn` \ pat' ->
73 lookupBndrRn name `thenRn` \ vname ->
74 returnRn (AsPatIn vname pat')
76 rnPat (ConPatIn con pats)
77 = lookupOccRn con `thenRn` \ con' ->
78 mapRn rnPat pats `thenRn` \ patslist ->
79 returnRn (ConPatIn con' patslist)
81 rnPat (ConOpPatIn pat1 con _ pat2)
82 = rnPat pat1 `thenRn` \ pat1' ->
83 lookupOccRn con `thenRn` \ con' ->
84 lookupFixity con `thenRn` \ fixity ->
85 rnPat pat2 `thenRn` \ pat2' ->
86 mkConOpPatRn pat1' con' fixity pat2'
88 -- Negated patters can only be literals, and they are dealt with
89 -- by negating the literal at compile time, not by using the negation
90 -- operation in Num. So we don't need to make an implicit reference
92 rnPat neg@(NegPatIn pat)
93 = checkRn (valid_neg_pat pat) (negPatErr neg)
95 rnPat pat `thenRn` \ pat' ->
96 returnRn (NegPatIn pat')
98 valid_neg_pat (LitPatIn (HsInt _)) = True
99 valid_neg_pat (LitPatIn (HsFrac _)) = True
100 valid_neg_pat _ = False
103 = rnPat pat `thenRn` \ pat' ->
104 returnRn (ParPatIn pat')
106 rnPat (NPlusKPatIn name lit)
107 = litOccurrence lit `thenRn_`
108 lookupImplicitOccRn ordClass_RDR `thenRn_`
109 lookupBndrRn name `thenRn` \ name' ->
110 returnRn (NPlusKPatIn name' lit)
112 rnPat (ListPatIn pats)
113 = addImplicitOccRn listType_name `thenRn_`
114 mapRn rnPat pats `thenRn` \ patslist ->
115 returnRn (ListPatIn patslist)
117 rnPat (TuplePatIn pats)
118 = addImplicitOccRn (tupleType_name (length pats)) `thenRn_`
119 mapRn rnPat pats `thenRn` \ patslist ->
120 returnRn (TuplePatIn patslist)
122 rnPat (RecPatIn con rpats)
123 = lookupOccRn con `thenRn` \ con' ->
124 rnRpats rpats `thenRn` \ rpats' ->
125 returnRn (RecPatIn con' rpats')
128 ************************************************************************
132 ************************************************************************
135 rnMatch, rnMatch1 :: RdrNameMatch -> RnMS s (RenamedMatch, FreeVars)
137 -- The only tricky bit here is that we want to do a single
138 -- bindLocalsRn for all the matches together, so that we spot
139 -- the repeated variable in
143 = pushSrcLocRn (getMatchLoc match) $
144 bindLocalsRn "pattern" (get_binders match) $ \ new_binders ->
145 rnMatch1 match `thenRn` \ (match', fvs) ->
147 binder_set = mkNameSet new_binders
148 unused_binders = binder_set `minusNameSet` fvs
149 net_fvs = fvs `minusNameSet` binder_set
151 warnUnusedMatches unused_binders `thenRn_`
153 returnRn (match', net_fvs)
155 get_binders (GRHSMatch _) = []
156 get_binders (PatMatch pat match) = collectPatBinders pat ++ get_binders match
158 rnMatch1 (PatMatch pat match)
159 = rnPat pat `thenRn` \ pat' ->
160 rnMatch1 match `thenRn` \ (match', fvs) ->
161 returnRn (PatMatch pat' match', fvs)
163 rnMatch1 (GRHSMatch grhss_and_binds)
164 = rnGRHSsAndBinds grhss_and_binds `thenRn` \ (grhss_and_binds', fvs) ->
165 returnRn (GRHSMatch grhss_and_binds', fvs)
168 %************************************************************************
170 \subsubsection{Guarded right-hand sides (GRHSsAndBinds)}
172 %************************************************************************
175 rnGRHSsAndBinds :: RdrNameGRHSsAndBinds -> RnMS s (RenamedGRHSsAndBinds, FreeVars)
177 rnGRHSsAndBinds (GRHSsAndBindsIn grhss binds)
178 = rnBinds binds $ \ binds' ->
179 rnGRHSs grhss `thenRn` \ (grhss', fvGRHS) ->
180 returnRn (GRHSsAndBindsIn grhss' binds', fvGRHS)
182 rnGRHSs [] = returnRn ([], emptyNameSet)
185 = rnGRHS grhs `thenRn` \ (grhs', fvs) ->
186 rnGRHSs grhss `thenRn` \ (grhss', fvss) ->
187 returnRn (grhs' : grhss', fvs `unionNameSets` fvss)
189 rnGRHS (GRHS guard expr locn)
190 = pushSrcLocRn locn $
191 (if not (opt_GlasgowExts || is_standard_guard guard) then
192 addWarnRn (nonStdGuardErr guard)
197 (rnStmts rnExpr guard $ \ guard' ->
198 -- This nested thing deals with scope and
199 -- the free vars of the guard, and knocking off the
200 -- free vars of the rhs that are bound by the guard
202 rnExpr expr `thenRn` \ (expr', fvse) ->
203 returnRn (GRHS guard' expr' locn, fvse))
205 -- Standard Haskell 1.4 guards are just a single boolean
206 -- expression, rather than a list of qualifiers as in the
208 is_standard_guard [] = True
209 is_standard_guard [GuardStmt _ _] = True
210 is_standard_guard other = False
213 %************************************************************************
215 \subsubsection{Expressions}
217 %************************************************************************
220 rnExprs :: [RdrNameHsExpr] -> RnMS s ([RenamedHsExpr], FreeVars)
221 rnExprs ls = rnExprs' ls emptyUniqSet
223 rnExprs' [] acc = returnRn ([], acc)
224 rnExprs' (expr:exprs) acc
225 = rnExpr expr `thenRn` \ (expr', fvExpr) ->
227 -- Now we do a "seq" on the free vars because typically it's small
228 -- or empty, especially in very long lists of constants
230 acc' = acc `unionNameSets` fvExpr
232 (grubby_seqNameSet acc' rnExprs') exprs acc' `thenRn` \ (exprs', fvExprs) ->
233 returnRn (expr':exprs', fvExprs)
235 -- Grubby little function to do "seq" on namesets; replace by proper seq when GHC can do seq
236 grubby_seqNameSet ns result | isNullUFM ns = result
240 Variables. We look up the variable and return the resulting name. The
241 interesting question is what the free-variable set should be. We
242 don't want to return imported or prelude things as free vars. So we
243 look at the Name returned from the lookup, and make it part of the
244 free-var set iff if it's a LocallyDefined Name.
248 rnExpr :: RdrNameHsExpr -> RnMS s (RenamedHsExpr, FreeVars)
251 = tryLookupOccRn v `thenRn` \ res ->
254 | opt_GlasgowExts && v == assertRdrName ->
255 -- if `assert' is not in scope,
256 -- we expand it to (GHCerr.assert__ location)
257 mkAssertExpr `thenRn` \ (expr, assert_name) ->
258 returnRn (expr, unitNameSet assert_name)
260 | otherwise -> -- a failure after all.
261 failWithRn nm err `thenRn_`
262 returnRn (HsVar nm, if isLocallyDefined nm
266 returnRn (HsVar vname, if isLocallyDefined vname
267 then unitNameSet vname
271 = litOccurrence lit `thenRn_`
272 returnRn (HsLit lit, emptyNameSet)
275 = rnMatch match `thenRn` \ (match', fvMatch) ->
276 returnRn (HsLam match', fvMatch)
278 rnExpr (HsApp fun arg)
279 = rnExpr fun `thenRn` \ (fun',fvFun) ->
280 rnExpr arg `thenRn` \ (arg',fvArg) ->
281 returnRn (HsApp fun' arg', fvFun `unionNameSets` fvArg)
283 rnExpr (OpApp e1 op@(HsVar op_name) _ e2)
284 = rnExpr e1 `thenRn` \ (e1', fv_e1) ->
285 rnExpr e2 `thenRn` \ (e2', fv_e2) ->
286 rnExpr op `thenRn` \ (op', fv_op) ->
289 -- When renaming code synthesised from "deriving" declarations
290 -- we're in Interface mode, and we should ignore fixity; assume
291 -- that the deriving code generator got the association correct
292 lookupFixity op_name `thenRn` \ fixity ->
293 getModeRn `thenRn` \ mode ->
295 SourceMode -> mkOpAppRn e1' op' fixity e2'
296 InterfaceMode _ _ -> returnRn (OpApp e1' op' fixity e2')
297 ) `thenRn` \ final_e ->
300 fv_e1 `unionNameSets` fv_op `unionNameSets` fv_e2)
303 = rnExpr e `thenRn` \ (e', fv_e) ->
304 lookupImplicitOccRn negate_RDR `thenRn` \ neg ->
305 mkNegAppRn e' (HsVar neg) `thenRn` \ final_e ->
306 returnRn (final_e, fv_e)
309 = rnExpr e `thenRn` \ (e', fvs_e) ->
310 returnRn (HsPar e', fvs_e)
312 rnExpr (SectionL expr op)
313 = rnExpr expr `thenRn` \ (expr', fvs_expr) ->
314 rnExpr op `thenRn` \ (op', fvs_op) ->
315 returnRn (SectionL expr' op', fvs_op `unionNameSets` fvs_expr)
317 rnExpr (SectionR op expr)
318 = rnExpr op `thenRn` \ (op', fvs_op) ->
319 rnExpr expr `thenRn` \ (expr', fvs_expr) ->
320 returnRn (SectionR op' expr', fvs_op `unionNameSets` fvs_expr)
322 rnExpr (CCall fun args may_gc is_casm fake_result_ty)
323 -- Check out the comment on RnIfaces.getNonWiredDataDecl about ccalls
324 = lookupImplicitOccRn ccallableClass_RDR `thenRn_`
325 lookupImplicitOccRn creturnableClass_RDR `thenRn_`
326 lookupImplicitOccRn ioDataCon_RDR `thenRn_`
327 lookupImplicitOccRn ioOkDataCon_RDR `thenRn_`
328 rnExprs args `thenRn` \ (args', fvs_args) ->
329 returnRn (CCall fun args' may_gc is_casm fake_result_ty, fvs_args)
331 rnExpr (HsSCC label expr)
332 = rnExpr expr `thenRn` \ (expr', fvs_expr) ->
333 returnRn (HsSCC label expr', fvs_expr)
335 rnExpr (HsCase expr ms src_loc)
336 = pushSrcLocRn src_loc $
337 rnExpr expr `thenRn` \ (new_expr, e_fvs) ->
338 mapAndUnzipRn rnMatch ms `thenRn` \ (new_ms, ms_fvs) ->
339 returnRn (HsCase new_expr new_ms src_loc, unionManyNameSets (e_fvs : ms_fvs))
341 rnExpr (HsLet binds expr)
342 = rnBinds binds $ \ binds' ->
343 rnExpr expr `thenRn` \ (expr',fvExpr) ->
344 returnRn (HsLet binds' expr', fvExpr)
346 rnExpr (HsDo do_or_lc stmts src_loc)
347 = pushSrcLocRn src_loc $
348 lookupImplicitOccRn monadZeroClass_RDR `thenRn_` -- Forces Monad to come too
349 (rnStmts rnExpr stmts $ \ stmts' ->
350 returnRn (HsDo do_or_lc stmts' src_loc, emptyNameSet))
352 rnExpr (ExplicitList exps)
353 = addImplicitOccRn listType_name `thenRn_`
354 rnExprs exps `thenRn` \ (exps', fvs) ->
355 returnRn (ExplicitList exps', fvs)
357 rnExpr (ExplicitTuple exps)
358 = addImplicitOccRn (tupleType_name (length exps)) `thenRn_`
359 rnExprs exps `thenRn` \ (exps', fvExps) ->
360 returnRn (ExplicitTuple exps', fvExps)
362 rnExpr (RecordCon con_id _ rbinds)
363 = lookupOccRn con_id `thenRn` \ conname ->
364 rnRbinds "construction" rbinds `thenRn` \ (rbinds', fvRbinds) ->
365 returnRn (RecordCon conname (error "rnExpr:RecordCon") rbinds', fvRbinds)
367 rnExpr (RecordUpd expr rbinds)
368 = rnExpr expr `thenRn` \ (expr', fvExpr) ->
369 rnRbinds "update" rbinds `thenRn` \ (rbinds', fvRbinds) ->
370 returnRn (RecordUpd expr' rbinds', fvExpr `unionNameSets` fvRbinds)
372 rnExpr (ExprWithTySig expr pty)
373 = rnExpr expr `thenRn` \ (expr', fvExpr) ->
374 rnHsSigType (text "an expression") pty `thenRn` \ pty' ->
375 returnRn (ExprWithTySig expr' pty', fvExpr)
377 rnExpr (HsIf p b1 b2 src_loc)
378 = pushSrcLocRn src_loc $
379 rnExpr p `thenRn` \ (p', fvP) ->
380 rnExpr b1 `thenRn` \ (b1', fvB1) ->
381 rnExpr b2 `thenRn` \ (b2', fvB2) ->
382 returnRn (HsIf p' b1' b2' src_loc, unionManyNameSets [fvP, fvB1, fvB2])
384 rnExpr (ArithSeqIn seq)
385 = lookupImplicitOccRn enumClass_RDR `thenRn_`
386 rn_seq seq `thenRn` \ (new_seq, fvs) ->
387 returnRn (ArithSeqIn new_seq, fvs)
390 = rnExpr expr `thenRn` \ (expr', fvExpr) ->
391 returnRn (From expr', fvExpr)
393 rn_seq (FromThen expr1 expr2)
394 = rnExpr expr1 `thenRn` \ (expr1', fvExpr1) ->
395 rnExpr expr2 `thenRn` \ (expr2', fvExpr2) ->
396 returnRn (FromThen expr1' expr2', fvExpr1 `unionNameSets` fvExpr2)
398 rn_seq (FromTo expr1 expr2)
399 = rnExpr expr1 `thenRn` \ (expr1', fvExpr1) ->
400 rnExpr expr2 `thenRn` \ (expr2', fvExpr2) ->
401 returnRn (FromTo expr1' expr2', fvExpr1 `unionNameSets` fvExpr2)
403 rn_seq (FromThenTo expr1 expr2 expr3)
404 = rnExpr expr1 `thenRn` \ (expr1', fvExpr1) ->
405 rnExpr expr2 `thenRn` \ (expr2', fvExpr2) ->
406 rnExpr expr3 `thenRn` \ (expr3', fvExpr3) ->
407 returnRn (FromThenTo expr1' expr2' expr3',
408 unionManyNameSets [fvExpr1, fvExpr2, fvExpr3])
411 %************************************************************************
413 \subsubsection{@Rbinds@s and @Rpats@s: in record expressions}
415 %************************************************************************
419 = mapRn field_dup_err dup_fields `thenRn_`
420 mapAndUnzipRn rn_rbind rbinds `thenRn` \ (rbinds', fvRbind_s) ->
421 returnRn (rbinds', unionManyNameSets fvRbind_s)
423 (_, dup_fields) = removeDups compare [ f | (f,_,_) <- rbinds ]
425 field_dup_err dups = addErrRn (dupFieldErr str dups)
427 rn_rbind (field, expr, pun)
428 = lookupGlobalOccRn field `thenRn` \ fieldname ->
429 rnExpr expr `thenRn` \ (expr', fvExpr) ->
430 returnRn ((fieldname, expr', pun), fvExpr)
433 = mapRn field_dup_err dup_fields `thenRn_`
436 (_, dup_fields) = removeDups compare [ f | (f,_,_) <- rpats ]
438 field_dup_err dups = addErrRn (dupFieldErr "pattern" dups)
440 rn_rpat (field, pat, pun)
441 = lookupGlobalOccRn field `thenRn` \ fieldname ->
442 rnPat pat `thenRn` \ pat' ->
443 returnRn (fieldname, pat', pun)
446 %************************************************************************
448 \subsubsection{@Stmt@s: in @do@ expressions}
450 %************************************************************************
452 Note that although some bound vars may appear in the free var set for
453 the first qual, these will eventually be removed by the caller. For
454 example, if we have @[p | r <- s, q <- r, p <- q]@, when doing
455 @[q <- r, p <- q]@, the free var set for @q <- r@ will
456 be @{r}@, and the free var set for the entire Quals will be @{r}@. This
457 @r@ will be removed only when we finally return from examining all the
461 type RnExprTy s = RdrNameHsExpr -> RnMS s (RenamedHsExpr, FreeVars)
463 rnStmts :: RnExprTy s
465 -> ([RenamedStmt] -> RnMS s (a, FreeVars))
466 -> RnMS s (a, FreeVars)
468 rnStmts rn_expr [] thing_inside
471 rnStmts rn_expr (stmt:stmts) thing_inside
472 = rnStmt rn_expr stmt $ \ stmt' ->
473 rnStmts rn_expr stmts $ \ stmts' ->
474 thing_inside (stmt' : stmts')
476 rnStmt :: RnExprTy s -> RdrNameStmt -> (RenamedStmt -> RnMS s (a, FreeVars)) -> RnMS s (a, FreeVars)
477 -- Because of mutual recursion we have to pass in rnExpr.
479 rnStmt rn_expr (BindStmt pat expr src_loc) thing_inside
480 = pushSrcLocRn src_loc $
481 rn_expr expr `thenRn` \ (expr', fv_expr) ->
482 bindLocalsRn "pattern in do binding" binders $ \ new_binders ->
483 rnPat pat `thenRn` \ pat' ->
485 thing_inside (BindStmt pat' expr' src_loc) `thenRn` \ (result, fvs) ->
486 returnRn (result, fv_expr `unionNameSets` (fvs `minusNameSet` mkNameSet new_binders))
488 binders = collectPatBinders pat
490 rnStmt rn_expr (ExprStmt expr src_loc) thing_inside
491 = pushSrcLocRn src_loc $
492 rn_expr expr `thenRn` \ (expr', fv_expr) ->
493 thing_inside (ExprStmt expr' src_loc) `thenRn` \ (result, fvs) ->
494 returnRn (result, fv_expr `unionNameSets` fvs)
496 rnStmt rn_expr (GuardStmt expr src_loc) thing_inside
497 = pushSrcLocRn src_loc $
498 rn_expr expr `thenRn` \ (expr', fv_expr) ->
499 thing_inside (GuardStmt expr' src_loc) `thenRn` \ (result, fvs) ->
500 returnRn (result, fv_expr `unionNameSets` fvs)
502 rnStmt rn_expr (ReturnStmt expr) thing_inside
503 = rn_expr expr `thenRn` \ (expr', fv_expr) ->
504 thing_inside (ReturnStmt expr') `thenRn` \ (result, fvs) ->
505 returnRn (result, fv_expr `unionNameSets` fvs)
507 rnStmt rn_expr (LetStmt binds) thing_inside
508 = rnBinds binds $ \ binds' ->
509 thing_inside (LetStmt binds')
512 %************************************************************************
514 \subsubsection{Precedence Parsing}
516 %************************************************************************
518 @mkOpAppRn@ deals with operator fixities. The argument expressions
519 are assumed to be already correctly arranged. It needs the fixities
520 recorded in the OpApp nodes, because fixity info applies to the things
521 the programmer actually wrote, so you can't find it out from the Name.
523 Furthermore, the second argument is guaranteed not to be another
524 operator application. Why? Because the parser parses all
525 operator appications left-associatively.
528 mkOpAppRn :: RenamedHsExpr -> RenamedHsExpr -> Fixity -> RenamedHsExpr
529 -> RnMS s RenamedHsExpr
531 mkOpAppRn e1@(OpApp e11 op1 fix1 e12)
534 = addErrRn (precParseErr (get op1,fix1) (get op2,fix2)) `thenRn_`
535 returnRn (OpApp e1 op2 fix2 e2)
538 = mkOpAppRn e12 op2 fix2 e2 `thenRn` \ new_e ->
539 returnRn (OpApp e11 op1 fix1 new_e)
541 (nofix_error, rearrange_me) = compareFixity fix1 fix2
543 mkOpAppRn e1@(NegApp neg_arg neg_op)
545 fix2@(Fixity prec2 dir2)
548 = addErrRn (precParseErr (get neg_op,fix_neg) (get op2,fix2)) `thenRn_`
549 returnRn (OpApp e1 op2 fix2 e2)
552 = mkOpAppRn neg_arg op2 fix2 e2 `thenRn` \ new_e ->
553 returnRn (NegApp new_e neg_op)
555 fix_neg = Fixity 6 InfixL -- Precedence of unary negate is wired in as infixl 6!
556 (nofix_error, rearrange_me) = compareFixity fix_neg fix2
558 mkOpAppRn e1 op fix e2 -- Default case, no rearrangment
559 = ASSERT( if right_op_ok fix e2 then True
560 else pprPanic "mkOpAppRn" (vcat [ppr e1, text "---", ppr op, text "---", ppr fix, text "---", ppr e2])
562 returnRn (OpApp e1 op fix e2)
566 -- Parser left-associates everything, but
567 -- derived instances may have correctly-associated things to
568 -- in the right operarand. So we just check that the right operand is OK
569 right_op_ok fix1 (OpApp _ _ fix2 _)
570 = not error_please && associate_right
572 (error_please, associate_right) = compareFixity fix1 fix2
573 right_op_ok fix1 other
576 -- Parser initially makes negation bind more tightly than any other operator
577 mkNegAppRn neg_arg neg_op
580 getModeRn `thenRn` \ mode ->
581 ASSERT( not_op_app mode neg_arg )
583 returnRn (NegApp neg_arg neg_op)
585 not_op_app SourceMode (OpApp _ _ _ _) = False
586 not_op_app mode other = True
590 mkConOpPatRn :: RenamedPat -> Name -> Fixity -> RenamedPat
593 mkConOpPatRn p1@(ConOpPatIn p11 op1 fix1 p12)
596 = addErrRn (precParseErr (op1,fix1) (op2,fix2)) `thenRn_`
597 returnRn (ConOpPatIn p1 op2 fix2 p2)
600 = mkConOpPatRn p12 op2 fix2 p2 `thenRn` \ new_p ->
601 returnRn (ConOpPatIn p11 op1 fix1 new_p)
604 (nofix_error, rearrange_me) = compareFixity fix1 fix2
606 mkConOpPatRn p1@(NegPatIn neg_arg)
608 fix2@(Fixity prec2 dir2)
610 | prec2 > 6 -- Precedence of unary - is wired in as 6!
611 = addErrRn (precParseNegPatErr (op2,fix2)) `thenRn_`
612 returnRn (ConOpPatIn p1 op2 fix2 p2)
614 mkConOpPatRn p1 op fix p2 -- Default case, no rearrangment
615 = ASSERT( not_op_pat p2 )
616 returnRn (ConOpPatIn p1 op fix p2)
618 not_op_pat (ConOpPatIn _ _ _ _) = False
619 not_op_pat other = True
623 checkPrecMatch :: Bool -> RdrName -> RdrNameMatch -> RnMS s ()
625 checkPrecMatch False fn match
627 checkPrecMatch True op (PatMatch p1 (PatMatch p2 (GRHSMatch _)))
628 = checkPrec op p1 False `thenRn_`
630 checkPrecMatch True op _
631 = panic "checkPrecMatch"
633 checkPrec op (ConOpPatIn _ op1 _ _) right
634 = lookupFixity op `thenRn` \ op_fix@(Fixity op_prec op_dir) ->
635 lookupFixity op1 `thenRn` \ op1_fix@(Fixity op1_prec op1_dir) ->
637 inf_ok = op1_prec > op_prec ||
638 (op1_prec == op_prec &&
639 (op1_dir == InfixR && op_dir == InfixR && right ||
640 op1_dir == InfixL && op_dir == InfixL && not right))
643 info1 = (op1,op1_fix)
644 (infol, infor) = if right then (info, info1) else (info1, info)
646 checkRn inf_ok (precParseErr infol infor)
648 checkPrec op (NegPatIn _) right
649 = lookupFixity op `thenRn` \ op_fix@(Fixity op_prec op_dir) ->
650 checkRn (op_prec <= 6) (precParseNegPatErr (op,op_fix))
652 checkPrec op pat right
659 (compareFixity op1 op2) tells which way to arrange appication, or
660 whether there's an error.
663 compareFixity :: Fixity -> Fixity
664 -> (Bool, -- Error please
665 Bool) -- Associate to the right: a op1 (b op2 c)
666 compareFixity (Fixity prec1 dir1) (Fixity prec2 dir2)
667 = case prec1 `compare` prec2 of
670 EQ -> case (dir1, dir2) of
671 (InfixR, InfixR) -> right
672 (InfixL, InfixL) -> left
675 right = (False, True)
676 left = (False, False)
677 error_please = (True, False)
680 %************************************************************************
682 \subsubsection{Literals}
684 %************************************************************************
686 When literals occur we have to make sure that the types and classes they involve
690 litOccurrence (HsChar _)
691 = addImplicitOccRn charType_name
693 litOccurrence (HsCharPrim _)
694 = addImplicitOccRn (getName charPrimTyCon)
696 litOccurrence (HsString _)
697 = addImplicitOccRn listType_name `thenRn_`
698 addImplicitOccRn charType_name
700 litOccurrence (HsStringPrim _)
701 = addImplicitOccRn (getName addrPrimTyCon)
703 litOccurrence (HsInt _)
704 = lookupImplicitOccRn numClass_RDR -- Int and Integer are forced in by Num
706 litOccurrence (HsFrac _)
707 = lookupImplicitOccRn fractionalClass_RDR `thenRn_`
708 lookupImplicitOccRn ratioDataCon_RDR
709 -- We have to make sure that the Ratio type is imported with
710 -- its constructor, because literals of type Ratio t are
711 -- built with that constructor.
712 -- The Rational type is needed too, but that will come in
713 -- when fractionalClass does.
715 litOccurrence (HsIntPrim _)
716 = addImplicitOccRn (getName intPrimTyCon)
718 litOccurrence (HsFloatPrim _)
719 = addImplicitOccRn (getName floatPrimTyCon)
721 litOccurrence (HsDoublePrim _)
722 = addImplicitOccRn (getName doublePrimTyCon)
724 litOccurrence (HsLitLit _)
725 = lookupImplicitOccRn ccallableClass_RDR
728 %************************************************************************
730 \subsubsection{Assertion utils}
732 %************************************************************************
735 mkAssertExpr :: RnMS s (RenamedHsExpr, Name)
737 newImportedGlobalName mod occ HiFile `thenRn` \ name ->
738 addOccurrenceName name `thenRn_`
739 getSrcLocRn `thenRn` \ sloc ->
741 expr = HsApp (HsVar name)
742 (HsLit (HsString (_PK_ (showSDoc (ppr sloc)))))
744 returnRn (expr, name)
747 mod = rdrNameModule assert_RDR
748 occ = rdrNameOcc assert_RDR
750 assertRdrName :: RdrName
751 assertRdrName = Unqual (VarOcc SLIT("assert"))
754 %************************************************************************
756 \subsubsection{Errors}
758 %************************************************************************
761 dupFieldErr str (dup:rest)
762 = hsep [ptext SLIT("duplicate field name"),
764 ptext SLIT("in record"), text str]
767 = sep [ptext SLIT("prefix `-' not applied to literal in pattern"), quotes (ppr pat)]
769 precParseNegPatErr op
770 = hang (ptext SLIT("precedence parsing error"))
771 4 (hsep [ptext SLIT("prefix `-' has lower precedence than"),
773 ptext SLIT("in pattern")])
776 = hang (ptext SLIT("precedence parsing error"))
777 4 (hsep [ptext SLIT("cannot mix"), quotes (pp_op op1), ptext SLIT("and"),
779 ptext SLIT("in the same infix expression")])
782 = hang (ptext SLIT("accepting non-standard pattern guards (-fglasgow-exts to suppress this message)"))
785 pp_op (op, fix) = hcat [ppr op, space, parens (ppr fix)]