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,
18 #include "HsVersions.h"
20 import {-# SOURCE #-} RnBinds ( rnBinds )
21 import {-# SOURCE #-} RnSource ( rnHsSigType, rnHsType )
28 import CmdLineOpts ( opt_GlasgowExts, opt_IgnoreAsserts )
29 import BasicTypes ( Fixity(..), FixityDirection(..) )
30 import PrelInfo ( numClass_RDR, fractionalClass_RDR, eqClass_RDR,
31 ccallableClass_RDR, creturnableClass_RDR,
32 monadClass_RDR, enumClass_RDR, ordClass_RDR,
33 ratioDataCon_RDR, negate_RDR, assertErr_RDR,
36 import TysPrim ( charPrimTyCon, addrPrimTyCon, intPrimTyCon,
37 floatPrimTyCon, doublePrimTyCon
39 import Name ( nameUnique, isLocallyDefined, NamedThing(..)
40 , mkSysLocalName, nameSrcLoc
43 import UniqFM ( isNullUFM )
44 import FiniteMap ( elemFM )
45 import UniqSet ( emptyUniqSet, UniqSet )
46 import Unique ( assertIdKey )
47 import Util ( removeDups )
48 import ListSetOps ( unionLists )
49 import Maybes ( maybeToBool )
54 *********************************************************
58 *********************************************************
61 rnPat :: RdrNamePat -> RnMS s (RenamedPat, FreeVars)
63 rnPat WildPatIn = returnRn (WildPatIn, emptyFVs)
66 = lookupBndrRn name `thenRn` \ vname ->
67 returnRn (VarPatIn vname, emptyFVs)
69 rnPat (SigPatIn pat ty)
71 = rnPat pat `thenRn` \ (pat', fvs1) ->
72 rnHsType doc ty `thenRn` \ (ty', fvs2) ->
73 returnRn (SigPatIn pat' ty', fvs1 `plusFV` fvs2)
76 = addErrRn (patSigErr ty) `thenRn_`
79 doc = text "a pattern type-signature"
82 = litOccurrence lit `thenRn_`
83 lookupImplicitOccRn eqClass_RDR `thenRn_` -- Needed to find equality on pattern
84 returnRn (LitPatIn lit, emptyFVs)
87 = rnPat pat `thenRn` \ (pat', fvs) ->
88 returnRn (LazyPatIn pat', fvs)
90 rnPat (AsPatIn name pat)
91 = rnPat pat `thenRn` \ (pat', fvs) ->
92 lookupBndrRn name `thenRn` \ vname ->
93 returnRn (AsPatIn vname pat', fvs)
95 rnPat (ConPatIn con pats)
96 = lookupOccRn con `thenRn` \ con' ->
97 mapAndUnzipRn rnPat pats `thenRn` \ (patslist, fvs_s) ->
98 returnRn (ConPatIn con' patslist, plusFVs fvs_s `addOneFV` con')
100 rnPat (ConOpPatIn pat1 con _ pat2)
101 = rnPat pat1 `thenRn` \ (pat1', fvs1) ->
102 lookupOccRn con `thenRn` \ con' ->
103 lookupFixity con' `thenRn` \ fixity ->
104 rnPat pat2 `thenRn` \ (pat2', fvs2) ->
105 mkConOpPatRn pat1' con' fixity pat2' `thenRn` \ pat' ->
106 returnRn (pat', fvs1 `plusFV` fvs2 `addOneFV` con')
108 -- Negated patters can only be literals, and they are dealt with
109 -- by negating the literal at compile time, not by using the negation
110 -- operation in Num. So we don't need to make an implicit reference
112 rnPat neg@(NegPatIn pat)
113 = checkRn (valid_neg_pat pat) (negPatErr neg)
115 rnPat pat `thenRn` \ (pat', fvs) ->
116 returnRn (NegPatIn pat', fvs)
118 valid_neg_pat (LitPatIn (HsInt _)) = True
119 valid_neg_pat (LitPatIn (HsFrac _)) = True
120 valid_neg_pat _ = False
123 = rnPat pat `thenRn` \ (pat', fvs) ->
124 returnRn (ParPatIn pat', fvs)
126 rnPat (NPlusKPatIn name lit)
127 = litOccurrence lit `thenRn_`
128 lookupImplicitOccRn ordClass_RDR `thenRn_`
129 lookupBndrRn name `thenRn` \ name' ->
130 returnRn (NPlusKPatIn name' lit, emptyFVs)
132 rnPat (ListPatIn pats)
133 = addImplicitOccRn listTyCon_name `thenRn_`
134 mapAndUnzipRn rnPat pats `thenRn` \ (patslist, fvs_s) ->
135 returnRn (ListPatIn patslist, plusFVs fvs_s)
137 rnPat (TuplePatIn pats boxed)
138 = addImplicitOccRn (tupleTyCon_name boxed (length pats)) `thenRn_`
139 mapAndUnzipRn rnPat pats `thenRn` \ (patslist, fvs_s) ->
140 returnRn (TuplePatIn patslist boxed, plusFVs fvs_s)
142 rnPat (RecPatIn con rpats)
143 = lookupOccRn con `thenRn` \ con' ->
144 rnRpats rpats `thenRn` \ (rpats', fvs) ->
145 returnRn (RecPatIn con' rpats', fvs `addOneFV` con')
148 ************************************************************************
152 ************************************************************************
155 rnMatch :: RdrNameMatch -> RnMS s (RenamedMatch, FreeVars)
157 rnMatch match@(Match _ pats maybe_rhs_sig grhss)
158 = pushSrcLocRn (getMatchLoc match) $
160 -- Find the universally quantified type variables
161 -- in the pattern type signatures
162 getLocalNameEnv `thenRn` \ name_env ->
164 tyvars_in_sigs = rhs_sig_tyvars `unionLists` tyvars_in_pats
165 rhs_sig_tyvars = case maybe_rhs_sig of
167 Just ty -> extractHsTyVars ty
168 tyvars_in_pats = extractPatsTyVars pats
169 forall_tyvars = filter (not . (`elemFM` name_env)) tyvars_in_sigs
170 doc = text "a pattern type-signature"
172 bindTyVarsFVRn doc (map UserTyVar forall_tyvars) $ \ sig_tyvars ->
174 -- Note that we do a single bindLocalsRn for all the
175 -- matches together, so that we spot the repeated variable in
177 bindLocalsFVRn "a pattern" (collectPatsBinders pats) $ \ new_binders ->
179 mapAndUnzipRn rnPat pats `thenRn` \ (pats', pat_fvs_s) ->
180 rnGRHSs grhss `thenRn` \ (grhss', grhss_fvs) ->
181 (case maybe_rhs_sig of
182 Nothing -> returnRn (Nothing, emptyFVs)
183 Just ty | opt_GlasgowExts -> rnHsType doc ty `thenRn` \ (ty', ty_fvs) ->
184 returnRn (Just ty', ty_fvs)
185 | otherwise -> addErrRn (patSigErr ty) `thenRn_`
186 returnRn (Nothing, emptyFVs)
187 ) `thenRn` \ (maybe_rhs_sig', ty_fvs) ->
190 binder_set = mkNameSet new_binders
191 unused_binders = nameSetToList (binder_set `minusNameSet` grhss_fvs)
192 all_fvs = grhss_fvs `plusFV` plusFVs pat_fvs_s `plusFV` ty_fvs
194 warnUnusedMatches unused_binders `thenRn_`
196 returnRn (Match sig_tyvars pats' maybe_rhs_sig' grhss', all_fvs)
197 -- The bindLocals and bindTyVars will remove the bound FVs
200 %************************************************************************
202 \subsubsection{Guarded right-hand sides (GRHSs)}
204 %************************************************************************
207 rnGRHSs :: RdrNameGRHSs -> RnMS s (RenamedGRHSs, FreeVars)
209 rnGRHSs (GRHSs grhss binds maybe_ty)
210 = ASSERT( not (maybeToBool maybe_ty) )
211 rnBinds binds $ \ binds' ->
212 mapAndUnzipRn rnGRHS grhss `thenRn` \ (grhss', fvGRHSs) ->
213 returnRn (GRHSs grhss' binds' Nothing, plusFVs fvGRHSs)
215 rnGRHS (GRHS guarded locn)
216 = pushSrcLocRn locn $
217 (if not (opt_GlasgowExts || is_standard_guard guarded) then
218 addWarnRn (nonStdGuardErr guarded)
223 rnStmts rnExpr guarded `thenRn` \ (guarded', fvs) ->
224 returnRn (GRHS guarded' locn, fvs)
226 -- Standard Haskell 1.4 guards are just a single boolean
227 -- expression, rather than a list of qualifiers as in the
229 is_standard_guard [ExprStmt _ _] = True
230 is_standard_guard [GuardStmt _ _, ExprStmt _ _] = True
231 is_standard_guard other = False
234 %************************************************************************
236 \subsubsection{Expressions}
238 %************************************************************************
241 rnExprs :: [RdrNameHsExpr] -> RnMS s ([RenamedHsExpr], FreeVars)
242 rnExprs ls = rnExprs' ls emptyUniqSet
244 rnExprs' [] acc = returnRn ([], acc)
245 rnExprs' (expr:exprs) acc
246 = rnExpr expr `thenRn` \ (expr', fvExpr) ->
248 -- Now we do a "seq" on the free vars because typically it's small
249 -- or empty, especially in very long lists of constants
251 acc' = acc `plusFV` fvExpr
253 (grubby_seqNameSet acc' rnExprs') exprs acc' `thenRn` \ (exprs', fvExprs) ->
254 returnRn (expr':exprs', fvExprs)
256 -- Grubby little function to do "seq" on namesets; replace by proper seq when GHC can do seq
257 grubby_seqNameSet ns result | isNullUFM ns = result
261 Variables. We look up the variable and return the resulting name.
264 rnExpr :: RdrNameHsExpr -> RnMS s (RenamedHsExpr, FreeVars)
267 = lookupOccRn v `thenRn` \ name ->
268 if nameUnique name == assertIdKey then
269 -- We expand it to (GHCerr.assert__ location)
270 mkAssertExpr `thenRn` \ expr ->
271 returnRn (expr, emptyUniqSet)
274 returnRn (HsVar name, unitFV name)
277 = litOccurrence lit `thenRn_`
278 returnRn (HsLit lit, emptyFVs)
281 = rnMatch match `thenRn` \ (match', fvMatch) ->
282 returnRn (HsLam match', fvMatch)
284 rnExpr (HsApp fun arg)
285 = rnExpr fun `thenRn` \ (fun',fvFun) ->
286 rnExpr arg `thenRn` \ (arg',fvArg) ->
287 returnRn (HsApp fun' arg', fvFun `plusFV` fvArg)
289 rnExpr (OpApp e1 op _ e2)
290 = rnExpr e1 `thenRn` \ (e1', fv_e1) ->
291 rnExpr e2 `thenRn` \ (e2', fv_e2) ->
292 rnExpr op `thenRn` \ (op'@(HsVar op_name), fv_op) ->
295 -- When renaming code synthesised from "deriving" declarations
296 -- we're in Interface mode, and we should ignore fixity; assume
297 -- that the deriving code generator got the association correct
298 lookupFixity op_name `thenRn` \ fixity ->
299 getModeRn `thenRn` \ mode ->
301 SourceMode -> mkOpAppRn e1' op' fixity e2'
302 InterfaceMode _ -> returnRn (OpApp e1' op' fixity e2')
303 ) `thenRn` \ final_e ->
306 fv_e1 `plusFV` fv_op `plusFV` fv_e2)
309 = rnExpr e `thenRn` \ (e', fv_e) ->
310 lookupImplicitOccRn negate_RDR `thenRn` \ neg ->
311 mkNegAppRn e' (HsVar neg) `thenRn` \ final_e ->
312 returnRn (final_e, fv_e)
315 = rnExpr e `thenRn` \ (e', fvs_e) ->
316 returnRn (HsPar e', fvs_e)
318 rnExpr (SectionL expr op)
319 = rnExpr expr `thenRn` \ (expr', fvs_expr) ->
320 rnExpr op `thenRn` \ (op', fvs_op) ->
321 returnRn (SectionL expr' op', fvs_op `plusFV` fvs_expr)
323 rnExpr (SectionR op expr)
324 = rnExpr op `thenRn` \ (op', fvs_op) ->
325 rnExpr expr `thenRn` \ (expr', fvs_expr) ->
326 returnRn (SectionR op' expr', fvs_op `plusFV` fvs_expr)
328 rnExpr (CCall fun args may_gc is_casm fake_result_ty)
329 -- Check out the comment on RnIfaces.getNonWiredDataDecl about ccalls
330 = lookupImplicitOccRn ccallableClass_RDR `thenRn_`
331 lookupImplicitOccRn creturnableClass_RDR `thenRn_`
332 lookupImplicitOccRn ioDataCon_RDR `thenRn_`
333 rnExprs args `thenRn` \ (args', fvs_args) ->
334 returnRn (CCall fun args' may_gc is_casm fake_result_ty, fvs_args)
336 rnExpr (HsSCC label expr)
337 = rnExpr expr `thenRn` \ (expr', fvs_expr) ->
338 returnRn (HsSCC label expr', fvs_expr)
340 rnExpr (HsCase expr ms src_loc)
341 = pushSrcLocRn src_loc $
342 rnExpr expr `thenRn` \ (new_expr, e_fvs) ->
343 mapAndUnzipRn rnMatch ms `thenRn` \ (new_ms, ms_fvs) ->
344 returnRn (HsCase new_expr new_ms src_loc, plusFVs (e_fvs : ms_fvs))
346 rnExpr (HsLet binds expr)
347 = rnBinds binds $ \ binds' ->
348 rnExpr expr `thenRn` \ (expr',fvExpr) ->
349 returnRn (HsLet binds' expr', fvExpr)
351 rnExpr (HsDo do_or_lc stmts src_loc)
352 = pushSrcLocRn src_loc $
353 lookupImplicitOccRn monadClass_RDR `thenRn_`
354 rnStmts rnExpr stmts `thenRn` \ (stmts', fvs) ->
355 returnRn (HsDo do_or_lc stmts' src_loc, fvs)
357 rnExpr (ExplicitList exps)
358 = addImplicitOccRn listTyCon_name `thenRn_`
359 rnExprs exps `thenRn` \ (exps', fvs) ->
360 returnRn (ExplicitList exps', fvs)
362 rnExpr (ExplicitTuple exps boxed)
363 = addImplicitOccRn (tupleTyCon_name boxed (length exps)) `thenRn_`
364 rnExprs exps `thenRn` \ (exps', fvExps) ->
365 returnRn (ExplicitTuple exps' boxed, fvExps)
367 rnExpr (RecordCon con_id rbinds)
368 = lookupOccRn con_id `thenRn` \ conname ->
369 rnRbinds "construction" rbinds `thenRn` \ (rbinds', fvRbinds) ->
370 returnRn (RecordCon conname rbinds', fvRbinds)
372 rnExpr (RecordUpd expr rbinds)
373 = rnExpr expr `thenRn` \ (expr', fvExpr) ->
374 rnRbinds "update" rbinds `thenRn` \ (rbinds', fvRbinds) ->
375 returnRn (RecordUpd expr' rbinds', fvExpr `plusFV` fvRbinds)
377 rnExpr (ExprWithTySig expr pty)
378 = rnExpr expr `thenRn` \ (expr', fvExpr) ->
379 rnHsSigType (text "an expression") pty `thenRn` \ (pty', fvTy) ->
380 returnRn (ExprWithTySig expr' pty', fvExpr `plusFV` fvTy)
382 rnExpr (HsIf p b1 b2 src_loc)
383 = pushSrcLocRn src_loc $
384 rnExpr p `thenRn` \ (p', fvP) ->
385 rnExpr b1 `thenRn` \ (b1', fvB1) ->
386 rnExpr b2 `thenRn` \ (b2', fvB2) ->
387 returnRn (HsIf p' b1' b2' src_loc, plusFVs [fvP, fvB1, fvB2])
389 rnExpr (ArithSeqIn seq)
390 = lookupImplicitOccRn enumClass_RDR `thenRn_`
391 rn_seq seq `thenRn` \ (new_seq, fvs) ->
392 returnRn (ArithSeqIn new_seq, fvs)
395 = rnExpr expr `thenRn` \ (expr', fvExpr) ->
396 returnRn (From expr', fvExpr)
398 rn_seq (FromThen expr1 expr2)
399 = rnExpr expr1 `thenRn` \ (expr1', fvExpr1) ->
400 rnExpr expr2 `thenRn` \ (expr2', fvExpr2) ->
401 returnRn (FromThen expr1' expr2', fvExpr1 `plusFV` fvExpr2)
403 rn_seq (FromTo expr1 expr2)
404 = rnExpr expr1 `thenRn` \ (expr1', fvExpr1) ->
405 rnExpr expr2 `thenRn` \ (expr2', fvExpr2) ->
406 returnRn (FromTo expr1' expr2', fvExpr1 `plusFV` fvExpr2)
408 rn_seq (FromThenTo expr1 expr2 expr3)
409 = rnExpr expr1 `thenRn` \ (expr1', fvExpr1) ->
410 rnExpr expr2 `thenRn` \ (expr2', fvExpr2) ->
411 rnExpr expr3 `thenRn` \ (expr3', fvExpr3) ->
412 returnRn (FromThenTo expr1' expr2' expr3',
413 plusFVs [fvExpr1, fvExpr2, fvExpr3])
416 %************************************************************************
418 \subsubsection{@Rbinds@s and @Rpats@s: in record expressions}
420 %************************************************************************
424 = mapRn_ field_dup_err dup_fields `thenRn_`
425 mapAndUnzipRn rn_rbind rbinds `thenRn` \ (rbinds', fvRbind_s) ->
426 returnRn (rbinds', plusFVs fvRbind_s)
428 (_, dup_fields) = removeDups compare [ f | (f,_,_) <- rbinds ]
430 field_dup_err dups = addErrRn (dupFieldErr str dups)
432 rn_rbind (field, expr, pun)
433 = lookupGlobalOccRn field `thenRn` \ fieldname ->
434 rnExpr expr `thenRn` \ (expr', fvExpr) ->
435 returnRn ((fieldname, expr', pun), fvExpr `addOneFV` fieldname)
438 = mapRn_ field_dup_err dup_fields `thenRn_`
439 mapAndUnzipRn rn_rpat rpats `thenRn` \ (rpats', fvs_s) ->
440 returnRn (rpats', plusFVs fvs_s)
442 (_, dup_fields) = removeDups compare [ f | (f,_,_) <- rpats ]
444 field_dup_err dups = addErrRn (dupFieldErr "pattern" dups)
446 rn_rpat (field, pat, pun)
447 = lookupGlobalOccRn field `thenRn` \ fieldname ->
448 rnPat pat `thenRn` \ (pat', fvs) ->
449 returnRn ((fieldname, pat', pun), fvs `addOneFV` fieldname)
452 %************************************************************************
454 \subsubsection{@Stmt@s: in @do@ expressions}
456 %************************************************************************
458 Note that although some bound vars may appear in the free var set for
459 the first qual, these will eventually be removed by the caller. For
460 example, if we have @[p | r <- s, q <- r, p <- q]@, when doing
461 @[q <- r, p <- q]@, the free var set for @q <- r@ will
462 be @{r}@, and the free var set for the entire Quals will be @{r}@. This
463 @r@ will be removed only when we finally return from examining all the
467 type RnExprTy s = RdrNameHsExpr -> RnMS s (RenamedHsExpr, FreeVars)
469 rnStmts :: RnExprTy s
471 -> RnMS s ([RenamedStmt], FreeVars)
474 = returnRn ([], emptyFVs)
476 rnStmts rn_expr (stmt:stmts)
477 = rnStmt rn_expr stmt $ \ stmt' ->
478 rnStmts rn_expr stmts `thenRn` \ (stmts', fvs) ->
479 returnRn (stmt' : stmts', fvs)
481 rnStmt :: RnExprTy s -> RdrNameStmt
482 -> (RenamedStmt -> RnMS s (a, FreeVars))
483 -> RnMS s (a, FreeVars)
484 -- Because of mutual recursion we have to pass in rnExpr.
486 rnStmt rn_expr (BindStmt pat expr src_loc) thing_inside
487 = pushSrcLocRn src_loc $
488 rn_expr expr `thenRn` \ (expr', fv_expr) ->
489 bindLocalsFVRn "a pattern in do binding" binders $ \ new_binders ->
490 rnPat pat `thenRn` \ (pat', fv_pat) ->
491 thing_inside (BindStmt pat' expr' src_loc) `thenRn` \ (result, fvs) ->
492 returnRn (result, fv_expr `plusFV` fvs `plusFV` fv_pat)
494 binders = collectPatBinders pat
496 rnStmt rn_expr (ExprStmt expr src_loc) thing_inside
497 = pushSrcLocRn src_loc $
498 rn_expr expr `thenRn` \ (expr', fv_expr) ->
499 thing_inside (ExprStmt expr' src_loc) `thenRn` \ (result, fvs) ->
500 returnRn (result, fv_expr `plusFV` fvs)
502 rnStmt rn_expr (GuardStmt expr src_loc) thing_inside
503 = pushSrcLocRn src_loc $
504 rn_expr expr `thenRn` \ (expr', fv_expr) ->
505 thing_inside (GuardStmt expr' src_loc) `thenRn` \ (result, fvs) ->
506 returnRn (result, fv_expr `plusFV` fvs)
508 rnStmt rn_expr (ReturnStmt expr) thing_inside
509 = rn_expr expr `thenRn` \ (expr', fv_expr) ->
510 thing_inside (ReturnStmt expr') `thenRn` \ (result, fvs) ->
511 returnRn (result, fv_expr `plusFV` fvs)
513 rnStmt rn_expr (LetStmt binds) thing_inside
514 = rnBinds binds $ \ binds' ->
515 thing_inside (LetStmt binds')
518 %************************************************************************
520 \subsubsection{Precedence Parsing}
522 %************************************************************************
524 @mkOpAppRn@ deals with operator fixities. The argument expressions
525 are assumed to be already correctly arranged. It needs the fixities
526 recorded in the OpApp nodes, because fixity info applies to the things
527 the programmer actually wrote, so you can't find it out from the Name.
529 Furthermore, the second argument is guaranteed not to be another
530 operator application. Why? Because the parser parses all
531 operator appications left-associatively.
534 mkOpAppRn :: RenamedHsExpr -> RenamedHsExpr -> Fixity -> RenamedHsExpr
535 -> RnMS s RenamedHsExpr
537 mkOpAppRn e1@(OpApp e11 op1 fix1 e12)
540 = addErrRn (precParseErr (get op1,fix1) (get op2,fix2)) `thenRn_`
541 returnRn (OpApp e1 op2 fix2 e2)
544 = mkOpAppRn e12 op2 fix2 e2 `thenRn` \ new_e ->
545 returnRn (OpApp e11 op1 fix1 new_e)
547 (nofix_error, rearrange_me) = compareFixity fix1 fix2
549 mkOpAppRn e1@(NegApp neg_arg neg_op)
551 fix2@(Fixity prec2 dir2)
554 = addErrRn (precParseErr (get neg_op,fix_neg) (get op2,fix2)) `thenRn_`
555 returnRn (OpApp e1 op2 fix2 e2)
558 = mkOpAppRn neg_arg op2 fix2 e2 `thenRn` \ new_e ->
559 returnRn (NegApp new_e neg_op)
561 fix_neg = Fixity 6 InfixL -- Precedence of unary negate is wired in as infixl 6!
562 (nofix_error, rearrange_me) = compareFixity fix_neg fix2
564 mkOpAppRn e1 op fix e2 -- Default case, no rearrangment
565 = ASSERT( if right_op_ok fix e2 then True
566 else pprPanic "mkOpAppRn" (vcat [ppr e1, text "---", ppr op,
567 text "---", ppr fix, text "---", ppr e2])
569 returnRn (OpApp e1 op fix e2)
573 -- Parser left-associates everything, but
574 -- derived instances may have correctly-associated things to
575 -- in the right operarand. So we just check that the right operand is OK
576 right_op_ok fix1 (OpApp _ _ fix2 _)
577 = not error_please && associate_right
579 (error_please, associate_right) = compareFixity fix1 fix2
580 right_op_ok fix1 other
583 -- Parser initially makes negation bind more tightly than any other operator
584 mkNegAppRn neg_arg neg_op
587 getModeRn `thenRn` \ mode ->
588 ASSERT( not_op_app mode neg_arg )
590 returnRn (NegApp neg_arg neg_op)
592 not_op_app SourceMode (OpApp _ _ _ _) = False
593 not_op_app mode other = True
597 mkConOpPatRn :: RenamedPat -> Name -> Fixity -> RenamedPat
600 mkConOpPatRn p1@(ConOpPatIn p11 op1 fix1 p12)
603 = addErrRn (precParseErr (op1,fix1) (op2,fix2)) `thenRn_`
604 returnRn (ConOpPatIn p1 op2 fix2 p2)
607 = mkConOpPatRn p12 op2 fix2 p2 `thenRn` \ new_p ->
608 returnRn (ConOpPatIn p11 op1 fix1 new_p)
611 (nofix_error, rearrange_me) = compareFixity fix1 fix2
613 mkConOpPatRn p1@(NegPatIn neg_arg)
615 fix2@(Fixity prec2 dir2)
617 | prec2 > 6 -- Precedence of unary - is wired in as 6!
618 = addErrRn (precParseNegPatErr (op2,fix2)) `thenRn_`
619 returnRn (ConOpPatIn p1 op2 fix2 p2)
621 mkConOpPatRn p1 op fix p2 -- Default case, no rearrangment
622 = ASSERT( not_op_pat p2 )
623 returnRn (ConOpPatIn p1 op fix p2)
625 not_op_pat (ConOpPatIn _ _ _ _) = False
626 not_op_pat other = True
630 checkPrecMatch :: Bool -> Name -> RenamedMatch -> RnMS s ()
632 checkPrecMatch False fn match
634 checkPrecMatch True op (Match _ [p1,p2] _ _)
635 = checkPrec op p1 False `thenRn_`
637 checkPrecMatch True op _ = panic "checkPrecMatch"
639 checkPrec op (ConOpPatIn _ op1 _ _) right
640 = lookupFixity op `thenRn` \ op_fix@(Fixity op_prec op_dir) ->
641 lookupFixity op1 `thenRn` \ op1_fix@(Fixity op1_prec op1_dir) ->
643 inf_ok = op1_prec > op_prec ||
644 (op1_prec == op_prec &&
645 (op1_dir == InfixR && op_dir == InfixR && right ||
646 op1_dir == InfixL && op_dir == InfixL && not right))
649 info1 = (op1,op1_fix)
650 (infol, infor) = if right then (info, info1) else (info1, info)
652 checkRn inf_ok (precParseErr infol infor)
654 checkPrec op (NegPatIn _) right
655 = lookupFixity op `thenRn` \ op_fix@(Fixity op_prec op_dir) ->
656 checkRn (op_prec <= 6) (precParseNegPatErr (op,op_fix))
658 checkPrec op pat right
665 (compareFixity op1 op2) tells which way to arrange appication, or
666 whether there's an error.
669 compareFixity :: Fixity -> Fixity
670 -> (Bool, -- Error please
671 Bool) -- Associate to the right: a op1 (b op2 c)
672 compareFixity (Fixity prec1 dir1) (Fixity prec2 dir2)
673 = case prec1 `compare` prec2 of
676 EQ -> case (dir1, dir2) of
677 (InfixR, InfixR) -> right
678 (InfixL, InfixL) -> left
681 right = (False, True)
682 left = (False, False)
683 error_please = (True, False)
686 %************************************************************************
688 \subsubsection{Literals}
690 %************************************************************************
692 When literals occur we have to make sure that the types and classes they involve
696 litOccurrence (HsChar _)
697 = addImplicitOccRn charTyCon_name
699 litOccurrence (HsCharPrim _)
700 = addImplicitOccRn (getName charPrimTyCon)
702 litOccurrence (HsString _)
703 = addImplicitOccRn listTyCon_name `thenRn_`
704 addImplicitOccRn charTyCon_name
706 litOccurrence (HsStringPrim _)
707 = addImplicitOccRn (getName addrPrimTyCon)
709 litOccurrence (HsInt _)
710 = lookupImplicitOccRn numClass_RDR -- Int and Integer are forced in by Num
712 litOccurrence (HsFrac _)
713 = lookupImplicitOccRn fractionalClass_RDR `thenRn_`
714 lookupImplicitOccRn ratioDataCon_RDR
715 -- We have to make sure that the Ratio type is imported with
716 -- its constructor, because literals of type Ratio t are
717 -- built with that constructor.
718 -- The Rational type is needed too, but that will come in
719 -- when fractionalClass does.
721 litOccurrence (HsIntPrim _)
722 = addImplicitOccRn (getName intPrimTyCon)
724 litOccurrence (HsFloatPrim _)
725 = addImplicitOccRn (getName floatPrimTyCon)
727 litOccurrence (HsDoublePrim _)
728 = addImplicitOccRn (getName doublePrimTyCon)
730 litOccurrence (HsLitLit _)
731 = lookupImplicitOccRn ccallableClass_RDR
734 %************************************************************************
736 \subsubsection{Assertion utils}
738 %************************************************************************
741 mkAssertExpr :: RnMS s RenamedHsExpr
743 newImportedGlobalFromRdrName assertErr_RDR `thenRn` \ name ->
744 addOccurrenceName name `thenRn_`
745 getSrcLocRn `thenRn` \ sloc ->
747 -- if we're ignoring asserts, return (\ _ e -> e)
748 -- if not, return (assertError "src-loc")
750 if opt_IgnoreAsserts then
751 getUniqRn `thenRn` \ uniq ->
753 vname = mkSysLocalName uniq SLIT("v")
754 expr = HsLam ignorePredMatch
755 loc = nameSrcLoc vname
756 ignorePredMatch = Match [] [WildPatIn, VarPatIn vname] Nothing
757 (GRHSs [GRHS [ExprStmt (HsVar vname) loc] loc]
765 (HsLit (HsString (_PK_ (showSDoc (ppr sloc)))))
772 %************************************************************************
774 \subsubsection{Errors}
776 %************************************************************************
779 dupFieldErr str (dup:rest)
780 = hsep [ptext SLIT("duplicate field name"),
782 ptext SLIT("in record"), text str]
785 = sep [ptext SLIT("prefix `-' not applied to literal in pattern"), quotes (ppr pat)]
787 precParseNegPatErr op
788 = hang (ptext SLIT("precedence parsing error"))
789 4 (hsep [ptext SLIT("prefix `-' has lower precedence than"),
791 ptext SLIT("in pattern")])
794 = hang (ptext SLIT("precedence parsing error"))
795 4 (hsep [ptext SLIT("cannot mix"), quotes (pp_op op1), ptext SLIT("and"),
797 ptext SLIT("in the same infix expression")])
800 = hang (ptext SLIT("accepting non-standard pattern guards (-fglasgow-exts to suppress this message)"))
804 = hang (ptext SLIT("Illegal signature in pattern:") <+> ppr ty)
805 4 (ptext SLIT("Use -fglasgow-exts to permit it"))
807 pp_op (op, fix) = hcat [ppr op, space, parens (ppr fix)]