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 = litOccurrence lit `thenRn` \ fvs ->
287 returnRn (HsLit lit, fvs)
290 = rnMatch match `thenRn` \ (match', fvMatch) ->
291 returnRn (HsLam match', fvMatch)
293 rnExpr (HsApp fun arg)
294 = rnExpr fun `thenRn` \ (fun',fvFun) ->
295 rnExpr arg `thenRn` \ (arg',fvArg) ->
296 returnRn (HsApp fun' arg', fvFun `plusFV` fvArg)
298 rnExpr (OpApp e1 op _ e2)
299 = rnExpr e1 `thenRn` \ (e1', fv_e1) ->
300 rnExpr e2 `thenRn` \ (e2', fv_e2) ->
301 rnExpr op `thenRn` \ (op'@(HsVar op_name), fv_op) ->
304 -- When renaming code synthesised from "deriving" declarations
305 -- we're in Interface mode, and we should ignore fixity; assume
306 -- that the deriving code generator got the association correct
307 -- Don't even look up the fixity when in interface mode
308 getModeRn `thenRn` \ mode ->
310 SourceMode -> lookupFixity op_name `thenRn` \ fixity ->
311 mkOpAppRn e1' op' fixity e2'
312 InterfaceMode -> returnRn (OpApp e1' op' defaultFixity e2')
313 ) `thenRn` \ final_e ->
316 fv_e1 `plusFV` fv_op `plusFV` fv_e2)
318 -- constant-fold some negate applications on unboxed literals. Since
319 -- negate is a polymorphic function, we have to do these here.
320 rnExpr (NegApp (HsLit (HsIntPrim i)) _) = rnExpr (HsLit (HsIntPrim (-i)))
321 rnExpr (NegApp (HsLit (HsFloatPrim i)) _) = rnExpr (HsLit (HsFloatPrim (-i)))
322 rnExpr (NegApp (HsLit (HsDoublePrim i)) _) = rnExpr (HsLit (HsDoublePrim (-i)))
325 = rnExpr e `thenRn` \ (e', fv_e) ->
326 lookupImplicitOccRn negate_RDR `thenRn` \ neg ->
327 mkNegAppRn e' (HsVar neg) `thenRn` \ final_e ->
328 returnRn (final_e, fv_e `addOneFV` neg)
331 = rnExpr e `thenRn` \ (e', fvs_e) ->
332 returnRn (HsPar e', fvs_e)
334 rnExpr section@(SectionL expr op)
335 = rnExpr expr `thenRn` \ (expr', fvs_expr) ->
336 rnExpr op `thenRn` \ (op', fvs_op) ->
337 checkSectionPrec "left" section op' expr' `thenRn_`
338 returnRn (SectionL expr' op', fvs_op `plusFV` fvs_expr)
340 rnExpr section@(SectionR op expr)
341 = rnExpr op `thenRn` \ (op', fvs_op) ->
342 rnExpr expr `thenRn` \ (expr', fvs_expr) ->
343 checkSectionPrec "right" section op' expr' `thenRn_`
344 returnRn (SectionR op' expr', fvs_op `plusFV` fvs_expr)
346 rnExpr (CCall fun args may_gc is_casm fake_result_ty)
347 -- Check out the comment on RnIfaces.getNonWiredDataDecl about ccalls
348 = lookupImplicitOccRn ccallableClass_RDR `thenRn` \ cc ->
349 lookupImplicitOccRn creturnableClass_RDR `thenRn` \ cr ->
350 lookupImplicitOccRn ioDataCon_RDR `thenRn` \ io ->
351 rnExprs args `thenRn` \ (args', fvs_args) ->
352 returnRn (CCall fun args' may_gc is_casm fake_result_ty,
353 fvs_args `addOneFV` cc `addOneFV` cr `addOneFV` io)
355 rnExpr (HsSCC lbl expr)
356 = rnExpr expr `thenRn` \ (expr', fvs_expr) ->
357 returnRn (HsSCC lbl expr', fvs_expr)
359 rnExpr (HsCase expr ms src_loc)
360 = pushSrcLocRn src_loc $
361 rnExpr expr `thenRn` \ (new_expr, e_fvs) ->
362 mapFvRn rnMatch ms `thenRn` \ (new_ms, ms_fvs) ->
363 returnRn (HsCase new_expr new_ms src_loc, e_fvs `plusFV` ms_fvs)
365 rnExpr (HsLet binds expr)
366 = rnBinds binds $ \ binds' ->
367 rnExpr expr `thenRn` \ (expr',fvExpr) ->
368 returnRn (HsLet binds' expr', fvExpr)
370 rnExpr e@(HsDo do_or_lc stmts src_loc)
371 = pushSrcLocRn src_loc $
372 lookupImplicitOccRn monadClass_RDR `thenRn` \ monad ->
373 rnStmts rnExpr stmts `thenRn` \ (stmts', fvs) ->
374 -- check the statement list ends in an expression
375 case last stmts' of {
376 ExprStmt _ _ -> returnRn () ;
377 ReturnStmt _ -> returnRn () ; -- for list comprehensions
378 _ -> addErrRn (doStmtListErr e)
380 returnRn (HsDo do_or_lc stmts' src_loc, fvs `addOneFV` monad)
382 rnExpr (ExplicitList exps)
383 = rnExprs exps `thenRn` \ (exps', fvs) ->
384 returnRn (ExplicitList exps', fvs `addOneFV` listTyCon_name)
386 rnExpr (ExplicitTuple exps boxed)
387 = rnExprs exps `thenRn` \ (exps', fvs) ->
388 returnRn (ExplicitTuple exps' boxed, fvs `addOneFV` tycon_name)
390 tycon_name = tupleTyCon_name boxed (length exps)
392 rnExpr (RecordCon con_id rbinds)
393 = lookupOccRn con_id `thenRn` \ conname ->
394 rnRbinds "construction" rbinds `thenRn` \ (rbinds', fvRbinds) ->
395 returnRn (RecordCon conname rbinds', fvRbinds `addOneFV` conname)
397 rnExpr (RecordUpd expr rbinds)
398 = rnExpr expr `thenRn` \ (expr', fvExpr) ->
399 rnRbinds "update" rbinds `thenRn` \ (rbinds', fvRbinds) ->
400 returnRn (RecordUpd expr' rbinds', fvExpr `plusFV` fvRbinds)
402 rnExpr (ExprWithTySig expr pty)
403 = rnExpr expr `thenRn` \ (expr', fvExpr) ->
404 rnHsSigType (text "an expression") pty `thenRn` \ (pty', fvTy) ->
405 returnRn (ExprWithTySig expr' pty', fvExpr `plusFV` fvTy)
407 rnExpr (HsIf p b1 b2 src_loc)
408 = pushSrcLocRn src_loc $
409 rnExpr p `thenRn` \ (p', fvP) ->
410 rnExpr b1 `thenRn` \ (b1', fvB1) ->
411 rnExpr b2 `thenRn` \ (b2', fvB2) ->
412 returnRn (HsIf p' b1' b2' src_loc, plusFVs [fvP, fvB1, fvB2])
414 rnExpr (ArithSeqIn seq)
415 = lookupImplicitOccRn enumClass_RDR `thenRn` \ enum ->
416 rn_seq seq `thenRn` \ (new_seq, fvs) ->
417 returnRn (ArithSeqIn new_seq, fvs `addOneFV` enum)
420 = rnExpr expr `thenRn` \ (expr', fvExpr) ->
421 returnRn (From expr', fvExpr)
423 rn_seq (FromThen expr1 expr2)
424 = rnExpr expr1 `thenRn` \ (expr1', fvExpr1) ->
425 rnExpr expr2 `thenRn` \ (expr2', fvExpr2) ->
426 returnRn (FromThen expr1' expr2', fvExpr1 `plusFV` fvExpr2)
428 rn_seq (FromTo expr1 expr2)
429 = rnExpr expr1 `thenRn` \ (expr1', fvExpr1) ->
430 rnExpr expr2 `thenRn` \ (expr2', fvExpr2) ->
431 returnRn (FromTo expr1' expr2', fvExpr1 `plusFV` fvExpr2)
433 rn_seq (FromThenTo expr1 expr2 expr3)
434 = rnExpr expr1 `thenRn` \ (expr1', fvExpr1) ->
435 rnExpr expr2 `thenRn` \ (expr2', fvExpr2) ->
436 rnExpr expr3 `thenRn` \ (expr3', fvExpr3) ->
437 returnRn (FromThenTo expr1' expr2' expr3',
438 plusFVs [fvExpr1, fvExpr2, fvExpr3])
441 These three are pattern syntax appearing in expressions.
442 Since all the symbols are reservedops we can simply reject them.
443 We return a (bogus) EWildPat in each case.
446 rnExpr e@EWildPat = addErrRn (patSynErr e) `thenRn_`
447 returnRn (EWildPat, emptyFVs)
449 rnExpr e@(EAsPat _ _) = addErrRn (patSynErr e) `thenRn_`
450 returnRn (EWildPat, emptyFVs)
452 rnExpr e@(ELazyPat _) = addErrRn (patSynErr e) `thenRn_`
453 returnRn (EWildPat, emptyFVs)
456 %************************************************************************
458 \subsubsection{@Rbinds@s and @Rpats@s: in record expressions}
460 %************************************************************************
464 = mapRn_ field_dup_err dup_fields `thenRn_`
465 mapFvRn rn_rbind rbinds `thenRn` \ (rbinds', fvRbind) ->
466 returnRn (rbinds', fvRbind)
468 (_, dup_fields) = removeDups compare [ f | (f,_,_) <- rbinds ]
470 field_dup_err dups = addErrRn (dupFieldErr str dups)
472 rn_rbind (field, expr, pun)
473 = lookupGlobalOccRn field `thenRn` \ fieldname ->
474 rnExpr expr `thenRn` \ (expr', fvExpr) ->
475 returnRn ((fieldname, expr', pun), fvExpr `addOneFV` fieldname)
478 = mapRn_ field_dup_err dup_fields `thenRn_`
479 mapFvRn rn_rpat rpats `thenRn` \ (rpats', fvs) ->
480 returnRn (rpats', fvs)
482 (_, dup_fields) = removeDups compare [ f | (f,_,_) <- rpats ]
484 field_dup_err dups = addErrRn (dupFieldErr "pattern" dups)
486 rn_rpat (field, pat, pun)
487 = lookupGlobalOccRn field `thenRn` \ fieldname ->
488 rnPat pat `thenRn` \ (pat', fvs) ->
489 returnRn ((fieldname, pat', pun), fvs `addOneFV` fieldname)
492 %************************************************************************
494 \subsubsection{@Stmt@s: in @do@ expressions}
496 %************************************************************************
498 Note that although some bound vars may appear in the free var set for
499 the first qual, these will eventually be removed by the caller. For
500 example, if we have @[p | r <- s, q <- r, p <- q]@, when doing
501 @[q <- r, p <- q]@, the free var set for @q <- r@ will
502 be @{r}@, and the free var set for the entire Quals will be @{r}@. This
503 @r@ will be removed only when we finally return from examining all the
507 type RnExprTy = RdrNameHsExpr -> RnMS (RenamedHsExpr, FreeVars)
511 -> RnMS ([RenamedStmt], FreeVars)
514 = returnRn ([], emptyFVs)
516 rnStmts rn_expr (stmt:stmts)
517 = rnStmt rn_expr stmt $ \ stmt' ->
518 rnStmts rn_expr stmts `thenRn` \ (stmts', fvs) ->
519 returnRn (stmt' : stmts', fvs)
521 rnStmt :: RnExprTy -> RdrNameStmt
522 -> (RenamedStmt -> RnMS (a, FreeVars))
523 -> RnMS (a, FreeVars)
524 -- Because of mutual recursion we have to pass in rnExpr.
526 rnStmt rn_expr (BindStmt pat expr src_loc) thing_inside
527 = pushSrcLocRn src_loc $
528 rn_expr expr `thenRn` \ (expr', fv_expr) ->
529 bindLocalsFVRn doc binders $ \ new_binders ->
530 rnPat pat `thenRn` \ (pat', fv_pat) ->
531 thing_inside (BindStmt pat' expr' src_loc) `thenRn` \ (result, fvs) ->
532 returnRn (result, fv_expr `plusFV` fvs `plusFV` fv_pat)
534 binders = collectPatBinders pat
535 doc = text "a pattern in do binding"
537 rnStmt rn_expr (ExprStmt expr src_loc) thing_inside
538 = pushSrcLocRn src_loc $
539 rn_expr expr `thenRn` \ (expr', fv_expr) ->
540 thing_inside (ExprStmt expr' src_loc) `thenRn` \ (result, fvs) ->
541 returnRn (result, fv_expr `plusFV` fvs)
543 rnStmt rn_expr (GuardStmt expr src_loc) thing_inside
544 = pushSrcLocRn src_loc $
545 rn_expr expr `thenRn` \ (expr', fv_expr) ->
546 thing_inside (GuardStmt expr' src_loc) `thenRn` \ (result, fvs) ->
547 returnRn (result, fv_expr `plusFV` fvs)
549 rnStmt rn_expr (ReturnStmt expr) thing_inside
550 = rn_expr expr `thenRn` \ (expr', fv_expr) ->
551 thing_inside (ReturnStmt expr') `thenRn` \ (result, fvs) ->
552 returnRn (result, fv_expr `plusFV` fvs)
554 rnStmt rn_expr (LetStmt binds) thing_inside
555 = rnBinds binds $ \ binds' ->
556 thing_inside (LetStmt binds')
559 %************************************************************************
561 \subsubsection{Precedence Parsing}
563 %************************************************************************
565 @mkOpAppRn@ deals with operator fixities. The argument expressions
566 are assumed to be already correctly arranged. It needs the fixities
567 recorded in the OpApp nodes, because fixity info applies to the things
568 the programmer actually wrote, so you can't find it out from the Name.
570 Furthermore, the second argument is guaranteed not to be another
571 operator application. Why? Because the parser parses all
572 operator appications left-associatively, EXCEPT negation, which
573 we need to handle specially.
576 mkOpAppRn :: RenamedHsExpr -- Left operand; already rearranged
577 -> RenamedHsExpr -> Fixity -- Operator and fixity
578 -> RenamedHsExpr -- Right operand (not an OpApp, but might
580 -> RnMS RenamedHsExpr
582 ---------------------------
583 -- (e11 `op1` e12) `op2` e2
584 mkOpAppRn e1@(OpApp e11 op1 fix1 e12) op2 fix2 e2
586 = addErrRn (precParseErr (ppr_op op1,fix1) (ppr_op op2,fix2)) `thenRn_`
587 returnRn (OpApp e1 op2 fix2 e2)
590 = mkOpAppRn e12 op2 fix2 e2 `thenRn` \ new_e ->
591 returnRn (OpApp e11 op1 fix1 new_e)
593 (nofix_error, associate_right) = compareFixity fix1 fix2
595 ---------------------------
596 -- (- neg_arg) `op` e2
597 mkOpAppRn e1@(NegApp neg_arg neg_op) op2 fix2 e2
599 = addErrRn (precParseErr (pp_prefix_minus,negateFixity) (ppr_op op2,fix2)) `thenRn_`
600 returnRn (OpApp e1 op2 fix2 e2)
603 = mkOpAppRn neg_arg op2 fix2 e2 `thenRn` \ new_e ->
604 returnRn (NegApp new_e neg_op)
606 (nofix_error, associate_right) = compareFixity negateFixity fix2
608 ---------------------------
610 mkOpAppRn e1 op1 fix1 e2@(NegApp neg_arg neg_op) -- NegApp can occur on the right
611 | not associate_right -- We *want* right association
612 = addErrRn (precParseErr (ppr_op op1, fix1) (pp_prefix_minus, negateFixity)) `thenRn_`
613 returnRn (OpApp e1 op1 fix1 e2)
615 (nofix_err, associate_right) = compareFixity fix1 negateFixity
617 ---------------------------
619 mkOpAppRn e1 op fix e2 -- Default case, no rearrangment
620 = ASSERT2( right_op_ok fix e2,
621 ppr e1 $$ text "---" $$ ppr op $$ text "---" $$ ppr fix $$ text "---" $$ ppr e2
623 returnRn (OpApp e1 op fix e2)
625 -- Parser left-associates everything, but
626 -- derived instances may have correctly-associated things to
627 -- in the right operarand. So we just check that the right operand is OK
628 right_op_ok fix1 (OpApp _ _ fix2 _)
629 = not error_please && associate_right
631 (error_please, associate_right) = compareFixity fix1 fix2
632 right_op_ok fix1 other
635 -- Parser initially makes negation bind more tightly than any other operator
636 mkNegAppRn neg_arg neg_op
639 getModeRn `thenRn` \ mode ->
640 ASSERT( not_op_app mode neg_arg )
642 returnRn (NegApp neg_arg neg_op)
644 not_op_app SourceMode (OpApp _ _ _ _) = False
645 not_op_app mode other = True
649 mkConOpPatRn :: RenamedPat -> Name -> Fixity -> RenamedPat
652 mkConOpPatRn p1@(ConOpPatIn p11 op1 fix1 p12)
655 = addErrRn (precParseErr (ppr_op op1,fix1) (ppr_op op2,fix2)) `thenRn_`
656 returnRn (ConOpPatIn p1 op2 fix2 p2)
659 = mkConOpPatRn p12 op2 fix2 p2 `thenRn` \ new_p ->
660 returnRn (ConOpPatIn p11 op1 fix1 new_p)
663 (nofix_error, associate_right) = compareFixity fix1 fix2
665 mkConOpPatRn p1@(NegPatIn neg_arg)
667 fix2@(Fixity prec2 dir2)
669 | prec2 > negatePrecedence -- Precedence of unary - is wired in
670 = addErrRn (precParseNegPatErr (ppr_op op2,fix2)) `thenRn_`
671 returnRn (ConOpPatIn p1 op2 fix2 p2)
673 mkConOpPatRn p1 op fix p2 -- Default case, no rearrangment
674 = ASSERT( not_op_pat p2 )
675 returnRn (ConOpPatIn p1 op fix p2)
677 not_op_pat (ConOpPatIn _ _ _ _) = False
678 not_op_pat other = True
682 checkPrecMatch :: Bool -> Name -> RenamedMatch -> RnMS ()
684 checkPrecMatch False fn match
687 checkPrecMatch True op (Match _ (p1:p2:_) _ _)
688 -- True indicates an infix lhs
689 = getModeRn `thenRn` \ mode ->
690 -- See comments with rnExpr (OpApp ...)
692 InterfaceMode -> returnRn ()
693 SourceMode -> checkPrec op p1 False `thenRn_`
696 checkPrecMatch True op _ = panic "checkPrecMatch"
698 checkPrec op (ConOpPatIn _ op1 _ _) right
699 = lookupFixity op `thenRn` \ op_fix@(Fixity op_prec op_dir) ->
700 lookupFixity op1 `thenRn` \ op1_fix@(Fixity op1_prec op1_dir) ->
702 inf_ok = op1_prec > op_prec ||
703 (op1_prec == op_prec &&
704 (op1_dir == InfixR && op_dir == InfixR && right ||
705 op1_dir == InfixL && op_dir == InfixL && not right))
707 info = (ppr_op op, op_fix)
708 info1 = (ppr_op op1, op1_fix)
709 (infol, infor) = if right then (info, info1) else (info1, info)
711 checkRn inf_ok (precParseErr infol infor)
713 checkPrec op (NegPatIn _) right
714 = lookupFixity op `thenRn` \ op_fix@(Fixity op_prec op_dir) ->
715 checkRn (op_prec <= negatePrecedence) (precParseNegPatErr (ppr_op op,op_fix))
717 checkPrec op pat right
720 -- Check precedence of (arg op) or (op arg) respectively
721 -- If arg is itself an operator application, its precedence should
722 -- be higher than that of op
723 checkSectionPrec left_or_right section op arg
725 OpApp _ op fix _ -> go_for_it (ppr_op op) fix
726 NegApp _ op -> go_for_it pp_prefix_minus negateFixity
730 go_for_it pp_arg_op arg_fix@(Fixity arg_prec _)
731 = lookupFixity op_name `thenRn` \ op_fix@(Fixity op_prec _) ->
732 checkRn (op_prec < arg_prec)
733 (sectionPrecErr (ppr_op op_name, op_fix) (pp_arg_op, arg_fix) section)
740 @(compareFixity op1 op2)@ tells which way to arrange appication, or
741 whether there's an error.
744 compareFixity :: Fixity -> Fixity
745 -> (Bool, -- Error please
746 Bool) -- Associate to the right: a op1 (b op2 c)
747 compareFixity (Fixity prec1 dir1) (Fixity prec2 dir2)
748 = case prec1 `compare` prec2 of
751 EQ -> case (dir1, dir2) of
752 (InfixR, InfixR) -> right
753 (InfixL, InfixL) -> left
756 right = (False, True)
757 left = (False, False)
758 error_please = (True, False)
761 %************************************************************************
763 \subsubsection{Literals}
765 %************************************************************************
767 When literals occur we have to make sure
768 that the types and classes they involve
772 litOccurrence (HsChar _)
773 = returnRn (unitFV charTyCon_name)
775 litOccurrence (HsCharPrim _)
776 = returnRn (unitFV (getName charPrimTyCon))
778 litOccurrence (HsString _)
779 = returnRn (unitFV listTyCon_name `plusFV` unitFV charTyCon_name)
781 litOccurrence (HsStringPrim _)
782 = returnRn (unitFV (getName addrPrimTyCon))
784 litOccurrence (HsInt _)
785 = lookupImplicitOccRn numClass_RDR `thenRn` \ num ->
786 returnRn (unitFV num) -- Int and Integer are forced in by Num
788 litOccurrence (HsFrac _)
789 = lookupImplicitOccRn fractionalClass_RDR `thenRn` \ frac ->
790 lookupImplicitOccRn ratioDataCon_RDR `thenRn` \ ratio ->
791 returnRn (unitFV frac `plusFV` unitFV ratio)
792 -- We have to make sure that the Ratio type is imported with
793 -- its constructor, because literals of type Ratio t are
794 -- built with that constructor.
795 -- The Rational type is needed too, but that will come in
796 -- when fractionalClass does.
798 litOccurrence (HsIntPrim _)
799 = returnRn (unitFV (getName intPrimTyCon))
801 litOccurrence (HsFloatPrim _)
802 = returnRn (unitFV (getName floatPrimTyCon))
804 litOccurrence (HsDoublePrim _)
805 = returnRn (unitFV (getName doublePrimTyCon))
807 litOccurrence (HsLitLit _)
808 = lookupImplicitOccRn ccallableClass_RDR `thenRn` \ cc ->
812 %************************************************************************
814 \subsubsection{Assertion utils}
816 %************************************************************************
819 mkAssertExpr :: RnMS (RenamedHsExpr, FreeVars)
821 mkImportedGlobalFromRdrName assertErr_RDR `thenRn` \ name ->
822 getSrcLocRn `thenRn` \ sloc ->
824 -- if we're ignoring asserts, return (\ _ e -> e)
825 -- if not, return (assertError "src-loc")
827 if opt_IgnoreAsserts then
828 getUniqRn `thenRn` \ uniq ->
830 vname = mkSysLocalName uniq SLIT("v")
831 expr = HsLam ignorePredMatch
832 loc = nameSrcLoc vname
833 ignorePredMatch = Match [] [WildPatIn, VarPatIn vname] Nothing
834 (GRHSs [GRHS [ExprStmt (HsVar vname) loc] loc]
837 returnRn (expr, unitFV name)
842 (HsLit (HsString (_PK_ (showSDoc (ppr sloc)))))
845 returnRn (expr, unitFV name)
849 %************************************************************************
851 \subsubsection{Errors}
853 %************************************************************************
856 ppr_op op = quotes (ppr op) -- Here, op can be a Name or a (Var n), where n is a Name
857 ppr_opfix (pp_op, fixity) = pp_op <+> brackets (ppr fixity)
858 pp_prefix_minus = ptext SLIT("prefix `-'")
860 dupFieldErr str (dup:rest)
861 = hsep [ptext SLIT("duplicate field name"),
863 ptext SLIT("in record"), text str]
866 = sep [pp_prefix_minus <+> ptext SLIT("not applied to literal in pattern"),
869 precParseNegPatErr op
870 = hang (ptext SLIT("precedence parsing error"))
871 4 (hsep [pp_prefix_minus <+> ptext SLIT("has lower precedence than"),
873 ptext SLIT("in pattern")])
876 = hang (ptext SLIT("precedence parsing error"))
877 4 (hsep [ptext SLIT("cannot mix"), ppr_opfix op1, ptext SLIT("and"),
879 ptext SLIT("in the same infix expression")])
881 sectionPrecErr op arg_op section
882 = vcat [ptext SLIT("The operator") <+> ppr_opfix op <+> ptext SLIT("of a section"),
883 nest 4 (ptext SLIT("must have lower precedence than the operand") <+> ppr_opfix arg_op),
884 nest 4 (ptext SLIT("In the section:") <+> quotes (ppr section))]
888 SLIT("accepting non-standard pattern guards (-fglasgow-exts to suppress this message)")
892 = (ptext SLIT("Illegal signature in pattern:") <+> ppr ty)
893 $$ nest 4 (ptext SLIT("Use -fglasgow-exts to permit it"))
896 = sep [ptext SLIT("Pattern syntax in expression context:"),
900 = sep [ptext SLIT("`do' statements must end in expression:"),