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, rnExpr, rnExprs,
18 #include "HsVersions.h"
20 import {-# SOURCE #-} RnBinds ( rnBinds )
21 import {-# SOURCE #-} RnSource ( rnHsSigType, rnHsType )
28 import RnIfaces ( lookupFixity )
29 import CmdLineOpts ( opt_GlasgowExts, opt_IgnoreAsserts )
30 import BasicTypes ( Fixity(..), FixityDirection(..), defaultFixity )
31 import PrelInfo ( numClass_RDR, fractionalClass_RDR, eqClass_RDR,
32 ccallableClass_RDR, creturnableClass_RDR,
33 monadClass_RDR, enumClass_RDR, ordClass_RDR,
34 ratioDataCon_RDR, negate_RDR, assertErr_RDR,
37 import TysPrim ( charPrimTyCon, addrPrimTyCon, intPrimTyCon,
38 floatPrimTyCon, doublePrimTyCon
40 import Name ( nameUnique, isLocallyDefined, NamedThing(..)
41 , mkSysLocalName, nameSrcLoc
44 import UniqFM ( isNullUFM )
45 import FiniteMap ( elemFM )
46 import UniqSet ( emptyUniqSet, UniqSet )
47 import Unique ( assertIdKey )
48 import Util ( removeDups )
49 import ListSetOps ( unionLists )
50 import Maybes ( maybeToBool )
55 *********************************************************
59 *********************************************************
62 rnPat :: RdrNamePat -> RnMS (RenamedPat, FreeVars)
64 rnPat WildPatIn = returnRn (WildPatIn, emptyFVs)
67 = lookupBndrRn name `thenRn` \ vname ->
68 returnRn (VarPatIn vname, emptyFVs)
70 rnPat (SigPatIn pat ty)
72 = rnPat pat `thenRn` \ (pat', fvs1) ->
73 rnHsType doc ty `thenRn` \ (ty', fvs2) ->
74 returnRn (SigPatIn pat' ty', fvs1 `plusFV` fvs2)
77 = addErrRn (patSigErr ty) `thenRn_`
80 doc = text "a pattern type-signature"
83 = litOccurrence lit `thenRn` \ fvs1 ->
84 lookupImplicitOccRn eqClass_RDR `thenRn` \ eq -> -- Needed to find equality on pattern
85 returnRn (LitPatIn lit, fvs1 `addOneFV` eq)
88 = rnPat pat `thenRn` \ (pat', fvs) ->
89 returnRn (LazyPatIn pat', fvs)
91 rnPat (AsPatIn name pat)
92 = rnPat pat `thenRn` \ (pat', fvs) ->
93 lookupBndrRn name `thenRn` \ vname ->
94 returnRn (AsPatIn vname pat', fvs)
96 rnPat (ConPatIn con pats)
97 = lookupOccRn con `thenRn` \ con' ->
98 mapFvRn rnPat pats `thenRn` \ (patslist, fvs) ->
99 returnRn (ConPatIn con' patslist, fvs `addOneFV` con')
101 rnPat (ConOpPatIn pat1 con _ pat2)
102 = rnPat pat1 `thenRn` \ (pat1', fvs1) ->
103 lookupOccRn con `thenRn` \ con' ->
104 rnPat pat2 `thenRn` \ (pat2', fvs2) ->
106 getModeRn `thenRn` \ mode ->
107 -- See comments with rnExpr (OpApp ...)
109 InterfaceMode -> returnRn (ConOpPatIn pat1' con' defaultFixity pat2')
110 SourceMode -> lookupFixity con' `thenRn` \ fixity ->
111 mkConOpPatRn pat1' con' fixity pat2'
113 returnRn (pat', fvs1 `plusFV` fvs2 `addOneFV` con')
115 -- Negated patters can only be literals, and they are dealt with
116 -- by negating the literal at compile time, not by using the negation
117 -- operation in Num. So we don't need to make an implicit reference
119 rnPat neg@(NegPatIn pat)
120 = checkRn (valid_neg_pat pat) (negPatErr neg)
122 rnPat pat `thenRn` \ (pat', fvs) ->
123 returnRn (NegPatIn pat', fvs)
125 valid_neg_pat (LitPatIn (HsInt _)) = True
126 valid_neg_pat (LitPatIn (HsFrac _)) = True
127 valid_neg_pat _ = False
130 = rnPat pat `thenRn` \ (pat', fvs) ->
131 returnRn (ParPatIn pat', fvs)
133 rnPat (NPlusKPatIn name lit)
134 = litOccurrence lit `thenRn` \ fvs ->
135 lookupImplicitOccRn ordClass_RDR `thenRn` \ ord ->
136 lookupBndrRn name `thenRn` \ name' ->
137 returnRn (NPlusKPatIn name' lit, fvs `addOneFV` ord)
139 rnPat (ListPatIn pats)
140 = mapFvRn rnPat pats `thenRn` \ (patslist, fvs) ->
141 returnRn (ListPatIn patslist, fvs `addOneFV` listTyCon_name)
143 rnPat (TuplePatIn pats boxed)
144 = mapFvRn rnPat pats `thenRn` \ (patslist, fvs) ->
145 returnRn (TuplePatIn patslist boxed, fvs `addOneFV` tycon_name)
147 tycon_name = tupleTyCon_name boxed (length pats)
149 rnPat (RecPatIn con rpats)
150 = lookupOccRn con `thenRn` \ con' ->
151 rnRpats rpats `thenRn` \ (rpats', fvs) ->
152 returnRn (RecPatIn con' rpats', fvs `addOneFV` con')
155 ************************************************************************
159 ************************************************************************
162 rnMatch :: RdrNameMatch -> RnMS (RenamedMatch, FreeVars)
164 rnMatch match@(Match _ pats maybe_rhs_sig grhss)
165 = pushSrcLocRn (getMatchLoc match) $
167 -- Find the universally quantified type variables
168 -- in the pattern type signatures
169 getLocalNameEnv `thenRn` \ name_env ->
171 tyvars_in_sigs = rhs_sig_tyvars `unionLists` tyvars_in_pats
172 rhs_sig_tyvars = case maybe_rhs_sig of
174 Just ty -> extractHsTyRdrNames ty
175 tyvars_in_pats = extractPatsTyVars pats
176 forall_tyvars = filter (not . (`elemFM` name_env)) tyvars_in_sigs
177 doc = text "a pattern type-signature"
179 bindTyVarsFVRn doc (map UserTyVar forall_tyvars) $ \ sig_tyvars ->
181 -- Note that we do a single bindLocalsRn for all the
182 -- matches together, so that we spot the repeated variable in
184 bindLocalsFVRn doc (collectPatsBinders pats) $ \ new_binders ->
186 mapFvRn rnPat pats `thenRn` \ (pats', pat_fvs) ->
187 rnGRHSs grhss `thenRn` \ (grhss', grhss_fvs) ->
188 (case maybe_rhs_sig of
189 Nothing -> returnRn (Nothing, emptyFVs)
190 Just ty | opt_GlasgowExts -> rnHsType doc ty `thenRn` \ (ty', ty_fvs) ->
191 returnRn (Just ty', ty_fvs)
192 | otherwise -> addErrRn (patSigErr ty) `thenRn_`
193 returnRn (Nothing, emptyFVs)
194 ) `thenRn` \ (maybe_rhs_sig', ty_fvs) ->
197 binder_set = mkNameSet new_binders
198 unused_binders = nameSetToList (binder_set `minusNameSet` grhss_fvs)
199 all_fvs = grhss_fvs `plusFV` pat_fvs `plusFV` ty_fvs
201 warnUnusedMatches unused_binders `thenRn_`
203 returnRn (Match sig_tyvars pats' maybe_rhs_sig' grhss', all_fvs)
204 -- The bindLocals and bindTyVars will remove the bound FVs
207 %************************************************************************
209 \subsubsection{Guarded right-hand sides (GRHSs)}
211 %************************************************************************
214 rnGRHSs :: RdrNameGRHSs -> RnMS (RenamedGRHSs, FreeVars)
216 rnGRHSs (GRHSs grhss binds maybe_ty)
217 = ASSERT( not (maybeToBool maybe_ty) )
218 rnBinds binds $ \ binds' ->
219 mapFvRn rnGRHS grhss `thenRn` \ (grhss', fvGRHSs) ->
220 returnRn (GRHSs grhss' binds' Nothing, fvGRHSs)
222 rnGRHS (GRHS guarded locn)
223 = pushSrcLocRn locn $
224 (if not (opt_GlasgowExts || is_standard_guard guarded) then
225 addWarnRn (nonStdGuardErr guarded)
230 rnStmts rnExpr guarded `thenRn` \ (guarded', fvs) ->
231 returnRn (GRHS guarded' locn, fvs)
233 -- Standard Haskell 1.4 guards are just a single boolean
234 -- expression, rather than a list of qualifiers as in the
236 is_standard_guard [ExprStmt _ _] = True
237 is_standard_guard [GuardStmt _ _, ExprStmt _ _] = True
238 is_standard_guard other = False
241 %************************************************************************
243 \subsubsection{Expressions}
245 %************************************************************************
248 rnExprs :: [RdrNameHsExpr] -> RnMS ([RenamedHsExpr], FreeVars)
249 rnExprs ls = rnExprs' ls emptyUniqSet
251 rnExprs' [] acc = returnRn ([], acc)
252 rnExprs' (expr:exprs) acc
253 = rnExpr expr `thenRn` \ (expr', fvExpr) ->
255 -- Now we do a "seq" on the free vars because typically it's small
256 -- or empty, especially in very long lists of constants
258 acc' = acc `plusFV` fvExpr
260 (grubby_seqNameSet acc' rnExprs') exprs acc' `thenRn` \ (exprs', fvExprs) ->
261 returnRn (expr':exprs', fvExprs)
263 -- Grubby little function to do "seq" on namesets; replace by proper seq when GHC can do seq
264 grubby_seqNameSet ns result | isNullUFM ns = result
268 Variables. We look up the variable and return the resulting name.
271 rnExpr :: RdrNameHsExpr -> RnMS (RenamedHsExpr, FreeVars)
274 = lookupOccRn v `thenRn` \ name ->
275 if nameUnique name == assertIdKey then
276 -- We expand it to (GHCerr.assert__ location)
280 returnRn (HsVar name, unitFV name)
283 = litOccurrence lit `thenRn` \ fvs ->
284 returnRn (HsLit lit, fvs)
287 = rnMatch match `thenRn` \ (match', fvMatch) ->
288 returnRn (HsLam match', fvMatch)
290 rnExpr (HsApp fun arg)
291 = rnExpr fun `thenRn` \ (fun',fvFun) ->
292 rnExpr arg `thenRn` \ (arg',fvArg) ->
293 returnRn (HsApp fun' arg', fvFun `plusFV` fvArg)
295 rnExpr (OpApp e1 op _ e2)
296 = rnExpr e1 `thenRn` \ (e1', fv_e1) ->
297 rnExpr e2 `thenRn` \ (e2', fv_e2) ->
298 rnExpr op `thenRn` \ (op'@(HsVar op_name), fv_op) ->
301 -- When renaming code synthesised from "deriving" declarations
302 -- we're in Interface mode, and we should ignore fixity; assume
303 -- that the deriving code generator got the association correct
304 -- Don't even look up the fixity when in interface mode
305 getModeRn `thenRn` \ mode ->
307 SourceMode -> lookupFixity op_name `thenRn` \ fixity ->
308 mkOpAppRn e1' op' fixity e2'
309 InterfaceMode -> returnRn (OpApp e1' op' defaultFixity e2')
310 ) `thenRn` \ final_e ->
313 fv_e1 `plusFV` fv_op `plusFV` fv_e2)
316 = rnExpr e `thenRn` \ (e', fv_e) ->
317 lookupImplicitOccRn negate_RDR `thenRn` \ neg ->
318 mkNegAppRn e' (HsVar neg) `thenRn` \ final_e ->
319 returnRn (final_e, fv_e `addOneFV` neg)
322 = rnExpr e `thenRn` \ (e', fvs_e) ->
323 returnRn (HsPar e', fvs_e)
325 rnExpr (SectionL expr op)
326 = rnExpr expr `thenRn` \ (expr', fvs_expr) ->
327 rnExpr op `thenRn` \ (op', fvs_op) ->
328 returnRn (SectionL expr' op', fvs_op `plusFV` fvs_expr)
330 rnExpr (SectionR op expr)
331 = rnExpr op `thenRn` \ (op', fvs_op) ->
332 rnExpr expr `thenRn` \ (expr', fvs_expr) ->
333 returnRn (SectionR op' expr', fvs_op `plusFV` fvs_expr)
335 rnExpr (CCall fun args may_gc is_casm fake_result_ty)
336 -- Check out the comment on RnIfaces.getNonWiredDataDecl about ccalls
337 = lookupImplicitOccRn ccallableClass_RDR `thenRn` \ cc ->
338 lookupImplicitOccRn creturnableClass_RDR `thenRn` \ cr ->
339 lookupImplicitOccRn ioDataCon_RDR `thenRn` \ io ->
340 rnExprs args `thenRn` \ (args', fvs_args) ->
341 returnRn (CCall fun args' may_gc is_casm fake_result_ty,
342 fvs_args `addOneFV` cc `addOneFV` cr `addOneFV` io)
344 rnExpr (HsSCC label expr)
345 = rnExpr expr `thenRn` \ (expr', fvs_expr) ->
346 returnRn (HsSCC label expr', fvs_expr)
348 rnExpr (HsCase expr ms src_loc)
349 = pushSrcLocRn src_loc $
350 rnExpr expr `thenRn` \ (new_expr, e_fvs) ->
351 mapFvRn rnMatch ms `thenRn` \ (new_ms, ms_fvs) ->
352 returnRn (HsCase new_expr new_ms src_loc, e_fvs `plusFV` ms_fvs)
354 rnExpr (HsLet binds expr)
355 = rnBinds binds $ \ binds' ->
356 rnExpr expr `thenRn` \ (expr',fvExpr) ->
357 returnRn (HsLet binds' expr', fvExpr)
359 rnExpr (HsDo do_or_lc stmts src_loc)
360 = pushSrcLocRn src_loc $
361 lookupImplicitOccRn monadClass_RDR `thenRn` \ monad ->
362 rnStmts rnExpr stmts `thenRn` \ (stmts', fvs) ->
363 returnRn (HsDo do_or_lc stmts' src_loc, fvs `addOneFV` monad)
365 rnExpr (ExplicitList exps)
366 = rnExprs exps `thenRn` \ (exps', fvs) ->
367 returnRn (ExplicitList exps', fvs `addOneFV` listTyCon_name)
369 rnExpr (ExplicitTuple exps boxed)
370 = rnExprs exps `thenRn` \ (exps', fvs) ->
371 returnRn (ExplicitTuple exps' boxed, fvs `addOneFV` tycon_name)
373 tycon_name = tupleTyCon_name boxed (length exps)
375 rnExpr (RecordCon con_id rbinds)
376 = lookupOccRn con_id `thenRn` \ conname ->
377 rnRbinds "construction" rbinds `thenRn` \ (rbinds', fvRbinds) ->
378 returnRn (RecordCon conname rbinds', fvRbinds `addOneFV` conname)
380 rnExpr (RecordUpd expr rbinds)
381 = rnExpr expr `thenRn` \ (expr', fvExpr) ->
382 rnRbinds "update" rbinds `thenRn` \ (rbinds', fvRbinds) ->
383 returnRn (RecordUpd expr' rbinds', fvExpr `plusFV` fvRbinds)
385 rnExpr (ExprWithTySig expr pty)
386 = rnExpr expr `thenRn` \ (expr', fvExpr) ->
387 rnHsSigType (text "an expression") pty `thenRn` \ (pty', fvTy) ->
388 returnRn (ExprWithTySig expr' pty', fvExpr `plusFV` fvTy)
390 rnExpr (HsIf p b1 b2 src_loc)
391 = pushSrcLocRn src_loc $
392 rnExpr p `thenRn` \ (p', fvP) ->
393 rnExpr b1 `thenRn` \ (b1', fvB1) ->
394 rnExpr b2 `thenRn` \ (b2', fvB2) ->
395 returnRn (HsIf p' b1' b2' src_loc, plusFVs [fvP, fvB1, fvB2])
397 rnExpr (ArithSeqIn seq)
398 = lookupImplicitOccRn enumClass_RDR `thenRn` \ enum ->
399 rn_seq seq `thenRn` \ (new_seq, fvs) ->
400 returnRn (ArithSeqIn new_seq, fvs `addOneFV` enum)
403 = rnExpr expr `thenRn` \ (expr', fvExpr) ->
404 returnRn (From expr', fvExpr)
406 rn_seq (FromThen expr1 expr2)
407 = rnExpr expr1 `thenRn` \ (expr1', fvExpr1) ->
408 rnExpr expr2 `thenRn` \ (expr2', fvExpr2) ->
409 returnRn (FromThen expr1' expr2', fvExpr1 `plusFV` fvExpr2)
411 rn_seq (FromTo expr1 expr2)
412 = rnExpr expr1 `thenRn` \ (expr1', fvExpr1) ->
413 rnExpr expr2 `thenRn` \ (expr2', fvExpr2) ->
414 returnRn (FromTo expr1' expr2', fvExpr1 `plusFV` fvExpr2)
416 rn_seq (FromThenTo expr1 expr2 expr3)
417 = rnExpr expr1 `thenRn` \ (expr1', fvExpr1) ->
418 rnExpr expr2 `thenRn` \ (expr2', fvExpr2) ->
419 rnExpr expr3 `thenRn` \ (expr3', fvExpr3) ->
420 returnRn (FromThenTo expr1' expr2' expr3',
421 plusFVs [fvExpr1, fvExpr2, fvExpr3])
424 %************************************************************************
426 \subsubsection{@Rbinds@s and @Rpats@s: in record expressions}
428 %************************************************************************
432 = mapRn_ field_dup_err dup_fields `thenRn_`
433 mapFvRn rn_rbind rbinds `thenRn` \ (rbinds', fvRbind) ->
434 returnRn (rbinds', fvRbind)
436 (_, dup_fields) = removeDups compare [ f | (f,_,_) <- rbinds ]
438 field_dup_err dups = addErrRn (dupFieldErr str dups)
440 rn_rbind (field, expr, pun)
441 = lookupGlobalOccRn field `thenRn` \ fieldname ->
442 rnExpr expr `thenRn` \ (expr', fvExpr) ->
443 returnRn ((fieldname, expr', pun), fvExpr `addOneFV` fieldname)
446 = mapRn_ field_dup_err dup_fields `thenRn_`
447 mapFvRn rn_rpat rpats `thenRn` \ (rpats', fvs) ->
448 returnRn (rpats', fvs)
450 (_, dup_fields) = removeDups compare [ f | (f,_,_) <- rpats ]
452 field_dup_err dups = addErrRn (dupFieldErr "pattern" dups)
454 rn_rpat (field, pat, pun)
455 = lookupGlobalOccRn field `thenRn` \ fieldname ->
456 rnPat pat `thenRn` \ (pat', fvs) ->
457 returnRn ((fieldname, pat', pun), fvs `addOneFV` fieldname)
460 %************************************************************************
462 \subsubsection{@Stmt@s: in @do@ expressions}
464 %************************************************************************
466 Note that although some bound vars may appear in the free var set for
467 the first qual, these will eventually be removed by the caller. For
468 example, if we have @[p | r <- s, q <- r, p <- q]@, when doing
469 @[q <- r, p <- q]@, the free var set for @q <- r@ will
470 be @{r}@, and the free var set for the entire Quals will be @{r}@. This
471 @r@ will be removed only when we finally return from examining all the
475 type RnExprTy = RdrNameHsExpr -> RnMS (RenamedHsExpr, FreeVars)
479 -> RnMS ([RenamedStmt], FreeVars)
482 = returnRn ([], emptyFVs)
484 rnStmts rn_expr (stmt:stmts)
485 = rnStmt rn_expr stmt $ \ stmt' ->
486 rnStmts rn_expr stmts `thenRn` \ (stmts', fvs) ->
487 returnRn (stmt' : stmts', fvs)
489 rnStmt :: RnExprTy -> RdrNameStmt
490 -> (RenamedStmt -> RnMS (a, FreeVars))
491 -> RnMS (a, FreeVars)
492 -- Because of mutual recursion we have to pass in rnExpr.
494 rnStmt rn_expr (BindStmt pat expr src_loc) thing_inside
495 = pushSrcLocRn src_loc $
496 rn_expr expr `thenRn` \ (expr', fv_expr) ->
497 bindLocalsFVRn doc binders $ \ new_binders ->
498 rnPat pat `thenRn` \ (pat', fv_pat) ->
499 thing_inside (BindStmt pat' expr' src_loc) `thenRn` \ (result, fvs) ->
500 returnRn (result, fv_expr `plusFV` fvs `plusFV` fv_pat)
502 binders = collectPatBinders pat
503 doc = text "a pattern in do binding"
505 rnStmt rn_expr (ExprStmt expr src_loc) thing_inside
506 = pushSrcLocRn src_loc $
507 rn_expr expr `thenRn` \ (expr', fv_expr) ->
508 thing_inside (ExprStmt expr' src_loc) `thenRn` \ (result, fvs) ->
509 returnRn (result, fv_expr `plusFV` fvs)
511 rnStmt rn_expr (GuardStmt expr src_loc) thing_inside
512 = pushSrcLocRn src_loc $
513 rn_expr expr `thenRn` \ (expr', fv_expr) ->
514 thing_inside (GuardStmt expr' src_loc) `thenRn` \ (result, fvs) ->
515 returnRn (result, fv_expr `plusFV` fvs)
517 rnStmt rn_expr (ReturnStmt expr) thing_inside
518 = rn_expr expr `thenRn` \ (expr', fv_expr) ->
519 thing_inside (ReturnStmt expr') `thenRn` \ (result, fvs) ->
520 returnRn (result, fv_expr `plusFV` fvs)
522 rnStmt rn_expr (LetStmt binds) thing_inside
523 = rnBinds binds $ \ binds' ->
524 thing_inside (LetStmt binds')
527 %************************************************************************
529 \subsubsection{Precedence Parsing}
531 %************************************************************************
533 @mkOpAppRn@ deals with operator fixities. The argument expressions
534 are assumed to be already correctly arranged. It needs the fixities
535 recorded in the OpApp nodes, because fixity info applies to the things
536 the programmer actually wrote, so you can't find it out from the Name.
538 Furthermore, the second argument is guaranteed not to be another
539 operator application. Why? Because the parser parses all
540 operator appications left-associatively.
543 mkOpAppRn :: RenamedHsExpr -> RenamedHsExpr -> Fixity -> RenamedHsExpr
544 -> RnMS RenamedHsExpr
546 mkOpAppRn e1@(OpApp e11 op1 fix1 e12)
549 = addErrRn (precParseErr (get op1,fix1) (get op2,fix2)) `thenRn_`
550 returnRn (OpApp e1 op2 fix2 e2)
553 = mkOpAppRn e12 op2 fix2 e2 `thenRn` \ new_e ->
554 returnRn (OpApp e11 op1 fix1 new_e)
556 (nofix_error, rearrange_me) = compareFixity fix1 fix2
558 mkOpAppRn e1@(NegApp neg_arg neg_op)
560 fix2@(Fixity prec2 dir2)
563 = addErrRn (precParseErr (get neg_op,fix_neg) (get op2,fix2)) `thenRn_`
564 returnRn (OpApp e1 op2 fix2 e2)
567 = mkOpAppRn neg_arg op2 fix2 e2 `thenRn` \ new_e ->
568 returnRn (NegApp new_e neg_op)
570 fix_neg = Fixity 6 InfixL -- Precedence of unary negate is wired in as infixl 6!
571 (nofix_error, rearrange_me) = compareFixity fix_neg fix2
573 mkOpAppRn e1 op fix e2 -- Default case, no rearrangment
574 = ASSERT( if right_op_ok fix e2 then True
575 else pprPanic "mkOpAppRn" (vcat [ppr e1, text "---", ppr op,
576 text "---", ppr fix, text "---", ppr e2])
578 returnRn (OpApp e1 op fix e2)
582 -- Parser left-associates everything, but
583 -- derived instances may have correctly-associated things to
584 -- in the right operarand. So we just check that the right operand is OK
585 right_op_ok fix1 (OpApp _ _ fix2 _)
586 = not error_please && associate_right
588 (error_please, associate_right) = compareFixity fix1 fix2
589 right_op_ok fix1 other
592 -- Parser initially makes negation bind more tightly than any other operator
593 mkNegAppRn neg_arg neg_op
596 getModeRn `thenRn` \ mode ->
597 ASSERT( not_op_app mode neg_arg )
599 returnRn (NegApp neg_arg neg_op)
601 not_op_app SourceMode (OpApp _ _ _ _) = False
602 not_op_app mode other = True
606 mkConOpPatRn :: RenamedPat -> Name -> Fixity -> RenamedPat
609 mkConOpPatRn p1@(ConOpPatIn p11 op1 fix1 p12)
612 = addErrRn (precParseErr (op1,fix1) (op2,fix2)) `thenRn_`
613 returnRn (ConOpPatIn p1 op2 fix2 p2)
616 = mkConOpPatRn p12 op2 fix2 p2 `thenRn` \ new_p ->
617 returnRn (ConOpPatIn p11 op1 fix1 new_p)
620 (nofix_error, rearrange_me) = compareFixity fix1 fix2
622 mkConOpPatRn p1@(NegPatIn neg_arg)
624 fix2@(Fixity prec2 dir2)
626 | prec2 > 6 -- Precedence of unary - is wired in as 6!
627 = addErrRn (precParseNegPatErr (op2,fix2)) `thenRn_`
628 returnRn (ConOpPatIn p1 op2 fix2 p2)
630 mkConOpPatRn p1 op fix p2 -- Default case, no rearrangment
631 = ASSERT( not_op_pat p2 )
632 returnRn (ConOpPatIn p1 op fix p2)
634 not_op_pat (ConOpPatIn _ _ _ _) = False
635 not_op_pat other = True
639 checkPrecMatch :: Bool -> Name -> RenamedMatch -> RnMS ()
641 checkPrecMatch False fn match
644 checkPrecMatch True op (Match _ [p1,p2] _ _)
645 = getModeRn `thenRn` \ mode ->
646 -- See comments with rnExpr (OpApp ...)
648 InterfaceMode -> returnRn ()
649 SourceMode -> checkPrec op p1 False `thenRn_`
652 checkPrecMatch True op _ = panic "checkPrecMatch"
654 checkPrec op (ConOpPatIn _ op1 _ _) right
655 = lookupFixity op `thenRn` \ op_fix@(Fixity op_prec op_dir) ->
656 lookupFixity op1 `thenRn` \ op1_fix@(Fixity op1_prec op1_dir) ->
658 inf_ok = op1_prec > op_prec ||
659 (op1_prec == op_prec &&
660 (op1_dir == InfixR && op_dir == InfixR && right ||
661 op1_dir == InfixL && op_dir == InfixL && not right))
664 info1 = (op1,op1_fix)
665 (infol, infor) = if right then (info, info1) else (info1, info)
667 checkRn inf_ok (precParseErr infol infor)
669 checkPrec op (NegPatIn _) right
670 = lookupFixity op `thenRn` \ op_fix@(Fixity op_prec op_dir) ->
671 checkRn (op_prec <= 6) (precParseNegPatErr (op,op_fix))
673 checkPrec op pat right
680 (compareFixity op1 op2) tells which way to arrange appication, or
681 whether there's an error.
684 compareFixity :: Fixity -> Fixity
685 -> (Bool, -- Error please
686 Bool) -- Associate to the right: a op1 (b op2 c)
687 compareFixity (Fixity prec1 dir1) (Fixity prec2 dir2)
688 = case prec1 `compare` prec2 of
691 EQ -> case (dir1, dir2) of
692 (InfixR, InfixR) -> right
693 (InfixL, InfixL) -> left
696 right = (False, True)
697 left = (False, False)
698 error_please = (True, False)
701 %************************************************************************
703 \subsubsection{Literals}
705 %************************************************************************
707 When literals occur we have to make sure that the types and classes they involve
711 litOccurrence (HsChar _)
712 = returnRn (unitFV charTyCon_name)
714 litOccurrence (HsCharPrim _)
715 = returnRn (unitFV (getName charPrimTyCon))
717 litOccurrence (HsString _)
718 = returnRn (unitFV listTyCon_name `plusFV` unitFV charTyCon_name)
720 litOccurrence (HsStringPrim _)
721 = returnRn (unitFV (getName addrPrimTyCon))
723 litOccurrence (HsInt _)
724 = lookupImplicitOccRn numClass_RDR `thenRn` \ num ->
725 returnRn (unitFV num) -- Int and Integer are forced in by Num
727 litOccurrence (HsFrac _)
728 = lookupImplicitOccRn fractionalClass_RDR `thenRn` \ frac ->
729 lookupImplicitOccRn ratioDataCon_RDR `thenRn` \ ratio ->
730 returnRn (unitFV frac `plusFV` unitFV ratio)
731 -- We have to make sure that the Ratio type is imported with
732 -- its constructor, because literals of type Ratio t are
733 -- built with that constructor.
734 -- The Rational type is needed too, but that will come in
735 -- when fractionalClass does.
737 litOccurrence (HsIntPrim _)
738 = returnRn (unitFV (getName intPrimTyCon))
740 litOccurrence (HsFloatPrim _)
741 = returnRn (unitFV (getName floatPrimTyCon))
743 litOccurrence (HsDoublePrim _)
744 = returnRn (unitFV (getName doublePrimTyCon))
746 litOccurrence (HsLitLit _)
747 = lookupImplicitOccRn ccallableClass_RDR `thenRn` \ cc ->
751 %************************************************************************
753 \subsubsection{Assertion utils}
755 %************************************************************************
758 mkAssertExpr :: RnMS (RenamedHsExpr, FreeVars)
760 mkImportedGlobalFromRdrName assertErr_RDR `thenRn` \ name ->
761 getSrcLocRn `thenRn` \ sloc ->
763 -- if we're ignoring asserts, return (\ _ e -> e)
764 -- if not, return (assertError "src-loc")
766 if opt_IgnoreAsserts then
767 getUniqRn `thenRn` \ uniq ->
769 vname = mkSysLocalName uniq SLIT("v")
770 expr = HsLam ignorePredMatch
771 loc = nameSrcLoc vname
772 ignorePredMatch = Match [] [WildPatIn, VarPatIn vname] Nothing
773 (GRHSs [GRHS [ExprStmt (HsVar vname) loc] loc]
776 returnRn (expr, unitFV name)
781 (HsLit (HsString (_PK_ (showSDoc (ppr sloc)))))
784 returnRn (expr, unitFV name)
788 %************************************************************************
790 \subsubsection{Errors}
792 %************************************************************************
795 dupFieldErr str (dup:rest)
796 = hsep [ptext SLIT("duplicate field name"),
798 ptext SLIT("in record"), text str]
801 = sep [ptext SLIT("prefix `-' not applied to literal in pattern"), quotes (ppr pat)]
803 precParseNegPatErr op
804 = hang (ptext SLIT("precedence parsing error"))
805 4 (hsep [ptext SLIT("prefix `-' has lower precedence than"),
807 ptext SLIT("in pattern")])
810 = hang (ptext SLIT("precedence parsing error"))
811 4 (hsep [ptext SLIT("cannot mix"), quotes (pp_op op1), ptext SLIT("and"),
813 ptext SLIT("in the same infix expression")])
816 = hang (ptext SLIT("accepting non-standard pattern guards (-fglasgow-exts to suppress this message)"))
820 = hang (ptext SLIT("Illegal signature in pattern:") <+> ppr ty)
821 4 (ptext SLIT("Use -fglasgow-exts to permit it"))
823 pp_op (op, fix) = hcat [ppr op, space, parens (ppr fix)]