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 )
46 import Name ( Name, nameOccName )
48 import UnicodeUtil ( stringToUtf8 )
49 import UniqFM ( isNullUFM )
50 import UniqSet ( emptyUniqSet )
51 import Util ( isSingleton )
52 import List ( intersectBy, unzip4 )
53 import ListSetOps ( removeDups )
59 ************************************************************************
63 ************************************************************************
66 rnMatch :: HsMatchContext Name -> RdrNameMatch -> RnM (RenamedMatch, FreeVars)
68 rnMatch ctxt match@(Match pats maybe_rhs_sig grhss)
69 = addSrcLoc (getMatchLoc match) $
71 -- Deal with the rhs type signature
72 bindPatSigTyVarsFV rhs_sig_tys $
73 doptM Opt_GlasgowExts `thenM` \ opt_GlasgowExts ->
74 (case maybe_rhs_sig of
75 Nothing -> returnM (Nothing, emptyFVs)
76 Just ty | opt_GlasgowExts -> rnHsTypeFVs doc_sig ty `thenM` \ (ty', ty_fvs) ->
77 returnM (Just ty', ty_fvs)
78 | otherwise -> addErr (patSigErr ty) `thenM_`
79 returnM (Nothing, emptyFVs)
80 ) `thenM` \ (maybe_rhs_sig', ty_fvs) ->
83 rnPatsAndThen ctxt pats $ \ pats' ->
84 rnGRHSs ctxt grhss `thenM` \ (grhss', grhss_fvs) ->
86 returnM (Match pats' maybe_rhs_sig' grhss', grhss_fvs `plusFV` ty_fvs)
87 -- The bindPatSigTyVarsFV and rnPatsAndThen will remove the bound FVs
89 rhs_sig_tys = case maybe_rhs_sig of
92 doc_sig = text "In a result type-signature"
96 %************************************************************************
98 \subsubsection{Guarded right-hand sides (GRHSs)}
100 %************************************************************************
103 rnGRHSs :: HsMatchContext Name -> RdrNameGRHSs -> RnM (RenamedGRHSs, FreeVars)
105 rnGRHSs ctxt (GRHSs grhss binds _)
106 = rnBindsAndThen binds $ \ binds' ->
107 mapFvRn (rnGRHS ctxt) grhss `thenM` \ (grhss', fvGRHSs) ->
108 returnM (GRHSs grhss' binds' placeHolderType, fvGRHSs)
110 rnGRHS ctxt (GRHS guarded locn)
112 doptM Opt_GlasgowExts `thenM` \ opt_GlasgowExts ->
113 checkM (opt_GlasgowExts || is_standard_guard guarded)
114 (addWarn (nonStdGuardErr guarded)) `thenM_`
116 rnStmts (PatGuard ctxt) guarded `thenM` \ (guarded', fvs) ->
117 returnM (GRHS guarded' locn, fvs)
119 -- Standard Haskell 1.4 guards are just a single boolean
120 -- expression, rather than a list of qualifiers as in the
122 is_standard_guard [ResultStmt _ _] = True
123 is_standard_guard [ExprStmt _ _ _, ResultStmt _ _] = True
124 is_standard_guard other = False
127 %************************************************************************
129 \subsubsection{Expressions}
131 %************************************************************************
134 rnExprs :: [RdrNameHsExpr] -> RnM ([RenamedHsExpr], FreeVars)
135 rnExprs ls = rnExprs' ls emptyUniqSet
137 rnExprs' [] acc = returnM ([], acc)
138 rnExprs' (expr:exprs) acc
139 = rnExpr expr `thenM` \ (expr', fvExpr) ->
141 -- Now we do a "seq" on the free vars because typically it's small
142 -- or empty, especially in very long lists of constants
144 acc' = acc `plusFV` fvExpr
146 (grubby_seqNameSet acc' rnExprs') exprs acc' `thenM` \ (exprs', fvExprs) ->
147 returnM (expr':exprs', fvExprs)
149 -- Grubby little function to do "seq" on namesets; replace by proper seq when GHC can do seq
150 grubby_seqNameSet ns result | isNullUFM ns = result
154 Variables. We look up the variable and return the resulting name.
157 rnExpr :: RdrNameHsExpr -> RnM (RenamedHsExpr, FreeVars)
160 = lookupOccRn v `thenM` \ name ->
161 if name `hasKey` assertIdKey && not opt_IgnoreAsserts then
162 -- We expand it to (GHC.Err.assertError location_string)
165 -- The normal case. Even if the Id was 'assert', if we are
166 -- ignoring assertions we leave it as GHC.Base.assert;
167 -- this function just ignores its first arg.
168 returnM (HsVar name, unitFV name)
171 = newIPName v `thenM` \ name ->
174 Linear _ -> mkFVs [splitName, fstName, sndName]
175 Dupable _ -> emptyFVs
177 returnM (HsIPVar name, fvs)
180 = litFVs lit `thenM` \ fvs ->
181 returnM (HsLit lit, fvs)
183 rnExpr (HsOverLit lit)
184 = rnOverLit lit `thenM` \ (lit', fvs) ->
185 returnM (HsOverLit lit', fvs)
188 = rnMatch LambdaExpr match `thenM` \ (match', fvMatch) ->
189 returnM (HsLam match', fvMatch)
191 rnExpr (HsApp fun arg)
192 = rnExpr fun `thenM` \ (fun',fvFun) ->
193 rnExpr arg `thenM` \ (arg',fvArg) ->
194 returnM (HsApp fun' arg', fvFun `plusFV` fvArg)
196 rnExpr (OpApp e1 op _ e2)
197 = rnExpr e1 `thenM` \ (e1', fv_e1) ->
198 rnExpr e2 `thenM` \ (e2', fv_e2) ->
199 rnExpr op `thenM` \ (op'@(HsVar op_name), fv_op) ->
202 -- When renaming code synthesised from "deriving" declarations
203 -- we're in Interface mode, and we should ignore fixity; assume
204 -- that the deriving code generator got the association correct
205 -- Don't even look up the fixity when in interface mode
206 getModeRn `thenM` \ mode ->
207 (if isInterfaceMode mode
208 then returnM (OpApp e1' op' defaultFixity e2')
209 else lookupFixityRn op_name `thenM` \ fixity ->
210 mkOpAppRn e1' op' fixity e2'
211 ) `thenM` \ final_e ->
214 fv_e1 `plusFV` fv_op `plusFV` fv_e2)
217 = rnExpr e `thenM` \ (e', fv_e) ->
218 lookupSyntaxName negateName `thenM` \ (neg_name, fv_neg) ->
219 mkNegAppRn e' neg_name `thenM` \ final_e ->
220 returnM (final_e, fv_e `plusFV` fv_neg)
223 = rnExpr e `thenM` \ (e', fvs_e) ->
224 returnM (HsPar e', fvs_e)
226 -- Template Haskell extensions
227 -- Don't ifdef-GHCI them because we want to fail gracefully
228 -- (not with an rnExpr crash) in a stage-1 compiler.
229 rnExpr e@(HsBracket br_body loc)
231 checkTH e "bracket" `thenM_`
232 rnBracket br_body `thenM` \ (body', fvs_e) ->
233 returnM (HsBracket body' loc, fvs_e `plusFV` thProxyName)
235 rnExpr e@(HsSplice n splice loc)
237 checkTH e "splice" `thenM_`
238 newLocalsRn [(n,loc)] `thenM` \ [n'] ->
239 rnExpr splice `thenM` \ (splice', fvs_e) ->
240 returnM (HsSplice n' splice' loc, fvs_e `plusFV` thProxyName)
242 rnExpr e@(HsReify (Reify flavour name))
243 = checkTH e "reify" `thenM_`
244 lookupGlobalOccRn name `thenM` \ name' ->
245 -- For now, we can only reify top-level things
246 returnM (HsReify (Reify flavour name'), unitFV name' `plusFV` thProxyName)
248 rnExpr section@(SectionL expr op)
249 = rnExpr expr `thenM` \ (expr', fvs_expr) ->
250 rnExpr op `thenM` \ (op', fvs_op) ->
251 checkSectionPrec InfixL section op' expr' `thenM_`
252 returnM (SectionL expr' op', fvs_op `plusFV` fvs_expr)
254 rnExpr section@(SectionR op expr)
255 = rnExpr op `thenM` \ (op', fvs_op) ->
256 rnExpr expr `thenM` \ (expr', fvs_expr) ->
257 checkSectionPrec InfixR section op' expr' `thenM_`
258 returnM (SectionR op' expr', fvs_op `plusFV` fvs_expr)
260 rnExpr (HsCCall fun args may_gc is_casm _)
261 -- Check out the comment on RnIfaces.getNonWiredDataDecl about ccalls
262 = rnExprs args `thenM` \ (args', fvs_args) ->
263 returnM (HsCCall fun args' may_gc is_casm placeHolderType,
264 fvs_args `plusFV` mkFVs [cCallableClassName,
265 cReturnableClassName,
268 rnExpr (HsCoreAnn ann expr)
269 = rnExpr expr `thenM` \ (expr', fvs_expr) ->
270 returnM (HsCoreAnn ann expr', fvs_expr)
272 rnExpr (HsSCC lbl expr)
273 = rnExpr expr `thenM` \ (expr', fvs_expr) ->
274 returnM (HsSCC lbl expr', fvs_expr)
276 rnExpr (HsCase expr ms src_loc)
277 = addSrcLoc src_loc $
278 rnExpr expr `thenM` \ (new_expr, e_fvs) ->
279 mapFvRn (rnMatch CaseAlt) ms `thenM` \ (new_ms, ms_fvs) ->
280 returnM (HsCase new_expr new_ms src_loc, e_fvs `plusFV` ms_fvs)
282 rnExpr (HsLet binds expr)
283 = rnBindsAndThen binds $ \ binds' ->
284 rnExpr expr `thenM` \ (expr',fvExpr) ->
285 returnM (HsLet binds' expr', fvExpr)
287 rnExpr e@(HsDo do_or_lc stmts _ _ src_loc)
288 = addSrcLoc src_loc $
289 rnStmts do_or_lc stmts `thenM` \ (stmts', fvs) ->
291 -- Check the statement list ends in an expression
292 case last stmts' of {
293 ResultStmt _ _ -> returnM () ;
294 _ -> addErr (doStmtListErr do_or_lc e)
297 -- Generate the rebindable syntax for the monad
298 mapAndUnzipM lookupSyntaxName
299 (syntax_names do_or_lc) `thenM` \ (monad_names', monad_fvs) ->
301 returnM (HsDo do_or_lc stmts' monad_names' placeHolderType src_loc,
302 fvs `plusFV` implicit_fvs do_or_lc `plusFV` plusFVs monad_fvs)
304 implicit_fvs PArrComp = mkFVs [replicatePName, mapPName, filterPName, crossPName, zipPName]
305 implicit_fvs ListComp = mkFVs [foldrName, buildName]
306 implicit_fvs DoExpr = emptyFVs
307 implicit_fvs MDoExpr = emptyFVs
309 syntax_names DoExpr = monadNames
310 syntax_names MDoExpr = monadNames ++ [mfixName]
311 syntax_names other = []
313 rnExpr (ExplicitList _ exps)
314 = rnExprs exps `thenM` \ (exps', fvs) ->
315 returnM (ExplicitList placeHolderType exps', fvs `addOneFV` listTyCon_name)
317 rnExpr (ExplicitPArr _ exps)
318 = rnExprs exps `thenM` \ (exps', fvs) ->
319 returnM (ExplicitPArr placeHolderType exps',
320 fvs `addOneFV` toPName `addOneFV` parrTyCon_name)
322 rnExpr e@(ExplicitTuple exps boxity)
323 = checkTupSize tup_size `thenM_`
324 rnExprs exps `thenM` \ (exps', fvs) ->
325 returnM (ExplicitTuple exps' boxity, fvs `addOneFV` tycon_name)
327 tup_size = length exps
328 tycon_name = tupleTyCon_name boxity tup_size
330 rnExpr (RecordCon con_id rbinds)
331 = lookupOccRn con_id `thenM` \ conname ->
332 rnRbinds "construction" rbinds `thenM` \ (rbinds', fvRbinds) ->
333 returnM (RecordCon conname rbinds', fvRbinds `addOneFV` conname)
335 rnExpr (RecordUpd expr rbinds)
336 = rnExpr expr `thenM` \ (expr', fvExpr) ->
337 rnRbinds "update" rbinds `thenM` \ (rbinds', fvRbinds) ->
338 returnM (RecordUpd expr' rbinds', fvExpr `plusFV` fvRbinds)
340 rnExpr (ExprWithTySig expr pty)
341 = rnExpr expr `thenM` \ (expr', fvExpr) ->
342 rnHsTypeFVs doc pty `thenM` \ (pty', fvTy) ->
343 returnM (ExprWithTySig expr' pty', fvExpr `plusFV` fvTy)
345 doc = text "In an expression type signature"
347 rnExpr (HsIf p b1 b2 src_loc)
348 = addSrcLoc src_loc $
349 rnExpr p `thenM` \ (p', fvP) ->
350 rnExpr b1 `thenM` \ (b1', fvB1) ->
351 rnExpr b2 `thenM` \ (b2', fvB2) ->
352 returnM (HsIf p' b1' b2' src_loc, plusFVs [fvP, fvB1, fvB2])
355 = rnHsTypeFVs doc a `thenM` \ (t, fvT) ->
356 returnM (HsType t, fvT)
358 doc = text "In a type argument"
360 rnExpr (ArithSeqIn seq)
361 = rnArithSeq seq `thenM` \ (new_seq, fvs) ->
362 returnM (ArithSeqIn new_seq, fvs `addOneFV` enumClassName)
364 rnExpr (PArrSeqIn seq)
365 = rnArithSeq seq `thenM` \ (new_seq, fvs) ->
366 returnM (PArrSeqIn new_seq,
367 fvs `plusFV` mkFVs [enumFromToPName, enumFromThenToPName])
370 These three are pattern syntax appearing in expressions.
371 Since all the symbols are reservedops we can simply reject them.
372 We return a (bogus) EWildPat in each case.
375 rnExpr e@EWildPat = addErr (patSynErr e) `thenM_`
376 returnM (EWildPat, emptyFVs)
378 rnExpr e@(EAsPat _ _) = addErr (patSynErr e) `thenM_`
379 returnM (EWildPat, emptyFVs)
381 rnExpr e@(ELazyPat _) = addErr (patSynErr e) `thenM_`
382 returnM (EWildPat, emptyFVs)
385 %************************************************************************
389 %************************************************************************
392 rnArithSeq (From expr)
393 = rnExpr expr `thenM` \ (expr', fvExpr) ->
394 returnM (From expr', fvExpr)
396 rnArithSeq (FromThen expr1 expr2)
397 = rnExpr expr1 `thenM` \ (expr1', fvExpr1) ->
398 rnExpr expr2 `thenM` \ (expr2', fvExpr2) ->
399 returnM (FromThen expr1' expr2', fvExpr1 `plusFV` fvExpr2)
401 rnArithSeq (FromTo expr1 expr2)
402 = rnExpr expr1 `thenM` \ (expr1', fvExpr1) ->
403 rnExpr expr2 `thenM` \ (expr2', fvExpr2) ->
404 returnM (FromTo expr1' expr2', fvExpr1 `plusFV` fvExpr2)
406 rnArithSeq (FromThenTo expr1 expr2 expr3)
407 = rnExpr expr1 `thenM` \ (expr1', fvExpr1) ->
408 rnExpr expr2 `thenM` \ (expr2', fvExpr2) ->
409 rnExpr expr3 `thenM` \ (expr3', fvExpr3) ->
410 returnM (FromThenTo expr1' expr2' expr3',
411 plusFVs [fvExpr1, fvExpr2, fvExpr3])
415 %************************************************************************
417 \subsubsection{@Rbinds@s and @Rpats@s: in record expressions}
419 %************************************************************************
423 = mappM_ field_dup_err dup_fields `thenM_`
424 mapFvRn rn_rbind rbinds `thenM` \ (rbinds', fvRbind) ->
425 returnM (rbinds', fvRbind)
427 (_, dup_fields) = removeDups compare [ f | (f,_) <- rbinds ]
429 field_dup_err dups = addErr (dupFieldErr str dups)
431 rn_rbind (field, expr)
432 = lookupGlobalOccRn field `thenM` \ fieldname ->
433 rnExpr expr `thenM` \ (expr', fvExpr) ->
434 returnM ((fieldname, expr'), fvExpr `addOneFV` fieldname)
437 %************************************************************************
439 Template Haskell brackets
441 %************************************************************************
444 rnBracket (ExpBr e) = rnExpr e `thenM` \ (e', fvs) ->
445 returnM (ExpBr e', fvs)
446 rnBracket (PatBr p) = rnPat p `thenM` \ (p', fvs) ->
447 returnM (PatBr p', fvs)
448 rnBracket (TypBr t) = rnHsTypeFVs doc t `thenM` \ (t', fvs) ->
449 returnM (TypBr t', fvs)
451 doc = ptext SLIT("In a Template-Haskell quoted type")
452 rnBracket (DecBr group)
453 = importsFromLocalDecls group `thenM` \ (rdr_env, avails) ->
454 -- Discard avails (not useful here)
456 updGblEnv (\gbl -> gbl { tcg_rdr_env = rdr_env `plusGlobalRdrEnv` tcg_rdr_env gbl }) $
458 rnSrcDecls group `thenM` \ (tcg_env, group', dus) ->
459 -- Discard the tcg_env; it contains only extra info about fixity
461 returnM (DecBr group', duUses dus `minusNameSet` duDefs dus)
464 %************************************************************************
466 \subsubsection{@Stmt@s: in @do@ expressions}
468 %************************************************************************
471 rnStmts :: HsStmtContext Name -> [RdrNameStmt] -> RnM ([RenamedStmt], FreeVars)
473 rnStmts MDoExpr stmts = rnMDoStmts stmts
474 rnStmts ctxt stmts = rnNormalStmts ctxt stmts
476 rnNormalStmts :: HsStmtContext Name -> [RdrNameStmt] -> RnM ([RenamedStmt], FreeVars)
477 -- Used for cases *other* than recursive mdo
478 -- Implements nested scopes
480 rnNormalStmts ctxt [] = returnM ([], emptyFVs)
481 -- Happens at the end of the sub-lists of a ParStmts
483 rnNormalStmts ctxt (ExprStmt expr _ src_loc : stmts)
484 = addSrcLoc src_loc $
485 rnExpr expr `thenM` \ (expr', fv_expr) ->
486 rnNormalStmts ctxt stmts `thenM` \ (stmts', fvs) ->
487 returnM (ExprStmt expr' placeHolderType src_loc : stmts',
488 fv_expr `plusFV` fvs)
490 rnNormalStmts ctxt [ResultStmt expr src_loc]
491 = addSrcLoc src_loc $
492 rnExpr expr `thenM` \ (expr', fv_expr) ->
493 returnM ([ResultStmt expr' src_loc], fv_expr)
495 rnNormalStmts ctxt (BindStmt pat expr src_loc : stmts)
496 = addSrcLoc src_loc $
497 rnExpr expr `thenM` \ (expr', fv_expr) ->
498 -- The binders do not scope over the expression
500 rnPatsAndThen (StmtCtxt ctxt) [pat] $ \ [pat'] ->
501 rnNormalStmts ctxt stmts `thenM` \ (stmts', fvs) ->
502 returnM (BindStmt pat' expr' src_loc : stmts',
503 fv_expr `plusFV` fvs) -- fv_expr shouldn't really be filtered by
504 -- the rnPatsAndThen, but it does not matter
506 rnNormalStmts ctxt (LetStmt binds : stmts)
507 = checkErr (ok ctxt binds) (badIpBinds binds) `thenM_`
508 rnBindsAndThen binds ( \ binds' ->
509 rnNormalStmts ctxt stmts `thenM` \ (stmts', fvs) ->
510 returnM (LetStmt binds' : stmts', fvs))
512 -- We do not allow implicit-parameter bindings in a parallel
513 -- list comprehension. I'm not sure what it might mean.
514 ok (ParStmtCtxt _) (IPBinds _ _) = False
517 rnNormalStmts ctxt (ParStmt stmtss : stmts)
518 = doptM Opt_GlasgowExts `thenM` \ opt_GlasgowExts ->
519 checkM opt_GlasgowExts parStmtErr `thenM_`
520 mapFvRn (rnNormalStmts (ParStmtCtxt ctxt)) stmtss `thenM` \ (stmtss', fv_stmtss) ->
522 bndrss = map collectStmtsBinders stmtss'
524 foldlM checkBndrs [] bndrss `thenM` \ new_binders ->
525 bindLocalNamesFV new_binders $
526 -- Note: binders are returned in scope order, so one may
527 -- shadow the next; e.g. x <- xs; x <- ys
528 rnNormalStmts ctxt stmts `thenM` \ (stmts', fvs) ->
529 returnM (ParStmtOut (bndrss `zip` stmtss') : stmts',
530 fv_stmtss `plusFV` fvs)
533 checkBndrs all_bndrs bndrs
534 = checkErr (null common) (err (head common)) `thenM_`
535 returnM (bndrs ++ all_bndrs)
537 common = intersectBy eqOcc all_bndrs bndrs
539 eqOcc n1 n2 = nameOccName n1 == nameOccName n2
540 err v = ptext SLIT("Duplicate binding in parallel list comprehension for:")
543 rnNormalStmts ctxt stmts = pprPanic "rnNormalStmts" (ppr stmts)
547 %************************************************************************
549 \subsubsection{Precedence Parsing}
551 %************************************************************************
554 type FwdRefs = NameSet
555 type Segment = (Defs,
556 Uses, -- May include defs
557 FwdRefs, -- A subset of uses that are
558 -- (a) used before they are bound in this segment, or
559 -- (b) used here, and bound in subsequent segments
562 ----------------------------------------------------
563 rnMDoStmts :: [RdrNameStmt] -> RnM ([RenamedStmt], FreeVars)
565 = -- Step1: bring all the binders of the mdo into scope
566 bindLocalsRn doc (collectStmtsBinders stmts) $ \ _ ->
568 -- Step 2: Rename each individual stmt, making a
569 -- singleton segment. At this stage the FwdRefs field
570 -- isn't finished: it's empty for all except a BindStmt
571 -- for which it's the fwd refs within the bind itself
572 mappM rn_mdo_stmt stmts `thenM` \ segs ->
574 -- Step 3: Fill in the fwd refs.
575 -- The segments are all singletons, but their fwd-ref
576 -- field mentions all the things used by the segment
577 -- that are bound after their use
578 segs_w_fwd_refs = addFwdRefs segs
580 -- Step 4: Group together the segments to make bigger segments
581 -- Invariant: in the result, no segment uses a variable
582 -- bound in a later segment
583 grouped_segs = glomSegments segs_w_fwd_refs
585 -- Step 5: Turn the segments into Stmts
586 -- Use RecStmt when and only when there are fwd refs
587 -- Also gather up the uses from the end towards the
588 -- start, so we can tell the RecStmt which things are
589 -- used 'after' the RecStmt
590 stmts_w_fvs = segsToStmts grouped_segs
594 doc = text "In a mdo-expression"
596 ----------------------------------------------------
597 rn_mdo_stmt :: RdrNameStmt -> RnM Segment
598 -- Assumes all binders are already in scope
599 -- Turns each stmt into a singleton Stmt
601 rn_mdo_stmt (ExprStmt expr _ src_loc)
602 = addSrcLoc src_loc (rnExpr expr) `thenM` \ (expr', fvs) ->
603 returnM (emptyNameSet, fvs, emptyNameSet,
604 [ExprStmt expr' placeHolderType src_loc])
606 rn_mdo_stmt (ResultStmt expr src_loc)
607 = addSrcLoc src_loc (rnExpr expr) `thenM` \ (expr', fvs) ->
608 returnM (emptyNameSet, fvs, emptyNameSet,
609 [ResultStmt expr' src_loc])
611 rn_mdo_stmt (BindStmt pat expr src_loc)
612 = addSrcLoc src_loc $
613 rnExpr expr `thenM` \ (expr', fv_expr) ->
614 rnPat pat `thenM` \ (pat', fv_pat) ->
616 bndrs = mkNameSet (collectPatBinders pat')
617 fvs = fv_expr `plusFV` fv_pat
619 returnM (bndrs, fvs, bndrs `intersectNameSet` fvs,
620 [BindStmt pat' expr' src_loc])
622 rn_mdo_stmt (LetStmt binds)
623 = rnBinds binds `thenM` \ (binds', du_binds) ->
624 returnM (duDefs du_binds, duUses du_binds,
625 emptyNameSet, [LetStmt binds'])
627 rn_mdo_stmt stmt@(ParStmt _) -- Syntactically illegal in mdo
628 = pprPanic "rn_mdo_stmt" (ppr stmt)
631 addFwdRefs :: [Segment] -> [Segment]
632 -- So far the segments only have forward refs *within* the Stmt
633 -- (which happens for bind: x <- ...x...)
634 -- This function adds the cross-seg fwd ref info
637 = fst (foldr mk_seg ([], emptyNameSet) pairs)
639 mk_seg (defs, uses, fwds, stmts) (segs, seg_defs)
640 = (new_seg : segs, all_defs)
642 new_seg = (defs, uses, new_fwds, stmts)
643 all_defs = seg_defs `unionNameSets` defs
644 new_fwds = fwds `unionNameSets` (uses `intersectNameSet` seg_defs)
645 -- Add the downstream fwd refs here
647 ----------------------------------------------------
648 -- Glomming the singleton segments of an mdo into
649 -- minimal recursive groups.
651 -- At first I thought this was just strongly connected components, but
652 -- there's an important constraint: the order of the stmts must not change.
655 -- mdo { x <- ...y...
662 -- Here, the first stmt mention 'y', which is bound in the third.
663 -- But that means that the innocent second stmt (p <- z) gets caught
664 -- up in the recursion. And that in turn means that the binding for
665 -- 'z' has to be included... and so on.
667 -- Start at the tail { r <- x }
668 -- Now add the next one { z <- y ; r <- x }
669 -- Now add one more { q <- x ; z <- y ; r <- x }
670 -- Now one more... but this time we have to group a bunch into rec
671 -- { rec { y <- ...x... ; q <- x ; z <- y } ; r <- x }
672 -- Now one more, which we can add on without a rec
674 -- rec { y <- ...x... ; q <- x ; z <- y } ;
676 -- Finally we add the last one; since it mentions y we have to
677 -- glom it togeher with the first two groups
678 -- { rec { x <- ...y...; p <- z ; y <- ...x... ;
679 -- q <- x ; z <- y } ;
682 glomSegments :: [Segment] -> [Segment]
684 glomSegments [seg] = [seg]
685 glomSegments ((defs,uses,fwds,stmts) : segs)
686 -- Actually stmts will always be a singleton
687 = (seg_defs, seg_uses, seg_fwds, seg_stmts) : others
689 segs' = glomSegments segs
690 (extras, others) = grab uses segs'
691 (ds, us, fs, ss) = unzip4 extras
693 seg_defs = plusFVs ds `plusFV` defs
694 seg_uses = plusFVs us `plusFV` uses
695 seg_fwds = plusFVs fs `plusFV` fwds
696 seg_stmts = stmts ++ concat ss
698 grab :: NameSet -- The client
700 -> ([Segment], -- Needed by the 'client'
701 [Segment]) -- Not needed by the client
702 -- The result is simply a split of the input
704 = (reverse yeses, reverse noes)
706 (noes, yeses) = span not_needed (reverse dus)
707 not_needed (defs,_,_,_) = not (intersectsNameSet defs uses)
710 ----------------------------------------------------
711 segsToStmts :: [Segment] -> ([RenamedStmt], FreeVars)
713 segsToStmts [] = ([], emptyFVs)
714 segsToStmts ((defs, uses, fwds, ss) : segs)
715 = (new_stmt : later_stmts, later_uses `plusFV` uses)
717 (later_stmts, later_uses) = segsToStmts segs
718 new_stmt | non_rec = head ss
719 | otherwise = RecStmt rec_names ss []
721 non_rec = isSingleton ss && isEmptyNameSet fwds
722 rec_names = nameSetToList (fwds `plusFV` (defs `intersectNameSet` later_uses))
723 -- The names for the fixpoint are
724 -- (a) the ones needed after the RecStmt
725 -- (b) the forward refs within the fixpoint
728 %************************************************************************
730 \subsubsection{Precedence Parsing}
732 %************************************************************************
734 @mkOpAppRn@ deals with operator fixities. The argument expressions
735 are assumed to be already correctly arranged. It needs the fixities
736 recorded in the OpApp nodes, because fixity info applies to the things
737 the programmer actually wrote, so you can't find it out from the Name.
739 Furthermore, the second argument is guaranteed not to be another
740 operator application. Why? Because the parser parses all
741 operator appications left-associatively, EXCEPT negation, which
742 we need to handle specially.
745 mkOpAppRn :: RenamedHsExpr -- Left operand; already rearranged
746 -> RenamedHsExpr -> Fixity -- Operator and fixity
747 -> RenamedHsExpr -- Right operand (not an OpApp, but might
751 ---------------------------
752 -- (e11 `op1` e12) `op2` e2
753 mkOpAppRn e1@(OpApp e11 op1 fix1 e12) op2 fix2 e2
755 = addErr (precParseErr (ppr_op op1,fix1) (ppr_op op2,fix2)) `thenM_`
756 returnM (OpApp e1 op2 fix2 e2)
759 = mkOpAppRn e12 op2 fix2 e2 `thenM` \ new_e ->
760 returnM (OpApp e11 op1 fix1 new_e)
762 (nofix_error, associate_right) = compareFixity fix1 fix2
764 ---------------------------
765 -- (- neg_arg) `op` e2
766 mkOpAppRn e1@(NegApp neg_arg neg_name) op2 fix2 e2
768 = addErr (precParseErr (pp_prefix_minus,negateFixity) (ppr_op op2,fix2)) `thenM_`
769 returnM (OpApp e1 op2 fix2 e2)
772 = mkOpAppRn neg_arg op2 fix2 e2 `thenM` \ new_e ->
773 returnM (NegApp new_e neg_name)
775 (nofix_error, associate_right) = compareFixity negateFixity fix2
777 ---------------------------
779 mkOpAppRn e1 op1 fix1 e2@(NegApp neg_arg _) -- NegApp can occur on the right
780 | not associate_right -- We *want* right association
781 = addErr (precParseErr (ppr_op op1, fix1) (pp_prefix_minus, negateFixity)) `thenM_`
782 returnM (OpApp e1 op1 fix1 e2)
784 (_, associate_right) = compareFixity fix1 negateFixity
786 ---------------------------
788 mkOpAppRn e1 op fix e2 -- Default case, no rearrangment
789 = ASSERT2( right_op_ok fix e2,
790 ppr e1 $$ text "---" $$ ppr op $$ text "---" $$ ppr fix $$ text "---" $$ ppr e2
792 returnM (OpApp e1 op fix e2)
794 -- Parser left-associates everything, but
795 -- derived instances may have correctly-associated things to
796 -- in the right operarand. So we just check that the right operand is OK
797 right_op_ok fix1 (OpApp _ _ fix2 _)
798 = not error_please && associate_right
800 (error_please, associate_right) = compareFixity fix1 fix2
801 right_op_ok fix1 other
804 -- Parser initially makes negation bind more tightly than any other operator
805 mkNegAppRn neg_arg neg_name
808 getModeRn `thenM` \ mode ->
809 ASSERT( not_op_app mode neg_arg )
811 returnM (NegApp neg_arg neg_name)
813 not_op_app SourceMode (OpApp _ _ _ _) = False
814 not_op_app mode other = True
818 checkPrecMatch :: Bool -> Name -> RenamedMatch -> RnM ()
820 checkPrecMatch False fn match
823 checkPrecMatch True op (Match (p1:p2:_) _ _)
824 -- True indicates an infix lhs
825 = getModeRn `thenM` \ mode ->
826 -- See comments with rnExpr (OpApp ...)
827 if isInterfaceMode mode
829 else checkPrec op p1 False `thenM_`
832 checkPrecMatch True op _ = panic "checkPrecMatch"
834 checkPrec op (ConPatIn op1 (InfixCon _ _)) right
835 = lookupFixityRn op `thenM` \ op_fix@(Fixity op_prec op_dir) ->
836 lookupFixityRn op1 `thenM` \ op1_fix@(Fixity op1_prec op1_dir) ->
838 inf_ok = op1_prec > op_prec ||
839 (op1_prec == op_prec &&
840 (op1_dir == InfixR && op_dir == InfixR && right ||
841 op1_dir == InfixL && op_dir == InfixL && not right))
843 info = (ppr_op op, op_fix)
844 info1 = (ppr_op op1, op1_fix)
845 (infol, infor) = if right then (info, info1) else (info1, info)
847 checkErr inf_ok (precParseErr infol infor)
849 checkPrec op pat right
852 -- Check precedence of (arg op) or (op arg) respectively
853 -- If arg is itself an operator application, then either
854 -- (a) its precedence must be higher than that of op
855 -- (b) its precedency & associativity must be the same as that of op
856 checkSectionPrec direction section op arg
858 OpApp _ op fix _ -> go_for_it (ppr_op op) fix
859 NegApp _ _ -> go_for_it pp_prefix_minus negateFixity
863 go_for_it pp_arg_op arg_fix@(Fixity arg_prec assoc)
864 = lookupFixityRn op_name `thenM` \ op_fix@(Fixity op_prec _) ->
865 checkErr (op_prec < arg_prec
866 || op_prec == arg_prec && direction == assoc)
867 (sectionPrecErr (ppr_op op_name, op_fix)
868 (pp_arg_op, arg_fix) section)
872 %************************************************************************
874 \subsubsection{Assertion utils}
876 %************************************************************************
879 mkAssertErrorExpr :: RnM (RenamedHsExpr, FreeVars)
880 -- Return an expression for (assertError "Foo.hs:27")
882 = getSrcLocM `thenM` \ sloc ->
884 expr = HsApp (HsVar assertErrorName) (HsLit msg)
885 msg = HsStringPrim (mkFastString (stringToUtf8 (showSDoc (ppr sloc))))
887 returnM (expr, unitFV assertErrorName)
890 %************************************************************************
892 \subsubsection{Errors}
894 %************************************************************************
897 ppr_op op = quotes (ppr op) -- Here, op can be a Name or a (Var n), where n is a Name
898 pp_prefix_minus = ptext SLIT("prefix `-'")
902 SLIT("accepting non-standard pattern guards (-fglasgow-exts to suppress this message)")
906 = sep [ptext SLIT("Pattern syntax in expression context:"),
909 doStmtListErr do_or_lc e
910 = sep [quotes (text binder_name) <+> ptext SLIT("statements must end in expression:"),
913 binder_name = case do_or_lc of
918 checkTH e what = returnM () -- OK
920 checkTH e what -- Raise an error in a stage-1 compiler
921 = addErr (vcat [ptext SLIT("Template Haskell") <+> text what <+>
922 ptext SLIT("illegal in a stage-1 compiler"),
926 parStmtErr = addErr (ptext SLIT("Illegal parallel list comprehension: use -fglagow-exts"))
929 = hang (ptext SLIT("Implicit-parameter bindings illegal in a parallel list comprehension:")) 4