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, checkTupSize )
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 e@(ExplicitTuple exps boxity)
326 = checkTupSize tup_size `thenM_`
327 rnExprs exps `thenM` \ (exps', fvs) ->
328 returnM (ExplicitTuple exps' boxity, fvs `addOneFV` tycon_name)
330 tup_size = length exps
331 tycon_name = tupleTyCon_name boxity tup_size
333 rnExpr (RecordCon con_id rbinds)
334 = lookupOccRn con_id `thenM` \ conname ->
335 rnRbinds "construction" rbinds `thenM` \ (rbinds', fvRbinds) ->
336 returnM (RecordCon conname rbinds', fvRbinds `addOneFV` conname)
338 rnExpr (RecordUpd expr rbinds)
339 = rnExpr expr `thenM` \ (expr', fvExpr) ->
340 rnRbinds "update" rbinds `thenM` \ (rbinds', fvRbinds) ->
341 returnM (RecordUpd expr' rbinds', fvExpr `plusFV` fvRbinds)
343 rnExpr (ExprWithTySig expr pty)
344 = rnExpr expr `thenM` \ (expr', fvExpr) ->
345 rnHsTypeFVs doc pty `thenM` \ (pty', fvTy) ->
346 returnM (ExprWithTySig expr' pty', fvExpr `plusFV` fvTy)
348 doc = text "In an expression type signature"
350 rnExpr (HsIf p b1 b2 src_loc)
351 = addSrcLoc src_loc $
352 rnExpr p `thenM` \ (p', fvP) ->
353 rnExpr b1 `thenM` \ (b1', fvB1) ->
354 rnExpr b2 `thenM` \ (b2', fvB2) ->
355 returnM (HsIf p' b1' b2' src_loc, plusFVs [fvP, fvB1, fvB2])
358 = rnHsTypeFVs doc a `thenM` \ (t, fvT) ->
359 returnM (HsType t, fvT)
361 doc = text "In a type argument"
363 rnExpr (ArithSeqIn seq)
364 = rnArithSeq seq `thenM` \ (new_seq, fvs) ->
365 returnM (ArithSeqIn new_seq, fvs `addOneFV` enumClassName)
367 rnExpr (PArrSeqIn seq)
368 = rnArithSeq seq `thenM` \ (new_seq, fvs) ->
369 returnM (PArrSeqIn new_seq,
370 fvs `plusFV` mkFVs [enumFromToPName, enumFromThenToPName])
373 These three are pattern syntax appearing in expressions.
374 Since all the symbols are reservedops we can simply reject them.
375 We return a (bogus) EWildPat in each case.
378 rnExpr e@EWildPat = addErr (patSynErr e) `thenM_`
379 returnM (EWildPat, emptyFVs)
381 rnExpr e@(EAsPat _ _) = addErr (patSynErr e) `thenM_`
382 returnM (EWildPat, emptyFVs)
384 rnExpr e@(ELazyPat _) = addErr (patSynErr e) `thenM_`
385 returnM (EWildPat, emptyFVs)
388 %************************************************************************
392 %************************************************************************
395 rnArithSeq (From expr)
396 = rnExpr expr `thenM` \ (expr', fvExpr) ->
397 returnM (From expr', fvExpr)
399 rnArithSeq (FromThen expr1 expr2)
400 = rnExpr expr1 `thenM` \ (expr1', fvExpr1) ->
401 rnExpr expr2 `thenM` \ (expr2', fvExpr2) ->
402 returnM (FromThen expr1' expr2', fvExpr1 `plusFV` fvExpr2)
404 rnArithSeq (FromTo expr1 expr2)
405 = rnExpr expr1 `thenM` \ (expr1', fvExpr1) ->
406 rnExpr expr2 `thenM` \ (expr2', fvExpr2) ->
407 returnM (FromTo expr1' expr2', fvExpr1 `plusFV` fvExpr2)
409 rnArithSeq (FromThenTo expr1 expr2 expr3)
410 = rnExpr expr1 `thenM` \ (expr1', fvExpr1) ->
411 rnExpr expr2 `thenM` \ (expr2', fvExpr2) ->
412 rnExpr expr3 `thenM` \ (expr3', fvExpr3) ->
413 returnM (FromThenTo expr1' expr2' expr3',
414 plusFVs [fvExpr1, fvExpr2, fvExpr3])
418 %************************************************************************
420 \subsubsection{@Rbinds@s and @Rpats@s: in record expressions}
422 %************************************************************************
426 = mappM_ field_dup_err dup_fields `thenM_`
427 mapFvRn rn_rbind rbinds `thenM` \ (rbinds', fvRbind) ->
428 returnM (rbinds', fvRbind)
430 (_, dup_fields) = removeDups compare [ f | (f,_) <- rbinds ]
432 field_dup_err dups = addErr (dupFieldErr str dups)
434 rn_rbind (field, expr)
435 = lookupGlobalOccRn field `thenM` \ fieldname ->
436 rnExpr expr `thenM` \ (expr', fvExpr) ->
437 returnM ((fieldname, expr'), fvExpr `addOneFV` fieldname)
440 %************************************************************************
442 Template Haskell brackets
444 %************************************************************************
447 rnBracket (ExpBr e) = rnExpr e `thenM` \ (e', fvs) ->
448 returnM (ExpBr e', fvs)
449 rnBracket (PatBr p) = rnPat p `thenM` \ (p', fvs) ->
450 returnM (PatBr p', fvs)
451 rnBracket (TypBr t) = rnHsTypeFVs doc t `thenM` \ (t', fvs) ->
452 returnM (TypBr t', fvs)
454 doc = ptext SLIT("In a Template-Haskell quoted type")
455 rnBracket (DecBr group)
456 = importsFromLocalDecls group `thenM` \ (rdr_env, avails) ->
457 -- Discard avails (not useful here)
459 updGblEnv (\gbl -> gbl { tcg_rdr_env = rdr_env `plusGlobalRdrEnv` tcg_rdr_env gbl }) $
461 rnSrcDecls group `thenM` \ (tcg_env, group', fvs) ->
462 -- Discard the tcg_env; it contains only extra info about fixity
464 returnM (DecBr group', fvs)
467 %************************************************************************
469 \subsubsection{@Stmt@s: in @do@ expressions}
471 %************************************************************************
474 rnStmts :: HsStmtContext Name -> [RdrNameStmt] -> RnM ([RenamedStmt], FreeVars)
476 rnStmts MDoExpr stmts = rnMDoStmts stmts
477 rnStmts ctxt stmts = rnNormalStmts ctxt stmts
479 rnNormalStmts :: HsStmtContext Name -> [RdrNameStmt] -> RnM ([RenamedStmt], FreeVars)
480 -- Used for cases *other* than recursive mdo
481 -- Implements nested scopes
483 rnNormalStmts ctxt [] = returnM ([], emptyFVs)
484 -- Happens at the end of the sub-lists of a ParStmts
486 rnNormalStmts ctxt (ExprStmt expr _ src_loc : stmts)
487 = addSrcLoc src_loc $
488 rnExpr expr `thenM` \ (expr', fv_expr) ->
489 rnNormalStmts ctxt stmts `thenM` \ (stmts', fvs) ->
490 returnM (ExprStmt expr' placeHolderType src_loc : stmts',
491 fv_expr `plusFV` fvs)
493 rnNormalStmts ctxt [ResultStmt expr src_loc]
494 = addSrcLoc src_loc $
495 rnExpr expr `thenM` \ (expr', fv_expr) ->
496 returnM ([ResultStmt expr' src_loc], fv_expr)
498 rnNormalStmts ctxt (BindStmt pat expr src_loc : stmts)
499 = addSrcLoc src_loc $
500 rnExpr expr `thenM` \ (expr', fv_expr) ->
501 -- The binders do not scope over the expression
503 rnPatsAndThen (StmtCtxt ctxt) [pat] $ \ [pat'] ->
504 rnNormalStmts ctxt stmts `thenM` \ (stmts', fvs) ->
505 returnM (BindStmt pat' expr' src_loc : stmts',
506 fv_expr `plusFV` fvs) -- fv_expr shouldn't really be filtered by
507 -- the rnPatsAndThen, but it does not matter
509 rnNormalStmts ctxt (LetStmt binds : stmts)
510 = checkErr (ok ctxt binds) (badIpBinds binds) `thenM_`
511 rnBindsAndThen binds ( \ binds' ->
512 rnNormalStmts ctxt stmts `thenM` \ (stmts', fvs) ->
513 returnM (LetStmt binds' : stmts', fvs))
515 -- We do not allow implicit-parameter bindings in a parallel
516 -- list comprehension. I'm not sure what it might mean.
517 ok (ParStmtCtxt _) (IPBinds _ _) = False
520 rnNormalStmts ctxt (ParStmt stmtss : stmts)
521 = mapFvRn (rnNormalStmts (ParStmtCtxt ctxt)) stmtss `thenM` \ (stmtss', fv_stmtss) ->
523 bndrss = map collectStmtsBinders stmtss'
525 foldlM checkBndrs [] bndrss `thenM` \ new_binders ->
526 bindLocalNamesFV new_binders $
527 -- Note: binders are returned in scope order, so one may
528 -- shadow the next; e.g. x <- xs; x <- ys
529 rnNormalStmts ctxt stmts `thenM` \ (stmts', fvs) ->
530 returnM (ParStmtOut (bndrss `zip` stmtss') : stmts',
531 fv_stmtss `plusFV` fvs)
534 checkBndrs all_bndrs bndrs
535 = checkErr (null common) (err (head common)) `thenM_`
536 returnM (bndrs ++ all_bndrs)
538 common = intersectBy eqOcc all_bndrs bndrs
540 eqOcc n1 n2 = nameOccName n1 == nameOccName n2
541 err v = ptext SLIT("Duplicate binding in parallel list comprehension for:")
544 rnNormalStmts ctxt stmts = pprPanic "rnNormalStmts" (ppr stmts)
548 %************************************************************************
550 \subsubsection{Precedence Parsing}
552 %************************************************************************
556 type Uses = NameSet -- Same as FreeVars really
557 type FwdRefs = NameSet
558 type Segment = (Defs,
559 Uses, -- May include defs
560 FwdRefs, -- A subset of uses that are
561 -- (a) used before they are bound in this segment, or
562 -- (b) used here, and bound in subsequent segments
565 ----------------------------------------------------
566 rnMDoStmts :: [RdrNameStmt] -> RnM ([RenamedStmt], FreeVars)
568 = -- Step1: bring all the binders of the mdo into scope
569 bindLocalsRn doc (collectStmtsBinders stmts) $ \ _ ->
571 -- Step 2: Rename each individual stmt, making a
572 -- singleton segment. At this stage the FwdRefs field
573 -- isn't finished: it's empty for all except a BindStmt
574 -- for which it's the fwd refs within the bind itself
575 mappM rn_mdo_stmt stmts `thenM` \ segs ->
577 -- Step 3: Fill in the fwd refs.
578 -- The segments are all singletons, but their fwd-ref
579 -- field mentions all the things used by the segment
580 -- that are bound after their use
581 segs_w_fwd_refs = addFwdRefs segs
583 -- Step 4: Group together the segments to make bigger segments
584 -- Invariant: in the result, no segment uses a variable
585 -- bound in a later segment
586 grouped_segs = glomSegments segs_w_fwd_refs
588 -- Step 5: Turn the segments into Stmts
589 -- Use RecStmt when and only when there are fwd refs
590 -- Also gather up the uses from the end towards the
591 -- start, so we can tell the RecStmt which things are
592 -- used 'after' the RecStmt
593 stmts_w_fvs = segsToStmts grouped_segs
597 doc = text "In a mdo-expression"
599 ----------------------------------------------------
600 rn_mdo_stmt :: RdrNameStmt -> RnM Segment
601 -- Assumes all binders are already in scope
602 -- Turns each stmt into a singleton Stmt
604 rn_mdo_stmt (ExprStmt expr _ src_loc)
605 = addSrcLoc src_loc (rnExpr expr) `thenM` \ (expr', fvs) ->
606 returnM (emptyNameSet, fvs, emptyNameSet,
607 [ExprStmt expr' placeHolderType src_loc])
609 rn_mdo_stmt (ResultStmt expr src_loc)
610 = addSrcLoc src_loc (rnExpr expr) `thenM` \ (expr', fvs) ->
611 returnM (emptyNameSet, fvs, emptyNameSet,
612 [ResultStmt expr' src_loc])
614 rn_mdo_stmt (BindStmt pat expr src_loc)
615 = addSrcLoc src_loc $
616 rnExpr expr `thenM` \ (expr', fv_expr) ->
617 rnPat pat `thenM` \ (pat', fv_pat) ->
619 bndrs = mkNameSet (collectPatBinders pat')
620 fvs = fv_expr `plusFV` fv_pat
622 returnM (bndrs, fvs, bndrs `intersectNameSet` fvs,
623 [BindStmt pat' expr' src_loc])
625 rn_mdo_stmt (LetStmt binds)
626 = rnBinds binds `thenM` \ (binds', fv_binds) ->
627 returnM (mkNameSet (collectHsBinders binds'),
628 fv_binds, emptyNameSet, [LetStmt binds'])
630 rn_mdo_stmt stmt@(ParStmt _) -- Syntactically illegal in mdo
631 = pprPanic "rn_mdo_stmt" (ppr stmt)
634 addFwdRefs :: [Segment] -> [Segment]
635 -- So far the segments only have forward refs *within* the Stmt
636 -- (which happens for bind: x <- ...x...)
637 -- This function adds the cross-seg fwd ref info
640 = fst (foldr mk_seg ([], emptyNameSet) pairs)
642 mk_seg (defs, uses, fwds, stmts) (segs, seg_defs)
643 = (new_seg : segs, all_defs)
645 new_seg = (defs, uses, new_fwds, stmts)
646 all_defs = seg_defs `unionNameSets` defs
647 new_fwds = fwds `unionNameSets` (uses `intersectNameSet` seg_defs)
648 -- Add the downstream fwd refs here
650 ----------------------------------------------------
651 -- Glomming the singleton segments of an mdo into
652 -- minimal recursive groups.
654 -- At first I thought this was just strongly connected components, but
655 -- there's an important constraint: the order of the stmts must not change.
658 -- mdo { x <- ...y...
665 -- Here, the first stmt mention 'y', which is bound in the third.
666 -- But that means that the innocent second stmt (p <- z) gets caught
667 -- up in the recursion. And that in turn means that the binding for
668 -- 'z' has to be included... and so on.
670 -- Start at the tail { r <- x }
671 -- Now add the next one { z <- y ; r <- x }
672 -- Now add one more { q <- x ; z <- y ; r <- x }
673 -- Now one more... but this time we have to group a bunch into rec
674 -- { rec { y <- ...x... ; q <- x ; z <- y } ; r <- x }
675 -- Now one more, which we can add on without a rec
677 -- rec { y <- ...x... ; q <- x ; z <- y } ;
679 -- Finally we add the last one; since it mentions y we have to
680 -- glom it togeher with the first two groups
681 -- { rec { x <- ...y...; p <- z ; y <- ...x... ;
682 -- q <- x ; z <- y } ;
685 glomSegments :: [Segment] -> [Segment]
687 glomSegments [seg] = [seg]
688 glomSegments ((defs,uses,fwds,stmts) : segs)
689 -- Actually stmts will always be a singleton
690 = (seg_defs, seg_uses, seg_fwds, seg_stmts) : others
692 segs' = glomSegments segs
693 (extras, others) = grab uses segs'
694 (ds, us, fs, ss) = unzip4 extras
696 seg_defs = plusFVs ds `plusFV` defs
697 seg_uses = plusFVs us `plusFV` uses
698 seg_fwds = plusFVs fs `plusFV` fwds
699 seg_stmts = stmts ++ concat ss
701 grab :: NameSet -- The client
703 -> ([Segment], -- Needed by the 'client'
704 [Segment]) -- Not needed by the client
705 -- The result is simply a split of the input
707 = (reverse yeses, reverse noes)
709 (noes, yeses) = span not_needed (reverse dus)
710 not_needed (defs,_,_,_) = not (intersectsNameSet defs uses)
713 ----------------------------------------------------
714 segsToStmts :: [Segment] -> ([RenamedStmt], FreeVars)
716 segsToStmts [] = ([], emptyFVs)
717 segsToStmts ((defs, uses, fwds, ss) : segs)
718 = (new_stmt : later_stmts, later_uses `plusFV` uses)
720 (later_stmts, later_uses) = segsToStmts segs
721 new_stmt | non_rec = head ss
722 | otherwise = RecStmt rec_names ss []
724 non_rec = isSingleton ss && isEmptyNameSet fwds
725 rec_names = nameSetToList (fwds `plusFV` (defs `intersectNameSet` later_uses))
726 -- The names for the fixpoint are
727 -- (a) the ones needed after the RecStmt
728 -- (b) the forward refs within the fixpoint
731 %************************************************************************
733 \subsubsection{Precedence Parsing}
735 %************************************************************************
737 @mkOpAppRn@ deals with operator fixities. The argument expressions
738 are assumed to be already correctly arranged. It needs the fixities
739 recorded in the OpApp nodes, because fixity info applies to the things
740 the programmer actually wrote, so you can't find it out from the Name.
742 Furthermore, the second argument is guaranteed not to be another
743 operator application. Why? Because the parser parses all
744 operator appications left-associatively, EXCEPT negation, which
745 we need to handle specially.
748 mkOpAppRn :: RenamedHsExpr -- Left operand; already rearranged
749 -> RenamedHsExpr -> Fixity -- Operator and fixity
750 -> RenamedHsExpr -- Right operand (not an OpApp, but might
754 ---------------------------
755 -- (e11 `op1` e12) `op2` e2
756 mkOpAppRn e1@(OpApp e11 op1 fix1 e12) op2 fix2 e2
758 = addErr (precParseErr (ppr_op op1,fix1) (ppr_op op2,fix2)) `thenM_`
759 returnM (OpApp e1 op2 fix2 e2)
762 = mkOpAppRn e12 op2 fix2 e2 `thenM` \ new_e ->
763 returnM (OpApp e11 op1 fix1 new_e)
765 (nofix_error, associate_right) = compareFixity fix1 fix2
767 ---------------------------
768 -- (- neg_arg) `op` e2
769 mkOpAppRn e1@(NegApp neg_arg neg_name) op2 fix2 e2
771 = addErr (precParseErr (pp_prefix_minus,negateFixity) (ppr_op op2,fix2)) `thenM_`
772 returnM (OpApp e1 op2 fix2 e2)
775 = mkOpAppRn neg_arg op2 fix2 e2 `thenM` \ new_e ->
776 returnM (NegApp new_e neg_name)
778 (nofix_error, associate_right) = compareFixity negateFixity fix2
780 ---------------------------
782 mkOpAppRn e1 op1 fix1 e2@(NegApp neg_arg _) -- NegApp can occur on the right
783 | not associate_right -- We *want* right association
784 = addErr (precParseErr (ppr_op op1, fix1) (pp_prefix_minus, negateFixity)) `thenM_`
785 returnM (OpApp e1 op1 fix1 e2)
787 (_, associate_right) = compareFixity fix1 negateFixity
789 ---------------------------
791 mkOpAppRn e1 op fix e2 -- Default case, no rearrangment
792 = ASSERT2( right_op_ok fix e2,
793 ppr e1 $$ text "---" $$ ppr op $$ text "---" $$ ppr fix $$ text "---" $$ ppr e2
795 returnM (OpApp e1 op fix e2)
797 -- Parser left-associates everything, but
798 -- derived instances may have correctly-associated things to
799 -- in the right operarand. So we just check that the right operand is OK
800 right_op_ok fix1 (OpApp _ _ fix2 _)
801 = not error_please && associate_right
803 (error_please, associate_right) = compareFixity fix1 fix2
804 right_op_ok fix1 other
807 -- Parser initially makes negation bind more tightly than any other operator
808 mkNegAppRn neg_arg neg_name
811 getModeRn `thenM` \ mode ->
812 ASSERT( not_op_app mode neg_arg )
814 returnM (NegApp neg_arg neg_name)
816 not_op_app SourceMode (OpApp _ _ _ _) = False
817 not_op_app mode other = True
821 checkPrecMatch :: Bool -> Name -> RenamedMatch -> RnM ()
823 checkPrecMatch False fn match
826 checkPrecMatch True op (Match (p1:p2:_) _ _)
827 -- True indicates an infix lhs
828 = getModeRn `thenM` \ mode ->
829 -- See comments with rnExpr (OpApp ...)
830 if isInterfaceMode mode
832 else checkPrec op p1 False `thenM_`
835 checkPrecMatch True op _ = panic "checkPrecMatch"
837 checkPrec op (ConPatIn op1 (InfixCon _ _)) right
838 = lookupFixityRn op `thenM` \ op_fix@(Fixity op_prec op_dir) ->
839 lookupFixityRn op1 `thenM` \ op1_fix@(Fixity op1_prec op1_dir) ->
841 inf_ok = op1_prec > op_prec ||
842 (op1_prec == op_prec &&
843 (op1_dir == InfixR && op_dir == InfixR && right ||
844 op1_dir == InfixL && op_dir == InfixL && not right))
846 info = (ppr_op op, op_fix)
847 info1 = (ppr_op op1, op1_fix)
848 (infol, infor) = if right then (info, info1) else (info1, info)
850 checkErr inf_ok (precParseErr infol infor)
852 checkPrec op pat right
855 -- Check precedence of (arg op) or (op arg) respectively
856 -- If arg is itself an operator application, then either
857 -- (a) its precedence must be higher than that of op
858 -- (b) its precedency & associativity must be the same as that of op
859 checkSectionPrec direction section op arg
861 OpApp _ op fix _ -> go_for_it (ppr_op op) fix
862 NegApp _ _ -> go_for_it pp_prefix_minus negateFixity
866 go_for_it pp_arg_op arg_fix@(Fixity arg_prec assoc)
867 = lookupFixityRn op_name `thenM` \ op_fix@(Fixity op_prec _) ->
868 checkErr (op_prec < arg_prec
869 || op_prec == arg_prec && direction == assoc)
870 (sectionPrecErr (ppr_op op_name, op_fix)
871 (pp_arg_op, arg_fix) section)
875 %************************************************************************
877 \subsubsection{Assertion utils}
879 %************************************************************************
882 mkAssertErrorExpr :: RnM (RenamedHsExpr, FreeVars)
883 -- Return an expression for (assertError "Foo.hs:27")
885 = getSrcLocM `thenM` \ sloc ->
887 expr = HsApp (HsVar assertErrorName) (HsLit msg)
888 msg = HsStringPrim (mkFastString (stringToUtf8 (showSDoc (ppr sloc))))
890 returnM (expr, unitFV assertErrorName)
893 %************************************************************************
895 \subsubsection{Errors}
897 %************************************************************************
900 ppr_op op = quotes (ppr op) -- Here, op can be a Name or a (Var n), where n is a Name
901 pp_prefix_minus = ptext SLIT("prefix `-'")
905 SLIT("accepting non-standard pattern guards (-fglasgow-exts to suppress this message)")
909 = sep [ptext SLIT("Pattern syntax in expression context:"),
912 doStmtListErr do_or_lc e
913 = sep [quotes (text binder_name) <+> ptext SLIT("statements must end in expression:"),
916 binder_name = case do_or_lc of
921 = ptext SLIT("Template Haskell") <+> text what <+>
922 ptext SLIT("illegal in a stage-1 compiler")
925 = hang (ptext SLIT("Implicit-parameter bindings illegal in a parallel list comprehension:")) 4