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, rnHsPolyType, rnHsType )
28 import RnIfaces ( lookupFixity )
29 import CmdLineOpts ( opt_GlasgowExts, opt_IgnoreAsserts )
30 import BasicTypes ( Fixity(..), FixityDirection(..), defaultFixity, negateFixity, negatePrecedence )
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 rnHsPolyType 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 (HsIntPrim _)) = True
127 valid_neg_pat (LitPatIn (HsFrac _)) = True
128 valid_neg_pat (LitPatIn (HsFloatPrim _)) = True
129 valid_neg_pat (LitPatIn (HsDoublePrim _)) = True
130 valid_neg_pat _ = False
133 = rnPat pat `thenRn` \ (pat', fvs) ->
134 returnRn (ParPatIn pat', fvs)
136 rnPat (NPlusKPatIn name lit)
137 = litOccurrence lit `thenRn` \ fvs ->
138 lookupImplicitOccRn ordClass_RDR `thenRn` \ ord ->
139 lookupBndrRn name `thenRn` \ name' ->
140 returnRn (NPlusKPatIn name' lit, fvs `addOneFV` ord)
142 rnPat (ListPatIn pats)
143 = mapFvRn rnPat pats `thenRn` \ (patslist, fvs) ->
144 returnRn (ListPatIn patslist, fvs `addOneFV` listTyCon_name)
146 rnPat (TuplePatIn pats boxed)
147 = mapFvRn rnPat pats `thenRn` \ (patslist, fvs) ->
148 returnRn (TuplePatIn patslist boxed, fvs `addOneFV` tycon_name)
150 tycon_name = tupleTyCon_name boxed (length pats)
152 rnPat (RecPatIn con rpats)
153 = lookupOccRn con `thenRn` \ con' ->
154 rnRpats rpats `thenRn` \ (rpats', fvs) ->
155 returnRn (RecPatIn con' rpats', fvs `addOneFV` con')
158 ************************************************************************
162 ************************************************************************
165 rnMatch :: RdrNameMatch -> RnMS (RenamedMatch, FreeVars)
167 rnMatch match@(Match _ pats maybe_rhs_sig grhss)
168 = pushSrcLocRn (getMatchLoc match) $
170 -- Find the universally quantified type variables
171 -- in the pattern type signatures
172 getLocalNameEnv `thenRn` \ name_env ->
174 tyvars_in_sigs = rhs_sig_tyvars `unionLists` tyvars_in_pats
175 rhs_sig_tyvars = case maybe_rhs_sig of
177 Just ty -> extractHsTyRdrNames ty
178 tyvars_in_pats = extractPatsTyVars pats
179 forall_tyvars = filter (not . (`elemFM` name_env)) tyvars_in_sigs
180 doc = text "a pattern type-signature"
182 bindTyVarsFVRn doc (map UserTyVar forall_tyvars) $ \ sig_tyvars ->
184 -- Note that we do a single bindLocalsRn for all the
185 -- matches together, so that we spot the repeated variable in
187 bindLocalsFVRn doc (collectPatsBinders pats) $ \ new_binders ->
189 mapFvRn rnPat pats `thenRn` \ (pats', pat_fvs) ->
190 rnGRHSs grhss `thenRn` \ (grhss', grhss_fvs) ->
191 (case maybe_rhs_sig of
192 Nothing -> returnRn (Nothing, emptyFVs)
193 Just ty | opt_GlasgowExts -> rnHsType doc ty `thenRn` \ (ty', ty_fvs) ->
194 returnRn (Just ty', ty_fvs)
195 | otherwise -> addErrRn (patSigErr ty) `thenRn_`
196 returnRn (Nothing, emptyFVs)
197 ) `thenRn` \ (maybe_rhs_sig', ty_fvs) ->
200 binder_set = mkNameSet new_binders
201 unused_binders = nameSetToList (binder_set `minusNameSet` grhss_fvs)
202 all_fvs = grhss_fvs `plusFV` pat_fvs `plusFV` ty_fvs
204 warnUnusedMatches unused_binders `thenRn_`
206 returnRn (Match sig_tyvars pats' maybe_rhs_sig' grhss', all_fvs)
207 -- The bindLocals and bindTyVars will remove the bound FVs
210 %************************************************************************
212 \subsubsection{Guarded right-hand sides (GRHSs)}
214 %************************************************************************
217 rnGRHSs :: RdrNameGRHSs -> RnMS (RenamedGRHSs, FreeVars)
219 rnGRHSs (GRHSs grhss binds maybe_ty)
220 = ASSERT( not (maybeToBool maybe_ty) )
221 rnBinds binds $ \ binds' ->
222 mapFvRn rnGRHS grhss `thenRn` \ (grhss', fvGRHSs) ->
223 returnRn (GRHSs grhss' binds' Nothing, fvGRHSs)
225 rnGRHS (GRHS guarded locn)
226 = pushSrcLocRn locn $
227 (if not (opt_GlasgowExts || is_standard_guard guarded) then
228 addWarnRn (nonStdGuardErr guarded)
233 rnStmts rnExpr guarded `thenRn` \ (guarded', fvs) ->
234 returnRn (GRHS guarded' locn, fvs)
236 -- Standard Haskell 1.4 guards are just a single boolean
237 -- expression, rather than a list of qualifiers as in the
239 is_standard_guard [ExprStmt _ _] = True
240 is_standard_guard [GuardStmt _ _, ExprStmt _ _] = True
241 is_standard_guard other = False
244 %************************************************************************
246 \subsubsection{Expressions}
248 %************************************************************************
251 rnExprs :: [RdrNameHsExpr] -> RnMS ([RenamedHsExpr], FreeVars)
252 rnExprs ls = rnExprs' ls emptyUniqSet
254 rnExprs' [] acc = returnRn ([], acc)
255 rnExprs' (expr:exprs) acc
256 = rnExpr expr `thenRn` \ (expr', fvExpr) ->
258 -- Now we do a "seq" on the free vars because typically it's small
259 -- or empty, especially in very long lists of constants
261 acc' = acc `plusFV` fvExpr
263 (grubby_seqNameSet acc' rnExprs') exprs acc' `thenRn` \ (exprs', fvExprs) ->
264 returnRn (expr':exprs', fvExprs)
266 -- Grubby little function to do "seq" on namesets; replace by proper seq when GHC can do seq
267 grubby_seqNameSet ns result | isNullUFM ns = result
271 Variables. We look up the variable and return the resulting name.
274 rnExpr :: RdrNameHsExpr -> RnMS (RenamedHsExpr, FreeVars)
277 = lookupOccRn v `thenRn` \ name ->
278 if nameUnique name == assertIdKey then
279 -- We expand it to (GHCerr.assert__ location)
283 returnRn (HsVar name, unitFV name)
286 = getIPName v `thenRn` \ name ->
287 returnRn (HsIPVar name, emptyFVs)
290 = litOccurrence lit `thenRn` \ fvs ->
291 returnRn (HsLit lit, fvs)
294 = rnMatch match `thenRn` \ (match', fvMatch) ->
295 returnRn (HsLam match', fvMatch)
297 rnExpr (HsApp fun arg)
298 = rnExpr fun `thenRn` \ (fun',fvFun) ->
299 rnExpr arg `thenRn` \ (arg',fvArg) ->
300 returnRn (HsApp fun' arg', fvFun `plusFV` fvArg)
302 rnExpr (OpApp e1 op _ e2)
303 = rnExpr e1 `thenRn` \ (e1', fv_e1) ->
304 rnExpr e2 `thenRn` \ (e2', fv_e2) ->
305 rnExpr op `thenRn` \ (op'@(HsVar op_name), fv_op) ->
308 -- When renaming code synthesised from "deriving" declarations
309 -- we're in Interface mode, and we should ignore fixity; assume
310 -- that the deriving code generator got the association correct
311 -- Don't even look up the fixity when in interface mode
312 getModeRn `thenRn` \ mode ->
314 SourceMode -> lookupFixity op_name `thenRn` \ fixity ->
315 mkOpAppRn e1' op' fixity e2'
316 InterfaceMode -> returnRn (OpApp e1' op' defaultFixity e2')
317 ) `thenRn` \ final_e ->
320 fv_e1 `plusFV` fv_op `plusFV` fv_e2)
322 -- constant-fold some negate applications on unboxed literals. Since
323 -- negate is a polymorphic function, we have to do these here.
324 rnExpr (NegApp (HsLit (HsIntPrim i)) _) = rnExpr (HsLit (HsIntPrim (-i)))
325 rnExpr (NegApp (HsLit (HsFloatPrim i)) _) = rnExpr (HsLit (HsFloatPrim (-i)))
326 rnExpr (NegApp (HsLit (HsDoublePrim i)) _) = rnExpr (HsLit (HsDoublePrim (-i)))
329 = rnExpr e `thenRn` \ (e', fv_e) ->
330 lookupImplicitOccRn negate_RDR `thenRn` \ neg ->
331 mkNegAppRn e' (HsVar neg) `thenRn` \ final_e ->
332 returnRn (final_e, fv_e `addOneFV` neg)
335 = rnExpr e `thenRn` \ (e', fvs_e) ->
336 returnRn (HsPar e', fvs_e)
338 rnExpr section@(SectionL expr op)
339 = rnExpr expr `thenRn` \ (expr', fvs_expr) ->
340 rnExpr op `thenRn` \ (op', fvs_op) ->
341 checkSectionPrec "left" section op' expr' `thenRn_`
342 returnRn (SectionL expr' op', fvs_op `plusFV` fvs_expr)
344 rnExpr section@(SectionR op expr)
345 = rnExpr op `thenRn` \ (op', fvs_op) ->
346 rnExpr expr `thenRn` \ (expr', fvs_expr) ->
347 checkSectionPrec "right" section op' expr' `thenRn_`
348 returnRn (SectionR op' expr', fvs_op `plusFV` fvs_expr)
350 rnExpr (CCall fun args may_gc is_casm fake_result_ty)
351 -- Check out the comment on RnIfaces.getNonWiredDataDecl about ccalls
352 = lookupImplicitOccRn ccallableClass_RDR `thenRn` \ cc ->
353 lookupImplicitOccRn creturnableClass_RDR `thenRn` \ cr ->
354 lookupImplicitOccRn ioDataCon_RDR `thenRn` \ io ->
355 rnExprs args `thenRn` \ (args', fvs_args) ->
356 returnRn (CCall fun args' may_gc is_casm fake_result_ty,
357 fvs_args `addOneFV` cc `addOneFV` cr `addOneFV` io)
359 rnExpr (HsSCC lbl expr)
360 = rnExpr expr `thenRn` \ (expr', fvs_expr) ->
361 returnRn (HsSCC lbl expr', fvs_expr)
363 rnExpr (HsCase expr ms src_loc)
364 = pushSrcLocRn src_loc $
365 rnExpr expr `thenRn` \ (new_expr, e_fvs) ->
366 mapFvRn rnMatch ms `thenRn` \ (new_ms, ms_fvs) ->
367 returnRn (HsCase new_expr new_ms src_loc, e_fvs `plusFV` ms_fvs)
369 rnExpr (HsLet binds expr)
370 = rnBinds binds $ \ binds' ->
371 rnExpr expr `thenRn` \ (expr',fvExpr) ->
372 returnRn (HsLet binds' expr', fvExpr)
374 rnExpr (HsWith expr binds)
375 = rnExpr expr `thenRn` \ (expr',fvExpr) ->
376 rnIPBinds binds `thenRn` \ (binds',fvBinds) ->
377 returnRn (HsWith expr' binds', fvExpr `plusFV` fvBinds)
379 rnExpr e@(HsDo do_or_lc stmts src_loc)
380 = pushSrcLocRn src_loc $
381 lookupImplicitOccRn monadClass_RDR `thenRn` \ monad ->
382 rnStmts rnExpr stmts `thenRn` \ (stmts', fvs) ->
383 -- check the statement list ends in an expression
384 case last stmts' of {
385 ExprStmt _ _ -> returnRn () ;
386 ReturnStmt _ -> returnRn () ; -- for list comprehensions
387 _ -> addErrRn (doStmtListErr e)
389 returnRn (HsDo do_or_lc stmts' src_loc, fvs `addOneFV` monad)
391 rnExpr (ExplicitList exps)
392 = rnExprs exps `thenRn` \ (exps', fvs) ->
393 returnRn (ExplicitList exps', fvs `addOneFV` listTyCon_name)
395 rnExpr (ExplicitTuple exps boxed)
396 = rnExprs exps `thenRn` \ (exps', fvs) ->
397 returnRn (ExplicitTuple exps' boxed, fvs `addOneFV` tycon_name)
399 tycon_name = tupleTyCon_name boxed (length exps)
401 rnExpr (RecordCon con_id rbinds)
402 = lookupOccRn con_id `thenRn` \ conname ->
403 rnRbinds "construction" rbinds `thenRn` \ (rbinds', fvRbinds) ->
404 returnRn (RecordCon conname rbinds', fvRbinds `addOneFV` conname)
406 rnExpr (RecordUpd expr rbinds)
407 = rnExpr expr `thenRn` \ (expr', fvExpr) ->
408 rnRbinds "update" rbinds `thenRn` \ (rbinds', fvRbinds) ->
409 returnRn (RecordUpd expr' rbinds', fvExpr `plusFV` fvRbinds)
411 rnExpr (ExprWithTySig expr pty)
412 = rnExpr expr `thenRn` \ (expr', fvExpr) ->
413 rnHsSigType (text "an expression") pty `thenRn` \ (pty', fvTy) ->
414 returnRn (ExprWithTySig expr' pty', fvExpr `plusFV` fvTy)
416 rnExpr (HsIf p b1 b2 src_loc)
417 = pushSrcLocRn src_loc $
418 rnExpr p `thenRn` \ (p', fvP) ->
419 rnExpr b1 `thenRn` \ (b1', fvB1) ->
420 rnExpr b2 `thenRn` \ (b2', fvB2) ->
421 returnRn (HsIf p' b1' b2' src_loc, plusFVs [fvP, fvB1, fvB2])
423 rnExpr (ArithSeqIn seq)
424 = lookupImplicitOccRn enumClass_RDR `thenRn` \ enum ->
425 rn_seq seq `thenRn` \ (new_seq, fvs) ->
426 returnRn (ArithSeqIn new_seq, fvs `addOneFV` enum)
429 = rnExpr expr `thenRn` \ (expr', fvExpr) ->
430 returnRn (From expr', fvExpr)
432 rn_seq (FromThen expr1 expr2)
433 = rnExpr expr1 `thenRn` \ (expr1', fvExpr1) ->
434 rnExpr expr2 `thenRn` \ (expr2', fvExpr2) ->
435 returnRn (FromThen expr1' expr2', fvExpr1 `plusFV` fvExpr2)
437 rn_seq (FromTo expr1 expr2)
438 = rnExpr expr1 `thenRn` \ (expr1', fvExpr1) ->
439 rnExpr expr2 `thenRn` \ (expr2', fvExpr2) ->
440 returnRn (FromTo expr1' expr2', fvExpr1 `plusFV` fvExpr2)
442 rn_seq (FromThenTo expr1 expr2 expr3)
443 = rnExpr expr1 `thenRn` \ (expr1', fvExpr1) ->
444 rnExpr expr2 `thenRn` \ (expr2', fvExpr2) ->
445 rnExpr expr3 `thenRn` \ (expr3', fvExpr3) ->
446 returnRn (FromThenTo expr1' expr2' expr3',
447 plusFVs [fvExpr1, fvExpr2, fvExpr3])
450 These three are pattern syntax appearing in expressions.
451 Since all the symbols are reservedops we can simply reject them.
452 We return a (bogus) EWildPat in each case.
455 rnExpr e@EWildPat = addErrRn (patSynErr e) `thenRn_`
456 returnRn (EWildPat, emptyFVs)
458 rnExpr e@(EAsPat _ _) = addErrRn (patSynErr e) `thenRn_`
459 returnRn (EWildPat, emptyFVs)
461 rnExpr e@(ELazyPat _) = addErrRn (patSynErr e) `thenRn_`
462 returnRn (EWildPat, emptyFVs)
465 %************************************************************************
467 \subsubsection{@Rbinds@s and @Rpats@s: in record expressions}
469 %************************************************************************
473 = mapRn_ field_dup_err dup_fields `thenRn_`
474 mapFvRn rn_rbind rbinds `thenRn` \ (rbinds', fvRbind) ->
475 returnRn (rbinds', fvRbind)
477 (_, dup_fields) = removeDups compare [ f | (f,_,_) <- rbinds ]
479 field_dup_err dups = addErrRn (dupFieldErr str dups)
481 rn_rbind (field, expr, pun)
482 = lookupGlobalOccRn field `thenRn` \ fieldname ->
483 rnExpr expr `thenRn` \ (expr', fvExpr) ->
484 returnRn ((fieldname, expr', pun), fvExpr `addOneFV` fieldname)
487 = mapRn_ field_dup_err dup_fields `thenRn_`
488 mapFvRn rn_rpat rpats `thenRn` \ (rpats', fvs) ->
489 returnRn (rpats', fvs)
491 (_, dup_fields) = removeDups compare [ f | (f,_,_) <- rpats ]
493 field_dup_err dups = addErrRn (dupFieldErr "pattern" dups)
495 rn_rpat (field, pat, pun)
496 = lookupGlobalOccRn field `thenRn` \ fieldname ->
497 rnPat pat `thenRn` \ (pat', fvs) ->
498 returnRn ((fieldname, pat', pun), fvs `addOneFV` fieldname)
501 %************************************************************************
503 \subsubsection{@rnIPBinds@s: in implicit parameter bindings} *
505 %************************************************************************
508 rnIPBinds [] = returnRn ([], emptyFVs)
509 rnIPBinds ((n, expr) : binds)
510 = getIPName n `thenRn` \ name ->
511 rnExpr expr `thenRn` \ (expr',fvExpr) ->
512 rnIPBinds binds `thenRn` \ (binds',fvBinds) ->
513 returnRn ((name, expr') : binds', fvExpr `plusFV` fvBinds)
517 %************************************************************************
519 \subsubsection{@Stmt@s: in @do@ expressions}
521 %************************************************************************
523 Note that although some bound vars may appear in the free var set for
524 the first qual, these will eventually be removed by the caller. For
525 example, if we have @[p | r <- s, q <- r, p <- q]@, when doing
526 @[q <- r, p <- q]@, the free var set for @q <- r@ will
527 be @{r}@, and the free var set for the entire Quals will be @{r}@. This
528 @r@ will be removed only when we finally return from examining all the
532 type RnExprTy = RdrNameHsExpr -> RnMS (RenamedHsExpr, FreeVars)
536 -> RnMS ([RenamedStmt], FreeVars)
539 = returnRn ([], emptyFVs)
541 rnStmts rn_expr (stmt:stmts)
542 = rnStmt rn_expr stmt $ \ stmt' ->
543 rnStmts rn_expr stmts `thenRn` \ (stmts', fvs) ->
544 returnRn (stmt' : stmts', fvs)
546 rnStmt :: RnExprTy -> RdrNameStmt
547 -> (RenamedStmt -> RnMS (a, FreeVars))
548 -> RnMS (a, FreeVars)
549 -- Because of mutual recursion we have to pass in rnExpr.
551 rnStmt rn_expr (BindStmt pat expr src_loc) thing_inside
552 = pushSrcLocRn src_loc $
553 rn_expr expr `thenRn` \ (expr', fv_expr) ->
554 bindLocalsFVRn doc binders $ \ new_binders ->
555 rnPat pat `thenRn` \ (pat', fv_pat) ->
556 thing_inside (BindStmt pat' expr' src_loc) `thenRn` \ (result, fvs) ->
557 returnRn (result, fv_expr `plusFV` fvs `plusFV` fv_pat)
559 binders = collectPatBinders pat
560 doc = text "a pattern in do binding"
562 rnStmt rn_expr (ExprStmt expr src_loc) thing_inside
563 = pushSrcLocRn src_loc $
564 rn_expr expr `thenRn` \ (expr', fv_expr) ->
565 thing_inside (ExprStmt expr' src_loc) `thenRn` \ (result, fvs) ->
566 returnRn (result, fv_expr `plusFV` fvs)
568 rnStmt rn_expr (GuardStmt expr src_loc) thing_inside
569 = pushSrcLocRn src_loc $
570 rn_expr expr `thenRn` \ (expr', fv_expr) ->
571 thing_inside (GuardStmt expr' src_loc) `thenRn` \ (result, fvs) ->
572 returnRn (result, fv_expr `plusFV` fvs)
574 rnStmt rn_expr (ReturnStmt expr) thing_inside
575 = rn_expr expr `thenRn` \ (expr', fv_expr) ->
576 thing_inside (ReturnStmt expr') `thenRn` \ (result, fvs) ->
577 returnRn (result, fv_expr `plusFV` fvs)
579 rnStmt rn_expr (LetStmt binds) thing_inside
580 = rnBinds binds $ \ binds' ->
581 thing_inside (LetStmt binds')
584 %************************************************************************
586 \subsubsection{Precedence Parsing}
588 %************************************************************************
590 @mkOpAppRn@ deals with operator fixities. The argument expressions
591 are assumed to be already correctly arranged. It needs the fixities
592 recorded in the OpApp nodes, because fixity info applies to the things
593 the programmer actually wrote, so you can't find it out from the Name.
595 Furthermore, the second argument is guaranteed not to be another
596 operator application. Why? Because the parser parses all
597 operator appications left-associatively, EXCEPT negation, which
598 we need to handle specially.
601 mkOpAppRn :: RenamedHsExpr -- Left operand; already rearranged
602 -> RenamedHsExpr -> Fixity -- Operator and fixity
603 -> RenamedHsExpr -- Right operand (not an OpApp, but might
605 -> RnMS RenamedHsExpr
607 ---------------------------
608 -- (e11 `op1` e12) `op2` e2
609 mkOpAppRn e1@(OpApp e11 op1 fix1 e12) op2 fix2 e2
611 = addErrRn (precParseErr (ppr_op op1,fix1) (ppr_op op2,fix2)) `thenRn_`
612 returnRn (OpApp e1 op2 fix2 e2)
615 = mkOpAppRn e12 op2 fix2 e2 `thenRn` \ new_e ->
616 returnRn (OpApp e11 op1 fix1 new_e)
618 (nofix_error, associate_right) = compareFixity fix1 fix2
620 ---------------------------
621 -- (- neg_arg) `op` e2
622 mkOpAppRn e1@(NegApp neg_arg neg_op) op2 fix2 e2
624 = addErrRn (precParseErr (pp_prefix_minus,negateFixity) (ppr_op op2,fix2)) `thenRn_`
625 returnRn (OpApp e1 op2 fix2 e2)
628 = mkOpAppRn neg_arg op2 fix2 e2 `thenRn` \ new_e ->
629 returnRn (NegApp new_e neg_op)
631 (nofix_error, associate_right) = compareFixity negateFixity fix2
633 ---------------------------
635 mkOpAppRn e1 op1 fix1 e2@(NegApp neg_arg neg_op) -- NegApp can occur on the right
636 | not associate_right -- We *want* right association
637 = addErrRn (precParseErr (ppr_op op1, fix1) (pp_prefix_minus, negateFixity)) `thenRn_`
638 returnRn (OpApp e1 op1 fix1 e2)
640 (nofix_err, associate_right) = compareFixity fix1 negateFixity
642 ---------------------------
644 mkOpAppRn e1 op fix e2 -- Default case, no rearrangment
645 = ASSERT2( right_op_ok fix e2,
646 ppr e1 $$ text "---" $$ ppr op $$ text "---" $$ ppr fix $$ text "---" $$ ppr e2
648 returnRn (OpApp e1 op fix e2)
650 -- Parser left-associates everything, but
651 -- derived instances may have correctly-associated things to
652 -- in the right operarand. So we just check that the right operand is OK
653 right_op_ok fix1 (OpApp _ _ fix2 _)
654 = not error_please && associate_right
656 (error_please, associate_right) = compareFixity fix1 fix2
657 right_op_ok fix1 other
660 -- Parser initially makes negation bind more tightly than any other operator
661 mkNegAppRn neg_arg neg_op
664 getModeRn `thenRn` \ mode ->
665 ASSERT( not_op_app mode neg_arg )
667 returnRn (NegApp neg_arg neg_op)
669 not_op_app SourceMode (OpApp _ _ _ _) = False
670 not_op_app mode other = True
674 mkConOpPatRn :: RenamedPat -> Name -> Fixity -> RenamedPat
677 mkConOpPatRn p1@(ConOpPatIn p11 op1 fix1 p12)
680 = addErrRn (precParseErr (ppr_op op1,fix1) (ppr_op op2,fix2)) `thenRn_`
681 returnRn (ConOpPatIn p1 op2 fix2 p2)
684 = mkConOpPatRn p12 op2 fix2 p2 `thenRn` \ new_p ->
685 returnRn (ConOpPatIn p11 op1 fix1 new_p)
688 (nofix_error, associate_right) = compareFixity fix1 fix2
690 mkConOpPatRn p1@(NegPatIn neg_arg)
692 fix2@(Fixity prec2 dir2)
694 | prec2 > negatePrecedence -- Precedence of unary - is wired in
695 = addErrRn (precParseNegPatErr (ppr_op op2,fix2)) `thenRn_`
696 returnRn (ConOpPatIn p1 op2 fix2 p2)
698 mkConOpPatRn p1 op fix p2 -- Default case, no rearrangment
699 = ASSERT( not_op_pat p2 )
700 returnRn (ConOpPatIn p1 op fix p2)
702 not_op_pat (ConOpPatIn _ _ _ _) = False
703 not_op_pat other = True
707 checkPrecMatch :: Bool -> Name -> RenamedMatch -> RnMS ()
709 checkPrecMatch False fn match
712 checkPrecMatch True op (Match _ (p1:p2:_) _ _)
713 -- True indicates an infix lhs
714 = getModeRn `thenRn` \ mode ->
715 -- See comments with rnExpr (OpApp ...)
717 InterfaceMode -> returnRn ()
718 SourceMode -> checkPrec op p1 False `thenRn_`
721 checkPrecMatch True op _ = panic "checkPrecMatch"
723 checkPrec op (ConOpPatIn _ op1 _ _) right
724 = lookupFixity op `thenRn` \ op_fix@(Fixity op_prec op_dir) ->
725 lookupFixity op1 `thenRn` \ op1_fix@(Fixity op1_prec op1_dir) ->
727 inf_ok = op1_prec > op_prec ||
728 (op1_prec == op_prec &&
729 (op1_dir == InfixR && op_dir == InfixR && right ||
730 op1_dir == InfixL && op_dir == InfixL && not right))
732 info = (ppr_op op, op_fix)
733 info1 = (ppr_op op1, op1_fix)
734 (infol, infor) = if right then (info, info1) else (info1, info)
736 checkRn inf_ok (precParseErr infol infor)
738 checkPrec op (NegPatIn _) right
739 = lookupFixity op `thenRn` \ op_fix@(Fixity op_prec op_dir) ->
740 checkRn (op_prec <= negatePrecedence) (precParseNegPatErr (ppr_op op,op_fix))
742 checkPrec op pat right
745 -- Check precedence of (arg op) or (op arg) respectively
746 -- If arg is itself an operator application, its precedence should
747 -- be higher than that of op
748 checkSectionPrec left_or_right section op arg
750 OpApp _ op fix _ -> go_for_it (ppr_op op) fix
751 NegApp _ op -> go_for_it pp_prefix_minus negateFixity
755 go_for_it pp_arg_op arg_fix@(Fixity arg_prec _)
756 = lookupFixity op_name `thenRn` \ op_fix@(Fixity op_prec _) ->
757 checkRn (op_prec < arg_prec)
758 (sectionPrecErr (ppr_op op_name, op_fix) (pp_arg_op, arg_fix) section)
765 @(compareFixity op1 op2)@ tells which way to arrange appication, or
766 whether there's an error.
769 compareFixity :: Fixity -> Fixity
770 -> (Bool, -- Error please
771 Bool) -- Associate to the right: a op1 (b op2 c)
772 compareFixity (Fixity prec1 dir1) (Fixity prec2 dir2)
773 = case prec1 `compare` prec2 of
776 EQ -> case (dir1, dir2) of
777 (InfixR, InfixR) -> right
778 (InfixL, InfixL) -> left
781 right = (False, True)
782 left = (False, False)
783 error_please = (True, False)
786 %************************************************************************
788 \subsubsection{Literals}
790 %************************************************************************
792 When literals occur we have to make sure
793 that the types and classes they involve
797 litOccurrence (HsChar _)
798 = returnRn (unitFV charTyCon_name)
800 litOccurrence (HsCharPrim _)
801 = returnRn (unitFV (getName charPrimTyCon))
803 litOccurrence (HsString _)
804 = returnRn (unitFV listTyCon_name `plusFV` unitFV charTyCon_name)
806 litOccurrence (HsStringPrim _)
807 = returnRn (unitFV (getName addrPrimTyCon))
809 litOccurrence (HsInt _)
810 = lookupImplicitOccRn numClass_RDR `thenRn` \ num ->
811 returnRn (unitFV num) -- Int and Integer are forced in by Num
813 litOccurrence (HsFrac _)
814 = lookupImplicitOccRn fractionalClass_RDR `thenRn` \ frac ->
815 lookupImplicitOccRn ratioDataCon_RDR `thenRn` \ ratio ->
816 returnRn (unitFV frac `plusFV` unitFV ratio)
817 -- We have to make sure that the Ratio type is imported with
818 -- its constructor, because literals of type Ratio t are
819 -- built with that constructor.
820 -- The Rational type is needed too, but that will come in
821 -- when fractionalClass does.
823 litOccurrence (HsIntPrim _)
824 = returnRn (unitFV (getName intPrimTyCon))
826 litOccurrence (HsFloatPrim _)
827 = returnRn (unitFV (getName floatPrimTyCon))
829 litOccurrence (HsDoublePrim _)
830 = returnRn (unitFV (getName doublePrimTyCon))
832 litOccurrence (HsLitLit _)
833 = lookupImplicitOccRn ccallableClass_RDR `thenRn` \ cc ->
837 %************************************************************************
839 \subsubsection{Assertion utils}
841 %************************************************************************
844 mkAssertExpr :: RnMS (RenamedHsExpr, FreeVars)
846 mkImportedGlobalFromRdrName assertErr_RDR `thenRn` \ name ->
847 getSrcLocRn `thenRn` \ sloc ->
849 -- if we're ignoring asserts, return (\ _ e -> e)
850 -- if not, return (assertError "src-loc")
852 if opt_IgnoreAsserts then
853 getUniqRn `thenRn` \ uniq ->
855 vname = mkSysLocalName uniq SLIT("v")
856 expr = HsLam ignorePredMatch
857 loc = nameSrcLoc vname
858 ignorePredMatch = Match [] [WildPatIn, VarPatIn vname] Nothing
859 (GRHSs [GRHS [ExprStmt (HsVar vname) loc] loc]
862 returnRn (expr, unitFV name)
867 (HsLit (HsString (_PK_ (showSDoc (ppr sloc)))))
870 returnRn (expr, unitFV name)
874 %************************************************************************
876 \subsubsection{Errors}
878 %************************************************************************
881 ppr_op op = quotes (ppr op) -- Here, op can be a Name or a (Var n), where n is a Name
882 ppr_opfix (pp_op, fixity) = pp_op <+> brackets (ppr fixity)
883 pp_prefix_minus = ptext SLIT("prefix `-'")
885 dupFieldErr str (dup:rest)
886 = hsep [ptext SLIT("duplicate field name"),
888 ptext SLIT("in record"), text str]
891 = sep [pp_prefix_minus <+> ptext SLIT("not applied to literal in pattern"),
894 precParseNegPatErr op
895 = hang (ptext SLIT("precedence parsing error"))
896 4 (hsep [pp_prefix_minus <+> ptext SLIT("has lower precedence than"),
898 ptext SLIT("in pattern")])
901 = hang (ptext SLIT("precedence parsing error"))
902 4 (hsep [ptext SLIT("cannot mix"), ppr_opfix op1, ptext SLIT("and"),
904 ptext SLIT("in the same infix expression")])
906 sectionPrecErr op arg_op section
907 = vcat [ptext SLIT("The operator") <+> ppr_opfix op <+> ptext SLIT("of a section"),
908 nest 4 (ptext SLIT("must have lower precedence than the operand") <+> ppr_opfix arg_op),
909 nest 4 (ptext SLIT("In the section:") <+> quotes (ppr section))]
913 SLIT("accepting non-standard pattern guards (-fglasgow-exts to suppress this message)")
917 = (ptext SLIT("Illegal signature in pattern:") <+> ppr ty)
918 $$ nest 4 (ptext SLIT("Use -fglasgow-exts to permit it"))
921 = sep [ptext SLIT("Pattern syntax in expression context:"),
925 = sep [ptext SLIT("`do' statements must end in expression:"),