2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
4 \section[RnExpr]{Renaming of expressions}
6 Basically dependency analysis.
8 Handles @Match@, @GRHSs@, @HsExpr@, and @Qualifier@ datatypes. In
9 general, all of these functions return a renamed thing, and a set of
14 rnMatch, rnGRHSs, rnPat,
18 #include "HsVersions.h"
20 import {-# SOURCE #-} RnBinds ( rnBinds )
21 import {-# SOURCE #-} RnSource ( rnHsSigType, rnHsType )
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, assertErr_RDR,
36 import TysPrim ( charPrimTyCon, addrPrimTyCon, intPrimTyCon,
37 floatPrimTyCon, doublePrimTyCon
39 import Name ( nameUnique, isLocallyDefined, NamedThing(..) )
41 import UniqFM ( isNullUFM )
42 import FiniteMap ( elemFM )
43 import UniqSet ( emptyUniqSet, UniqSet )
44 import Unique ( assertIdKey )
45 import Util ( removeDups )
46 import ListSetOps ( unionLists )
47 import Maybes ( maybeToBool )
52 *********************************************************
56 *********************************************************
59 rnPat :: RdrNamePat -> RnMS s (RenamedPat, FreeVars)
61 rnPat WildPatIn = returnRn (WildPatIn, emptyFVs)
64 = lookupBndrRn name `thenRn` \ vname ->
65 returnRn (VarPatIn vname, emptyFVs)
67 rnPat (SigPatIn pat ty)
69 = rnPat pat `thenRn` \ (pat', fvs1) ->
70 rnHsType doc ty `thenRn` \ (ty', fvs2) ->
71 returnRn (SigPatIn pat' ty', fvs1 `plusFV` fvs2)
74 = addErrRn (patSigErr ty) `thenRn_`
77 doc = text "a pattern type-signature"
80 = litOccurrence lit `thenRn_`
81 lookupImplicitOccRn eqClass_RDR `thenRn_` -- Needed to find equality on pattern
82 returnRn (LitPatIn lit, emptyFVs)
85 = rnPat pat `thenRn` \ (pat', fvs) ->
86 returnRn (LazyPatIn pat', fvs)
88 rnPat (AsPatIn name pat)
89 = rnPat pat `thenRn` \ (pat', fvs) ->
90 lookupBndrRn name `thenRn` \ vname ->
91 returnRn (AsPatIn vname pat', fvs)
93 rnPat (ConPatIn con pats)
94 = lookupOccRn con `thenRn` \ con' ->
95 mapAndUnzipRn rnPat pats `thenRn` \ (patslist, fvs_s) ->
96 returnRn (ConPatIn con' patslist, plusFVs fvs_s `addOneFV` con')
98 rnPat (ConOpPatIn pat1 con _ pat2)
99 = rnPat pat1 `thenRn` \ (pat1', fvs1) ->
100 lookupOccRn con `thenRn` \ con' ->
101 lookupFixity con' `thenRn` \ fixity ->
102 rnPat pat2 `thenRn` \ (pat2', fvs2) ->
103 mkConOpPatRn pat1' con' fixity pat2' `thenRn` \ pat' ->
104 returnRn (pat', fvs1 `plusFV` fvs2 `addOneFV` con')
106 -- Negated patters can only be literals, and they are dealt with
107 -- by negating the literal at compile time, not by using the negation
108 -- operation in Num. So we don't need to make an implicit reference
110 rnPat neg@(NegPatIn pat)
111 = checkRn (valid_neg_pat pat) (negPatErr neg)
113 rnPat pat `thenRn` \ (pat', fvs) ->
114 returnRn (NegPatIn pat', fvs)
116 valid_neg_pat (LitPatIn (HsInt _)) = True
117 valid_neg_pat (LitPatIn (HsFrac _)) = True
118 valid_neg_pat _ = False
121 = rnPat pat `thenRn` \ (pat', fvs) ->
122 returnRn (ParPatIn pat', fvs)
124 rnPat (NPlusKPatIn name lit)
125 = litOccurrence lit `thenRn_`
126 lookupImplicitOccRn ordClass_RDR `thenRn_`
127 lookupBndrRn name `thenRn` \ name' ->
128 returnRn (NPlusKPatIn name' lit, emptyFVs)
130 rnPat (ListPatIn pats)
131 = addImplicitOccRn listTyCon_name `thenRn_`
132 mapAndUnzipRn rnPat pats `thenRn` \ (patslist, fvs_s) ->
133 returnRn (ListPatIn patslist, plusFVs fvs_s)
135 rnPat (TuplePatIn pats boxed)
136 = addImplicitOccRn (tupleTyCon_name boxed (length pats)) `thenRn_`
137 mapAndUnzipRn rnPat pats `thenRn` \ (patslist, fvs_s) ->
138 returnRn (TuplePatIn patslist boxed, plusFVs fvs_s)
140 rnPat (RecPatIn con rpats)
141 = lookupOccRn con `thenRn` \ con' ->
142 rnRpats rpats `thenRn` \ (rpats', fvs) ->
143 returnRn (RecPatIn con' rpats', fvs `addOneFV` con')
146 ************************************************************************
150 ************************************************************************
153 rnMatch :: RdrNameMatch -> RnMS s (RenamedMatch, FreeVars)
155 rnMatch match@(Match _ pats maybe_rhs_sig grhss)
156 = pushSrcLocRn (getMatchLoc match) $
158 -- Find the universally quantified type variables
159 -- in the pattern type signatures
160 getLocalNameEnv `thenRn` \ name_env ->
162 tyvars_in_sigs = rhs_sig_tyvars `unionLists` tyvars_in_pats
163 rhs_sig_tyvars = case maybe_rhs_sig of
165 Just ty -> extractHsTyVars ty
166 tyvars_in_pats = extractPatsTyVars pats
167 forall_tyvars = filter (not . (`elemFM` name_env)) tyvars_in_sigs
168 doc = text "a pattern type-signature"
170 bindTyVarsFVRn doc (map UserTyVar forall_tyvars) $ \ sig_tyvars ->
172 -- Note that we do a single bindLocalsRn for all the
173 -- matches together, so that we spot the repeated variable in
175 bindLocalsFVRn "pattern" (collectPatsBinders pats) $ \ new_binders ->
177 mapAndUnzipRn rnPat pats `thenRn` \ (pats', pat_fvs_s) ->
178 rnGRHSs grhss `thenRn` \ (grhss', grhss_fvs) ->
179 (case maybe_rhs_sig of
180 Nothing -> returnRn (Nothing, emptyFVs)
181 Just ty | opt_GlasgowExts -> rnHsType doc ty `thenRn` \ (ty', ty_fvs) ->
182 returnRn (Just ty', ty_fvs)
183 | otherwise -> addErrRn (patSigErr ty) `thenRn_`
184 returnRn (Nothing, emptyFVs)
185 ) `thenRn` \ (maybe_rhs_sig', ty_fvs) ->
188 binder_set = mkNameSet new_binders
189 unused_binders = nameSetToList (binder_set `minusNameSet` grhss_fvs)
190 all_fvs = grhss_fvs `plusFV` plusFVs pat_fvs_s `plusFV` ty_fvs
192 warnUnusedMatches unused_binders `thenRn_`
194 returnRn (Match sig_tyvars pats' maybe_rhs_sig' grhss', all_fvs)
195 -- The bindLocals and bindTyVars will remove the bound FVs
198 %************************************************************************
200 \subsubsection{Guarded right-hand sides (GRHSs)}
202 %************************************************************************
205 rnGRHSs :: RdrNameGRHSs -> RnMS s (RenamedGRHSs, FreeVars)
207 rnGRHSs (GRHSs grhss binds maybe_ty)
208 = ASSERT( not (maybeToBool maybe_ty) )
209 rnBinds binds $ \ binds' ->
210 mapAndUnzipRn rnGRHS grhss `thenRn` \ (grhss', fvGRHSs) ->
211 returnRn (GRHSs grhss' binds' Nothing, plusFVs fvGRHSs)
213 rnGRHS (GRHS guarded locn)
214 = pushSrcLocRn locn $
215 (if not (opt_GlasgowExts || is_standard_guard guarded) then
216 addWarnRn (nonStdGuardErr guarded)
221 rnStmts rnExpr guarded `thenRn` \ (guarded', fvs) ->
222 returnRn (GRHS guarded' locn, fvs)
224 -- Standard Haskell 1.4 guards are just a single boolean
225 -- expression, rather than a list of qualifiers as in the
227 is_standard_guard [ExprStmt _ _] = True
228 is_standard_guard [GuardStmt _ _, ExprStmt _ _] = True
229 is_standard_guard other = False
232 %************************************************************************
234 \subsubsection{Expressions}
236 %************************************************************************
239 rnExprs :: [RdrNameHsExpr] -> RnMS s ([RenamedHsExpr], FreeVars)
240 rnExprs ls = rnExprs' ls emptyUniqSet
242 rnExprs' [] acc = returnRn ([], acc)
243 rnExprs' (expr:exprs) acc
244 = rnExpr expr `thenRn` \ (expr', fvExpr) ->
246 -- Now we do a "seq" on the free vars because typically it's small
247 -- or empty, especially in very long lists of constants
249 acc' = acc `plusFV` fvExpr
251 (grubby_seqNameSet acc' rnExprs') exprs acc' `thenRn` \ (exprs', fvExprs) ->
252 returnRn (expr':exprs', fvExprs)
254 -- Grubby little function to do "seq" on namesets; replace by proper seq when GHC can do seq
255 grubby_seqNameSet ns result | isNullUFM ns = result
259 Variables. We look up the variable and return the resulting name. The
260 interesting question is what the free-variable set should be. We
261 don't want to return imported or prelude things as free vars. So we
262 look at the Name returned from the lookup, and make it part of the
263 free-var set iff if it's a LocallyDefined Name.
267 rnExpr :: RdrNameHsExpr -> RnMS s (RenamedHsExpr, FreeVars)
270 = lookupOccRn v `thenRn` \ name ->
271 if nameUnique name == assertIdKey then
272 -- We expand it to (GHCerr.assert__ location)
273 mkAssertExpr `thenRn` \ expr ->
274 returnRn (expr, emptyUniqSet)
277 returnRn (HsVar name, if isLocallyDefined name
278 then unitNameSet name
282 = litOccurrence lit `thenRn_`
283 returnRn (HsLit lit, emptyNameSet)
286 = rnMatch match `thenRn` \ (match', fvMatch) ->
287 returnRn (HsLam match', fvMatch)
289 rnExpr (HsApp fun arg)
290 = rnExpr fun `thenRn` \ (fun',fvFun) ->
291 rnExpr arg `thenRn` \ (arg',fvArg) ->
292 returnRn (HsApp fun' arg', fvFun `plusFV` fvArg)
294 rnExpr (OpApp e1 op _ e2)
295 = rnExpr e1 `thenRn` \ (e1', fv_e1) ->
296 rnExpr e2 `thenRn` \ (e2', fv_e2) ->
297 rnExpr op `thenRn` \ (op'@(HsVar op_name), fv_op) ->
300 -- When renaming code synthesised from "deriving" declarations
301 -- we're in Interface mode, and we should ignore fixity; assume
302 -- that the deriving code generator got the association correct
303 lookupFixity op_name `thenRn` \ fixity ->
304 getModeRn `thenRn` \ mode ->
306 SourceMode -> mkOpAppRn e1' op' fixity e2'
307 InterfaceMode _ -> returnRn (OpApp e1' op' fixity e2')
308 ) `thenRn` \ final_e ->
311 fv_e1 `plusFV` fv_op `plusFV` fv_e2)
314 = rnExpr e `thenRn` \ (e', fv_e) ->
315 lookupImplicitOccRn negate_RDR `thenRn` \ neg ->
316 mkNegAppRn e' (HsVar neg) `thenRn` \ final_e ->
317 returnRn (final_e, fv_e)
320 = rnExpr e `thenRn` \ (e', fvs_e) ->
321 returnRn (HsPar e', fvs_e)
323 rnExpr (SectionL expr op)
324 = rnExpr expr `thenRn` \ (expr', fvs_expr) ->
325 rnExpr op `thenRn` \ (op', fvs_op) ->
326 returnRn (SectionL expr' op', fvs_op `plusFV` fvs_expr)
328 rnExpr (SectionR op expr)
329 = rnExpr op `thenRn` \ (op', fvs_op) ->
330 rnExpr expr `thenRn` \ (expr', fvs_expr) ->
331 returnRn (SectionR op' expr', fvs_op `plusFV` fvs_expr)
333 rnExpr (CCall fun args may_gc is_casm fake_result_ty)
334 -- Check out the comment on RnIfaces.getNonWiredDataDecl about ccalls
335 = lookupImplicitOccRn ccallableClass_RDR `thenRn_`
336 lookupImplicitOccRn creturnableClass_RDR `thenRn_`
337 lookupImplicitOccRn ioDataCon_RDR `thenRn_`
338 rnExprs args `thenRn` \ (args', fvs_args) ->
339 returnRn (CCall fun args' may_gc is_casm fake_result_ty, fvs_args)
341 rnExpr (HsSCC label expr)
342 = rnExpr expr `thenRn` \ (expr', fvs_expr) ->
343 returnRn (HsSCC label expr', fvs_expr)
345 rnExpr (HsCase expr ms src_loc)
346 = pushSrcLocRn src_loc $
347 rnExpr expr `thenRn` \ (new_expr, e_fvs) ->
348 mapAndUnzipRn rnMatch ms `thenRn` \ (new_ms, ms_fvs) ->
349 returnRn (HsCase new_expr new_ms src_loc, plusFVs (e_fvs : ms_fvs))
351 rnExpr (HsLet binds expr)
352 = rnBinds binds $ \ binds' ->
353 rnExpr expr `thenRn` \ (expr',fvExpr) ->
354 returnRn (HsLet binds' expr', fvExpr)
356 rnExpr (HsDo do_or_lc stmts src_loc)
357 = pushSrcLocRn src_loc $
358 lookupImplicitOccRn monadZeroClass_RDR `thenRn_` -- Forces Monad to come too
359 rnStmts rnExpr stmts `thenRn` \ (stmts', fvs) ->
360 returnRn (HsDo do_or_lc stmts' src_loc, fvs)
362 rnExpr (ExplicitList exps)
363 = addImplicitOccRn listTyCon_name `thenRn_`
364 rnExprs exps `thenRn` \ (exps', fvs) ->
365 returnRn (ExplicitList exps', fvs)
367 rnExpr (ExplicitTuple exps boxed)
368 = addImplicitOccRn (tupleTyCon_name boxed (length exps)) `thenRn_`
369 rnExprs exps `thenRn` \ (exps', fvExps) ->
370 returnRn (ExplicitTuple exps' boxed, fvExps)
372 rnExpr (RecordCon con_id rbinds)
373 = lookupOccRn con_id `thenRn` \ conname ->
374 rnRbinds "construction" rbinds `thenRn` \ (rbinds', fvRbinds) ->
375 returnRn (RecordCon conname rbinds', fvRbinds)
377 rnExpr (RecordUpd expr rbinds)
378 = rnExpr expr `thenRn` \ (expr', fvExpr) ->
379 rnRbinds "update" rbinds `thenRn` \ (rbinds', fvRbinds) ->
380 returnRn (RecordUpd expr' rbinds', fvExpr `plusFV` fvRbinds)
382 rnExpr (ExprWithTySig expr pty)
383 = rnExpr expr `thenRn` \ (expr', fvExpr) ->
384 rnHsSigType (text "an expression") pty `thenRn` \ (pty', fvTy) ->
385 returnRn (ExprWithTySig expr' pty', fvExpr `plusFV` fvTy)
387 rnExpr (HsIf p b1 b2 src_loc)
388 = pushSrcLocRn src_loc $
389 rnExpr p `thenRn` \ (p', fvP) ->
390 rnExpr b1 `thenRn` \ (b1', fvB1) ->
391 rnExpr b2 `thenRn` \ (b2', fvB2) ->
392 returnRn (HsIf p' b1' b2' src_loc, plusFVs [fvP, fvB1, fvB2])
394 rnExpr (ArithSeqIn seq)
395 = lookupImplicitOccRn enumClass_RDR `thenRn_`
396 rn_seq seq `thenRn` \ (new_seq, fvs) ->
397 returnRn (ArithSeqIn new_seq, fvs)
400 = rnExpr expr `thenRn` \ (expr', fvExpr) ->
401 returnRn (From expr', fvExpr)
403 rn_seq (FromThen expr1 expr2)
404 = rnExpr expr1 `thenRn` \ (expr1', fvExpr1) ->
405 rnExpr expr2 `thenRn` \ (expr2', fvExpr2) ->
406 returnRn (FromThen expr1' expr2', fvExpr1 `plusFV` fvExpr2)
408 rn_seq (FromTo expr1 expr2)
409 = rnExpr expr1 `thenRn` \ (expr1', fvExpr1) ->
410 rnExpr expr2 `thenRn` \ (expr2', fvExpr2) ->
411 returnRn (FromTo expr1' expr2', fvExpr1 `plusFV` fvExpr2)
413 rn_seq (FromThenTo expr1 expr2 expr3)
414 = rnExpr expr1 `thenRn` \ (expr1', fvExpr1) ->
415 rnExpr expr2 `thenRn` \ (expr2', fvExpr2) ->
416 rnExpr expr3 `thenRn` \ (expr3', fvExpr3) ->
417 returnRn (FromThenTo expr1' expr2' expr3',
418 plusFVs [fvExpr1, fvExpr2, fvExpr3])
421 %************************************************************************
423 \subsubsection{@Rbinds@s and @Rpats@s: in record expressions}
425 %************************************************************************
429 = mapRn field_dup_err dup_fields `thenRn_`
430 mapAndUnzipRn rn_rbind rbinds `thenRn` \ (rbinds', fvRbind_s) ->
431 returnRn (rbinds', plusFVs fvRbind_s)
433 (_, dup_fields) = removeDups compare [ f | (f,_,_) <- rbinds ]
435 field_dup_err dups = addErrRn (dupFieldErr str dups)
437 rn_rbind (field, expr, pun)
438 = lookupGlobalOccRn field `thenRn` \ fieldname ->
439 rnExpr expr `thenRn` \ (expr', fvExpr) ->
440 returnRn ((fieldname, expr', pun), fvExpr)
443 = mapRn field_dup_err dup_fields `thenRn_`
444 mapAndUnzipRn rn_rpat rpats `thenRn` \ (rpats', fvs_s) ->
445 returnRn (rpats', plusFVs fvs_s)
447 (_, dup_fields) = removeDups compare [ f | (f,_,_) <- rpats ]
449 field_dup_err dups = addErrRn (dupFieldErr "pattern" dups)
451 rn_rpat (field, pat, pun)
452 = lookupGlobalOccRn field `thenRn` \ fieldname ->
453 rnPat pat `thenRn` \ (pat', fvs) ->
454 returnRn ((fieldname, pat', pun), fvs)
457 %************************************************************************
459 \subsubsection{@Stmt@s: in @do@ expressions}
461 %************************************************************************
463 Note that although some bound vars may appear in the free var set for
464 the first qual, these will eventually be removed by the caller. For
465 example, if we have @[p | r <- s, q <- r, p <- q]@, when doing
466 @[q <- r, p <- q]@, the free var set for @q <- r@ will
467 be @{r}@, and the free var set for the entire Quals will be @{r}@. This
468 @r@ will be removed only when we finally return from examining all the
472 type RnExprTy s = RdrNameHsExpr -> RnMS s (RenamedHsExpr, FreeVars)
474 rnStmts :: RnExprTy s
476 -> RnMS s ([RenamedStmt], FreeVars)
479 = returnRn ([], emptyNameSet)
481 rnStmts rn_expr (stmt:stmts)
482 = rnStmt rn_expr stmt $ \ stmt' ->
483 rnStmts rn_expr stmts `thenRn` \ (stmts', fvs) ->
484 returnRn (stmt' : stmts', fvs)
486 rnStmt :: RnExprTy s -> RdrNameStmt
487 -> (RenamedStmt -> RnMS s (a, FreeVars))
488 -> RnMS s (a, FreeVars)
489 -- Because of mutual recursion we have to pass in rnExpr.
491 rnStmt rn_expr (BindStmt pat expr src_loc) thing_inside
492 = pushSrcLocRn src_loc $
493 rn_expr expr `thenRn` \ (expr', fv_expr) ->
494 bindLocalsFVRn "pattern in do binding" binders $ \ new_binders ->
495 rnPat pat `thenRn` \ (pat', fv_pat) ->
496 thing_inside (BindStmt pat' expr' src_loc) `thenRn` \ (result, fvs) ->
497 returnRn (result, fv_expr `plusFV` fvs `plusFV` fv_pat)
499 binders = collectPatBinders pat
501 rnStmt rn_expr (ExprStmt expr src_loc) thing_inside
502 = pushSrcLocRn src_loc $
503 rn_expr expr `thenRn` \ (expr', fv_expr) ->
504 thing_inside (ExprStmt expr' src_loc) `thenRn` \ (result, fvs) ->
505 returnRn (result, fv_expr `plusFV` fvs)
507 rnStmt rn_expr (GuardStmt expr src_loc) thing_inside
508 = pushSrcLocRn src_loc $
509 rn_expr expr `thenRn` \ (expr', fv_expr) ->
510 thing_inside (GuardStmt expr' src_loc) `thenRn` \ (result, fvs) ->
511 returnRn (result, fv_expr `plusFV` fvs)
513 rnStmt rn_expr (ReturnStmt expr) thing_inside
514 = rn_expr expr `thenRn` \ (expr', fv_expr) ->
515 thing_inside (ReturnStmt expr') `thenRn` \ (result, fvs) ->
516 returnRn (result, fv_expr `plusFV` fvs)
518 rnStmt rn_expr (LetStmt binds) thing_inside
519 = rnBinds binds $ \ binds' ->
520 thing_inside (LetStmt binds')
523 %************************************************************************
525 \subsubsection{Precedence Parsing}
527 %************************************************************************
529 @mkOpAppRn@ deals with operator fixities. The argument expressions
530 are assumed to be already correctly arranged. It needs the fixities
531 recorded in the OpApp nodes, because fixity info applies to the things
532 the programmer actually wrote, so you can't find it out from the Name.
534 Furthermore, the second argument is guaranteed not to be another
535 operator application. Why? Because the parser parses all
536 operator appications left-associatively.
539 mkOpAppRn :: RenamedHsExpr -> RenamedHsExpr -> Fixity -> RenamedHsExpr
540 -> RnMS s RenamedHsExpr
542 mkOpAppRn e1@(OpApp e11 op1 fix1 e12)
545 = addErrRn (precParseErr (get op1,fix1) (get op2,fix2)) `thenRn_`
546 returnRn (OpApp e1 op2 fix2 e2)
549 = mkOpAppRn e12 op2 fix2 e2 `thenRn` \ new_e ->
550 returnRn (OpApp e11 op1 fix1 new_e)
552 (nofix_error, rearrange_me) = compareFixity fix1 fix2
554 mkOpAppRn e1@(NegApp neg_arg neg_op)
556 fix2@(Fixity prec2 dir2)
559 = addErrRn (precParseErr (get neg_op,fix_neg) (get op2,fix2)) `thenRn_`
560 returnRn (OpApp e1 op2 fix2 e2)
563 = mkOpAppRn neg_arg op2 fix2 e2 `thenRn` \ new_e ->
564 returnRn (NegApp new_e neg_op)
566 fix_neg = Fixity 6 InfixL -- Precedence of unary negate is wired in as infixl 6!
567 (nofix_error, rearrange_me) = compareFixity fix_neg fix2
569 mkOpAppRn e1 op fix e2 -- Default case, no rearrangment
570 = ASSERT( if right_op_ok fix e2 then True
571 else pprPanic "mkOpAppRn" (vcat [ppr e1, text "---", ppr op,
572 text "---", ppr fix, text "---", ppr e2])
574 returnRn (OpApp e1 op fix e2)
578 -- Parser left-associates everything, but
579 -- derived instances may have correctly-associated things to
580 -- in the right operarand. So we just check that the right operand is OK
581 right_op_ok fix1 (OpApp _ _ fix2 _)
582 = not error_please && associate_right
584 (error_please, associate_right) = compareFixity fix1 fix2
585 right_op_ok fix1 other
588 -- Parser initially makes negation bind more tightly than any other operator
589 mkNegAppRn neg_arg neg_op
592 getModeRn `thenRn` \ mode ->
593 ASSERT( not_op_app mode neg_arg )
595 returnRn (NegApp neg_arg neg_op)
597 not_op_app SourceMode (OpApp _ _ _ _) = False
598 not_op_app mode other = True
602 mkConOpPatRn :: RenamedPat -> Name -> Fixity -> RenamedPat
605 mkConOpPatRn p1@(ConOpPatIn p11 op1 fix1 p12)
608 = addErrRn (precParseErr (op1,fix1) (op2,fix2)) `thenRn_`
609 returnRn (ConOpPatIn p1 op2 fix2 p2)
612 = mkConOpPatRn p12 op2 fix2 p2 `thenRn` \ new_p ->
613 returnRn (ConOpPatIn p11 op1 fix1 new_p)
616 (nofix_error, rearrange_me) = compareFixity fix1 fix2
618 mkConOpPatRn p1@(NegPatIn neg_arg)
620 fix2@(Fixity prec2 dir2)
622 | prec2 > 6 -- Precedence of unary - is wired in as 6!
623 = addErrRn (precParseNegPatErr (op2,fix2)) `thenRn_`
624 returnRn (ConOpPatIn p1 op2 fix2 p2)
626 mkConOpPatRn p1 op fix p2 -- Default case, no rearrangment
627 = ASSERT( not_op_pat p2 )
628 returnRn (ConOpPatIn p1 op fix p2)
630 not_op_pat (ConOpPatIn _ _ _ _) = False
631 not_op_pat other = True
635 checkPrecMatch :: Bool -> Name -> RenamedMatch -> RnMS s ()
637 checkPrecMatch False fn match
639 checkPrecMatch True op (Match _ [p1,p2] _ _)
640 = checkPrec op p1 False `thenRn_`
642 checkPrecMatch True op _ = panic "checkPrecMatch"
644 checkPrec op (ConOpPatIn _ op1 _ _) right
645 = lookupFixity op `thenRn` \ op_fix@(Fixity op_prec op_dir) ->
646 lookupFixity op1 `thenRn` \ op1_fix@(Fixity op1_prec op1_dir) ->
648 inf_ok = op1_prec > op_prec ||
649 (op1_prec == op_prec &&
650 (op1_dir == InfixR && op_dir == InfixR && right ||
651 op1_dir == InfixL && op_dir == InfixL && not right))
654 info1 = (op1,op1_fix)
655 (infol, infor) = if right then (info, info1) else (info1, info)
657 checkRn inf_ok (precParseErr infol infor)
659 checkPrec op (NegPatIn _) right
660 = lookupFixity op `thenRn` \ op_fix@(Fixity op_prec op_dir) ->
661 checkRn (op_prec <= 6) (precParseNegPatErr (op,op_fix))
663 checkPrec op pat right
670 (compareFixity op1 op2) tells which way to arrange appication, or
671 whether there's an error.
674 compareFixity :: Fixity -> Fixity
675 -> (Bool, -- Error please
676 Bool) -- Associate to the right: a op1 (b op2 c)
677 compareFixity (Fixity prec1 dir1) (Fixity prec2 dir2)
678 = case prec1 `compare` prec2 of
681 EQ -> case (dir1, dir2) of
682 (InfixR, InfixR) -> right
683 (InfixL, InfixL) -> left
686 right = (False, True)
687 left = (False, False)
688 error_please = (True, False)
691 %************************************************************************
693 \subsubsection{Literals}
695 %************************************************************************
697 When literals occur we have to make sure that the types and classes they involve
701 litOccurrence (HsChar _)
702 = addImplicitOccRn charTyCon_name
704 litOccurrence (HsCharPrim _)
705 = addImplicitOccRn (getName charPrimTyCon)
707 litOccurrence (HsString _)
708 = addImplicitOccRn listTyCon_name `thenRn_`
709 addImplicitOccRn charTyCon_name
711 litOccurrence (HsStringPrim _)
712 = addImplicitOccRn (getName addrPrimTyCon)
714 litOccurrence (HsInt _)
715 = lookupImplicitOccRn numClass_RDR -- Int and Integer are forced in by Num
717 litOccurrence (HsFrac _)
718 = lookupImplicitOccRn fractionalClass_RDR `thenRn_`
719 lookupImplicitOccRn ratioDataCon_RDR
720 -- We have to make sure that the Ratio type is imported with
721 -- its constructor, because literals of type Ratio t are
722 -- built with that constructor.
723 -- The Rational type is needed too, but that will come in
724 -- when fractionalClass does.
726 litOccurrence (HsIntPrim _)
727 = addImplicitOccRn (getName intPrimTyCon)
729 litOccurrence (HsFloatPrim _)
730 = addImplicitOccRn (getName floatPrimTyCon)
732 litOccurrence (HsDoublePrim _)
733 = addImplicitOccRn (getName doublePrimTyCon)
735 litOccurrence (HsLitLit _)
736 = lookupImplicitOccRn ccallableClass_RDR
739 %************************************************************************
741 \subsubsection{Assertion utils}
743 %************************************************************************
746 mkAssertExpr :: RnMS s RenamedHsExpr
748 newImportedGlobalName mod occ HiFile `thenRn` \ name ->
749 addOccurrenceName name `thenRn_`
750 getSrcLocRn `thenRn` \ sloc ->
752 expr = HsApp (HsVar name)
753 (HsLit (HsString (_PK_ (showSDoc (ppr sloc)))))
758 mod = rdrNameModule assertErr_RDR
759 occ = rdrNameOcc assertErr_RDR
762 %************************************************************************
764 \subsubsection{Errors}
766 %************************************************************************
769 dupFieldErr str (dup:rest)
770 = hsep [ptext SLIT("duplicate field name"),
772 ptext SLIT("in record"), text str]
775 = sep [ptext SLIT("prefix `-' not applied to literal in pattern"), quotes (ppr pat)]
777 precParseNegPatErr op
778 = hang (ptext SLIT("precedence parsing error"))
779 4 (hsep [ptext SLIT("prefix `-' has lower precedence than"),
781 ptext SLIT("in pattern")])
784 = hang (ptext SLIT("precedence parsing error"))
785 4 (hsep [ptext SLIT("cannot mix"), quotes (pp_op op1), ptext SLIT("and"),
787 ptext SLIT("in the same infix expression")])
790 = hang (ptext SLIT("accepting non-standard pattern guards (-fglasgow-exts to suppress this message)"))
794 = hang (ptext SLIT("Illegal signature in pattern:") <+> ppr ty)
795 4 (ptext SLIT("Use -fglasgow-exts to permit it"))
797 pp_op (op, fix) = hcat [ppr op, space, parens (ppr fix)]