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, rnStmt,
18 #include "HsVersions.h"
20 import {-# SOURCE #-} RnBinds ( rnBinds )
21 import {-# SOURCE #-} RnSource ( rnHsTypeFVs )
28 import RnHiFiles ( lookupFixityRn )
29 import CmdLineOpts ( DynFlag(..), opt_IgnoreAsserts )
30 import Literal ( inIntRange, inCharRange )
31 import BasicTypes ( Fixity(..), FixityDirection(..), defaultFixity, negateFixity )
32 import PrelNames ( hasKey, assertIdKey, minusName, negateName, fromIntegerName,
33 eqClass_RDR, foldr_RDR, build_RDR, eqString_RDR,
34 cCallableClass_RDR, cReturnableClass_RDR,
35 monadClass_RDR, enumClass_RDR, ordClass_RDR,
36 ratioDataCon_RDR, assertErr_RDR,
37 ioDataCon_RDR, plusInteger_RDR, timesInteger_RDR,
38 fromInteger_RDR, fromRational_RDR,
40 import TysPrim ( charPrimTyCon, addrPrimTyCon, intPrimTyCon,
41 floatPrimTyCon, doublePrimTyCon
43 import TysWiredIn ( intTyCon )
44 import Name ( NamedThing(..), mkSysLocalName, nameSrcLoc )
46 import UniqFM ( isNullUFM )
47 import FiniteMap ( elemFM )
48 import UniqSet ( emptyUniqSet )
49 import List ( intersectBy )
50 import ListSetOps ( unionLists, removeDups )
51 import Maybes ( maybeToBool )
56 *********************************************************
60 *********************************************************
63 rnPat :: RdrNamePat -> RnMS (RenamedPat, FreeVars)
65 rnPat WildPatIn = returnRn (WildPatIn, emptyFVs)
68 = lookupBndrRn name `thenRn` \ vname ->
69 returnRn (VarPatIn vname, emptyFVs)
71 rnPat (SigPatIn pat ty)
72 = doptRn Opt_GlasgowExts `thenRn` \ glaExts ->
75 then rnPat pat `thenRn` \ (pat', fvs1) ->
76 rnHsTypeFVs doc ty `thenRn` \ (ty', fvs2) ->
77 returnRn (SigPatIn pat' ty', fvs1 `plusFV` fvs2)
79 else addErrRn (patSigErr ty) `thenRn_`
82 doc = text "a pattern type-signature"
84 rnPat (LitPatIn s@(HsString _))
85 = lookupOrigName eqString_RDR `thenRn` \ eq ->
86 returnRn (LitPatIn s, unitFV eq)
89 = litFVs lit `thenRn` \ fvs ->
90 returnRn (LitPatIn lit, fvs)
93 = rnOverLit lit `thenRn` \ (lit', fvs1) ->
94 lookupOrigName eqClass_RDR `thenRn` \ eq -> -- Needed to find equality on pattern
95 returnRn (NPatIn lit', fvs1 `addOneFV` eq)
97 rnPat (NPlusKPatIn name lit)
98 = rnOverLit lit `thenRn` \ (lit', fvs) ->
99 lookupOrigName ordClass_RDR `thenRn` \ ord ->
100 lookupBndrRn name `thenRn` \ name' ->
101 returnRn (NPlusKPatIn name' lit', fvs `addOneFV` ord `addOneFV` minusName)
103 rnPat (LazyPatIn pat)
104 = rnPat pat `thenRn` \ (pat', fvs) ->
105 returnRn (LazyPatIn pat', fvs)
107 rnPat (AsPatIn name pat)
108 = rnPat pat `thenRn` \ (pat', fvs) ->
109 lookupBndrRn name `thenRn` \ vname ->
110 returnRn (AsPatIn vname pat', fvs)
112 rnPat (ConPatIn con pats)
113 = lookupOccRn con `thenRn` \ con' ->
114 mapFvRn rnPat pats `thenRn` \ (patslist, fvs) ->
115 returnRn (ConPatIn con' patslist, fvs `addOneFV` con')
117 rnPat (ConOpPatIn pat1 con _ pat2)
118 = rnPat pat1 `thenRn` \ (pat1', fvs1) ->
119 lookupOccRn con `thenRn` \ con' ->
120 rnPat pat2 `thenRn` \ (pat2', fvs2) ->
122 getModeRn `thenRn` \ mode ->
123 -- See comments with rnExpr (OpApp ...)
124 (if isInterfaceMode mode
125 then returnRn (ConOpPatIn pat1' con' defaultFixity pat2')
126 else lookupFixityRn con' `thenRn` \ fixity ->
127 mkConOpPatRn pat1' con' fixity pat2'
129 returnRn (pat', fvs1 `plusFV` fvs2 `addOneFV` con')
132 = rnPat pat `thenRn` \ (pat', fvs) ->
133 returnRn (ParPatIn pat', fvs)
135 rnPat (ListPatIn pats)
136 = mapFvRn rnPat pats `thenRn` \ (patslist, fvs) ->
137 returnRn (ListPatIn patslist, fvs `addOneFV` listTyCon_name)
139 rnPat (TuplePatIn pats boxed)
140 = mapFvRn rnPat pats `thenRn` \ (patslist, fvs) ->
141 returnRn (TuplePatIn patslist boxed, fvs `addOneFV` tycon_name)
143 tycon_name = tupleTyCon_name boxed (length pats)
145 rnPat (RecPatIn con rpats)
146 = lookupOccRn con `thenRn` \ con' ->
147 rnRpats rpats `thenRn` \ (rpats', fvs) ->
148 returnRn (RecPatIn con' rpats', fvs `addOneFV` con')
150 rnPat (TypePatIn name) =
151 rnHsTypeFVs (text "type pattern") name `thenRn` \ (name', fvs) ->
152 returnRn (TypePatIn name', fvs)
155 ************************************************************************
159 ************************************************************************
162 rnMatch :: HsMatchContext RdrName -> RdrNameMatch -> RnMS (RenamedMatch, FreeVars)
164 rnMatch ctxt match@(Match _ pats maybe_rhs_sig grhss)
165 = pushSrcLocRn (getMatchLoc match) $
167 -- Bind pattern-bound type variables
169 rhs_sig_tys = case maybe_rhs_sig of
172 pat_sig_tys = collectSigTysFromPats pats
173 doc_sig = text "In a result type-signature"
174 doc_pat = pprMatchContext ctxt
176 bindPatSigTyVars (rhs_sig_tys ++ pat_sig_tys) $ \ sig_tyvars ->
178 -- Note that we do a single bindLocalsRn for all the
179 -- matches together, so that we spot the repeated variable in
181 bindLocalsFVRn doc_pat (collectPatsBinders pats) $ \ new_binders ->
183 mapFvRn rnPat pats `thenRn` \ (pats', pat_fvs) ->
184 rnGRHSs grhss `thenRn` \ (grhss', grhss_fvs) ->
185 doptRn Opt_GlasgowExts `thenRn` \ opt_GlasgowExts ->
186 (case maybe_rhs_sig of
187 Nothing -> returnRn (Nothing, emptyFVs)
188 Just ty | opt_GlasgowExts -> rnHsTypeFVs doc_sig ty `thenRn` \ (ty', ty_fvs) ->
189 returnRn (Just ty', ty_fvs)
190 | otherwise -> addErrRn (patSigErr ty) `thenRn_`
191 returnRn (Nothing, emptyFVs)
192 ) `thenRn` \ (maybe_rhs_sig', ty_fvs) ->
195 binder_set = mkNameSet new_binders
196 unused_binders = nameSetToList (binder_set `minusNameSet` grhss_fvs)
197 all_fvs = grhss_fvs `plusFV` pat_fvs `plusFV` ty_fvs
199 warnUnusedMatches unused_binders `thenRn_`
201 returnRn (Match sig_tyvars pats' maybe_rhs_sig' grhss', all_fvs)
202 -- The bindLocals and bindTyVars will remove the bound FVs
205 bindPatSigTyVars :: [RdrNameHsType]
206 -> ([Name] -> RnMS (a, FreeVars))
207 -> RnMS (a, FreeVars)
208 -- Find the type variables in the pattern type
209 -- signatures that must be brought into scope
210 bindPatSigTyVars tys thing_inside
211 = getLocalNameEnv `thenRn` \ name_env ->
213 tyvars_in_sigs = extractHsTysRdrTyVars tys
214 forall_tyvars = filter (not . (`elemFM` name_env)) tyvars_in_sigs
215 doc_sig = text "In a pattern type-signature"
217 bindNakedTyVarsFVRn doc_sig forall_tyvars thing_inside
220 %************************************************************************
222 \subsubsection{Guarded right-hand sides (GRHSs)}
224 %************************************************************************
227 rnGRHSs :: RdrNameGRHSs -> RnMS (RenamedGRHSs, FreeVars)
229 rnGRHSs (GRHSs grhss binds maybe_ty)
230 = ASSERT( not (maybeToBool maybe_ty) )
231 rnBinds binds $ \ binds' ->
232 mapFvRn rnGRHS grhss `thenRn` \ (grhss', fvGRHSs) ->
233 returnRn (GRHSs grhss' binds' Nothing, fvGRHSs)
235 rnGRHS (GRHS guarded locn)
236 = doptRn Opt_GlasgowExts `thenRn` \ opt_GlasgowExts ->
238 (if not (opt_GlasgowExts || is_standard_guard guarded) then
239 addWarnRn (nonStdGuardErr guarded)
244 rnStmts guarded `thenRn` \ ((_, guarded'), fvs) ->
245 returnRn (GRHS guarded' locn, fvs)
247 -- Standard Haskell 1.4 guards are just a single boolean
248 -- expression, rather than a list of qualifiers as in the
250 is_standard_guard [ResultStmt _ _] = True
251 is_standard_guard [ExprStmt _ _, ResultStmt _ _] = True
252 is_standard_guard other = False
255 %************************************************************************
257 \subsubsection{Expressions}
259 %************************************************************************
262 rnExprs :: [RdrNameHsExpr] -> RnMS ([RenamedHsExpr], FreeVars)
263 rnExprs ls = rnExprs' ls emptyUniqSet
265 rnExprs' [] acc = returnRn ([], acc)
266 rnExprs' (expr:exprs) acc
267 = rnExpr expr `thenRn` \ (expr', fvExpr) ->
269 -- Now we do a "seq" on the free vars because typically it's small
270 -- or empty, especially in very long lists of constants
272 acc' = acc `plusFV` fvExpr
274 (grubby_seqNameSet acc' rnExprs') exprs acc' `thenRn` \ (exprs', fvExprs) ->
275 returnRn (expr':exprs', fvExprs)
277 -- Grubby little function to do "seq" on namesets; replace by proper seq when GHC can do seq
278 grubby_seqNameSet ns result | isNullUFM ns = result
282 Variables. We look up the variable and return the resulting name.
285 rnExpr :: RdrNameHsExpr -> RnMS (RenamedHsExpr, FreeVars)
288 = lookupOccRn v `thenRn` \ name ->
289 if name `hasKey` assertIdKey then
290 -- We expand it to (GHCerr.assert__ location)
294 returnRn (HsVar name, unitFV name)
297 = newIPName v `thenRn` \ name ->
298 returnRn (HsIPVar name, emptyFVs)
301 = litFVs lit `thenRn` \ fvs ->
302 returnRn (HsLit lit, fvs)
304 rnExpr (HsOverLit lit)
305 = rnOverLit lit `thenRn` \ (lit', fvs) ->
306 returnRn (HsOverLit lit', fvs)
309 = rnMatch LambdaExpr match `thenRn` \ (match', fvMatch) ->
310 returnRn (HsLam match', fvMatch)
312 rnExpr (HsApp fun arg)
313 = rnExpr fun `thenRn` \ (fun',fvFun) ->
314 rnExpr arg `thenRn` \ (arg',fvArg) ->
315 returnRn (HsApp fun' arg', fvFun `plusFV` fvArg)
317 rnExpr (OpApp e1 op _ e2)
318 = rnExpr e1 `thenRn` \ (e1', fv_e1) ->
319 rnExpr e2 `thenRn` \ (e2', fv_e2) ->
320 rnExpr op `thenRn` \ (op'@(HsVar op_name), fv_op) ->
323 -- When renaming code synthesised from "deriving" declarations
324 -- we're in Interface mode, and we should ignore fixity; assume
325 -- that the deriving code generator got the association correct
326 -- Don't even look up the fixity when in interface mode
327 getModeRn `thenRn` \ mode ->
328 (if isInterfaceMode mode
329 then returnRn (OpApp e1' op' defaultFixity e2')
330 else lookupFixityRn op_name `thenRn` \ fixity ->
331 mkOpAppRn e1' op' fixity e2'
332 ) `thenRn` \ final_e ->
335 fv_e1 `plusFV` fv_op `plusFV` fv_e2)
338 = rnExpr e `thenRn` \ (e', fv_e) ->
339 mkNegAppRn e' `thenRn` \ final_e ->
340 returnRn (final_e, fv_e `addOneFV` negateName)
343 = rnExpr e `thenRn` \ (e', fvs_e) ->
344 returnRn (HsPar e', fvs_e)
346 rnExpr section@(SectionL expr op)
347 = rnExpr expr `thenRn` \ (expr', fvs_expr) ->
348 rnExpr op `thenRn` \ (op', fvs_op) ->
349 checkSectionPrec "left" section op' expr' `thenRn_`
350 returnRn (SectionL expr' op', fvs_op `plusFV` fvs_expr)
352 rnExpr section@(SectionR op expr)
353 = rnExpr op `thenRn` \ (op', fvs_op) ->
354 rnExpr expr `thenRn` \ (expr', fvs_expr) ->
355 checkSectionPrec "right" section op' expr' `thenRn_`
356 returnRn (SectionR op' expr', fvs_op `plusFV` fvs_expr)
358 rnExpr (HsCCall fun args may_gc is_casm fake_result_ty)
359 -- Check out the comment on RnIfaces.getNonWiredDataDecl about ccalls
360 = lookupOrigNames [cCallableClass_RDR,
361 cReturnableClass_RDR,
362 ioDataCon_RDR] `thenRn` \ implicit_fvs ->
363 rnExprs args `thenRn` \ (args', fvs_args) ->
364 returnRn (HsCCall fun args' may_gc is_casm fake_result_ty,
365 fvs_args `plusFV` implicit_fvs)
367 rnExpr (HsSCC lbl expr)
368 = rnExpr expr `thenRn` \ (expr', fvs_expr) ->
369 returnRn (HsSCC lbl expr', fvs_expr)
371 rnExpr (HsCase expr ms src_loc)
372 = pushSrcLocRn src_loc $
373 rnExpr expr `thenRn` \ (new_expr, e_fvs) ->
374 mapFvRn (rnMatch CaseAlt) ms `thenRn` \ (new_ms, ms_fvs) ->
375 returnRn (HsCase new_expr new_ms src_loc, e_fvs `plusFV` ms_fvs)
377 rnExpr (HsLet binds expr)
378 = rnBinds binds $ \ binds' ->
379 rnExpr expr `thenRn` \ (expr',fvExpr) ->
380 returnRn (HsLet binds' expr', fvExpr)
382 rnExpr (HsWith expr binds)
383 = rnExpr expr `thenRn` \ (expr',fvExpr) ->
384 rnIPBinds binds `thenRn` \ (binds',fvBinds) ->
385 returnRn (HsWith expr' binds', fvExpr `plusFV` fvBinds)
387 rnExpr e@(HsDo do_or_lc stmts src_loc)
388 = pushSrcLocRn src_loc $
389 lookupOrigNames implicit_rdr_names `thenRn` \ implicit_fvs ->
390 rnStmts stmts `thenRn` \ ((_, stmts'), fvs) ->
391 -- check the statement list ends in an expression
392 case last stmts' of {
393 ResultStmt _ _ -> returnRn () ;
394 _ -> addErrRn (doStmtListErr e)
396 returnRn (HsDo do_or_lc stmts' src_loc, fvs `plusFV` implicit_fvs)
398 implicit_rdr_names = [foldr_RDR, build_RDR, monadClass_RDR]
399 -- Monad stuff should not be necessary for a list comprehension
400 -- but the typechecker looks up the bind and return Ids anyway
404 rnExpr (ExplicitList exps)
405 = rnExprs exps `thenRn` \ (exps', fvs) ->
406 returnRn (ExplicitList exps', fvs `addOneFV` listTyCon_name)
408 rnExpr (ExplicitTuple exps boxity)
409 = rnExprs exps `thenRn` \ (exps', fvs) ->
410 returnRn (ExplicitTuple exps' boxity, fvs `addOneFV` tycon_name)
412 tycon_name = tupleTyCon_name boxity (length exps)
414 rnExpr (RecordCon con_id rbinds)
415 = lookupOccRn con_id `thenRn` \ conname ->
416 rnRbinds "construction" rbinds `thenRn` \ (rbinds', fvRbinds) ->
417 returnRn (RecordCon conname rbinds', fvRbinds `addOneFV` conname)
419 rnExpr (RecordUpd expr rbinds)
420 = rnExpr expr `thenRn` \ (expr', fvExpr) ->
421 rnRbinds "update" rbinds `thenRn` \ (rbinds', fvRbinds) ->
422 returnRn (RecordUpd expr' rbinds', fvExpr `plusFV` fvRbinds)
424 rnExpr (ExprWithTySig expr pty)
425 = rnExpr expr `thenRn` \ (expr', fvExpr) ->
426 rnHsTypeFVs (text "an expression type signature") pty `thenRn` \ (pty', fvTy) ->
427 returnRn (ExprWithTySig expr' pty', fvExpr `plusFV` fvTy)
429 rnExpr (HsIf p b1 b2 src_loc)
430 = pushSrcLocRn src_loc $
431 rnExpr p `thenRn` \ (p', fvP) ->
432 rnExpr b1 `thenRn` \ (b1', fvB1) ->
433 rnExpr b2 `thenRn` \ (b2', fvB2) ->
434 returnRn (HsIf p' b1' b2' src_loc, plusFVs [fvP, fvB1, fvB2])
437 = rnHsTypeFVs doc a `thenRn` \ (t, fvT) ->
438 returnRn (HsType t, fvT)
440 doc = text "renaming a type pattern"
442 rnExpr (ArithSeqIn seq)
443 = lookupOrigName enumClass_RDR `thenRn` \ enum ->
444 rn_seq seq `thenRn` \ (new_seq, fvs) ->
445 returnRn (ArithSeqIn new_seq, fvs `addOneFV` enum)
448 = rnExpr expr `thenRn` \ (expr', fvExpr) ->
449 returnRn (From expr', fvExpr)
451 rn_seq (FromThen expr1 expr2)
452 = rnExpr expr1 `thenRn` \ (expr1', fvExpr1) ->
453 rnExpr expr2 `thenRn` \ (expr2', fvExpr2) ->
454 returnRn (FromThen expr1' expr2', fvExpr1 `plusFV` fvExpr2)
456 rn_seq (FromTo expr1 expr2)
457 = rnExpr expr1 `thenRn` \ (expr1', fvExpr1) ->
458 rnExpr expr2 `thenRn` \ (expr2', fvExpr2) ->
459 returnRn (FromTo expr1' expr2', fvExpr1 `plusFV` fvExpr2)
461 rn_seq (FromThenTo expr1 expr2 expr3)
462 = rnExpr expr1 `thenRn` \ (expr1', fvExpr1) ->
463 rnExpr expr2 `thenRn` \ (expr2', fvExpr2) ->
464 rnExpr expr3 `thenRn` \ (expr3', fvExpr3) ->
465 returnRn (FromThenTo expr1' expr2' expr3',
466 plusFVs [fvExpr1, fvExpr2, fvExpr3])
469 These three are pattern syntax appearing in expressions.
470 Since all the symbols are reservedops we can simply reject them.
471 We return a (bogus) EWildPat in each case.
474 rnExpr e@EWildPat = addErrRn (patSynErr e) `thenRn_`
475 returnRn (EWildPat, emptyFVs)
477 rnExpr e@(EAsPat _ _) = addErrRn (patSynErr e) `thenRn_`
478 returnRn (EWildPat, emptyFVs)
480 rnExpr e@(ELazyPat _) = addErrRn (patSynErr e) `thenRn_`
481 returnRn (EWildPat, emptyFVs)
486 %************************************************************************
488 \subsubsection{@Rbinds@s and @Rpats@s: in record expressions}
490 %************************************************************************
494 = mapRn_ field_dup_err dup_fields `thenRn_`
495 mapFvRn rn_rbind rbinds `thenRn` \ (rbinds', fvRbind) ->
496 returnRn (rbinds', fvRbind)
498 (_, dup_fields) = removeDups compare [ f | (f,_,_) <- rbinds ]
500 field_dup_err dups = addErrRn (dupFieldErr str dups)
502 rn_rbind (field, expr, pun)
503 = lookupGlobalOccRn field `thenRn` \ fieldname ->
504 rnExpr expr `thenRn` \ (expr', fvExpr) ->
505 returnRn ((fieldname, expr', pun), fvExpr `addOneFV` fieldname)
508 = mapRn_ field_dup_err dup_fields `thenRn_`
509 mapFvRn rn_rpat rpats `thenRn` \ (rpats', fvs) ->
510 returnRn (rpats', fvs)
512 (_, dup_fields) = removeDups compare [ f | (f,_,_) <- rpats ]
514 field_dup_err dups = addErrRn (dupFieldErr "pattern" dups)
516 rn_rpat (field, pat, pun)
517 = lookupGlobalOccRn field `thenRn` \ fieldname ->
518 rnPat pat `thenRn` \ (pat', fvs) ->
519 returnRn ((fieldname, pat', pun), fvs `addOneFV` fieldname)
522 %************************************************************************
524 \subsubsection{@rnIPBinds@s: in implicit parameter bindings} *
526 %************************************************************************
529 rnIPBinds [] = returnRn ([], emptyFVs)
530 rnIPBinds ((n, expr) : binds)
531 = newIPName n `thenRn` \ name ->
532 rnExpr expr `thenRn` \ (expr',fvExpr) ->
533 rnIPBinds binds `thenRn` \ (binds',fvBinds) ->
534 returnRn ((name, expr') : binds', fvExpr `plusFV` fvBinds)
538 %************************************************************************
540 \subsubsection{@Stmt@s: in @do@ expressions}
542 %************************************************************************
544 Note that although some bound vars may appear in the free var set for
545 the first qual, these will eventually be removed by the caller. For
546 example, if we have @[p | r <- s, q <- r, p <- q]@, when doing
547 @[q <- r, p <- q]@, the free var set for @q <- r@ will
548 be @{r}@, and the free var set for the entire Quals will be @{r}@. This
549 @r@ will be removed only when we finally return from examining all the
553 rnStmts :: [RdrNameStmt]
554 -> RnMS (([Name], [RenamedStmt]), FreeVars)
557 = returnRn (([], []), emptyFVs)
560 = getLocalNameEnv `thenRn` \ name_env ->
561 rnStmt stmt $ \ stmt' ->
562 rnStmts stmts `thenRn` \ ((binders, stmts'), fvs) ->
563 returnRn ((binders, stmt' : stmts'), fvs)
565 rnStmt :: RdrNameStmt
566 -> (RenamedStmt -> RnMS (([Name], a), FreeVars))
567 -> RnMS (([Name], a), FreeVars)
568 -- The thing list of names returned is the list returned by the
569 -- thing_inside, plus the binders of the arguments stmt
571 -- Because of mutual recursion we have to pass in rnExpr.
573 rnStmt (ParStmt stmtss) thing_inside
574 = mapFvRn rnStmts stmtss `thenRn` \ (bndrstmtss, fv_stmtss) ->
575 let binderss = map fst bndrstmtss
576 checkBndrs all_bndrs bndrs
577 = checkRn (null (intersectBy eqOcc all_bndrs bndrs)) err `thenRn_`
578 returnRn (bndrs ++ all_bndrs)
579 eqOcc n1 n2 = nameOccName n1 == nameOccName n2
580 err = text "duplicate binding in parallel list comprehension"
582 foldlRn checkBndrs [] binderss `thenRn` \ new_binders ->
583 bindLocalNamesFV new_binders $
584 thing_inside (ParStmtOut bndrstmtss)`thenRn` \ ((rest_bndrs, result), fv_rest) ->
585 returnRn ((new_binders ++ rest_bndrs, result), fv_stmtss `plusFV` fv_rest)
587 rnStmt (BindStmt pat expr src_loc) thing_inside
588 = pushSrcLocRn src_loc $
589 rnExpr expr `thenRn` \ (expr', fv_expr) ->
590 bindPatSigTyVars (collectSigTysFromPat pat) $ \ sig_tyvars ->
591 bindLocalsFVRn doc (collectPatBinders pat) $ \ new_binders ->
592 rnPat pat `thenRn` \ (pat', fv_pat) ->
593 thing_inside (BindStmt pat' expr' src_loc) `thenRn` \ ((rest_binders, result), fvs) ->
594 returnRn ((new_binders ++ rest_binders, result),
595 fv_expr `plusFV` fvs `plusFV` fv_pat)
597 doc = text "In a pattern in 'do' binding"
599 rnStmt (ExprStmt expr src_loc) thing_inside
600 = pushSrcLocRn src_loc $
601 rnExpr expr `thenRn` \ (expr', fv_expr) ->
602 thing_inside (ExprStmt expr' src_loc) `thenRn` \ (result, fvs) ->
603 returnRn (result, fv_expr `plusFV` fvs)
605 rnStmt (ResultStmt expr src_loc) thing_inside
606 = pushSrcLocRn src_loc $
607 rnExpr expr `thenRn` \ (expr', fv_expr) ->
608 thing_inside (ResultStmt expr' src_loc) `thenRn` \ (result, fvs) ->
609 returnRn (result, fv_expr `plusFV` fvs)
611 rnStmt (LetStmt binds) thing_inside
612 = rnBinds binds $ \ binds' ->
613 let new_binders = collectHsBinders binds' in
614 thing_inside (LetStmt binds') `thenRn` \ ((rest_binders, result), fvs) ->
615 returnRn ((new_binders ++ rest_binders, result), fvs )
618 %************************************************************************
620 \subsubsection{Precedence Parsing}
622 %************************************************************************
624 @mkOpAppRn@ deals with operator fixities. The argument expressions
625 are assumed to be already correctly arranged. It needs the fixities
626 recorded in the OpApp nodes, because fixity info applies to the things
627 the programmer actually wrote, so you can't find it out from the Name.
629 Furthermore, the second argument is guaranteed not to be another
630 operator application. Why? Because the parser parses all
631 operator appications left-associatively, EXCEPT negation, which
632 we need to handle specially.
635 mkOpAppRn :: RenamedHsExpr -- Left operand; already rearranged
636 -> RenamedHsExpr -> Fixity -- Operator and fixity
637 -> RenamedHsExpr -- Right operand (not an OpApp, but might
639 -> RnMS RenamedHsExpr
641 ---------------------------
642 -- (e11 `op1` e12) `op2` e2
643 mkOpAppRn e1@(OpApp e11 op1 fix1 e12) op2 fix2 e2
645 = addErrRn (precParseErr (ppr_op op1,fix1) (ppr_op op2,fix2)) `thenRn_`
646 returnRn (OpApp e1 op2 fix2 e2)
649 = mkOpAppRn e12 op2 fix2 e2 `thenRn` \ new_e ->
650 returnRn (OpApp e11 op1 fix1 new_e)
652 (nofix_error, associate_right) = compareFixity fix1 fix2
654 ---------------------------
655 -- (- neg_arg) `op` e2
656 mkOpAppRn e1@(NegApp neg_arg) op2 fix2 e2
658 = addErrRn (precParseErr (pp_prefix_minus,negateFixity) (ppr_op op2,fix2)) `thenRn_`
659 returnRn (OpApp e1 op2 fix2 e2)
662 = mkOpAppRn neg_arg op2 fix2 e2 `thenRn` \ new_e ->
663 returnRn (NegApp new_e)
665 (nofix_error, associate_right) = compareFixity negateFixity fix2
667 ---------------------------
669 mkOpAppRn e1 op1 fix1 e2@(NegApp neg_arg) -- NegApp can occur on the right
670 | not associate_right -- We *want* right association
671 = addErrRn (precParseErr (ppr_op op1, fix1) (pp_prefix_minus, negateFixity)) `thenRn_`
672 returnRn (OpApp e1 op1 fix1 e2)
674 (_, associate_right) = compareFixity fix1 negateFixity
676 ---------------------------
678 mkOpAppRn e1 op fix e2 -- Default case, no rearrangment
679 = ASSERT2( right_op_ok fix e2,
680 ppr e1 $$ text "---" $$ ppr op $$ text "---" $$ ppr fix $$ text "---" $$ ppr e2
682 returnRn (OpApp e1 op fix e2)
684 -- Parser left-associates everything, but
685 -- derived instances may have correctly-associated things to
686 -- in the right operarand. So we just check that the right operand is OK
687 right_op_ok fix1 (OpApp _ _ fix2 _)
688 = not error_please && associate_right
690 (error_please, associate_right) = compareFixity fix1 fix2
691 right_op_ok fix1 other
694 -- Parser initially makes negation bind more tightly than any other operator
698 getModeRn `thenRn` \ mode ->
699 ASSERT( not_op_app mode neg_arg )
701 returnRn (NegApp neg_arg)
703 not_op_app SourceMode (OpApp _ _ _ _) = False
704 not_op_app mode other = True
708 mkConOpPatRn :: RenamedPat -> Name -> Fixity -> RenamedPat
711 mkConOpPatRn p1@(ConOpPatIn p11 op1 fix1 p12)
714 = addErrRn (precParseErr (ppr_op op1,fix1) (ppr_op op2,fix2)) `thenRn_`
715 returnRn (ConOpPatIn p1 op2 fix2 p2)
718 = mkConOpPatRn p12 op2 fix2 p2 `thenRn` \ new_p ->
719 returnRn (ConOpPatIn p11 op1 fix1 new_p)
722 (nofix_error, associate_right) = compareFixity fix1 fix2
724 mkConOpPatRn p1 op fix p2 -- Default case, no rearrangment
725 = ASSERT( not_op_pat p2 )
726 returnRn (ConOpPatIn p1 op fix p2)
728 not_op_pat (ConOpPatIn _ _ _ _) = False
729 not_op_pat other = True
733 checkPrecMatch :: Bool -> Name -> RenamedMatch -> RnMS ()
735 checkPrecMatch False fn match
738 checkPrecMatch True op (Match _ (p1:p2:_) _ _)
739 -- True indicates an infix lhs
740 = getModeRn `thenRn` \ mode ->
741 -- See comments with rnExpr (OpApp ...)
742 if isInterfaceMode mode
744 else checkPrec op p1 False `thenRn_`
747 checkPrecMatch True op _ = panic "checkPrecMatch"
749 checkPrec op (ConOpPatIn _ op1 _ _) right
750 = lookupFixityRn op `thenRn` \ op_fix@(Fixity op_prec op_dir) ->
751 lookupFixityRn op1 `thenRn` \ op1_fix@(Fixity op1_prec op1_dir) ->
753 inf_ok = op1_prec > op_prec ||
754 (op1_prec == op_prec &&
755 (op1_dir == InfixR && op_dir == InfixR && right ||
756 op1_dir == InfixL && op_dir == InfixL && not right))
758 info = (ppr_op op, op_fix)
759 info1 = (ppr_op op1, op1_fix)
760 (infol, infor) = if right then (info, info1) else (info1, info)
762 checkRn inf_ok (precParseErr infol infor)
764 checkPrec op pat right
767 -- Check precedence of (arg op) or (op arg) respectively
768 -- If arg is itself an operator application, its precedence should
769 -- be higher than that of op
770 checkSectionPrec left_or_right section op arg
772 OpApp _ op fix _ -> go_for_it (ppr_op op) fix
773 NegApp _ -> go_for_it pp_prefix_minus negateFixity
777 go_for_it pp_arg_op arg_fix@(Fixity arg_prec _)
778 = lookupFixityRn op_name `thenRn` \ op_fix@(Fixity op_prec _) ->
779 checkRn (op_prec < arg_prec)
780 (sectionPrecErr (ppr_op op_name, op_fix) (pp_arg_op, arg_fix) section)
787 @(compareFixity op1 op2)@ tells which way to arrange appication, or
788 whether there's an error.
791 compareFixity :: Fixity -> Fixity
792 -> (Bool, -- Error please
793 Bool) -- Associate to the right: a op1 (b op2 c)
794 compareFixity (Fixity prec1 dir1) (Fixity prec2 dir2)
795 = case prec1 `compare` prec2 of
798 EQ -> case (dir1, dir2) of
799 (InfixR, InfixR) -> right
800 (InfixL, InfixL) -> left
803 right = (False, True)
804 left = (False, False)
805 error_please = (True, False)
808 %************************************************************************
810 \subsubsection{Literals}
812 %************************************************************************
814 When literals occur we have to make sure
815 that the types and classes they involve
820 = checkRn (inCharRange c) (bogusCharError c) `thenRn_`
821 returnRn (unitFV charTyCon_name)
823 litFVs (HsCharPrim c) = returnRn (unitFV (getName charPrimTyCon))
824 litFVs (HsString s) = returnRn (mkFVs [listTyCon_name, charTyCon_name])
825 litFVs (HsStringPrim s) = returnRn (unitFV (getName addrPrimTyCon))
826 litFVs (HsInt i) = returnRn (unitFV (getName intTyCon))
827 litFVs (HsIntPrim i) = returnRn (unitFV (getName intPrimTyCon))
828 litFVs (HsFloatPrim f) = returnRn (unitFV (getName floatPrimTyCon))
829 litFVs (HsDoublePrim d) = returnRn (unitFV (getName doublePrimTyCon))
830 litFVs (HsLitLit l bogus_ty) = lookupOrigName cCallableClass_RDR `thenRn` \ cc ->
832 litFVs lit = pprPanic "RnExpr.litFVs" (ppr lit) -- HsInteger and HsRat only appear
833 -- in post-typechecker translations
835 rnOverLit (HsIntegral i)
837 = returnRn (HsIntegral i, unitFV fromIntegerName)
839 = lookupOrigNames [fromInteger_RDR, plusInteger_RDR, timesInteger_RDR] `thenRn` \ ns ->
840 -- Big integers are built, using + and *, out of small integers
841 -- [No particular reason why we use fromIntegerName in one case can
842 -- fromInteger_RDR in the other; but plusInteger_RDR means we
843 -- can get away without plusIntegerName altogether.]
844 returnRn (HsIntegral i, ns)
846 rnOverLit (HsFractional i)
847 = lookupOrigNames [fromRational_RDR, ratioDataCon_RDR,
848 plusInteger_RDR, timesInteger_RDR] `thenRn` \ ns ->
849 -- We have to make sure that the Ratio type is imported with
850 -- its constructor, because literals of type Ratio t are
851 -- built with that constructor.
852 -- The Rational type is needed too, but that will come in
853 -- when fractionalClass does.
854 -- The plus/times integer operations may be needed to construct the numerator
855 -- and denominator (see DsUtils.mkIntegerLit)
856 returnRn (HsFractional i, ns)
859 %************************************************************************
861 \subsubsection{Assertion utils}
863 %************************************************************************
866 mkAssertExpr :: RnMS (RenamedHsExpr, FreeVars)
868 lookupOrigName assertErr_RDR `thenRn` \ name ->
869 getSrcLocRn `thenRn` \ sloc ->
871 -- if we're ignoring asserts, return (\ _ e -> e)
872 -- if not, return (assertError "src-loc")
874 if opt_IgnoreAsserts then
875 getUniqRn `thenRn` \ uniq ->
877 vname = mkSysLocalName uniq SLIT("v")
878 expr = HsLam ignorePredMatch
879 loc = nameSrcLoc vname
880 ignorePredMatch = mkSimpleMatch [WildPatIn, VarPatIn vname] (HsVar vname) Nothing loc
882 returnRn (expr, unitFV name)
887 (HsLit (HsString (_PK_ (showSDoc (ppr sloc)))))
890 returnRn (expr, unitFV name)
894 %************************************************************************
896 \subsubsection{Errors}
898 %************************************************************************
901 ppr_op op = quotes (ppr op) -- Here, op can be a Name or a (Var n), where n is a Name
902 ppr_opfix (pp_op, fixity) = pp_op <+> brackets (ppr fixity)
903 pp_prefix_minus = ptext SLIT("prefix `-'")
905 dupFieldErr str (dup:rest)
906 = hsep [ptext SLIT("duplicate field name"),
908 ptext SLIT("in record"), text str]
911 = hang (ptext SLIT("precedence parsing error"))
912 4 (hsep [ptext SLIT("cannot mix"), ppr_opfix op1, ptext SLIT("and"),
914 ptext SLIT("in the same infix expression")])
916 sectionPrecErr op arg_op section
917 = vcat [ptext SLIT("The operator") <+> ppr_opfix op <+> ptext SLIT("of a section"),
918 nest 4 (ptext SLIT("must have lower precedence than the operand") <+> ppr_opfix arg_op),
919 nest 4 (ptext SLIT("in the section:") <+> quotes (ppr section))]
923 SLIT("accepting non-standard pattern guards (-fglasgow-exts to suppress this message)")
927 = (ptext SLIT("Illegal signature in pattern:") <+> ppr ty)
928 $$ nest 4 (ptext SLIT("Use -fglasgow-exts to permit it"))
931 = sep [ptext SLIT("Pattern syntax in expression context:"),
935 = sep [ptext SLIT("`do' statements must end in expression:"),
939 = ptext SLIT("character literal out of range: '\\") <> int c <> char '\''