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 ( lookupFixityRn )
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,
35 ioDataCon_RDR, addr2Integer_RDR,
38 import TysPrim ( charPrimTyCon, addrPrimTyCon, intPrimTyCon,
39 floatPrimTyCon, doublePrimTyCon
41 import Name ( nameUnique, isLocallyDefined, NamedThing(..)
42 , mkSysLocalName, nameSrcLoc
45 import UniqFM ( isNullUFM )
46 import FiniteMap ( elemFM )
47 import UniqSet ( emptyUniqSet, UniqSet )
48 import Unique ( hasKey, assertIdKey )
49 import Util ( removeDups )
50 import ListSetOps ( unionLists )
51 import Maybes ( maybeToBool )
53 import Literal ( inIntRange, tARGET_MAX_INT )
54 import RdrName ( mkSrcUnqual )
55 import OccName ( varName )
59 *********************************************************
63 *********************************************************
66 rnPat :: RdrNamePat -> RnMS (RenamedPat, FreeVars)
68 rnPat WildPatIn = returnRn (WildPatIn, emptyFVs)
71 = lookupBndrRn name `thenRn` \ vname ->
72 returnRn (VarPatIn vname, emptyFVs)
74 rnPat (SigPatIn pat ty)
76 = rnPat pat `thenRn` \ (pat', fvs1) ->
77 rnHsType doc ty `thenRn` \ (ty', fvs2) ->
78 returnRn (SigPatIn pat' ty', fvs1 `plusFV` fvs2)
81 = addErrRn (patSigErr ty) `thenRn_`
84 doc = text "a pattern type-signature"
87 = litOccurrence lit `thenRn` \ fvs1 ->
88 lookupImplicitOccRn eqClass_RDR `thenRn` \ eq -> -- Needed to find equality on pattern
89 returnRn (LitPatIn lit, fvs1 `addOneFV` eq)
92 = rnPat pat `thenRn` \ (pat', fvs) ->
93 returnRn (LazyPatIn pat', fvs)
95 rnPat (AsPatIn name pat)
96 = rnPat pat `thenRn` \ (pat', fvs) ->
97 lookupBndrRn name `thenRn` \ vname ->
98 returnRn (AsPatIn vname pat', fvs)
100 rnPat (ConPatIn con pats)
101 = lookupOccRn con `thenRn` \ con' ->
102 mapFvRn rnPat pats `thenRn` \ (patslist, fvs) ->
103 returnRn (ConPatIn con' patslist, fvs `addOneFV` con')
105 rnPat (ConOpPatIn pat1 con _ pat2)
106 = rnPat pat1 `thenRn` \ (pat1', fvs1) ->
107 lookupOccRn con `thenRn` \ con' ->
108 rnPat pat2 `thenRn` \ (pat2', fvs2) ->
110 getModeRn `thenRn` \ mode ->
111 -- See comments with rnExpr (OpApp ...)
113 InterfaceMode -> returnRn (ConOpPatIn pat1' con' defaultFixity pat2')
114 SourceMode -> lookupFixityRn con' `thenRn` \ fixity ->
115 mkConOpPatRn pat1' con' fixity pat2'
117 returnRn (pat', fvs1 `plusFV` fvs2 `addOneFV` con')
119 -- Negated patters can only be literals, and they are dealt with
120 -- by negating the literal at compile time, not by using the negation
121 -- operation in Num. So we don't need to make an implicit reference
123 rnPat neg@(NegPatIn pat)
124 = checkRn (valid_neg_pat pat) (negPatErr neg)
126 rnPat pat `thenRn` \ (pat', fvs) ->
127 returnRn (NegPatIn pat', fvs)
129 valid_neg_pat (LitPatIn (HsInt _)) = True
130 valid_neg_pat (LitPatIn (HsIntPrim _)) = True
131 valid_neg_pat (LitPatIn (HsFrac _)) = True
132 valid_neg_pat (LitPatIn (HsFloatPrim _)) = True
133 valid_neg_pat (LitPatIn (HsDoublePrim _)) = True
134 valid_neg_pat _ = False
137 = rnPat pat `thenRn` \ (pat', fvs) ->
138 returnRn (ParPatIn pat', fvs)
140 rnPat (NPlusKPatIn name lit)
141 = litOccurrence lit `thenRn` \ fvs ->
142 lookupImplicitOccRn ordClass_RDR `thenRn` \ ord ->
143 lookupBndrRn name `thenRn` \ name' ->
144 returnRn (NPlusKPatIn name' lit, fvs `addOneFV` ord)
146 rnPat (ListPatIn pats)
147 = mapFvRn rnPat pats `thenRn` \ (patslist, fvs) ->
148 returnRn (ListPatIn patslist, fvs `addOneFV` listTyCon_name)
150 rnPat (TuplePatIn pats boxed)
151 = mapFvRn rnPat pats `thenRn` \ (patslist, fvs) ->
152 returnRn (TuplePatIn patslist boxed, fvs `addOneFV` tycon_name)
154 tycon_name = tupleTyCon_name boxed (length pats)
156 rnPat (RecPatIn con rpats)
157 = lookupOccRn con `thenRn` \ con' ->
158 rnRpats rpats `thenRn` \ (rpats', fvs) ->
159 returnRn (RecPatIn con' rpats', fvs `addOneFV` con')
162 ************************************************************************
166 ************************************************************************
169 rnMatch :: RdrNameMatch -> RnMS (RenamedMatch, FreeVars)
171 rnMatch match@(Match _ pats maybe_rhs_sig grhss)
172 = pushSrcLocRn (getMatchLoc match) $
174 -- Find the universally quantified type variables
175 -- in the pattern type signatures
176 getLocalNameEnv `thenRn` \ name_env ->
178 tyvars_in_sigs = rhs_sig_tyvars `unionLists` tyvars_in_pats
179 rhs_sig_tyvars = case maybe_rhs_sig of
181 Just ty -> extractHsTyRdrTyVars ty
182 tyvars_in_pats = extractPatsTyVars pats
183 forall_tyvars = filter (not . (`elemFM` name_env)) tyvars_in_sigs
184 doc_sig = text "a pattern type-signature"
185 doc_pats = text "in a pattern match"
187 bindTyVarsFVRn doc_sig (map UserTyVar forall_tyvars) $ \ sig_tyvars ->
189 -- Note that we do a single bindLocalsRn for all the
190 -- matches together, so that we spot the repeated variable in
192 bindLocalsFVRn doc_pats (collectPatsBinders pats) $ \ new_binders ->
194 mapFvRn rnPat pats `thenRn` \ (pats', pat_fvs) ->
195 rnGRHSs grhss `thenRn` \ (grhss', grhss_fvs) ->
196 (case maybe_rhs_sig of
197 Nothing -> returnRn (Nothing, emptyFVs)
198 Just ty | opt_GlasgowExts -> rnHsType doc_sig ty `thenRn` \ (ty', ty_fvs) ->
199 returnRn (Just ty', ty_fvs)
200 | otherwise -> addErrRn (patSigErr ty) `thenRn_`
201 returnRn (Nothing, emptyFVs)
202 ) `thenRn` \ (maybe_rhs_sig', ty_fvs) ->
205 binder_set = mkNameSet new_binders
206 unused_binders = nameSetToList (binder_set `minusNameSet` grhss_fvs)
207 all_fvs = grhss_fvs `plusFV` pat_fvs `plusFV` ty_fvs
209 warnUnusedMatches unused_binders `thenRn_`
211 returnRn (Match sig_tyvars pats' maybe_rhs_sig' grhss', all_fvs)
212 -- The bindLocals and bindTyVars will remove the bound FVs
215 %************************************************************************
217 \subsubsection{Guarded right-hand sides (GRHSs)}
219 %************************************************************************
222 rnGRHSs :: RdrNameGRHSs -> RnMS (RenamedGRHSs, FreeVars)
224 rnGRHSs (GRHSs grhss binds maybe_ty)
225 = ASSERT( not (maybeToBool maybe_ty) )
226 rnBinds binds $ \ binds' ->
227 mapFvRn rnGRHS grhss `thenRn` \ (grhss', fvGRHSs) ->
228 returnRn (GRHSs grhss' binds' Nothing, fvGRHSs)
230 rnGRHS (GRHS guarded locn)
231 = pushSrcLocRn locn $
232 (if not (opt_GlasgowExts || is_standard_guard guarded) then
233 addWarnRn (nonStdGuardErr guarded)
238 rnStmts rnExpr guarded `thenRn` \ (guarded', fvs) ->
239 returnRn (GRHS guarded' locn, fvs)
241 -- Standard Haskell 1.4 guards are just a single boolean
242 -- expression, rather than a list of qualifiers as in the
244 is_standard_guard [ExprStmt _ _] = True
245 is_standard_guard [GuardStmt _ _, ExprStmt _ _] = True
246 is_standard_guard other = False
249 %************************************************************************
251 \subsubsection{Expressions}
253 %************************************************************************
256 rnExprs :: [RdrNameHsExpr] -> RnMS ([RenamedHsExpr], FreeVars)
257 rnExprs ls = rnExprs' ls emptyUniqSet
259 rnExprs' [] acc = returnRn ([], acc)
260 rnExprs' (expr:exprs) acc
261 = rnExpr expr `thenRn` \ (expr', fvExpr) ->
263 -- Now we do a "seq" on the free vars because typically it's small
264 -- or empty, especially in very long lists of constants
266 acc' = acc `plusFV` fvExpr
268 (grubby_seqNameSet acc' rnExprs') exprs acc' `thenRn` \ (exprs', fvExprs) ->
269 returnRn (expr':exprs', fvExprs)
271 -- Grubby little function to do "seq" on namesets; replace by proper seq when GHC can do seq
272 grubby_seqNameSet ns result | isNullUFM ns = result
276 Variables. We look up the variable and return the resulting name.
279 rnExpr :: RdrNameHsExpr -> RnMS (RenamedHsExpr, FreeVars)
282 = lookupOccRn v `thenRn` \ name ->
283 if name `hasKey` assertIdKey then
284 -- We expand it to (GHCerr.assert__ location)
288 returnRn (HsVar name, unitFV name)
291 = getIPName v `thenRn` \ name ->
292 returnRn (HsIPVar name, emptyFVs)
294 -- Special case for integral literals with a large magnitude:
295 -- They are transformed into an expression involving only smaller
296 -- integral literals. This improves constant folding.
297 rnExpr (HsLit (HsInt i))
298 | not (inIntRange i) = rnExpr (horner tARGET_MAX_INT i)
301 = litOccurrence lit `thenRn` \ fvs ->
302 returnRn (HsLit lit, fvs)
305 = rnMatch match `thenRn` \ (match', fvMatch) ->
306 returnRn (HsLam match', fvMatch)
308 rnExpr (HsApp fun arg)
309 = rnExpr fun `thenRn` \ (fun',fvFun) ->
310 rnExpr arg `thenRn` \ (arg',fvArg) ->
311 returnRn (HsApp fun' arg', fvFun `plusFV` fvArg)
313 rnExpr (OpApp e1 op _ e2)
314 = rnExpr e1 `thenRn` \ (e1', fv_e1) ->
315 rnExpr e2 `thenRn` \ (e2', fv_e2) ->
316 rnExpr op `thenRn` \ (op'@(HsVar op_name), fv_op) ->
319 -- When renaming code synthesised from "deriving" declarations
320 -- we're in Interface mode, and we should ignore fixity; assume
321 -- that the deriving code generator got the association correct
322 -- Don't even look up the fixity when in interface mode
323 getModeRn `thenRn` \ mode ->
325 SourceMode -> lookupFixityRn op_name `thenRn` \ fixity ->
326 mkOpAppRn e1' op' fixity e2'
327 InterfaceMode -> returnRn (OpApp e1' op' defaultFixity e2')
328 ) `thenRn` \ final_e ->
331 fv_e1 `plusFV` fv_op `plusFV` fv_e2)
333 -- constant-fold some negate applications on unboxed literals. Since
334 -- negate is a polymorphic function, we have to do these here.
335 rnExpr (NegApp (HsLit (HsIntPrim i)) _) = rnExpr (HsLit (HsIntPrim (-i)))
336 rnExpr (NegApp (HsLit (HsFloatPrim i)) _) = rnExpr (HsLit (HsFloatPrim (-i)))
337 rnExpr (NegApp (HsLit (HsDoublePrim i)) _) = rnExpr (HsLit (HsDoublePrim (-i)))
340 = rnExpr e `thenRn` \ (e', fv_e) ->
341 lookupImplicitOccRn negate_RDR `thenRn` \ neg ->
342 mkNegAppRn e' (HsVar neg) `thenRn` \ final_e ->
343 returnRn (final_e, fv_e `addOneFV` neg)
346 = rnExpr e `thenRn` \ (e', fvs_e) ->
347 returnRn (HsPar e', fvs_e)
349 rnExpr section@(SectionL expr op)
350 = rnExpr expr `thenRn` \ (expr', fvs_expr) ->
351 rnExpr op `thenRn` \ (op', fvs_op) ->
352 checkSectionPrec "left" section op' expr' `thenRn_`
353 returnRn (SectionL expr' op', fvs_op `plusFV` fvs_expr)
355 rnExpr section@(SectionR op expr)
356 = rnExpr op `thenRn` \ (op', fvs_op) ->
357 rnExpr expr `thenRn` \ (expr', fvs_expr) ->
358 checkSectionPrec "right" section op' expr' `thenRn_`
359 returnRn (SectionR op' expr', fvs_op `plusFV` fvs_expr)
361 rnExpr (HsCCall fun args may_gc is_casm fake_result_ty)
362 -- Check out the comment on RnIfaces.getNonWiredDataDecl about ccalls
363 = lookupImplicitOccsRn [ccallableClass_RDR,
364 creturnableClass_RDR,
365 ioDataCon_RDR] `thenRn` \ implicit_fvs ->
366 rnExprs args `thenRn` \ (args', fvs_args) ->
367 returnRn (HsCCall fun args' may_gc is_casm fake_result_ty,
368 fvs_args `plusFV` implicit_fvs)
370 rnExpr (HsSCC lbl expr)
371 = rnExpr expr `thenRn` \ (expr', fvs_expr) ->
372 returnRn (HsSCC lbl expr', fvs_expr)
374 rnExpr (HsCase expr ms src_loc)
375 = pushSrcLocRn src_loc $
376 rnExpr expr `thenRn` \ (new_expr, e_fvs) ->
377 mapFvRn rnMatch ms `thenRn` \ (new_ms, ms_fvs) ->
378 returnRn (HsCase new_expr new_ms src_loc, e_fvs `plusFV` ms_fvs)
380 rnExpr (HsLet binds expr)
381 = rnBinds binds $ \ binds' ->
382 rnExpr expr `thenRn` \ (expr',fvExpr) ->
383 returnRn (HsLet binds' expr', fvExpr)
385 rnExpr (HsWith expr binds)
386 = rnExpr expr `thenRn` \ (expr',fvExpr) ->
387 rnIPBinds binds `thenRn` \ (binds',fvBinds) ->
388 returnRn (HsWith expr' binds', fvExpr `plusFV` fvBinds)
390 rnExpr e@(HsDo do_or_lc stmts src_loc)
391 = pushSrcLocRn src_loc $
392 lookupImplicitOccsRn implicit_rdr_names `thenRn` \ implicit_fvs ->
393 rnStmts rnExpr stmts `thenRn` \ (stmts', fvs) ->
394 -- check the statement list ends in an expression
395 case last stmts' of {
396 ExprStmt _ _ -> returnRn () ;
397 ReturnStmt _ -> returnRn () ; -- for list comprehensions
398 _ -> addErrRn (doStmtListErr e)
400 returnRn (HsDo do_or_lc stmts' src_loc, fvs `plusFV` implicit_fvs)
402 implicit_rdr_names = [foldr_RDR, build_RDR, monadClass_RDR]
403 -- Monad stuff should not be necessary for a list comprehension
404 -- but the typechecker looks up the bind and return Ids anyway
408 rnExpr (ExplicitList exps)
409 = rnExprs exps `thenRn` \ (exps', fvs) ->
410 returnRn (ExplicitList exps', fvs `addOneFV` listTyCon_name)
412 rnExpr (ExplicitTuple exps boxity)
413 = rnExprs exps `thenRn` \ (exps', fvs) ->
414 returnRn (ExplicitTuple exps' boxity, fvs `addOneFV` tycon_name)
416 tycon_name = tupleTyCon_name boxity (length exps)
418 rnExpr (RecordCon con_id rbinds)
419 = lookupOccRn con_id `thenRn` \ conname ->
420 rnRbinds "construction" rbinds `thenRn` \ (rbinds', fvRbinds) ->
421 returnRn (RecordCon conname rbinds', fvRbinds `addOneFV` conname)
423 rnExpr (RecordUpd expr rbinds)
424 = rnExpr expr `thenRn` \ (expr', fvExpr) ->
425 rnRbinds "update" rbinds `thenRn` \ (rbinds', fvRbinds) ->
426 returnRn (RecordUpd expr' rbinds', fvExpr `plusFV` fvRbinds)
428 rnExpr (ExprWithTySig expr pty)
429 = rnExpr expr `thenRn` \ (expr', fvExpr) ->
430 rnHsSigType (text "an expression") pty `thenRn` \ (pty', fvTy) ->
431 returnRn (ExprWithTySig expr' pty', fvExpr `plusFV` fvTy)
433 rnExpr (HsIf p b1 b2 src_loc)
434 = pushSrcLocRn src_loc $
435 rnExpr p `thenRn` \ (p', fvP) ->
436 rnExpr b1 `thenRn` \ (b1', fvB1) ->
437 rnExpr b2 `thenRn` \ (b2', fvB2) ->
438 returnRn (HsIf p' b1' b2' src_loc, plusFVs [fvP, fvB1, fvB2])
440 rnExpr (ArithSeqIn seq)
441 = lookupImplicitOccRn enumClass_RDR `thenRn` \ enum ->
442 rn_seq seq `thenRn` \ (new_seq, fvs) ->
443 returnRn (ArithSeqIn new_seq, fvs `addOneFV` enum)
446 = rnExpr expr `thenRn` \ (expr', fvExpr) ->
447 returnRn (From expr', fvExpr)
449 rn_seq (FromThen expr1 expr2)
450 = rnExpr expr1 `thenRn` \ (expr1', fvExpr1) ->
451 rnExpr expr2 `thenRn` \ (expr2', fvExpr2) ->
452 returnRn (FromThen expr1' expr2', fvExpr1 `plusFV` fvExpr2)
454 rn_seq (FromTo expr1 expr2)
455 = rnExpr expr1 `thenRn` \ (expr1', fvExpr1) ->
456 rnExpr expr2 `thenRn` \ (expr2', fvExpr2) ->
457 returnRn (FromTo expr1' expr2', fvExpr1 `plusFV` fvExpr2)
459 rn_seq (FromThenTo expr1 expr2 expr3)
460 = rnExpr expr1 `thenRn` \ (expr1', fvExpr1) ->
461 rnExpr expr2 `thenRn` \ (expr2', fvExpr2) ->
462 rnExpr expr3 `thenRn` \ (expr3', fvExpr3) ->
463 returnRn (FromThenTo expr1' expr2' expr3',
464 plusFVs [fvExpr1, fvExpr2, fvExpr3])
467 These three are pattern syntax appearing in expressions.
468 Since all the symbols are reservedops we can simply reject them.
469 We return a (bogus) EWildPat in each case.
472 rnExpr e@EWildPat = addErrRn (patSynErr e) `thenRn_`
473 returnRn (EWildPat, emptyFVs)
475 rnExpr e@(EAsPat _ _) = addErrRn (patSynErr e) `thenRn_`
476 returnRn (EWildPat, emptyFVs)
478 rnExpr e@(ELazyPat _) = addErrRn (patSynErr e) `thenRn_`
479 returnRn (EWildPat, emptyFVs)
481 -- Transform i into (x1 + (x2 + (x3 + (...) * b) * b) * b) with abs xi <= b
482 horner :: Integer -> Integer -> RdrNameHsExpr
483 horner b i | abs q <= 1 = if r == 0 || r == i then mkInt i else mkInt r `plus` mkInt (i-r)
484 | r == 0 = horner b q `times` mkInt b
485 | otherwise = mkInt r `plus` (horner b q `times` mkInt b)
486 where (q,r) = i `quotRem` b
487 mkInt i = HsLit (HsInt i)
490 mkOp op = \x y -> HsPar (OpApp x (HsVar (mkSrcUnqual varName (_PK_ op))) (panic "fixity") y)
493 %************************************************************************
495 \subsubsection{@Rbinds@s and @Rpats@s: in record expressions}
497 %************************************************************************
501 = mapRn_ field_dup_err dup_fields `thenRn_`
502 mapFvRn rn_rbind rbinds `thenRn` \ (rbinds', fvRbind) ->
503 returnRn (rbinds', fvRbind)
505 (_, dup_fields) = removeDups compare [ f | (f,_,_) <- rbinds ]
507 field_dup_err dups = addErrRn (dupFieldErr str dups)
509 rn_rbind (field, expr, pun)
510 = lookupGlobalOccRn field `thenRn` \ fieldname ->
511 rnExpr expr `thenRn` \ (expr', fvExpr) ->
512 returnRn ((fieldname, expr', pun), fvExpr `addOneFV` fieldname)
515 = mapRn_ field_dup_err dup_fields `thenRn_`
516 mapFvRn rn_rpat rpats `thenRn` \ (rpats', fvs) ->
517 returnRn (rpats', fvs)
519 (_, dup_fields) = removeDups compare [ f | (f,_,_) <- rpats ]
521 field_dup_err dups = addErrRn (dupFieldErr "pattern" dups)
523 rn_rpat (field, pat, pun)
524 = lookupGlobalOccRn field `thenRn` \ fieldname ->
525 rnPat pat `thenRn` \ (pat', fvs) ->
526 returnRn ((fieldname, pat', pun), fvs `addOneFV` fieldname)
529 %************************************************************************
531 \subsubsection{@rnIPBinds@s: in implicit parameter bindings} *
533 %************************************************************************
536 rnIPBinds [] = returnRn ([], emptyFVs)
537 rnIPBinds ((n, expr) : binds)
538 = getIPName n `thenRn` \ name ->
539 rnExpr expr `thenRn` \ (expr',fvExpr) ->
540 rnIPBinds binds `thenRn` \ (binds',fvBinds) ->
541 returnRn ((name, expr') : binds', fvExpr `plusFV` fvBinds)
545 %************************************************************************
547 \subsubsection{@Stmt@s: in @do@ expressions}
549 %************************************************************************
551 Note that although some bound vars may appear in the free var set for
552 the first qual, these will eventually be removed by the caller. For
553 example, if we have @[p | r <- s, q <- r, p <- q]@, when doing
554 @[q <- r, p <- q]@, the free var set for @q <- r@ will
555 be @{r}@, and the free var set for the entire Quals will be @{r}@. This
556 @r@ will be removed only when we finally return from examining all the
560 type RnExprTy = RdrNameHsExpr -> RnMS (RenamedHsExpr, FreeVars)
564 -> RnMS ([RenamedStmt], FreeVars)
567 = returnRn ([], emptyFVs)
569 rnStmts rn_expr (stmt:stmts)
570 = rnStmt rn_expr stmt $ \ stmt' ->
571 rnStmts rn_expr stmts `thenRn` \ (stmts', fvs) ->
572 returnRn (stmt' : stmts', fvs)
574 rnStmt :: RnExprTy -> RdrNameStmt
575 -> (RenamedStmt -> RnMS (a, FreeVars))
576 -> RnMS (a, FreeVars)
577 -- Because of mutual recursion we have to pass in rnExpr.
579 rnStmt rn_expr (BindStmt pat expr src_loc) thing_inside
580 = pushSrcLocRn src_loc $
581 rn_expr expr `thenRn` \ (expr', fv_expr) ->
582 bindLocalsFVRn doc binders $ \ new_binders ->
583 rnPat pat `thenRn` \ (pat', fv_pat) ->
584 thing_inside (BindStmt pat' expr' src_loc) `thenRn` \ (result, fvs) ->
585 returnRn (result, fv_expr `plusFV` fvs `plusFV` fv_pat)
587 binders = collectPatBinders pat
588 doc = text "a pattern in do binding"
590 rnStmt rn_expr (ExprStmt expr src_loc) thing_inside
591 = pushSrcLocRn src_loc $
592 rn_expr expr `thenRn` \ (expr', fv_expr) ->
593 thing_inside (ExprStmt expr' src_loc) `thenRn` \ (result, fvs) ->
594 returnRn (result, fv_expr `plusFV` fvs)
596 rnStmt rn_expr (GuardStmt expr src_loc) thing_inside
597 = pushSrcLocRn src_loc $
598 rn_expr expr `thenRn` \ (expr', fv_expr) ->
599 thing_inside (GuardStmt expr' src_loc) `thenRn` \ (result, fvs) ->
600 returnRn (result, fv_expr `plusFV` fvs)
602 rnStmt rn_expr (ReturnStmt expr) thing_inside
603 = rn_expr expr `thenRn` \ (expr', fv_expr) ->
604 thing_inside (ReturnStmt expr') `thenRn` \ (result, fvs) ->
605 returnRn (result, fv_expr `plusFV` fvs)
607 rnStmt rn_expr (LetStmt binds) thing_inside
608 = rnBinds binds $ \ binds' ->
609 thing_inside (LetStmt binds')
612 %************************************************************************
614 \subsubsection{Precedence Parsing}
616 %************************************************************************
618 @mkOpAppRn@ deals with operator fixities. The argument expressions
619 are assumed to be already correctly arranged. It needs the fixities
620 recorded in the OpApp nodes, because fixity info applies to the things
621 the programmer actually wrote, so you can't find it out from the Name.
623 Furthermore, the second argument is guaranteed not to be another
624 operator application. Why? Because the parser parses all
625 operator appications left-associatively, EXCEPT negation, which
626 we need to handle specially.
629 mkOpAppRn :: RenamedHsExpr -- Left operand; already rearranged
630 -> RenamedHsExpr -> Fixity -- Operator and fixity
631 -> RenamedHsExpr -- Right operand (not an OpApp, but might
633 -> RnMS RenamedHsExpr
635 ---------------------------
636 -- (e11 `op1` e12) `op2` e2
637 mkOpAppRn e1@(OpApp e11 op1 fix1 e12) op2 fix2 e2
639 = addErrRn (precParseErr (ppr_op op1,fix1) (ppr_op op2,fix2)) `thenRn_`
640 returnRn (OpApp e1 op2 fix2 e2)
643 = mkOpAppRn e12 op2 fix2 e2 `thenRn` \ new_e ->
644 returnRn (OpApp e11 op1 fix1 new_e)
646 (nofix_error, associate_right) = compareFixity fix1 fix2
648 ---------------------------
649 -- (- neg_arg) `op` e2
650 mkOpAppRn e1@(NegApp neg_arg neg_op) op2 fix2 e2
652 = addErrRn (precParseErr (pp_prefix_minus,negateFixity) (ppr_op op2,fix2)) `thenRn_`
653 returnRn (OpApp e1 op2 fix2 e2)
656 = mkOpAppRn neg_arg op2 fix2 e2 `thenRn` \ new_e ->
657 returnRn (NegApp new_e neg_op)
659 (nofix_error, associate_right) = compareFixity negateFixity fix2
661 ---------------------------
663 mkOpAppRn e1 op1 fix1 e2@(NegApp neg_arg neg_op) -- NegApp can occur on the right
664 | not associate_right -- We *want* right association
665 = addErrRn (precParseErr (ppr_op op1, fix1) (pp_prefix_minus, negateFixity)) `thenRn_`
666 returnRn (OpApp e1 op1 fix1 e2)
668 (_, associate_right) = compareFixity fix1 negateFixity
670 ---------------------------
672 mkOpAppRn e1 op fix e2 -- Default case, no rearrangment
673 = ASSERT2( right_op_ok fix e2,
674 ppr e1 $$ text "---" $$ ppr op $$ text "---" $$ ppr fix $$ text "---" $$ ppr e2
676 returnRn (OpApp e1 op fix e2)
678 -- Parser left-associates everything, but
679 -- derived instances may have correctly-associated things to
680 -- in the right operarand. So we just check that the right operand is OK
681 right_op_ok fix1 (OpApp _ _ fix2 _)
682 = not error_please && associate_right
684 (error_please, associate_right) = compareFixity fix1 fix2
685 right_op_ok fix1 other
688 -- Parser initially makes negation bind more tightly than any other operator
689 mkNegAppRn neg_arg neg_op
692 getModeRn `thenRn` \ mode ->
693 ASSERT( not_op_app mode neg_arg )
695 returnRn (NegApp neg_arg neg_op)
697 not_op_app SourceMode (OpApp _ _ _ _) = False
698 not_op_app mode other = True
702 mkConOpPatRn :: RenamedPat -> Name -> Fixity -> RenamedPat
705 mkConOpPatRn p1@(ConOpPatIn p11 op1 fix1 p12)
708 = addErrRn (precParseErr (ppr_op op1,fix1) (ppr_op op2,fix2)) `thenRn_`
709 returnRn (ConOpPatIn p1 op2 fix2 p2)
712 = mkConOpPatRn p12 op2 fix2 p2 `thenRn` \ new_p ->
713 returnRn (ConOpPatIn p11 op1 fix1 new_p)
716 (nofix_error, associate_right) = compareFixity fix1 fix2
718 mkConOpPatRn p1@(NegPatIn neg_arg)
720 fix2@(Fixity prec2 dir2)
722 | prec2 > negatePrecedence -- Precedence of unary - is wired in
723 = addErrRn (precParseNegPatErr (ppr_op op2,fix2)) `thenRn_`
724 returnRn (ConOpPatIn p1 op2 fix2 p2)
726 mkConOpPatRn p1 op fix p2 -- Default case, no rearrangment
727 = ASSERT( not_op_pat p2 )
728 returnRn (ConOpPatIn p1 op fix p2)
730 not_op_pat (ConOpPatIn _ _ _ _) = False
731 not_op_pat other = True
735 checkPrecMatch :: Bool -> Name -> RenamedMatch -> RnMS ()
737 checkPrecMatch False fn match
740 checkPrecMatch True op (Match _ (p1:p2:_) _ _)
741 -- True indicates an infix lhs
742 = getModeRn `thenRn` \ mode ->
743 -- See comments with rnExpr (OpApp ...)
745 InterfaceMode -> returnRn ()
746 SourceMode -> checkPrec op p1 False `thenRn_`
749 checkPrecMatch True op _ = panic "checkPrecMatch"
751 checkPrec op (ConOpPatIn _ op1 _ _) right
752 = lookupFixityRn op `thenRn` \ op_fix@(Fixity op_prec op_dir) ->
753 lookupFixityRn op1 `thenRn` \ op1_fix@(Fixity op1_prec op1_dir) ->
755 inf_ok = op1_prec > op_prec ||
756 (op1_prec == op_prec &&
757 (op1_dir == InfixR && op_dir == InfixR && right ||
758 op1_dir == InfixL && op_dir == InfixL && not right))
760 info = (ppr_op op, op_fix)
761 info1 = (ppr_op op1, op1_fix)
762 (infol, infor) = if right then (info, info1) else (info1, info)
764 checkRn inf_ok (precParseErr infol infor)
766 checkPrec op (NegPatIn _) right
767 = lookupFixityRn op `thenRn` \ op_fix@(Fixity op_prec op_dir) ->
768 checkRn (op_prec <= negatePrecedence) (precParseNegPatErr (ppr_op op,op_fix))
770 checkPrec op pat right
773 -- Check precedence of (arg op) or (op arg) respectively
774 -- If arg is itself an operator application, its precedence should
775 -- be higher than that of op
776 checkSectionPrec left_or_right section op arg
778 OpApp _ op fix _ -> go_for_it (ppr_op op) fix
779 NegApp _ op -> go_for_it pp_prefix_minus negateFixity
783 go_for_it pp_arg_op arg_fix@(Fixity arg_prec _)
784 = lookupFixityRn op_name `thenRn` \ op_fix@(Fixity op_prec _) ->
785 checkRn (op_prec < arg_prec)
786 (sectionPrecErr (ppr_op op_name, op_fix) (pp_arg_op, arg_fix) section)
793 @(compareFixity op1 op2)@ tells which way to arrange appication, or
794 whether there's an error.
797 compareFixity :: Fixity -> Fixity
798 -> (Bool, -- Error please
799 Bool) -- Associate to the right: a op1 (b op2 c)
800 compareFixity (Fixity prec1 dir1) (Fixity prec2 dir2)
801 = case prec1 `compare` prec2 of
804 EQ -> case (dir1, dir2) of
805 (InfixR, InfixR) -> right
806 (InfixL, InfixL) -> left
809 right = (False, True)
810 left = (False, False)
811 error_please = (True, False)
814 %************************************************************************
816 \subsubsection{Literals}
818 %************************************************************************
820 When literals occur we have to make sure
821 that the types and classes they involve
825 litOccurrence (HsChar _)
826 = returnRn (unitFV charTyCon_name)
828 litOccurrence (HsCharPrim _)
829 = returnRn (unitFV (getName charPrimTyCon))
831 litOccurrence (HsString _)
832 = returnRn (unitFV listTyCon_name `plusFV` unitFV charTyCon_name)
834 litOccurrence (HsStringPrim _)
835 = returnRn (unitFV (getName addrPrimTyCon))
837 litOccurrence (HsInt _)
838 = lookupImplicitOccsRn [numClass_RDR, addr2Integer_RDR]
839 -- Int and Integer are forced in by Num
841 litOccurrence (HsFrac _)
842 = lookupImplicitOccsRn [fractionalClass_RDR,ratioDataCon_RDR,addr2Integer_RDR]
843 -- We have to make sure that the Ratio type is imported with
844 -- its constructor, because literals of type Ratio t are
845 -- built with that constructor.
846 -- The Rational type is needed too, but that will come in
847 -- when fractionalClass does.
849 litOccurrence (HsIntPrim _)
850 = returnRn (unitFV (getName intPrimTyCon))
852 litOccurrence (HsFloatPrim _)
853 = returnRn (unitFV (getName floatPrimTyCon))
855 litOccurrence (HsDoublePrim _)
856 = returnRn (unitFV (getName doublePrimTyCon))
858 litOccurrence (HsLitLit _)
859 = lookupImplicitOccRn ccallableClass_RDR `thenRn` \ cc ->
863 %************************************************************************
865 \subsubsection{Assertion utils}
867 %************************************************************************
870 mkAssertExpr :: RnMS (RenamedHsExpr, FreeVars)
872 mkImportedGlobalFromRdrName assertErr_RDR `thenRn` \ name ->
873 getSrcLocRn `thenRn` \ sloc ->
875 -- if we're ignoring asserts, return (\ _ e -> e)
876 -- if not, return (assertError "src-loc")
878 if opt_IgnoreAsserts then
879 getUniqRn `thenRn` \ uniq ->
881 vname = mkSysLocalName uniq SLIT("v")
882 expr = HsLam ignorePredMatch
883 loc = nameSrcLoc vname
884 ignorePredMatch = Match [] [WildPatIn, VarPatIn vname] Nothing
885 (GRHSs [GRHS [ExprStmt (HsVar vname) loc] loc]
888 returnRn (expr, unitFV name)
893 (HsLit (HsString (_PK_ (showSDoc (ppr sloc)))))
896 returnRn (expr, unitFV name)
900 %************************************************************************
902 \subsubsection{Errors}
904 %************************************************************************
907 ppr_op op = quotes (ppr op) -- Here, op can be a Name or a (Var n), where n is a Name
908 ppr_opfix (pp_op, fixity) = pp_op <+> brackets (ppr fixity)
909 pp_prefix_minus = ptext SLIT("prefix `-'")
911 dupFieldErr str (dup:rest)
912 = hsep [ptext SLIT("duplicate field name"),
914 ptext SLIT("in record"), text str]
917 = sep [pp_prefix_minus <+> ptext SLIT("not applied to literal in pattern"),
920 precParseNegPatErr op
921 = hang (ptext SLIT("precedence parsing error"))
922 4 (hsep [pp_prefix_minus <+> ptext SLIT("has lower precedence than"),
924 ptext SLIT("in pattern")])
927 = hang (ptext SLIT("precedence parsing error"))
928 4 (hsep [ptext SLIT("cannot mix"), ppr_opfix op1, ptext SLIT("and"),
930 ptext SLIT("in the same infix expression")])
932 sectionPrecErr op arg_op section
933 = vcat [ptext SLIT("The operator") <+> ppr_opfix op <+> ptext SLIT("of a section"),
934 nest 4 (ptext SLIT("must have lower precedence than the operand") <+> ppr_opfix arg_op),
935 nest 4 (ptext SLIT("In the section:") <+> quotes (ppr section))]
939 SLIT("accepting non-standard pattern guards (-fglasgow-exts to suppress this message)")
943 = (ptext SLIT("Illegal signature in pattern:") <+> ppr ty)
944 $$ nest 4 (ptext SLIT("Use -fglasgow-exts to permit it"))
947 = sep [ptext SLIT("Pattern syntax in expression context:"),
951 = sep [ptext SLIT("`do' statements must end in expression:"),