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, rnExpr, rnExprs, rnStmts,
18 #include "HsVersions.h"
20 import {-# SOURCE #-} RnSource ( rnSrcDecls, rnBindsAndThen, rnBinds )
22 -- RnSource imports RnBinds.rnTopMonoBinds, RnExpr.rnExpr
23 -- RnBinds imports RnExpr.rnMatch, etc
24 -- RnExpr imports [boot] RnSource.rnSrcDecls, RnSource.rnBinds
31 import RnNames ( importsFromLocalDecls )
32 import RnTypes ( rnHsTypeFVs, rnPat, litFVs, rnOverLit, rnPatsAndThen,
33 dupFieldErr, precParseErr, sectionPrecErr, patSigErr )
34 import CmdLineOpts ( DynFlag(..), opt_IgnoreAsserts )
35 import BasicTypes ( Fixity(..), FixityDirection(..), IPName(..),
36 defaultFixity, negateFixity, compareFixity )
37 import PrelNames ( hasKey, assertIdKey,
39 cCallableClassName, cReturnableClassName,
41 splitName, fstName, sndName, ioDataConName,
42 replicatePName, mapPName, filterPName,
43 crossPName, zipPName, toPName,
44 enumFromToPName, enumFromThenToPName, assertErrorName,
45 negateName, monadNames, mfixName )
47 import DsMeta ( qTyConName )
49 import Name ( Name, nameOccName )
51 import UnicodeUtil ( stringToUtf8 )
52 import UniqFM ( isNullUFM )
53 import UniqSet ( emptyUniqSet )
54 import Util ( isSingleton )
55 import List ( intersectBy, unzip4 )
56 import ListSetOps ( removeDups )
62 ************************************************************************
66 ************************************************************************
69 rnMatch :: HsMatchContext Name -> RdrNameMatch -> RnM (RenamedMatch, FreeVars)
71 rnMatch ctxt match@(Match pats maybe_rhs_sig grhss)
72 = addSrcLoc (getMatchLoc match) $
74 -- Deal with the rhs type signature
75 bindPatSigTyVars rhs_sig_tys $
76 doptM Opt_GlasgowExts `thenM` \ opt_GlasgowExts ->
77 (case maybe_rhs_sig of
78 Nothing -> returnM (Nothing, emptyFVs)
79 Just ty | opt_GlasgowExts -> rnHsTypeFVs doc_sig ty `thenM` \ (ty', ty_fvs) ->
80 returnM (Just ty', ty_fvs)
81 | otherwise -> addErr (patSigErr ty) `thenM_`
82 returnM (Nothing, emptyFVs)
83 ) `thenM` \ (maybe_rhs_sig', ty_fvs) ->
86 rnPatsAndThen ctxt pats $ \ pats' ->
87 rnGRHSs ctxt grhss `thenM` \ (grhss', grhss_fvs) ->
89 returnM (Match pats' maybe_rhs_sig' grhss', grhss_fvs `plusFV` ty_fvs)
90 -- The bindPatSigTyVars and rnPatsAndThen will remove the bound FVs
92 rhs_sig_tys = case maybe_rhs_sig of
95 doc_sig = text "In a result type-signature"
99 %************************************************************************
101 \subsubsection{Guarded right-hand sides (GRHSs)}
103 %************************************************************************
106 rnGRHSs :: HsMatchContext Name -> RdrNameGRHSs -> RnM (RenamedGRHSs, FreeVars)
108 rnGRHSs ctxt (GRHSs grhss binds _)
109 = rnBindsAndThen binds $ \ binds' ->
110 mapFvRn (rnGRHS ctxt) grhss `thenM` \ (grhss', fvGRHSs) ->
111 returnM (GRHSs grhss' binds' placeHolderType, fvGRHSs)
113 rnGRHS ctxt (GRHS guarded locn)
115 doptM Opt_GlasgowExts `thenM` \ opt_GlasgowExts ->
116 checkM (opt_GlasgowExts || is_standard_guard guarded)
117 (addWarn (nonStdGuardErr guarded)) `thenM_`
119 rnStmts (PatGuard ctxt) guarded `thenM` \ (guarded', fvs) ->
120 returnM (GRHS guarded' locn, fvs)
122 -- Standard Haskell 1.4 guards are just a single boolean
123 -- expression, rather than a list of qualifiers as in the
125 is_standard_guard [ResultStmt _ _] = True
126 is_standard_guard [ExprStmt _ _ _, ResultStmt _ _] = True
127 is_standard_guard other = False
130 %************************************************************************
132 \subsubsection{Expressions}
134 %************************************************************************
137 rnExprs :: [RdrNameHsExpr] -> RnM ([RenamedHsExpr], FreeVars)
138 rnExprs ls = rnExprs' ls emptyUniqSet
140 rnExprs' [] acc = returnM ([], acc)
141 rnExprs' (expr:exprs) acc
142 = rnExpr expr `thenM` \ (expr', fvExpr) ->
144 -- Now we do a "seq" on the free vars because typically it's small
145 -- or empty, especially in very long lists of constants
147 acc' = acc `plusFV` fvExpr
149 (grubby_seqNameSet acc' rnExprs') exprs acc' `thenM` \ (exprs', fvExprs) ->
150 returnM (expr':exprs', fvExprs)
152 -- Grubby little function to do "seq" on namesets; replace by proper seq when GHC can do seq
153 grubby_seqNameSet ns result | isNullUFM ns = result
157 Variables. We look up the variable and return the resulting name.
160 rnExpr :: RdrNameHsExpr -> RnM (RenamedHsExpr, FreeVars)
163 = lookupOccRn v `thenM` \ name ->
164 if name `hasKey` assertIdKey && not opt_IgnoreAsserts then
165 -- We expand it to (GHC.Err.assertError location_string)
168 -- The normal case. Even if the Id was 'assert', if we are
169 -- ignoring assertions we leave it as GHC.Base.assert;
170 -- this function just ignores its first arg.
171 returnM (HsVar name, unitFV name)
174 = newIPName v `thenM` \ name ->
177 Linear _ -> mkFVs [splitName, fstName, sndName]
178 Dupable _ -> emptyFVs
180 returnM (HsIPVar name, fvs)
183 = litFVs lit `thenM` \ fvs ->
184 returnM (HsLit lit, fvs)
186 rnExpr (HsOverLit lit)
187 = rnOverLit lit `thenM` \ (lit', fvs) ->
188 returnM (HsOverLit lit', fvs)
191 = rnMatch LambdaExpr match `thenM` \ (match', fvMatch) ->
192 returnM (HsLam match', fvMatch)
194 rnExpr (HsApp fun arg)
195 = rnExpr fun `thenM` \ (fun',fvFun) ->
196 rnExpr arg `thenM` \ (arg',fvArg) ->
197 returnM (HsApp fun' arg', fvFun `plusFV` fvArg)
199 rnExpr (OpApp e1 op _ e2)
200 = rnExpr e1 `thenM` \ (e1', fv_e1) ->
201 rnExpr e2 `thenM` \ (e2', fv_e2) ->
202 rnExpr op `thenM` \ (op'@(HsVar op_name), fv_op) ->
205 -- When renaming code synthesised from "deriving" declarations
206 -- we're in Interface mode, and we should ignore fixity; assume
207 -- that the deriving code generator got the association correct
208 -- Don't even look up the fixity when in interface mode
209 getModeRn `thenM` \ mode ->
210 (if isInterfaceMode mode
211 then returnM (OpApp e1' op' defaultFixity e2')
212 else lookupFixityRn op_name `thenM` \ fixity ->
213 mkOpAppRn e1' op' fixity e2'
214 ) `thenM` \ final_e ->
217 fv_e1 `plusFV` fv_op `plusFV` fv_e2)
220 = rnExpr e `thenM` \ (e', fv_e) ->
221 lookupSyntaxName negateName `thenM` \ (neg_name, fv_neg) ->
222 mkNegAppRn e' neg_name `thenM` \ final_e ->
223 returnM (final_e, fv_e `plusFV` fv_neg)
226 = rnExpr e `thenM` \ (e', fvs_e) ->
227 returnM (HsPar e', fvs_e)
229 -- Template Haskell extensions
231 rnExpr (HsBracket br_body loc)
233 checkGHCI (thErr "bracket") `thenM_`
234 rnBracket br_body `thenM` \ (body', fvs_e) ->
235 returnM (HsBracket body' loc, fvs_e `addOneFV` qTyConName)
236 -- We use the Q tycon as a proxy to haul in all the smart
237 -- constructors; see the hack in RnIfaces
239 rnExpr (HsSplice n e loc)
241 checkGHCI (thErr "splice") `thenM_`
242 newLocalsRn [(n,loc)] `thenM` \ [n'] ->
243 rnExpr e `thenM` \ (e', fvs_e) ->
244 returnM (HsSplice n' e' loc, fvs_e `addOneFV` qTyConName)
245 -- The qTyCon brutally pulls in all the meta stuff
247 rnExpr (HsReify (Reify flavour name))
248 = checkGHCI (thErr "reify") `thenM_`
249 lookupGlobalOccRn name `thenM` \ name' ->
250 -- For now, we can only reify top-level things
251 returnM (HsReify (Reify flavour name'), mkFVs [name', qTyConName])
252 -- The qTyCon brutally pulls in all the meta stuff
255 rnExpr section@(SectionL expr op)
256 = rnExpr expr `thenM` \ (expr', fvs_expr) ->
257 rnExpr op `thenM` \ (op', fvs_op) ->
258 checkSectionPrec InfixL section op' expr' `thenM_`
259 returnM (SectionL expr' op', fvs_op `plusFV` fvs_expr)
261 rnExpr section@(SectionR op expr)
262 = rnExpr op `thenM` \ (op', fvs_op) ->
263 rnExpr expr `thenM` \ (expr', fvs_expr) ->
264 checkSectionPrec InfixR section op' expr' `thenM_`
265 returnM (SectionR op' expr', fvs_op `plusFV` fvs_expr)
267 rnExpr (HsCCall fun args may_gc is_casm _)
268 -- Check out the comment on RnIfaces.getNonWiredDataDecl about ccalls
269 = rnExprs args `thenM` \ (args', fvs_args) ->
270 returnM (HsCCall fun args' may_gc is_casm placeHolderType,
271 fvs_args `plusFV` mkFVs [cCallableClassName,
272 cReturnableClassName,
275 rnExpr (HsSCC lbl expr)
276 = rnExpr expr `thenM` \ (expr', fvs_expr) ->
277 returnM (HsSCC lbl expr', fvs_expr)
279 rnExpr (HsCase expr ms src_loc)
280 = addSrcLoc src_loc $
281 rnExpr expr `thenM` \ (new_expr, e_fvs) ->
282 mapFvRn (rnMatch CaseAlt) ms `thenM` \ (new_ms, ms_fvs) ->
283 returnM (HsCase new_expr new_ms src_loc, e_fvs `plusFV` ms_fvs)
285 rnExpr (HsLet binds expr)
286 = rnBindsAndThen binds $ \ binds' ->
287 rnExpr expr `thenM` \ (expr',fvExpr) ->
288 returnM (HsLet binds' expr', fvExpr)
290 rnExpr e@(HsDo do_or_lc stmts _ _ src_loc)
291 = addSrcLoc src_loc $
292 rnStmts do_or_lc stmts `thenM` \ (stmts', fvs) ->
294 -- Check the statement list ends in an expression
295 case last stmts' of {
296 ResultStmt _ _ -> returnM () ;
297 _ -> addErr (doStmtListErr do_or_lc e)
300 -- Generate the rebindable syntax for the monad
301 mapAndUnzipM lookupSyntaxName
302 (syntax_names do_or_lc) `thenM` \ (monad_names', monad_fvs) ->
304 returnM (HsDo do_or_lc stmts' monad_names' placeHolderType src_loc,
305 fvs `plusFV` implicit_fvs do_or_lc `plusFV` plusFVs monad_fvs)
307 implicit_fvs PArrComp = mkFVs [replicatePName, mapPName, filterPName, crossPName, zipPName]
308 implicit_fvs ListComp = mkFVs [foldrName, buildName]
309 implicit_fvs DoExpr = emptyFVs
310 implicit_fvs MDoExpr = emptyFVs
312 syntax_names DoExpr = monadNames
313 syntax_names MDoExpr = monadNames ++ [mfixName]
314 syntax_names other = []
316 rnExpr (ExplicitList _ exps)
317 = rnExprs exps `thenM` \ (exps', fvs) ->
318 returnM (ExplicitList placeHolderType exps', fvs `addOneFV` listTyCon_name)
320 rnExpr (ExplicitPArr _ exps)
321 = rnExprs exps `thenM` \ (exps', fvs) ->
322 returnM (ExplicitPArr placeHolderType exps',
323 fvs `addOneFV` toPName `addOneFV` parrTyCon_name)
325 rnExpr (ExplicitTuple exps boxity)
326 = rnExprs exps `thenM` \ (exps', fvs) ->
327 returnM (ExplicitTuple exps' boxity, fvs `addOneFV` tycon_name)
329 tycon_name = tupleTyCon_name boxity (length exps)
331 rnExpr (RecordCon con_id rbinds)
332 = lookupOccRn con_id `thenM` \ conname ->
333 rnRbinds "construction" rbinds `thenM` \ (rbinds', fvRbinds) ->
334 returnM (RecordCon conname rbinds', fvRbinds `addOneFV` conname)
336 rnExpr (RecordUpd expr rbinds)
337 = rnExpr expr `thenM` \ (expr', fvExpr) ->
338 rnRbinds "update" rbinds `thenM` \ (rbinds', fvRbinds) ->
339 returnM (RecordUpd expr' rbinds', fvExpr `plusFV` fvRbinds)
341 rnExpr (ExprWithTySig expr pty)
342 = rnExpr expr `thenM` \ (expr', fvExpr) ->
343 rnHsTypeFVs doc pty `thenM` \ (pty', fvTy) ->
344 returnM (ExprWithTySig expr' pty', fvExpr `plusFV` fvTy)
346 doc = text "In an expression type signature"
348 rnExpr (HsIf p b1 b2 src_loc)
349 = addSrcLoc src_loc $
350 rnExpr p `thenM` \ (p', fvP) ->
351 rnExpr b1 `thenM` \ (b1', fvB1) ->
352 rnExpr b2 `thenM` \ (b2', fvB2) ->
353 returnM (HsIf p' b1' b2' src_loc, plusFVs [fvP, fvB1, fvB2])
356 = rnHsTypeFVs doc a `thenM` \ (t, fvT) ->
357 returnM (HsType t, fvT)
359 doc = text "In a type argument"
361 rnExpr (ArithSeqIn seq)
362 = rnArithSeq seq `thenM` \ (new_seq, fvs) ->
363 returnM (ArithSeqIn new_seq, fvs `addOneFV` enumClassName)
365 rnExpr (PArrSeqIn seq)
366 = rnArithSeq seq `thenM` \ (new_seq, fvs) ->
367 returnM (PArrSeqIn new_seq,
368 fvs `plusFV` mkFVs [enumFromToPName, enumFromThenToPName])
371 These three are pattern syntax appearing in expressions.
372 Since all the symbols are reservedops we can simply reject them.
373 We return a (bogus) EWildPat in each case.
376 rnExpr e@EWildPat = addErr (patSynErr e) `thenM_`
377 returnM (EWildPat, emptyFVs)
379 rnExpr e@(EAsPat _ _) = addErr (patSynErr e) `thenM_`
380 returnM (EWildPat, emptyFVs)
382 rnExpr e@(ELazyPat _) = addErr (patSynErr e) `thenM_`
383 returnM (EWildPat, emptyFVs)
386 %************************************************************************
390 %************************************************************************
393 rnArithSeq (From expr)
394 = rnExpr expr `thenM` \ (expr', fvExpr) ->
395 returnM (From expr', fvExpr)
397 rnArithSeq (FromThen expr1 expr2)
398 = rnExpr expr1 `thenM` \ (expr1', fvExpr1) ->
399 rnExpr expr2 `thenM` \ (expr2', fvExpr2) ->
400 returnM (FromThen expr1' expr2', fvExpr1 `plusFV` fvExpr2)
402 rnArithSeq (FromTo expr1 expr2)
403 = rnExpr expr1 `thenM` \ (expr1', fvExpr1) ->
404 rnExpr expr2 `thenM` \ (expr2', fvExpr2) ->
405 returnM (FromTo expr1' expr2', fvExpr1 `plusFV` fvExpr2)
407 rnArithSeq (FromThenTo expr1 expr2 expr3)
408 = rnExpr expr1 `thenM` \ (expr1', fvExpr1) ->
409 rnExpr expr2 `thenM` \ (expr2', fvExpr2) ->
410 rnExpr expr3 `thenM` \ (expr3', fvExpr3) ->
411 returnM (FromThenTo expr1' expr2' expr3',
412 plusFVs [fvExpr1, fvExpr2, fvExpr3])
416 %************************************************************************
418 \subsubsection{@Rbinds@s and @Rpats@s: in record expressions}
420 %************************************************************************
424 = mappM_ field_dup_err dup_fields `thenM_`
425 mapFvRn rn_rbind rbinds `thenM` \ (rbinds', fvRbind) ->
426 returnM (rbinds', fvRbind)
428 (_, dup_fields) = removeDups compare [ f | (f,_) <- rbinds ]
430 field_dup_err dups = addErr (dupFieldErr str dups)
432 rn_rbind (field, expr)
433 = lookupGlobalOccRn field `thenM` \ fieldname ->
434 rnExpr expr `thenM` \ (expr', fvExpr) ->
435 returnM ((fieldname, expr'), fvExpr `addOneFV` fieldname)
438 %************************************************************************
440 Template Haskell brackets
442 %************************************************************************
445 rnBracket (ExpBr e) = rnExpr e `thenM` \ (e', fvs) ->
446 returnM (ExpBr e', fvs)
447 rnBracket (PatBr p) = rnPat p `thenM` \ (p', fvs) ->
448 returnM (PatBr p', fvs)
449 rnBracket (TypBr t) = rnHsTypeFVs doc t `thenM` \ (t', fvs) ->
450 returnM (TypBr t', fvs)
452 doc = ptext SLIT("In a Template-Haskell quoted type")
453 rnBracket (DecBr group)
454 = importsFromLocalDecls group `thenM` \ (rdr_env, avails) ->
455 -- Discard avails (not useful here)
457 updGblEnv (\gbl -> gbl { tcg_rdr_env = rdr_env `plusGlobalRdrEnv` tcg_rdr_env gbl }) $
459 rnSrcDecls group `thenM` \ (tcg_env, group', fvs) ->
460 -- Discard the tcg_env; it contains only extra info about fixity
462 returnM (DecBr group', fvs)
465 %************************************************************************
467 \subsubsection{@Stmt@s: in @do@ expressions}
469 %************************************************************************
472 rnStmts :: HsStmtContext Name -> [RdrNameStmt] -> RnM ([RenamedStmt], FreeVars)
474 rnStmts MDoExpr stmts = rnMDoStmts stmts
475 rnStmts ctxt stmts = rnNormalStmts ctxt stmts
477 rnNormalStmts :: HsStmtContext Name -> [RdrNameStmt] -> RnM ([RenamedStmt], FreeVars)
478 -- Used for cases *other* than recursive mdo
479 -- Implements nested scopes
481 rnNormalStmts ctxt [] = returnM ([], emptyFVs)
482 -- Happens at the end of the sub-lists of a ParStmts
484 rnNormalStmts ctxt (ExprStmt expr _ src_loc : stmts)
485 = addSrcLoc src_loc $
486 rnExpr expr `thenM` \ (expr', fv_expr) ->
487 rnNormalStmts ctxt stmts `thenM` \ (stmts', fvs) ->
488 returnM (ExprStmt expr' placeHolderType src_loc : stmts',
489 fv_expr `plusFV` fvs)
491 rnNormalStmts ctxt [ResultStmt expr src_loc]
492 = addSrcLoc src_loc $
493 rnExpr expr `thenM` \ (expr', fv_expr) ->
494 returnM ([ResultStmt expr' src_loc], fv_expr)
496 rnNormalStmts ctxt (BindStmt pat expr src_loc : stmts)
497 = addSrcLoc src_loc $
498 rnExpr expr `thenM` \ (expr', fv_expr) ->
499 -- The binders do not scope over the expression
501 rnPatsAndThen (StmtCtxt ctxt) [pat] $ \ [pat'] ->
502 rnNormalStmts ctxt stmts `thenM` \ (stmts', fvs) ->
503 returnM (BindStmt pat' expr' src_loc : stmts',
504 fv_expr `plusFV` fvs) -- fv_expr shouldn't really be filtered by
505 -- the rnPatsAndThen, but it does not matter
507 rnNormalStmts ctxt (LetStmt binds : stmts)
508 = checkErr (ok ctxt binds) (badIpBinds binds) `thenM_`
509 rnBindsAndThen binds ( \ binds' ->
510 rnNormalStmts ctxt stmts `thenM` \ (stmts', fvs) ->
511 returnM (LetStmt binds' : stmts', fvs))
513 -- We do not allow implicit-parameter bindings in a parallel
514 -- list comprehension. I'm not sure what it might mean.
515 ok (ParStmtCtxt _) (IPBinds _ _) = False
518 rnNormalStmts ctxt (ParStmt stmtss : stmts)
519 = mapFvRn (rnNormalStmts (ParStmtCtxt ctxt)) stmtss `thenM` \ (stmtss', fv_stmtss) ->
521 bndrss = map collectStmtsBinders stmtss'
523 foldlM checkBndrs [] bndrss `thenM` \ new_binders ->
524 bindLocalNamesFV new_binders $
525 -- Note: binders are returned in scope order, so one may
526 -- shadow the next; e.g. x <- xs; x <- ys
527 rnNormalStmts ctxt stmts `thenM` \ (stmts', fvs) ->
528 returnM (ParStmtOut (bndrss `zip` stmtss') : stmts',
529 fv_stmtss `plusFV` fvs)
532 checkBndrs all_bndrs bndrs
533 = checkErr (null common) (err (head common)) `thenM_`
534 returnM (bndrs ++ all_bndrs)
536 common = intersectBy eqOcc all_bndrs bndrs
538 eqOcc n1 n2 = nameOccName n1 == nameOccName n2
539 err v = ptext SLIT("Duplicate binding in parallel list comprehension for:")
542 rnNormalStmts ctxt stmts = pprPanic "rnNormalStmts" (ppr stmts)
546 %************************************************************************
548 \subsubsection{Precedence Parsing}
550 %************************************************************************
554 type Uses = NameSet -- Same as FreeVars really
555 type FwdRefs = NameSet
556 type Segment = (Defs,
557 Uses, -- May include defs
558 FwdRefs, -- A subset of uses that are
559 -- (a) used before they are bound in this segment, or
560 -- (b) used here, and bound in subsequent segments
563 ----------------------------------------------------
564 rnMDoStmts :: [RdrNameStmt] -> RnM ([RenamedStmt], FreeVars)
566 = -- Step1: bring all the binders of the mdo into scope
567 bindLocalsRn doc (collectStmtsBinders stmts) $ \ _ ->
569 -- Step 2: Rename each individual stmt, making a
570 -- singleton segment. At this stage the FwdRefs field
571 -- isn't finished: it's empty for all except a BindStmt
572 -- for which it's the fwd refs within the bind itself
573 mappM rn_mdo_stmt stmts `thenM` \ segs ->
575 -- Step 3: Fill in the fwd refs.
576 -- The segments are all singletons, but their fwd-ref
577 -- field mentions all the things used by the segment
578 -- that are bound after their use
579 segs_w_fwd_refs = addFwdRefs segs
581 -- Step 4: Group together the segments to make bigger segments
582 -- Invariant: in the result, no segment uses a variable
583 -- bound in a later segment
584 grouped_segs = glomSegments segs_w_fwd_refs
586 -- Step 5: Turn the segments into Stmts
587 -- Use RecStmt when and only when there are fwd refs
588 -- Also gather up the uses from the end towards the
589 -- start, so we can tell the RecStmt which things are
590 -- used 'after' the RecStmt
591 stmts_w_fvs = segsToStmts grouped_segs
595 doc = text "In a mdo-expression"
597 ----------------------------------------------------
598 rn_mdo_stmt :: RdrNameStmt -> RnM Segment
599 -- Assumes all binders are already in scope
600 -- Turns each stmt into a singleton Stmt
602 rn_mdo_stmt (ExprStmt expr _ src_loc)
603 = addSrcLoc src_loc (rnExpr expr) `thenM` \ (expr', fvs) ->
604 returnM (emptyNameSet, fvs, emptyNameSet,
605 [ExprStmt expr' placeHolderType src_loc])
607 rn_mdo_stmt (ResultStmt expr src_loc)
608 = addSrcLoc src_loc (rnExpr expr) `thenM` \ (expr', fvs) ->
609 returnM (emptyNameSet, fvs, emptyNameSet,
610 [ResultStmt expr' src_loc])
612 rn_mdo_stmt (BindStmt pat expr src_loc)
613 = addSrcLoc src_loc $
614 rnExpr expr `thenM` \ (expr', fv_expr) ->
615 rnPat pat `thenM` \ (pat', fv_pat) ->
617 bndrs = mkNameSet (collectPatBinders pat')
618 fvs = fv_expr `plusFV` fv_pat
620 returnM (bndrs, fvs, bndrs `intersectNameSet` fvs,
621 [BindStmt pat' expr' src_loc])
623 rn_mdo_stmt (LetStmt binds)
624 = rnBinds binds `thenM` \ (binds', fv_binds) ->
625 returnM (mkNameSet (collectHsBinders binds'),
626 fv_binds, emptyNameSet, [LetStmt binds'])
628 rn_mdo_stmt stmt@(ParStmt _) -- Syntactically illegal in mdo
629 = pprPanic "rn_mdo_stmt" (ppr stmt)
632 addFwdRefs :: [Segment] -> [Segment]
633 -- So far the segments only have forward refs *within* the Stmt
634 -- (which happens for bind: x <- ...x...)
635 -- This function adds the cross-seg fwd ref info
638 = fst (foldr mk_seg ([], emptyNameSet) pairs)
640 mk_seg (defs, uses, fwds, stmts) (segs, seg_defs)
641 = (new_seg : segs, all_defs)
643 new_seg = (defs, uses, new_fwds, stmts)
644 all_defs = seg_defs `unionNameSets` defs
645 new_fwds = fwds `unionNameSets` (uses `intersectNameSet` seg_defs)
646 -- Add the downstream fwd refs here
648 ----------------------------------------------------
649 -- Glomming the singleton segments of an mdo into
650 -- minimal recursive groups.
652 -- At first I thought this was just strongly connected components, but
653 -- there's an important constraint: the order of the stmts must not change.
656 -- mdo { x <- ...y...
663 -- Here, the first stmt mention 'y', which is bound in the third.
664 -- But that means that the innocent second stmt (p <- z) gets caught
665 -- up in the recursion. And that in turn means that the binding for
666 -- 'z' has to be included... and so on.
668 -- Start at the tail { r <- x }
669 -- Now add the next one { z <- y ; r <- x }
670 -- Now add one more { q <- x ; z <- y ; r <- x }
671 -- Now one more... but this time we have to group a bunch into rec
672 -- { rec { y <- ...x... ; q <- x ; z <- y } ; r <- x }
673 -- Now one more, which we can add on without a rec
675 -- rec { y <- ...x... ; q <- x ; z <- y } ;
677 -- Finally we add the last one; since it mentions y we have to
678 -- glom it togeher with the first two groups
679 -- { rec { x <- ...y...; p <- z ; y <- ...x... ;
680 -- q <- x ; z <- y } ;
683 glomSegments :: [Segment] -> [Segment]
685 glomSegments [seg] = [seg]
686 glomSegments ((defs,uses,fwds,stmts) : segs)
687 -- Actually stmts will always be a singleton
688 = (seg_defs, seg_uses, seg_fwds, seg_stmts) : others
690 segs' = glomSegments segs
691 (extras, others) = grab uses segs'
692 (ds, us, fs, ss) = unzip4 extras
694 seg_defs = plusFVs ds `plusFV` defs
695 seg_uses = plusFVs us `plusFV` uses
696 seg_fwds = plusFVs fs `plusFV` fwds
697 seg_stmts = stmts ++ concat ss
699 grab :: NameSet -- The client
701 -> ([Segment], -- Needed by the 'client'
702 [Segment]) -- Not needed by the client
703 -- The result is simply a split of the input
705 = (reverse yeses, reverse noes)
707 (noes, yeses) = span not_needed (reverse dus)
708 not_needed (defs,_,_,_) = not (intersectsNameSet defs uses)
711 ----------------------------------------------------
712 segsToStmts :: [Segment] -> ([RenamedStmt], FreeVars)
714 segsToStmts [] = ([], emptyFVs)
715 segsToStmts ((defs, uses, fwds, ss) : segs)
716 = (new_stmt : later_stmts, later_uses `plusFV` uses)
718 (later_stmts, later_uses) = segsToStmts segs
719 new_stmt | non_rec = head ss
720 | otherwise = RecStmt rec_names ss []
722 non_rec = isSingleton ss && isEmptyNameSet fwds
723 rec_names = nameSetToList (fwds `plusFV` (defs `intersectNameSet` later_uses))
724 -- The names for the fixpoint are
725 -- (a) the ones needed after the RecStmt
726 -- (b) the forward refs within the fixpoint
729 %************************************************************************
731 \subsubsection{Precedence Parsing}
733 %************************************************************************
735 @mkOpAppRn@ deals with operator fixities. The argument expressions
736 are assumed to be already correctly arranged. It needs the fixities
737 recorded in the OpApp nodes, because fixity info applies to the things
738 the programmer actually wrote, so you can't find it out from the Name.
740 Furthermore, the second argument is guaranteed not to be another
741 operator application. Why? Because the parser parses all
742 operator appications left-associatively, EXCEPT negation, which
743 we need to handle specially.
746 mkOpAppRn :: RenamedHsExpr -- Left operand; already rearranged
747 -> RenamedHsExpr -> Fixity -- Operator and fixity
748 -> RenamedHsExpr -- Right operand (not an OpApp, but might
752 ---------------------------
753 -- (e11 `op1` e12) `op2` e2
754 mkOpAppRn e1@(OpApp e11 op1 fix1 e12) op2 fix2 e2
756 = addErr (precParseErr (ppr_op op1,fix1) (ppr_op op2,fix2)) `thenM_`
757 returnM (OpApp e1 op2 fix2 e2)
760 = mkOpAppRn e12 op2 fix2 e2 `thenM` \ new_e ->
761 returnM (OpApp e11 op1 fix1 new_e)
763 (nofix_error, associate_right) = compareFixity fix1 fix2
765 ---------------------------
766 -- (- neg_arg) `op` e2
767 mkOpAppRn e1@(NegApp neg_arg neg_name) op2 fix2 e2
769 = addErr (precParseErr (pp_prefix_minus,negateFixity) (ppr_op op2,fix2)) `thenM_`
770 returnM (OpApp e1 op2 fix2 e2)
773 = mkOpAppRn neg_arg op2 fix2 e2 `thenM` \ new_e ->
774 returnM (NegApp new_e neg_name)
776 (nofix_error, associate_right) = compareFixity negateFixity fix2
778 ---------------------------
780 mkOpAppRn e1 op1 fix1 e2@(NegApp neg_arg _) -- NegApp can occur on the right
781 | not associate_right -- We *want* right association
782 = addErr (precParseErr (ppr_op op1, fix1) (pp_prefix_minus, negateFixity)) `thenM_`
783 returnM (OpApp e1 op1 fix1 e2)
785 (_, associate_right) = compareFixity fix1 negateFixity
787 ---------------------------
789 mkOpAppRn e1 op fix e2 -- Default case, no rearrangment
790 = ASSERT2( right_op_ok fix e2,
791 ppr e1 $$ text "---" $$ ppr op $$ text "---" $$ ppr fix $$ text "---" $$ ppr e2
793 returnM (OpApp e1 op fix e2)
795 -- Parser left-associates everything, but
796 -- derived instances may have correctly-associated things to
797 -- in the right operarand. So we just check that the right operand is OK
798 right_op_ok fix1 (OpApp _ _ fix2 _)
799 = not error_please && associate_right
801 (error_please, associate_right) = compareFixity fix1 fix2
802 right_op_ok fix1 other
805 -- Parser initially makes negation bind more tightly than any other operator
806 mkNegAppRn neg_arg neg_name
809 getModeRn `thenM` \ mode ->
810 ASSERT( not_op_app mode neg_arg )
812 returnM (NegApp neg_arg neg_name)
814 not_op_app SourceMode (OpApp _ _ _ _) = False
815 not_op_app mode other = True
819 checkPrecMatch :: Bool -> Name -> RenamedMatch -> RnM ()
821 checkPrecMatch False fn match
824 checkPrecMatch True op (Match (p1:p2:_) _ _)
825 -- True indicates an infix lhs
826 = getModeRn `thenM` \ mode ->
827 -- See comments with rnExpr (OpApp ...)
828 if isInterfaceMode mode
830 else checkPrec op p1 False `thenM_`
833 checkPrecMatch True op _ = panic "checkPrecMatch"
835 checkPrec op (ConPatIn op1 (InfixCon _ _)) right
836 = lookupFixityRn op `thenM` \ op_fix@(Fixity op_prec op_dir) ->
837 lookupFixityRn op1 `thenM` \ op1_fix@(Fixity op1_prec op1_dir) ->
839 inf_ok = op1_prec > op_prec ||
840 (op1_prec == op_prec &&
841 (op1_dir == InfixR && op_dir == InfixR && right ||
842 op1_dir == InfixL && op_dir == InfixL && not right))
844 info = (ppr_op op, op_fix)
845 info1 = (ppr_op op1, op1_fix)
846 (infol, infor) = if right then (info, info1) else (info1, info)
848 checkErr inf_ok (precParseErr infol infor)
850 checkPrec op pat right
853 -- Check precedence of (arg op) or (op arg) respectively
854 -- If arg is itself an operator application, then either
855 -- (a) its precedence must be higher than that of op
856 -- (b) its precedency & associativity must be the same as that of op
857 checkSectionPrec direction section op arg
859 OpApp _ op fix _ -> go_for_it (ppr_op op) fix
860 NegApp _ _ -> go_for_it pp_prefix_minus negateFixity
864 go_for_it pp_arg_op arg_fix@(Fixity arg_prec assoc)
865 = lookupFixityRn op_name `thenM` \ op_fix@(Fixity op_prec _) ->
866 checkErr (op_prec < arg_prec
867 || op_prec == arg_prec && direction == assoc)
868 (sectionPrecErr (ppr_op op_name, op_fix)
869 (pp_arg_op, arg_fix) section)
873 %************************************************************************
875 \subsubsection{Assertion utils}
877 %************************************************************************
880 mkAssertErrorExpr :: RnM (RenamedHsExpr, FreeVars)
881 -- Return an expression for (assertError "Foo.hs:27")
883 = getSrcLocM `thenM` \ sloc ->
885 expr = HsApp (HsVar assertErrorName) (HsLit msg)
886 msg = HsStringPrim (mkFastString (stringToUtf8 (showSDoc (ppr sloc))))
888 returnM (expr, unitFV assertErrorName)
891 %************************************************************************
893 \subsubsection{Errors}
895 %************************************************************************
898 ppr_op op = quotes (ppr op) -- Here, op can be a Name or a (Var n), where n is a Name
899 pp_prefix_minus = ptext SLIT("prefix `-'")
903 SLIT("accepting non-standard pattern guards (-fglasgow-exts to suppress this message)")
907 = sep [ptext SLIT("Pattern syntax in expression context:"),
910 doStmtListErr do_or_lc e
911 = sep [quotes (text binder_name) <+> ptext SLIT("statements must end in expression:"),
914 binder_name = case do_or_lc of
919 = ptext SLIT("Template Haskell") <+> text what <+>
920 ptext SLIT("illegal in a stage-1 compiler")
923 = hang (ptext SLIT("Implicit-parameter bindings illegal in a parallel list comprehension:")) 4