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 -> extractHsTyRdrTyVars ty
178 tyvars_in_pats = extractPatsTyVars pats
179 forall_tyvars = filter (not . (`elemFM` name_env)) tyvars_in_sigs
180 doc_sig = text "a pattern type-signature"
181 doc_pats = text "in a pattern match"
183 bindTyVarsFVRn doc_sig (map UserTyVar forall_tyvars) $ \ sig_tyvars ->
185 -- Note that we do a single bindLocalsRn for all the
186 -- matches together, so that we spot the repeated variable in
188 bindLocalsFVRn doc_pats (collectPatsBinders pats) $ \ new_binders ->
190 mapFvRn rnPat pats `thenRn` \ (pats', pat_fvs) ->
191 rnGRHSs grhss `thenRn` \ (grhss', grhss_fvs) ->
192 (case maybe_rhs_sig of
193 Nothing -> returnRn (Nothing, emptyFVs)
194 Just ty | opt_GlasgowExts -> rnHsPolyType doc_sig ty `thenRn` \ (ty', ty_fvs) ->
195 returnRn (Just ty', ty_fvs)
196 | otherwise -> addErrRn (patSigErr ty) `thenRn_`
197 returnRn (Nothing, emptyFVs)
198 ) `thenRn` \ (maybe_rhs_sig', ty_fvs) ->
201 binder_set = mkNameSet new_binders
202 unused_binders = nameSetToList (binder_set `minusNameSet` grhss_fvs)
203 all_fvs = grhss_fvs `plusFV` pat_fvs `plusFV` ty_fvs
205 warnUnusedMatches unused_binders `thenRn_`
207 returnRn (Match sig_tyvars pats' maybe_rhs_sig' grhss', all_fvs)
208 -- The bindLocals and bindTyVars will remove the bound FVs
211 %************************************************************************
213 \subsubsection{Guarded right-hand sides (GRHSs)}
215 %************************************************************************
218 rnGRHSs :: RdrNameGRHSs -> RnMS (RenamedGRHSs, FreeVars)
220 rnGRHSs (GRHSs grhss binds maybe_ty)
221 = ASSERT( not (maybeToBool maybe_ty) )
222 rnBinds binds $ \ binds' ->
223 mapFvRn rnGRHS grhss `thenRn` \ (grhss', fvGRHSs) ->
224 returnRn (GRHSs grhss' binds' Nothing, fvGRHSs)
226 rnGRHS (GRHS guarded locn)
227 = pushSrcLocRn locn $
228 (if not (opt_GlasgowExts || is_standard_guard guarded) then
229 addWarnRn (nonStdGuardErr guarded)
234 rnStmts rnExpr guarded `thenRn` \ (guarded', fvs) ->
235 returnRn (GRHS guarded' locn, fvs)
237 -- Standard Haskell 1.4 guards are just a single boolean
238 -- expression, rather than a list of qualifiers as in the
240 is_standard_guard [ExprStmt _ _] = True
241 is_standard_guard [GuardStmt _ _, ExprStmt _ _] = True
242 is_standard_guard other = False
245 %************************************************************************
247 \subsubsection{Expressions}
249 %************************************************************************
252 rnExprs :: [RdrNameHsExpr] -> RnMS ([RenamedHsExpr], FreeVars)
253 rnExprs ls = rnExprs' ls emptyUniqSet
255 rnExprs' [] acc = returnRn ([], acc)
256 rnExprs' (expr:exprs) acc
257 = rnExpr expr `thenRn` \ (expr', fvExpr) ->
259 -- Now we do a "seq" on the free vars because typically it's small
260 -- or empty, especially in very long lists of constants
262 acc' = acc `plusFV` fvExpr
264 (grubby_seqNameSet acc' rnExprs') exprs acc' `thenRn` \ (exprs', fvExprs) ->
265 returnRn (expr':exprs', fvExprs)
267 -- Grubby little function to do "seq" on namesets; replace by proper seq when GHC can do seq
268 grubby_seqNameSet ns result | isNullUFM ns = result
272 Variables. We look up the variable and return the resulting name.
275 rnExpr :: RdrNameHsExpr -> RnMS (RenamedHsExpr, FreeVars)
278 = lookupOccRn v `thenRn` \ name ->
279 if nameUnique name == assertIdKey then
280 -- We expand it to (GHCerr.assert__ location)
284 returnRn (HsVar name, unitFV name)
287 = getIPName v `thenRn` \ name ->
288 returnRn (HsIPVar name, emptyFVs)
291 = litOccurrence lit `thenRn` \ fvs ->
292 returnRn (HsLit lit, fvs)
295 = rnMatch match `thenRn` \ (match', fvMatch) ->
296 returnRn (HsLam match', fvMatch)
298 rnExpr (HsApp fun arg)
299 = rnExpr fun `thenRn` \ (fun',fvFun) ->
300 rnExpr arg `thenRn` \ (arg',fvArg) ->
301 returnRn (HsApp fun' arg', fvFun `plusFV` fvArg)
303 rnExpr (OpApp e1 op _ e2)
304 = rnExpr e1 `thenRn` \ (e1', fv_e1) ->
305 rnExpr e2 `thenRn` \ (e2', fv_e2) ->
306 rnExpr op `thenRn` \ (op'@(HsVar op_name), fv_op) ->
309 -- When renaming code synthesised from "deriving" declarations
310 -- we're in Interface mode, and we should ignore fixity; assume
311 -- that the deriving code generator got the association correct
312 -- Don't even look up the fixity when in interface mode
313 getModeRn `thenRn` \ mode ->
315 SourceMode -> lookupFixity op_name `thenRn` \ fixity ->
316 mkOpAppRn e1' op' fixity e2'
317 InterfaceMode -> returnRn (OpApp e1' op' defaultFixity e2')
318 ) `thenRn` \ final_e ->
321 fv_e1 `plusFV` fv_op `plusFV` fv_e2)
323 -- constant-fold some negate applications on unboxed literals. Since
324 -- negate is a polymorphic function, we have to do these here.
325 rnExpr (NegApp (HsLit (HsIntPrim i)) _) = rnExpr (HsLit (HsIntPrim (-i)))
326 rnExpr (NegApp (HsLit (HsFloatPrim i)) _) = rnExpr (HsLit (HsFloatPrim (-i)))
327 rnExpr (NegApp (HsLit (HsDoublePrim i)) _) = rnExpr (HsLit (HsDoublePrim (-i)))
330 = rnExpr e `thenRn` \ (e', fv_e) ->
331 lookupImplicitOccRn negate_RDR `thenRn` \ neg ->
332 mkNegAppRn e' (HsVar neg) `thenRn` \ final_e ->
333 returnRn (final_e, fv_e `addOneFV` neg)
336 = rnExpr e `thenRn` \ (e', fvs_e) ->
337 returnRn (HsPar e', fvs_e)
339 rnExpr section@(SectionL expr op)
340 = rnExpr expr `thenRn` \ (expr', fvs_expr) ->
341 rnExpr op `thenRn` \ (op', fvs_op) ->
342 checkSectionPrec "left" section op' expr' `thenRn_`
343 returnRn (SectionL expr' op', fvs_op `plusFV` fvs_expr)
345 rnExpr section@(SectionR op expr)
346 = rnExpr op `thenRn` \ (op', fvs_op) ->
347 rnExpr expr `thenRn` \ (expr', fvs_expr) ->
348 checkSectionPrec "right" section op' expr' `thenRn_`
349 returnRn (SectionR op' expr', fvs_op `plusFV` fvs_expr)
351 rnExpr (HsCCall fun args may_gc is_casm fake_result_ty)
352 -- Check out the comment on RnIfaces.getNonWiredDataDecl about ccalls
353 = lookupImplicitOccRn ccallableClass_RDR `thenRn` \ cc ->
354 lookupImplicitOccRn creturnableClass_RDR `thenRn` \ cr ->
355 lookupImplicitOccRn ioDataCon_RDR `thenRn` \ io ->
356 rnExprs args `thenRn` \ (args', fvs_args) ->
357 returnRn (HsCCall fun args' may_gc is_casm fake_result_ty,
358 fvs_args `addOneFV` cc `addOneFV` cr `addOneFV` io)
360 rnExpr (HsSCC lbl expr)
361 = rnExpr expr `thenRn` \ (expr', fvs_expr) ->
362 returnRn (HsSCC lbl expr', fvs_expr)
364 rnExpr (HsCase expr ms src_loc)
365 = pushSrcLocRn src_loc $
366 rnExpr expr `thenRn` \ (new_expr, e_fvs) ->
367 mapFvRn rnMatch ms `thenRn` \ (new_ms, ms_fvs) ->
368 returnRn (HsCase new_expr new_ms src_loc, e_fvs `plusFV` ms_fvs)
370 rnExpr (HsLet binds expr)
371 = rnBinds binds $ \ binds' ->
372 rnExpr expr `thenRn` \ (expr',fvExpr) ->
373 returnRn (HsLet binds' expr', fvExpr)
375 rnExpr (HsWith expr binds)
376 = rnExpr expr `thenRn` \ (expr',fvExpr) ->
377 rnIPBinds binds `thenRn` \ (binds',fvBinds) ->
378 returnRn (HsWith expr' binds', fvExpr `plusFV` fvBinds)
380 rnExpr e@(HsDo do_or_lc stmts src_loc)
381 = pushSrcLocRn src_loc $
382 lookupImplicitOccRn monadClass_RDR `thenRn` \ monad ->
383 rnStmts rnExpr stmts `thenRn` \ (stmts', fvs) ->
384 -- check the statement list ends in an expression
385 case last stmts' of {
386 ExprStmt _ _ -> returnRn () ;
387 ReturnStmt _ -> returnRn () ; -- for list comprehensions
388 _ -> addErrRn (doStmtListErr e)
390 returnRn (HsDo do_or_lc stmts' src_loc, fvs `addOneFV` monad)
392 rnExpr (ExplicitList exps)
393 = rnExprs exps `thenRn` \ (exps', fvs) ->
394 returnRn (ExplicitList exps', fvs `addOneFV` listTyCon_name)
396 rnExpr (ExplicitTuple exps boxed)
397 = rnExprs exps `thenRn` \ (exps', fvs) ->
398 returnRn (ExplicitTuple exps' boxed, fvs `addOneFV` tycon_name)
400 tycon_name = tupleTyCon_name boxed (length exps)
402 rnExpr (RecordCon con_id rbinds)
403 = lookupOccRn con_id `thenRn` \ conname ->
404 rnRbinds "construction" rbinds `thenRn` \ (rbinds', fvRbinds) ->
405 returnRn (RecordCon conname rbinds', fvRbinds `addOneFV` conname)
407 rnExpr (RecordUpd expr rbinds)
408 = rnExpr expr `thenRn` \ (expr', fvExpr) ->
409 rnRbinds "update" rbinds `thenRn` \ (rbinds', fvRbinds) ->
410 returnRn (RecordUpd expr' rbinds', fvExpr `plusFV` fvRbinds)
412 rnExpr (ExprWithTySig expr pty)
413 = rnExpr expr `thenRn` \ (expr', fvExpr) ->
414 rnHsSigType (text "an expression") pty `thenRn` \ (pty', fvTy) ->
415 returnRn (ExprWithTySig expr' pty', fvExpr `plusFV` fvTy)
417 rnExpr (HsIf p b1 b2 src_loc)
418 = pushSrcLocRn src_loc $
419 rnExpr p `thenRn` \ (p', fvP) ->
420 rnExpr b1 `thenRn` \ (b1', fvB1) ->
421 rnExpr b2 `thenRn` \ (b2', fvB2) ->
422 returnRn (HsIf p' b1' b2' src_loc, plusFVs [fvP, fvB1, fvB2])
424 rnExpr (ArithSeqIn seq)
425 = lookupImplicitOccRn enumClass_RDR `thenRn` \ enum ->
426 rn_seq seq `thenRn` \ (new_seq, fvs) ->
427 returnRn (ArithSeqIn new_seq, fvs `addOneFV` enum)
430 = rnExpr expr `thenRn` \ (expr', fvExpr) ->
431 returnRn (From expr', fvExpr)
433 rn_seq (FromThen expr1 expr2)
434 = rnExpr expr1 `thenRn` \ (expr1', fvExpr1) ->
435 rnExpr expr2 `thenRn` \ (expr2', fvExpr2) ->
436 returnRn (FromThen expr1' expr2', fvExpr1 `plusFV` fvExpr2)
438 rn_seq (FromTo expr1 expr2)
439 = rnExpr expr1 `thenRn` \ (expr1', fvExpr1) ->
440 rnExpr expr2 `thenRn` \ (expr2', fvExpr2) ->
441 returnRn (FromTo expr1' expr2', fvExpr1 `plusFV` fvExpr2)
443 rn_seq (FromThenTo expr1 expr2 expr3)
444 = rnExpr expr1 `thenRn` \ (expr1', fvExpr1) ->
445 rnExpr expr2 `thenRn` \ (expr2', fvExpr2) ->
446 rnExpr expr3 `thenRn` \ (expr3', fvExpr3) ->
447 returnRn (FromThenTo expr1' expr2' expr3',
448 plusFVs [fvExpr1, fvExpr2, fvExpr3])
451 These three are pattern syntax appearing in expressions.
452 Since all the symbols are reservedops we can simply reject them.
453 We return a (bogus) EWildPat in each case.
456 rnExpr e@EWildPat = addErrRn (patSynErr e) `thenRn_`
457 returnRn (EWildPat, emptyFVs)
459 rnExpr e@(EAsPat _ _) = addErrRn (patSynErr e) `thenRn_`
460 returnRn (EWildPat, emptyFVs)
462 rnExpr e@(ELazyPat _) = addErrRn (patSynErr e) `thenRn_`
463 returnRn (EWildPat, emptyFVs)
466 %************************************************************************
468 \subsubsection{@Rbinds@s and @Rpats@s: in record expressions}
470 %************************************************************************
474 = mapRn_ field_dup_err dup_fields `thenRn_`
475 mapFvRn rn_rbind rbinds `thenRn` \ (rbinds', fvRbind) ->
476 returnRn (rbinds', fvRbind)
478 (_, dup_fields) = removeDups compare [ f | (f,_,_) <- rbinds ]
480 field_dup_err dups = addErrRn (dupFieldErr str dups)
482 rn_rbind (field, expr, pun)
483 = lookupGlobalOccRn field `thenRn` \ fieldname ->
484 rnExpr expr `thenRn` \ (expr', fvExpr) ->
485 returnRn ((fieldname, expr', pun), fvExpr `addOneFV` fieldname)
488 = mapRn_ field_dup_err dup_fields `thenRn_`
489 mapFvRn rn_rpat rpats `thenRn` \ (rpats', fvs) ->
490 returnRn (rpats', fvs)
492 (_, dup_fields) = removeDups compare [ f | (f,_,_) <- rpats ]
494 field_dup_err dups = addErrRn (dupFieldErr "pattern" dups)
496 rn_rpat (field, pat, pun)
497 = lookupGlobalOccRn field `thenRn` \ fieldname ->
498 rnPat pat `thenRn` \ (pat', fvs) ->
499 returnRn ((fieldname, pat', pun), fvs `addOneFV` fieldname)
502 %************************************************************************
504 \subsubsection{@rnIPBinds@s: in implicit parameter bindings} *
506 %************************************************************************
509 rnIPBinds [] = returnRn ([], emptyFVs)
510 rnIPBinds ((n, expr) : binds)
511 = getIPName n `thenRn` \ name ->
512 rnExpr expr `thenRn` \ (expr',fvExpr) ->
513 rnIPBinds binds `thenRn` \ (binds',fvBinds) ->
514 returnRn ((name, expr') : binds', fvExpr `plusFV` fvBinds)
518 %************************************************************************
520 \subsubsection{@Stmt@s: in @do@ expressions}
522 %************************************************************************
524 Note that although some bound vars may appear in the free var set for
525 the first qual, these will eventually be removed by the caller. For
526 example, if we have @[p | r <- s, q <- r, p <- q]@, when doing
527 @[q <- r, p <- q]@, the free var set for @q <- r@ will
528 be @{r}@, and the free var set for the entire Quals will be @{r}@. This
529 @r@ will be removed only when we finally return from examining all the
533 type RnExprTy = RdrNameHsExpr -> RnMS (RenamedHsExpr, FreeVars)
537 -> RnMS ([RenamedStmt], FreeVars)
540 = returnRn ([], emptyFVs)
542 rnStmts rn_expr (stmt:stmts)
543 = rnStmt rn_expr stmt $ \ stmt' ->
544 rnStmts rn_expr stmts `thenRn` \ (stmts', fvs) ->
545 returnRn (stmt' : stmts', fvs)
547 rnStmt :: RnExprTy -> RdrNameStmt
548 -> (RenamedStmt -> RnMS (a, FreeVars))
549 -> RnMS (a, FreeVars)
550 -- Because of mutual recursion we have to pass in rnExpr.
552 rnStmt rn_expr (BindStmt pat expr src_loc) thing_inside
553 = pushSrcLocRn src_loc $
554 rn_expr expr `thenRn` \ (expr', fv_expr) ->
555 bindLocalsFVRn doc binders $ \ new_binders ->
556 rnPat pat `thenRn` \ (pat', fv_pat) ->
557 thing_inside (BindStmt pat' expr' src_loc) `thenRn` \ (result, fvs) ->
558 returnRn (result, fv_expr `plusFV` fvs `plusFV` fv_pat)
560 binders = collectPatBinders pat
561 doc = text "a pattern in do binding"
563 rnStmt rn_expr (ExprStmt expr src_loc) thing_inside
564 = pushSrcLocRn src_loc $
565 rn_expr expr `thenRn` \ (expr', fv_expr) ->
566 thing_inside (ExprStmt expr' src_loc) `thenRn` \ (result, fvs) ->
567 returnRn (result, fv_expr `plusFV` fvs)
569 rnStmt rn_expr (GuardStmt expr src_loc) thing_inside
570 = pushSrcLocRn src_loc $
571 rn_expr expr `thenRn` \ (expr', fv_expr) ->
572 thing_inside (GuardStmt expr' src_loc) `thenRn` \ (result, fvs) ->
573 returnRn (result, fv_expr `plusFV` fvs)
575 rnStmt rn_expr (ReturnStmt expr) thing_inside
576 = rn_expr expr `thenRn` \ (expr', fv_expr) ->
577 thing_inside (ReturnStmt expr') `thenRn` \ (result, fvs) ->
578 returnRn (result, fv_expr `plusFV` fvs)
580 rnStmt rn_expr (LetStmt binds) thing_inside
581 = rnBinds binds $ \ binds' ->
582 thing_inside (LetStmt binds')
585 %************************************************************************
587 \subsubsection{Precedence Parsing}
589 %************************************************************************
591 @mkOpAppRn@ deals with operator fixities. The argument expressions
592 are assumed to be already correctly arranged. It needs the fixities
593 recorded in the OpApp nodes, because fixity info applies to the things
594 the programmer actually wrote, so you can't find it out from the Name.
596 Furthermore, the second argument is guaranteed not to be another
597 operator application. Why? Because the parser parses all
598 operator appications left-associatively, EXCEPT negation, which
599 we need to handle specially.
602 mkOpAppRn :: RenamedHsExpr -- Left operand; already rearranged
603 -> RenamedHsExpr -> Fixity -- Operator and fixity
604 -> RenamedHsExpr -- Right operand (not an OpApp, but might
606 -> RnMS RenamedHsExpr
608 ---------------------------
609 -- (e11 `op1` e12) `op2` e2
610 mkOpAppRn e1@(OpApp e11 op1 fix1 e12) op2 fix2 e2
612 = addErrRn (precParseErr (ppr_op op1,fix1) (ppr_op op2,fix2)) `thenRn_`
613 returnRn (OpApp e1 op2 fix2 e2)
616 = mkOpAppRn e12 op2 fix2 e2 `thenRn` \ new_e ->
617 returnRn (OpApp e11 op1 fix1 new_e)
619 (nofix_error, associate_right) = compareFixity fix1 fix2
621 ---------------------------
622 -- (- neg_arg) `op` e2
623 mkOpAppRn e1@(NegApp neg_arg neg_op) op2 fix2 e2
625 = addErrRn (precParseErr (pp_prefix_minus,negateFixity) (ppr_op op2,fix2)) `thenRn_`
626 returnRn (OpApp e1 op2 fix2 e2)
629 = mkOpAppRn neg_arg op2 fix2 e2 `thenRn` \ new_e ->
630 returnRn (NegApp new_e neg_op)
632 (nofix_error, associate_right) = compareFixity negateFixity fix2
634 ---------------------------
636 mkOpAppRn e1 op1 fix1 e2@(NegApp neg_arg neg_op) -- NegApp can occur on the right
637 | not associate_right -- We *want* right association
638 = addErrRn (precParseErr (ppr_op op1, fix1) (pp_prefix_minus, negateFixity)) `thenRn_`
639 returnRn (OpApp e1 op1 fix1 e2)
641 (_, associate_right) = compareFixity fix1 negateFixity
643 ---------------------------
645 mkOpAppRn e1 op fix e2 -- Default case, no rearrangment
646 = ASSERT2( right_op_ok fix e2,
647 ppr e1 $$ text "---" $$ ppr op $$ text "---" $$ ppr fix $$ text "---" $$ ppr e2
649 returnRn (OpApp e1 op fix e2)
651 -- Parser left-associates everything, but
652 -- derived instances may have correctly-associated things to
653 -- in the right operarand. So we just check that the right operand is OK
654 right_op_ok fix1 (OpApp _ _ fix2 _)
655 = not error_please && associate_right
657 (error_please, associate_right) = compareFixity fix1 fix2
658 right_op_ok fix1 other
661 -- Parser initially makes negation bind more tightly than any other operator
662 mkNegAppRn neg_arg neg_op
665 getModeRn `thenRn` \ mode ->
666 ASSERT( not_op_app mode neg_arg )
668 returnRn (NegApp neg_arg neg_op)
670 not_op_app SourceMode (OpApp _ _ _ _) = False
671 not_op_app mode other = True
675 mkConOpPatRn :: RenamedPat -> Name -> Fixity -> RenamedPat
678 mkConOpPatRn p1@(ConOpPatIn p11 op1 fix1 p12)
681 = addErrRn (precParseErr (ppr_op op1,fix1) (ppr_op op2,fix2)) `thenRn_`
682 returnRn (ConOpPatIn p1 op2 fix2 p2)
685 = mkConOpPatRn p12 op2 fix2 p2 `thenRn` \ new_p ->
686 returnRn (ConOpPatIn p11 op1 fix1 new_p)
689 (nofix_error, associate_right) = compareFixity fix1 fix2
691 mkConOpPatRn p1@(NegPatIn neg_arg)
693 fix2@(Fixity prec2 dir2)
695 | prec2 > negatePrecedence -- Precedence of unary - is wired in
696 = addErrRn (precParseNegPatErr (ppr_op op2,fix2)) `thenRn_`
697 returnRn (ConOpPatIn p1 op2 fix2 p2)
699 mkConOpPatRn p1 op fix p2 -- Default case, no rearrangment
700 = ASSERT( not_op_pat p2 )
701 returnRn (ConOpPatIn p1 op fix p2)
703 not_op_pat (ConOpPatIn _ _ _ _) = False
704 not_op_pat other = True
708 checkPrecMatch :: Bool -> Name -> RenamedMatch -> RnMS ()
710 checkPrecMatch False fn match
713 checkPrecMatch True op (Match _ (p1:p2:_) _ _)
714 -- True indicates an infix lhs
715 = getModeRn `thenRn` \ mode ->
716 -- See comments with rnExpr (OpApp ...)
718 InterfaceMode -> returnRn ()
719 SourceMode -> checkPrec op p1 False `thenRn_`
722 checkPrecMatch True op _ = panic "checkPrecMatch"
724 checkPrec op (ConOpPatIn _ op1 _ _) right
725 = lookupFixity op `thenRn` \ op_fix@(Fixity op_prec op_dir) ->
726 lookupFixity op1 `thenRn` \ op1_fix@(Fixity op1_prec op1_dir) ->
728 inf_ok = op1_prec > op_prec ||
729 (op1_prec == op_prec &&
730 (op1_dir == InfixR && op_dir == InfixR && right ||
731 op1_dir == InfixL && op_dir == InfixL && not right))
733 info = (ppr_op op, op_fix)
734 info1 = (ppr_op op1, op1_fix)
735 (infol, infor) = if right then (info, info1) else (info1, info)
737 checkRn inf_ok (precParseErr infol infor)
739 checkPrec op (NegPatIn _) right
740 = lookupFixity op `thenRn` \ op_fix@(Fixity op_prec op_dir) ->
741 checkRn (op_prec <= negatePrecedence) (precParseNegPatErr (ppr_op op,op_fix))
743 checkPrec op pat right
746 -- Check precedence of (arg op) or (op arg) respectively
747 -- If arg is itself an operator application, its precedence should
748 -- be higher than that of op
749 checkSectionPrec left_or_right section op arg
751 OpApp _ op fix _ -> go_for_it (ppr_op op) fix
752 NegApp _ op -> go_for_it pp_prefix_minus negateFixity
756 go_for_it pp_arg_op arg_fix@(Fixity arg_prec _)
757 = lookupFixity op_name `thenRn` \ op_fix@(Fixity op_prec _) ->
758 checkRn (op_prec < arg_prec)
759 (sectionPrecErr (ppr_op op_name, op_fix) (pp_arg_op, arg_fix) section)
766 @(compareFixity op1 op2)@ tells which way to arrange appication, or
767 whether there's an error.
770 compareFixity :: Fixity -> Fixity
771 -> (Bool, -- Error please
772 Bool) -- Associate to the right: a op1 (b op2 c)
773 compareFixity (Fixity prec1 dir1) (Fixity prec2 dir2)
774 = case prec1 `compare` prec2 of
777 EQ -> case (dir1, dir2) of
778 (InfixR, InfixR) -> right
779 (InfixL, InfixL) -> left
782 right = (False, True)
783 left = (False, False)
784 error_please = (True, False)
787 %************************************************************************
789 \subsubsection{Literals}
791 %************************************************************************
793 When literals occur we have to make sure
794 that the types and classes they involve
798 litOccurrence (HsChar _)
799 = returnRn (unitFV charTyCon_name)
801 litOccurrence (HsCharPrim _)
802 = returnRn (unitFV (getName charPrimTyCon))
804 litOccurrence (HsString _)
805 = returnRn (unitFV listTyCon_name `plusFV` unitFV charTyCon_name)
807 litOccurrence (HsStringPrim _)
808 = returnRn (unitFV (getName addrPrimTyCon))
810 litOccurrence (HsInt _)
811 = lookupImplicitOccRn numClass_RDR `thenRn` \ num ->
812 returnRn (unitFV num) -- Int and Integer are forced in by Num
814 litOccurrence (HsFrac _)
815 = lookupImplicitOccRn fractionalClass_RDR `thenRn` \ frac ->
816 lookupImplicitOccRn ratioDataCon_RDR `thenRn` \ ratio ->
817 returnRn (unitFV frac `plusFV` unitFV ratio)
818 -- We have to make sure that the Ratio type is imported with
819 -- its constructor, because literals of type Ratio t are
820 -- built with that constructor.
821 -- The Rational type is needed too, but that will come in
822 -- when fractionalClass does.
824 litOccurrence (HsIntPrim _)
825 = returnRn (unitFV (getName intPrimTyCon))
827 litOccurrence (HsFloatPrim _)
828 = returnRn (unitFV (getName floatPrimTyCon))
830 litOccurrence (HsDoublePrim _)
831 = returnRn (unitFV (getName doublePrimTyCon))
833 litOccurrence (HsLitLit _)
834 = lookupImplicitOccRn ccallableClass_RDR `thenRn` \ cc ->
838 %************************************************************************
840 \subsubsection{Assertion utils}
842 %************************************************************************
845 mkAssertExpr :: RnMS (RenamedHsExpr, FreeVars)
847 mkImportedGlobalFromRdrName assertErr_RDR `thenRn` \ name ->
848 getSrcLocRn `thenRn` \ sloc ->
850 -- if we're ignoring asserts, return (\ _ e -> e)
851 -- if not, return (assertError "src-loc")
853 if opt_IgnoreAsserts then
854 getUniqRn `thenRn` \ uniq ->
856 vname = mkSysLocalName uniq SLIT("v")
857 expr = HsLam ignorePredMatch
858 loc = nameSrcLoc vname
859 ignorePredMatch = Match [] [WildPatIn, VarPatIn vname] Nothing
860 (GRHSs [GRHS [ExprStmt (HsVar vname) loc] loc]
863 returnRn (expr, unitFV name)
868 (HsLit (HsString (_PK_ (showSDoc (ppr sloc)))))
871 returnRn (expr, unitFV name)
875 %************************************************************************
877 \subsubsection{Errors}
879 %************************************************************************
882 ppr_op op = quotes (ppr op) -- Here, op can be a Name or a (Var n), where n is a Name
883 ppr_opfix (pp_op, fixity) = pp_op <+> brackets (ppr fixity)
884 pp_prefix_minus = ptext SLIT("prefix `-'")
886 dupFieldErr str (dup:rest)
887 = hsep [ptext SLIT("duplicate field name"),
889 ptext SLIT("in record"), text str]
892 = sep [pp_prefix_minus <+> ptext SLIT("not applied to literal in pattern"),
895 precParseNegPatErr op
896 = hang (ptext SLIT("precedence parsing error"))
897 4 (hsep [pp_prefix_minus <+> ptext SLIT("has lower precedence than"),
899 ptext SLIT("in pattern")])
902 = hang (ptext SLIT("precedence parsing error"))
903 4 (hsep [ptext SLIT("cannot mix"), ppr_opfix op1, ptext SLIT("and"),
905 ptext SLIT("in the same infix expression")])
907 sectionPrecErr op arg_op section
908 = vcat [ptext SLIT("The operator") <+> ppr_opfix op <+> ptext SLIT("of a section"),
909 nest 4 (ptext SLIT("must have lower precedence than the operand") <+> ppr_opfix arg_op),
910 nest 4 (ptext SLIT("In the section:") <+> quotes (ppr section))]
914 SLIT("accepting non-standard pattern guards (-fglasgow-exts to suppress this message)")
918 = (ptext SLIT("Illegal signature in pattern:") <+> ppr ty)
919 $$ nest 4 (ptext SLIT("Use -fglasgow-exts to permit it"))
922 = sep [ptext SLIT("Pattern syntax in expression context:"),
926 = sep [ptext SLIT("`do' statements must end in expression:"),