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 (SectionL expr op)
335 = rnExpr expr `thenRn` \ (expr', fvs_expr) ->
336 rnExpr op `thenRn` \ (op', fvs_op) ->
337 returnRn (SectionL expr' op', fvs_op `plusFV` fvs_expr)
339 rnExpr (SectionR op expr)
340 = rnExpr op `thenRn` \ (op', fvs_op) ->
341 rnExpr expr `thenRn` \ (expr', fvs_expr) ->
342 returnRn (SectionR op' expr', fvs_op `plusFV` fvs_expr)
344 rnExpr (CCall fun args may_gc is_casm fake_result_ty)
345 -- Check out the comment on RnIfaces.getNonWiredDataDecl about ccalls
346 = lookupImplicitOccRn ccallableClass_RDR `thenRn` \ cc ->
347 lookupImplicitOccRn creturnableClass_RDR `thenRn` \ cr ->
348 lookupImplicitOccRn ioDataCon_RDR `thenRn` \ io ->
349 rnExprs args `thenRn` \ (args', fvs_args) ->
350 returnRn (CCall fun args' may_gc is_casm fake_result_ty,
351 fvs_args `addOneFV` cc `addOneFV` cr `addOneFV` io)
353 rnExpr (HsSCC lbl expr)
354 = rnExpr expr `thenRn` \ (expr', fvs_expr) ->
355 returnRn (HsSCC lbl expr', fvs_expr)
357 rnExpr (HsCase expr ms src_loc)
358 = pushSrcLocRn src_loc $
359 rnExpr expr `thenRn` \ (new_expr, e_fvs) ->
360 mapFvRn rnMatch ms `thenRn` \ (new_ms, ms_fvs) ->
361 returnRn (HsCase new_expr new_ms src_loc, e_fvs `plusFV` ms_fvs)
363 rnExpr (HsLet binds expr)
364 = rnBinds binds $ \ binds' ->
365 rnExpr expr `thenRn` \ (expr',fvExpr) ->
366 returnRn (HsLet binds' expr', fvExpr)
368 rnExpr e@(HsDo do_or_lc stmts src_loc)
369 = pushSrcLocRn src_loc $
370 lookupImplicitOccRn monadClass_RDR `thenRn` \ monad ->
371 rnStmts rnExpr stmts `thenRn` \ (stmts', fvs) ->
372 -- check the statement list ends in an expression
373 case last stmts' of {
374 ExprStmt _ _ -> returnRn () ;
375 ReturnStmt _ -> returnRn () ; -- for list comprehensions
376 _ -> addErrRn (doStmtListErr e)
378 returnRn (HsDo do_or_lc stmts' src_loc, fvs `addOneFV` monad)
380 rnExpr (ExplicitList exps)
381 = rnExprs exps `thenRn` \ (exps', fvs) ->
382 returnRn (ExplicitList exps', fvs `addOneFV` listTyCon_name)
384 rnExpr (ExplicitTuple exps boxed)
385 = rnExprs exps `thenRn` \ (exps', fvs) ->
386 returnRn (ExplicitTuple exps' boxed, fvs `addOneFV` tycon_name)
388 tycon_name = tupleTyCon_name boxed (length exps)
390 rnExpr (RecordCon con_id rbinds)
391 = lookupOccRn con_id `thenRn` \ conname ->
392 rnRbinds "construction" rbinds `thenRn` \ (rbinds', fvRbinds) ->
393 returnRn (RecordCon conname rbinds', fvRbinds `addOneFV` conname)
395 rnExpr (RecordUpd expr rbinds)
396 = rnExpr expr `thenRn` \ (expr', fvExpr) ->
397 rnRbinds "update" rbinds `thenRn` \ (rbinds', fvRbinds) ->
398 returnRn (RecordUpd expr' rbinds', fvExpr `plusFV` fvRbinds)
400 rnExpr (ExprWithTySig expr pty)
401 = rnExpr expr `thenRn` \ (expr', fvExpr) ->
402 rnHsSigType (text "an expression") pty `thenRn` \ (pty', fvTy) ->
403 returnRn (ExprWithTySig expr' pty', fvExpr `plusFV` fvTy)
405 rnExpr (HsIf p b1 b2 src_loc)
406 = pushSrcLocRn src_loc $
407 rnExpr p `thenRn` \ (p', fvP) ->
408 rnExpr b1 `thenRn` \ (b1', fvB1) ->
409 rnExpr b2 `thenRn` \ (b2', fvB2) ->
410 returnRn (HsIf p' b1' b2' src_loc, plusFVs [fvP, fvB1, fvB2])
412 rnExpr (ArithSeqIn seq)
413 = lookupImplicitOccRn enumClass_RDR `thenRn` \ enum ->
414 rn_seq seq `thenRn` \ (new_seq, fvs) ->
415 returnRn (ArithSeqIn new_seq, fvs `addOneFV` enum)
418 = rnExpr expr `thenRn` \ (expr', fvExpr) ->
419 returnRn (From expr', fvExpr)
421 rn_seq (FromThen expr1 expr2)
422 = rnExpr expr1 `thenRn` \ (expr1', fvExpr1) ->
423 rnExpr expr2 `thenRn` \ (expr2', fvExpr2) ->
424 returnRn (FromThen expr1' expr2', fvExpr1 `plusFV` fvExpr2)
426 rn_seq (FromTo expr1 expr2)
427 = rnExpr expr1 `thenRn` \ (expr1', fvExpr1) ->
428 rnExpr expr2 `thenRn` \ (expr2', fvExpr2) ->
429 returnRn (FromTo expr1' expr2', fvExpr1 `plusFV` fvExpr2)
431 rn_seq (FromThenTo expr1 expr2 expr3)
432 = rnExpr expr1 `thenRn` \ (expr1', fvExpr1) ->
433 rnExpr expr2 `thenRn` \ (expr2', fvExpr2) ->
434 rnExpr expr3 `thenRn` \ (expr3', fvExpr3) ->
435 returnRn (FromThenTo expr1' expr2' expr3',
436 plusFVs [fvExpr1, fvExpr2, fvExpr3])
439 These three are pattern syntax appearing in expressions.
440 Since all the symbols are reservedops we can simply reject them.
441 We return a (bogus) EWildPat in each case.
444 rnExpr e@EWildPat = addErrRn (patSynErr e) `thenRn_`
445 returnRn (EWildPat, emptyFVs)
447 rnExpr e@(EAsPat _ _) = addErrRn (patSynErr e) `thenRn_`
448 returnRn (EWildPat, emptyFVs)
450 rnExpr e@(ELazyPat _) = addErrRn (patSynErr e) `thenRn_`
451 returnRn (EWildPat, emptyFVs)
454 %************************************************************************
456 \subsubsection{@Rbinds@s and @Rpats@s: in record expressions}
458 %************************************************************************
462 = mapRn_ field_dup_err dup_fields `thenRn_`
463 mapFvRn rn_rbind rbinds `thenRn` \ (rbinds', fvRbind) ->
464 returnRn (rbinds', fvRbind)
466 (_, dup_fields) = removeDups compare [ f | (f,_,_) <- rbinds ]
468 field_dup_err dups = addErrRn (dupFieldErr str dups)
470 rn_rbind (field, expr, pun)
471 = lookupGlobalOccRn field `thenRn` \ fieldname ->
472 rnExpr expr `thenRn` \ (expr', fvExpr) ->
473 returnRn ((fieldname, expr', pun), fvExpr `addOneFV` fieldname)
476 = mapRn_ field_dup_err dup_fields `thenRn_`
477 mapFvRn rn_rpat rpats `thenRn` \ (rpats', fvs) ->
478 returnRn (rpats', fvs)
480 (_, dup_fields) = removeDups compare [ f | (f,_,_) <- rpats ]
482 field_dup_err dups = addErrRn (dupFieldErr "pattern" dups)
484 rn_rpat (field, pat, pun)
485 = lookupGlobalOccRn field `thenRn` \ fieldname ->
486 rnPat pat `thenRn` \ (pat', fvs) ->
487 returnRn ((fieldname, pat', pun), fvs `addOneFV` fieldname)
490 %************************************************************************
492 \subsubsection{@Stmt@s: in @do@ expressions}
494 %************************************************************************
496 Note that although some bound vars may appear in the free var set for
497 the first qual, these will eventually be removed by the caller. For
498 example, if we have @[p | r <- s, q <- r, p <- q]@, when doing
499 @[q <- r, p <- q]@, the free var set for @q <- r@ will
500 be @{r}@, and the free var set for the entire Quals will be @{r}@. This
501 @r@ will be removed only when we finally return from examining all the
505 type RnExprTy = RdrNameHsExpr -> RnMS (RenamedHsExpr, FreeVars)
509 -> RnMS ([RenamedStmt], FreeVars)
512 = returnRn ([], emptyFVs)
514 rnStmts rn_expr (stmt:stmts)
515 = rnStmt rn_expr stmt $ \ stmt' ->
516 rnStmts rn_expr stmts `thenRn` \ (stmts', fvs) ->
517 returnRn (stmt' : stmts', fvs)
519 rnStmt :: RnExprTy -> RdrNameStmt
520 -> (RenamedStmt -> RnMS (a, FreeVars))
521 -> RnMS (a, FreeVars)
522 -- Because of mutual recursion we have to pass in rnExpr.
524 rnStmt rn_expr (BindStmt pat expr src_loc) thing_inside
525 = pushSrcLocRn src_loc $
526 rn_expr expr `thenRn` \ (expr', fv_expr) ->
527 bindLocalsFVRn doc binders $ \ new_binders ->
528 rnPat pat `thenRn` \ (pat', fv_pat) ->
529 thing_inside (BindStmt pat' expr' src_loc) `thenRn` \ (result, fvs) ->
530 returnRn (result, fv_expr `plusFV` fvs `plusFV` fv_pat)
532 binders = collectPatBinders pat
533 doc = text "a pattern in do binding"
535 rnStmt rn_expr (ExprStmt expr src_loc) thing_inside
536 = pushSrcLocRn src_loc $
537 rn_expr expr `thenRn` \ (expr', fv_expr) ->
538 thing_inside (ExprStmt expr' src_loc) `thenRn` \ (result, fvs) ->
539 returnRn (result, fv_expr `plusFV` fvs)
541 rnStmt rn_expr (GuardStmt expr src_loc) thing_inside
542 = pushSrcLocRn src_loc $
543 rn_expr expr `thenRn` \ (expr', fv_expr) ->
544 thing_inside (GuardStmt expr' src_loc) `thenRn` \ (result, fvs) ->
545 returnRn (result, fv_expr `plusFV` fvs)
547 rnStmt rn_expr (ReturnStmt expr) thing_inside
548 = rn_expr expr `thenRn` \ (expr', fv_expr) ->
549 thing_inside (ReturnStmt expr') `thenRn` \ (result, fvs) ->
550 returnRn (result, fv_expr `plusFV` fvs)
552 rnStmt rn_expr (LetStmt binds) thing_inside
553 = rnBinds binds $ \ binds' ->
554 thing_inside (LetStmt binds')
557 %************************************************************************
559 \subsubsection{Precedence Parsing}
561 %************************************************************************
563 @mkOpAppRn@ deals with operator fixities. The argument expressions
564 are assumed to be already correctly arranged. It needs the fixities
565 recorded in the OpApp nodes, because fixity info applies to the things
566 the programmer actually wrote, so you can't find it out from the Name.
568 Furthermore, the second argument is guaranteed not to be another
569 operator application. Why? Because the parser parses all
570 operator appications left-associatively, EXCEPT negation, which
571 we need to handle specially.
574 mkOpAppRn :: RenamedHsExpr -- Left operand; already rearranged
575 -> RenamedHsExpr -> Fixity -- Operator and fixity
576 -> RenamedHsExpr -- Right operand (not an OpApp, but might
578 -> RnMS RenamedHsExpr
580 ---------------------------
581 -- (e11 `op1` e12) `op2` e2
582 mkOpAppRn e1@(OpApp e11 op1 fix1 e12) op2 fix2 e2
584 = addErrRn (precParseErr (get op1,fix1) (get op2,fix2)) `thenRn_`
585 returnRn (OpApp e1 op2 fix2 e2)
588 = mkOpAppRn e12 op2 fix2 e2 `thenRn` \ new_e ->
589 returnRn (OpApp e11 op1 fix1 new_e)
591 (nofix_error, associate_right) = compareFixity fix1 fix2
593 ---------------------------
594 -- (- neg_arg) `op` e2
595 mkOpAppRn e1@(NegApp neg_arg neg_op) op2 fix2 e2
597 = addErrRn (precParseErr (get neg_op,negateFixity) (get op2,fix2)) `thenRn_`
598 returnRn (OpApp e1 op2 fix2 e2)
601 = mkOpAppRn neg_arg op2 fix2 e2 `thenRn` \ new_e ->
602 returnRn (NegApp new_e neg_op)
604 (nofix_error, associate_right) = compareFixity negateFixity fix2
606 ---------------------------
608 mkOpAppRn e1 op1 fix1 e2@(NegApp neg_arg neg_op) -- NegApp can occur on the right
609 | not associate_right -- We *want* right association
610 = addErrRn (precParseErr (get op1, fix1) (get neg_op, negateFixity)) `thenRn_`
611 returnRn (OpApp e1 op1 fix1 e2)
613 (nofix_err, associate_right) = compareFixity fix1 negateFixity
615 ---------------------------
617 mkOpAppRn e1 op fix e2 -- Default case, no rearrangment
618 = ASSERT2( right_op_ok fix e2,
619 ppr e1 $$ text "---" $$ ppr op $$ text "---" $$ ppr fix $$ text "---" $$ ppr e2
621 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 (op1,fix1) (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 (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 = getModeRn `thenRn` \ mode ->
689 -- See comments with rnExpr (OpApp ...)
691 InterfaceMode -> returnRn ()
692 SourceMode -> checkPrec op p1 False `thenRn_`
695 checkPrecMatch True op _ = panic "checkPrecMatch"
697 checkPrec op (ConOpPatIn _ op1 _ _) right
698 = lookupFixity op `thenRn` \ op_fix@(Fixity op_prec op_dir) ->
699 lookupFixity op1 `thenRn` \ op1_fix@(Fixity op1_prec op1_dir) ->
701 inf_ok = op1_prec > op_prec ||
702 (op1_prec == op_prec &&
703 (op1_dir == InfixR && op_dir == InfixR && right ||
704 op1_dir == InfixL && op_dir == InfixL && not right))
707 info1 = (op1,op1_fix)
708 (infol, infor) = if right then (info, info1) else (info1, info)
710 checkRn inf_ok (precParseErr infol infor)
712 checkPrec op (NegPatIn _) right
713 = lookupFixity op `thenRn` \ op_fix@(Fixity op_prec op_dir) ->
714 checkRn (op_prec <= negatePrecedence) (precParseNegPatErr (op,op_fix))
716 checkPrec op pat right
724 @(compareFixity op1 op2)@ tells which way to arrange appication, or
725 whether there's an error.
728 compareFixity :: Fixity -> Fixity
729 -> (Bool, -- Error please
730 Bool) -- Associate to the right: a op1 (b op2 c)
731 compareFixity (Fixity prec1 dir1) (Fixity prec2 dir2)
732 = case prec1 `compare` prec2 of
735 EQ -> case (dir1, dir2) of
736 (InfixR, InfixR) -> right
737 (InfixL, InfixL) -> left
740 right = (False, True)
741 left = (False, False)
742 error_please = (True, False)
745 %************************************************************************
747 \subsubsection{Literals}
749 %************************************************************************
751 When literals occur we have to make sure
752 that the types and classes they involve
756 litOccurrence (HsChar _)
757 = returnRn (unitFV charTyCon_name)
759 litOccurrence (HsCharPrim _)
760 = returnRn (unitFV (getName charPrimTyCon))
762 litOccurrence (HsString _)
763 = returnRn (unitFV listTyCon_name `plusFV` unitFV charTyCon_name)
765 litOccurrence (HsStringPrim _)
766 = returnRn (unitFV (getName addrPrimTyCon))
768 litOccurrence (HsInt _)
769 = lookupImplicitOccRn numClass_RDR `thenRn` \ num ->
770 returnRn (unitFV num) -- Int and Integer are forced in by Num
772 litOccurrence (HsFrac _)
773 = lookupImplicitOccRn fractionalClass_RDR `thenRn` \ frac ->
774 lookupImplicitOccRn ratioDataCon_RDR `thenRn` \ ratio ->
775 returnRn (unitFV frac `plusFV` unitFV ratio)
776 -- We have to make sure that the Ratio type is imported with
777 -- its constructor, because literals of type Ratio t are
778 -- built with that constructor.
779 -- The Rational type is needed too, but that will come in
780 -- when fractionalClass does.
782 litOccurrence (HsIntPrim _)
783 = returnRn (unitFV (getName intPrimTyCon))
785 litOccurrence (HsFloatPrim _)
786 = returnRn (unitFV (getName floatPrimTyCon))
788 litOccurrence (HsDoublePrim _)
789 = returnRn (unitFV (getName doublePrimTyCon))
791 litOccurrence (HsLitLit _)
792 = lookupImplicitOccRn ccallableClass_RDR `thenRn` \ cc ->
796 %************************************************************************
798 \subsubsection{Assertion utils}
800 %************************************************************************
803 mkAssertExpr :: RnMS (RenamedHsExpr, FreeVars)
805 mkImportedGlobalFromRdrName assertErr_RDR `thenRn` \ name ->
806 getSrcLocRn `thenRn` \ sloc ->
808 -- if we're ignoring asserts, return (\ _ e -> e)
809 -- if not, return (assertError "src-loc")
811 if opt_IgnoreAsserts then
812 getUniqRn `thenRn` \ uniq ->
814 vname = mkSysLocalName uniq SLIT("v")
815 expr = HsLam ignorePredMatch
816 loc = nameSrcLoc vname
817 ignorePredMatch = Match [] [WildPatIn, VarPatIn vname] Nothing
818 (GRHSs [GRHS [ExprStmt (HsVar vname) loc] loc]
821 returnRn (expr, unitFV name)
826 (HsLit (HsString (_PK_ (showSDoc (ppr sloc)))))
829 returnRn (expr, unitFV name)
833 %************************************************************************
835 \subsubsection{Errors}
837 %************************************************************************
840 dupFieldErr str (dup:rest)
841 = hsep [ptext SLIT("duplicate field name"),
843 ptext SLIT("in record"), text str]
846 = sep [ptext SLIT("prefix `-' not applied to literal in pattern"), quotes (ppr pat)]
848 precParseNegPatErr op
849 = hang (ptext SLIT("precedence parsing error"))
850 4 (hsep [ptext SLIT("prefix `-' has lower precedence than"),
852 ptext SLIT("in pattern")])
855 = hang (ptext SLIT("precedence parsing error"))
856 4 (hsep [ptext SLIT("cannot mix"), pp_op op1, ptext SLIT("and"),
858 ptext SLIT("in the same infix expression")])
862 SLIT("accepting non-standard pattern guards (-fglasgow-exts to suppress this message)")
866 = (ptext SLIT("Illegal signature in pattern:") <+> ppr ty)
867 $$ nest 4 (ptext SLIT("Use -fglasgow-exts to permit it"))
869 pp_op (op, fix) = hcat [quotes (ppr op), space, parens (ppr fix)]
872 = sep [ptext SLIT("Pattern syntax in expression context:"),
876 = sep [ptext SLIT("`do' statements must end in expression:"),