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 RnTypes ( rnHsTypeFVs, rnPat, litFVs, rnOverLit, rnPatsAndThen,
32 dupFieldErr, precParseErr, sectionPrecErr, patSigErr )
33 import CmdLineOpts ( DynFlag(..), opt_IgnoreAsserts )
34 import BasicTypes ( Fixity(..), FixityDirection(..), IPName(..),
35 defaultFixity, negateFixity, compareFixity )
36 import PrelNames ( hasKey, assertIdKey,
38 cCallableClassName, cReturnableClassName,
40 splitName, fstName, sndName, ioDataConName,
41 replicatePName, mapPName, filterPName,
42 crossPName, zipPName, toPName,
43 enumFromToPName, enumFromThenToPName, assertErrorName,
44 negateName, qTyConName, monadNames, mfixName )
45 import RdrName ( RdrName )
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 bindPatSigTyVars 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 bindPatSigTyVars 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 rnExpr (HsBracket br_body)
228 = checkGHCI (thErr "bracket") `thenM_`
229 rnBracket br_body `thenM` \ (body', fvs_e) ->
230 returnM (HsBracket body', fvs_e `addOneFV` qTyConName)
231 -- We use the Q tycon as a proxy to haul in all the smart
232 -- constructors; see the hack in RnIfaces
234 rnExpr (HsSplice n e)
235 = checkGHCI (thErr "splice") `thenM_`
236 getSrcLocM `thenM` \ loc ->
237 newLocalsRn [(n,loc)] `thenM` \ [n'] ->
238 rnExpr e `thenM` \ (e', fvs_e) ->
239 returnM (HsSplice n' e', fvs_e)
241 rnExpr section@(SectionL expr op)
242 = rnExpr expr `thenM` \ (expr', fvs_expr) ->
243 rnExpr op `thenM` \ (op', fvs_op) ->
244 checkSectionPrec InfixL section op' expr' `thenM_`
245 returnM (SectionL expr' op', fvs_op `plusFV` fvs_expr)
247 rnExpr section@(SectionR op expr)
248 = rnExpr op `thenM` \ (op', fvs_op) ->
249 rnExpr expr `thenM` \ (expr', fvs_expr) ->
250 checkSectionPrec InfixR section op' expr' `thenM_`
251 returnM (SectionR op' expr', fvs_op `plusFV` fvs_expr)
253 rnExpr (HsCCall fun args may_gc is_casm _)
254 -- Check out the comment on RnIfaces.getNonWiredDataDecl about ccalls
255 = rnExprs args `thenM` \ (args', fvs_args) ->
256 returnM (HsCCall fun args' may_gc is_casm placeHolderType,
257 fvs_args `plusFV` mkFVs [cCallableClassName,
258 cReturnableClassName,
261 rnExpr (HsSCC lbl expr)
262 = rnExpr expr `thenM` \ (expr', fvs_expr) ->
263 returnM (HsSCC lbl expr', fvs_expr)
265 rnExpr (HsCase expr ms src_loc)
266 = addSrcLoc src_loc $
267 rnExpr expr `thenM` \ (new_expr, e_fvs) ->
268 mapFvRn (rnMatch CaseAlt) ms `thenM` \ (new_ms, ms_fvs) ->
269 returnM (HsCase new_expr new_ms src_loc, e_fvs `plusFV` ms_fvs)
271 rnExpr (HsLet binds expr)
272 = rnBindsAndThen binds $ \ binds' ->
273 rnExpr expr `thenM` \ (expr',fvExpr) ->
274 returnM (HsLet binds' expr', fvExpr)
276 rnExpr (HsWith expr binds is_with)
277 = warnIf is_with withWarning `thenM_`
278 rnExpr expr `thenM` \ (expr',fvExpr) ->
279 rnIPBinds binds `thenM` \ (binds',fvBinds) ->
280 returnM (HsWith expr' binds' is_with, fvExpr `plusFV` fvBinds)
282 rnExpr e@(HsDo do_or_lc stmts _ _ src_loc)
283 = addSrcLoc src_loc $
284 rnStmts do_or_lc stmts `thenM` \ (stmts', fvs) ->
286 -- Check the statement list ends in an expression
287 case last stmts' of {
288 ResultStmt _ _ -> returnM () ;
289 _ -> addErr (doStmtListErr do_or_lc e)
292 -- Generate the rebindable syntax for the monad
293 mapAndUnzipM lookupSyntaxName
294 (syntax_names do_or_lc) `thenM` \ (monad_names', monad_fvs) ->
296 returnM (HsDo do_or_lc stmts' monad_names' placeHolderType src_loc,
297 fvs `plusFV` implicit_fvs do_or_lc `plusFV` plusFVs monad_fvs)
299 implicit_fvs PArrComp = mkFVs [replicatePName, mapPName, filterPName, crossPName, zipPName]
300 implicit_fvs ListComp = mkFVs [foldrName, buildName]
301 implicit_fvs DoExpr = emptyFVs
302 implicit_fvs MDoExpr = emptyFVs
304 syntax_names DoExpr = monadNames
305 syntax_names MDoExpr = monadNames ++ [mfixName]
306 syntax_names other = []
308 rnExpr (ExplicitList _ exps)
309 = rnExprs exps `thenM` \ (exps', fvs) ->
310 returnM (ExplicitList placeHolderType exps', fvs `addOneFV` listTyCon_name)
312 rnExpr (ExplicitPArr _ exps)
313 = rnExprs exps `thenM` \ (exps', fvs) ->
314 returnM (ExplicitPArr placeHolderType exps',
315 fvs `addOneFV` toPName `addOneFV` parrTyCon_name)
317 rnExpr (ExplicitTuple exps boxity)
318 = rnExprs exps `thenM` \ (exps', fvs) ->
319 returnM (ExplicitTuple exps' boxity, fvs `addOneFV` tycon_name)
321 tycon_name = tupleTyCon_name boxity (length exps)
323 rnExpr (RecordCon con_id rbinds)
324 = lookupOccRn con_id `thenM` \ conname ->
325 rnRbinds "construction" rbinds `thenM` \ (rbinds', fvRbinds) ->
326 returnM (RecordCon conname rbinds', fvRbinds `addOneFV` conname)
328 rnExpr (RecordUpd expr rbinds)
329 = rnExpr expr `thenM` \ (expr', fvExpr) ->
330 rnRbinds "update" rbinds `thenM` \ (rbinds', fvRbinds) ->
331 returnM (RecordUpd expr' rbinds', fvExpr `plusFV` fvRbinds)
333 rnExpr (ExprWithTySig expr pty)
334 = rnExpr expr `thenM` \ (expr', fvExpr) ->
335 rnHsTypeFVs doc pty `thenM` \ (pty', fvTy) ->
336 returnM (ExprWithTySig expr' pty', fvExpr `plusFV` fvTy)
338 doc = text "In an expression type signature"
340 rnExpr (HsIf p b1 b2 src_loc)
341 = addSrcLoc src_loc $
342 rnExpr p `thenM` \ (p', fvP) ->
343 rnExpr b1 `thenM` \ (b1', fvB1) ->
344 rnExpr b2 `thenM` \ (b2', fvB2) ->
345 returnM (HsIf p' b1' b2' src_loc, plusFVs [fvP, fvB1, fvB2])
348 = rnHsTypeFVs doc a `thenM` \ (t, fvT) ->
349 returnM (HsType t, fvT)
351 doc = text "In a type argument"
353 rnExpr (ArithSeqIn seq)
354 = rnArithSeq seq `thenM` \ (new_seq, fvs) ->
355 returnM (ArithSeqIn new_seq, fvs `addOneFV` enumClassName)
357 rnExpr (PArrSeqIn seq)
358 = rnArithSeq seq `thenM` \ (new_seq, fvs) ->
359 returnM (PArrSeqIn new_seq,
360 fvs `plusFV` mkFVs [enumFromToPName, enumFromThenToPName])
363 These three are pattern syntax appearing in expressions.
364 Since all the symbols are reservedops we can simply reject them.
365 We return a (bogus) EWildPat in each case.
368 rnExpr e@EWildPat = addErr (patSynErr e) `thenM_`
369 returnM (EWildPat, emptyFVs)
371 rnExpr e@(EAsPat _ _) = addErr (patSynErr e) `thenM_`
372 returnM (EWildPat, emptyFVs)
374 rnExpr e@(ELazyPat _) = addErr (patSynErr e) `thenM_`
375 returnM (EWildPat, emptyFVs)
378 %************************************************************************
382 %************************************************************************
385 rnArithSeq (From expr)
386 = rnExpr expr `thenM` \ (expr', fvExpr) ->
387 returnM (From expr', fvExpr)
389 rnArithSeq (FromThen expr1 expr2)
390 = rnExpr expr1 `thenM` \ (expr1', fvExpr1) ->
391 rnExpr expr2 `thenM` \ (expr2', fvExpr2) ->
392 returnM (FromThen expr1' expr2', fvExpr1 `plusFV` fvExpr2)
394 rnArithSeq (FromTo expr1 expr2)
395 = rnExpr expr1 `thenM` \ (expr1', fvExpr1) ->
396 rnExpr expr2 `thenM` \ (expr2', fvExpr2) ->
397 returnM (FromTo expr1' expr2', fvExpr1 `plusFV` fvExpr2)
399 rnArithSeq (FromThenTo expr1 expr2 expr3)
400 = rnExpr expr1 `thenM` \ (expr1', fvExpr1) ->
401 rnExpr expr2 `thenM` \ (expr2', fvExpr2) ->
402 rnExpr expr3 `thenM` \ (expr3', fvExpr3) ->
403 returnM (FromThenTo expr1' expr2' expr3',
404 plusFVs [fvExpr1, fvExpr2, fvExpr3])
408 %************************************************************************
410 \subsubsection{@Rbinds@s and @Rpats@s: in record expressions}
412 %************************************************************************
416 = mappM_ field_dup_err dup_fields `thenM_`
417 mapFvRn rn_rbind rbinds `thenM` \ (rbinds', fvRbind) ->
418 returnM (rbinds', fvRbind)
420 (_, dup_fields) = removeDups compare [ f | (f,_) <- rbinds ]
422 field_dup_err dups = addErr (dupFieldErr str dups)
424 rn_rbind (field, expr)
425 = lookupGlobalOccRn field `thenM` \ fieldname ->
426 rnExpr expr `thenM` \ (expr', fvExpr) ->
427 returnM ((fieldname, expr'), fvExpr `addOneFV` fieldname)
430 %************************************************************************
432 \subsubsection{@rnIPBinds@s: in implicit parameter bindings} *
434 %************************************************************************
437 rnIPBinds [] = returnM ([], emptyFVs)
438 rnIPBinds ((n, expr) : binds)
439 = newIPName n `thenM` \ name ->
440 rnExpr expr `thenM` \ (expr',fvExpr) ->
441 rnIPBinds binds `thenM` \ (binds',fvBinds) ->
442 returnM ((name, expr') : binds', fvExpr `plusFV` fvBinds)
446 %************************************************************************
448 Template Haskell brackets
450 %************************************************************************
453 rnBracket (ExpBr e) = rnExpr e `thenM` \ (e', fvs) ->
454 returnM (ExpBr e', fvs)
455 rnBracket (PatBr p) = rnPat p `thenM` \ (p', fvs) ->
456 returnM (PatBr p', fvs)
457 rnBracket (TypBr t) = rnHsTypeFVs doc t `thenM` \ (t', fvs) ->
458 returnM (TypBr t', fvs)
460 doc = ptext SLIT("In a Template-Haskell quoted type")
461 rnBracket (DecBr ds) = rnSrcDecls ds `thenM` \ (tcg_env, ds', fvs) ->
462 -- Discard the tcg_env; it contains the extended global RdrEnv
463 -- because there is no scope that these decls cover (yet!)
464 returnM (DecBr ds', 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 = rnBindsAndThen binds $ \ binds' ->
511 rnNormalStmts ctxt stmts `thenM` \ (stmts', fvs) ->
512 returnM (LetStmt binds' : stmts', fvs)
514 rnNormalStmts ctxt (ParStmt stmtss : stmts)
515 = mapFvRn (rnNormalStmts ctxt) stmtss `thenM` \ (stmtss', fv_stmtss) ->
517 bndrss = map collectStmtsBinders stmtss'
519 foldlM checkBndrs [] bndrss `thenM` \ new_binders ->
520 bindLocalNamesFV new_binders $
521 -- Note: binders are returned in scope order, so one may
522 -- shadow the next; e.g. x <- xs; x <- ys
523 rnNormalStmts ctxt stmts `thenM` \ (stmts', fvs) ->
524 returnM (ParStmtOut (bndrss `zip` stmtss') : stmts',
525 fv_stmtss `plusFV` fvs)
528 checkBndrs all_bndrs bndrs
529 = checkErr (null common) (err (head common)) `thenM_`
530 returnM (bndrs ++ all_bndrs)
532 common = intersectBy eqOcc all_bndrs bndrs
534 eqOcc n1 n2 = nameOccName n1 == nameOccName n2
535 err v = ptext SLIT("Duplicate binding in parallel list comprehension for:")
538 rnNormalStmts ctxt stmts = pprPanic "rnNormalStmts" (ppr stmts)
542 %************************************************************************
544 \subsubsection{Precedence Parsing}
546 %************************************************************************
550 type Uses = NameSet -- Same as FreeVars really
551 type FwdRefs = NameSet
552 type Segment = (Defs,
553 Uses, -- May include defs
554 FwdRefs, -- A subset of uses that are
555 -- (a) used before they are bound in this segment, or
556 -- (b) used here, and bound in subsequent segments
559 ----------------------------------------------------
560 rnMDoStmts :: [RdrNameStmt] -> RnM ([RenamedStmt], FreeVars)
562 = -- Step1: bring all the binders of the mdo into scope
563 bindLocalsRn doc (collectStmtsBinders stmts) $ \ _ ->
565 -- Step 2: Rename each individual stmt, making a
566 -- singleton segment. At this stage the FwdRefs field
567 -- isn't finished: it's empty for all except a BindStmt
568 -- for which it's the fwd refs within the bind itself
569 mappM rn_mdo_stmt stmts `thenM` \ segs ->
571 -- Step 3: Fill in the fwd refs.
572 -- The segments are all singletons, but their fwd-ref
573 -- field mentions all the things used by the segment
574 -- that are bound after their use
575 segs_w_fwd_refs = addFwdRefs segs
577 -- Step 4: Group together the segments to make bigger segments
578 -- Invariant: in the result, no segment uses a variable
579 -- bound in a later segment
580 grouped_segs = glomSegments segs_w_fwd_refs
582 -- Step 5: Turn the segments into Stmts
583 -- Use RecStmt when and only when there are fwd refs
584 -- Also gather up the uses from the end towards the
585 -- start, so we can tell the RecStmt which things are
586 -- used 'after' the RecStmt
587 stmts_w_fvs = segsToStmts grouped_segs
591 doc = text "In a mdo-expression"
593 ----------------------------------------------------
594 rn_mdo_stmt :: RdrNameStmt -> RnM Segment
595 -- Assumes all binders are already in scope
596 -- Turns each stmt into a singleton Stmt
598 rn_mdo_stmt (ExprStmt expr _ src_loc)
599 = addSrcLoc src_loc (rnExpr expr) `thenM` \ (expr', fvs) ->
600 returnM (emptyNameSet, fvs, emptyNameSet,
601 [ExprStmt expr' placeHolderType src_loc])
603 rn_mdo_stmt (ResultStmt expr src_loc)
604 = addSrcLoc src_loc (rnExpr expr) `thenM` \ (expr', fvs) ->
605 returnM (emptyNameSet, fvs, emptyNameSet,
606 [ResultStmt expr' src_loc])
608 rn_mdo_stmt (BindStmt pat expr src_loc)
609 = addSrcLoc src_loc $
610 rnExpr expr `thenM` \ (expr', fv_expr) ->
611 rnPat pat `thenM` \ (pat', fv_pat) ->
613 bndrs = mkNameSet (collectPatBinders pat')
614 fvs = fv_expr `plusFV` fv_pat
616 returnM (bndrs, fvs, bndrs `intersectNameSet` fvs,
617 [BindStmt pat' expr' src_loc])
619 rn_mdo_stmt (LetStmt binds)
620 = rnBinds binds `thenM` \ (binds', fv_binds) ->
621 returnM (mkNameSet (collectHsBinders binds'),
622 fv_binds, emptyNameSet, [LetStmt binds'])
624 rn_mdo_stmt stmt@(ParStmt _) -- Syntactically illegal in mdo
625 = pprPanic "rn_mdo_stmt" (ppr stmt)
628 addFwdRefs :: [Segment] -> [Segment]
629 -- So far the segments only have forward refs *within* the Stmt
630 -- (which happens for bind: x <- ...x...)
631 -- This function adds the cross-seg fwd ref info
634 = fst (foldr mk_seg ([], emptyNameSet) pairs)
636 mk_seg (defs, uses, fwds, stmts) (segs, seg_defs)
637 = (new_seg : segs, all_defs)
639 new_seg = (defs, uses, new_fwds, stmts)
640 all_defs = seg_defs `unionNameSets` defs
641 new_fwds = fwds `unionNameSets` (uses `intersectNameSet` seg_defs)
642 -- Add the downstream fwd refs here
644 ----------------------------------------------------
645 -- Glomming the singleton segments of an mdo into
646 -- minimal recursive groups.
648 -- At first I thought this was just strongly connected components, but
649 -- there's an important constraint: the order of the stmts must not change.
652 -- mdo { x <- ...y...
659 -- Here, the first stmt mention 'y', which is bound in the third.
660 -- But that means that the innocent second stmt (p <- z) gets caught
661 -- up in the recursion. And that in turn means that the binding for
662 -- 'z' has to be included... and so on.
664 -- Start at the tail { r <- x }
665 -- Now add the next one { z <- y ; r <- x }
666 -- Now add one more { q <- x ; z <- y ; r <- x }
667 -- Now one more... but this time we have to group a bunch into rec
668 -- { rec { y <- ...x... ; q <- x ; z <- y } ; r <- x }
669 -- Now one more, which we can add on without a rec
671 -- rec { y <- ...x... ; q <- x ; z <- y } ;
673 -- Finally we add the last one; since it mentions y we have to
674 -- glom it togeher with the first two groups
675 -- { rec { x <- ...y...; p <- z ; y <- ...x... ;
676 -- q <- x ; z <- y } ;
679 glomSegments :: [Segment] -> [Segment]
681 glomSegments [seg] = [seg]
682 glomSegments ((defs,uses,fwds,stmts) : segs)
683 -- Actually stmts will always be a singleton
684 = (seg_defs, seg_uses, seg_fwds, seg_stmts) : others
686 segs' = glomSegments segs
687 (extras, others) = grab uses segs'
688 (ds, us, fs, ss) = unzip4 extras
690 seg_defs = plusFVs ds `plusFV` defs
691 seg_uses = plusFVs us `plusFV` uses
692 seg_fwds = plusFVs fs `plusFV` fwds
693 seg_stmts = stmts ++ concat ss
695 grab :: NameSet -- The client
697 -> ([Segment], -- Needed by the 'client'
698 [Segment]) -- Not needed by the client
699 -- The result is simply a split of the input
701 = (reverse yeses, reverse noes)
703 (noes, yeses) = span not_needed (reverse dus)
704 not_needed (defs,_,_,_) = not (intersectsNameSet defs uses)
707 ----------------------------------------------------
708 segsToStmts :: [Segment] -> ([RenamedStmt], FreeVars)
710 segsToStmts [] = ([], emptyFVs)
711 segsToStmts ((defs, uses, fwds, ss) : segs)
712 = (new_stmt : later_stmts, later_uses `plusFV` uses)
714 (later_stmts, later_uses) = segsToStmts segs
715 new_stmt | non_rec = head ss
716 | otherwise = RecStmt rec_names ss
718 non_rec = isSingleton ss && isEmptyNameSet fwds
719 rec_names = nameSetToList (fwds `plusFV` (defs `intersectNameSet` later_uses))
720 -- The names for the fixpoint are
721 -- (a) the ones needed after the RecStmt
722 -- (b) the forward refs within the fixpoint
725 %************************************************************************
727 \subsubsection{Precedence Parsing}
729 %************************************************************************
731 @mkOpAppRn@ deals with operator fixities. The argument expressions
732 are assumed to be already correctly arranged. It needs the fixities
733 recorded in the OpApp nodes, because fixity info applies to the things
734 the programmer actually wrote, so you can't find it out from the Name.
736 Furthermore, the second argument is guaranteed not to be another
737 operator application. Why? Because the parser parses all
738 operator appications left-associatively, EXCEPT negation, which
739 we need to handle specially.
742 mkOpAppRn :: RenamedHsExpr -- Left operand; already rearranged
743 -> RenamedHsExpr -> Fixity -- Operator and fixity
744 -> RenamedHsExpr -- Right operand (not an OpApp, but might
748 ---------------------------
749 -- (e11 `op1` e12) `op2` e2
750 mkOpAppRn e1@(OpApp e11 op1 fix1 e12) op2 fix2 e2
752 = addErr (precParseErr (ppr_op op1,fix1) (ppr_op op2,fix2)) `thenM_`
753 returnM (OpApp e1 op2 fix2 e2)
756 = mkOpAppRn e12 op2 fix2 e2 `thenM` \ new_e ->
757 returnM (OpApp e11 op1 fix1 new_e)
759 (nofix_error, associate_right) = compareFixity fix1 fix2
761 ---------------------------
762 -- (- neg_arg) `op` e2
763 mkOpAppRn e1@(NegApp neg_arg neg_name) op2 fix2 e2
765 = addErr (precParseErr (pp_prefix_minus,negateFixity) (ppr_op op2,fix2)) `thenM_`
766 returnM (OpApp e1 op2 fix2 e2)
769 = mkOpAppRn neg_arg op2 fix2 e2 `thenM` \ new_e ->
770 returnM (NegApp new_e neg_name)
772 (nofix_error, associate_right) = compareFixity negateFixity fix2
774 ---------------------------
776 mkOpAppRn e1 op1 fix1 e2@(NegApp neg_arg _) -- NegApp can occur on the right
777 | not associate_right -- We *want* right association
778 = addErr (precParseErr (ppr_op op1, fix1) (pp_prefix_minus, negateFixity)) `thenM_`
779 returnM (OpApp e1 op1 fix1 e2)
781 (_, associate_right) = compareFixity fix1 negateFixity
783 ---------------------------
785 mkOpAppRn e1 op fix e2 -- Default case, no rearrangment
786 = ASSERT2( right_op_ok fix e2,
787 ppr e1 $$ text "---" $$ ppr op $$ text "---" $$ ppr fix $$ text "---" $$ ppr e2
789 returnM (OpApp e1 op fix e2)
791 -- Parser left-associates everything, but
792 -- derived instances may have correctly-associated things to
793 -- in the right operarand. So we just check that the right operand is OK
794 right_op_ok fix1 (OpApp _ _ fix2 _)
795 = not error_please && associate_right
797 (error_please, associate_right) = compareFixity fix1 fix2
798 right_op_ok fix1 other
801 -- Parser initially makes negation bind more tightly than any other operator
802 mkNegAppRn neg_arg neg_name
805 getModeRn `thenM` \ mode ->
806 ASSERT( not_op_app mode neg_arg )
808 returnM (NegApp neg_arg neg_name)
810 not_op_app SourceMode (OpApp _ _ _ _) = False
811 not_op_app mode other = True
815 checkPrecMatch :: Bool -> Name -> RenamedMatch -> RnM ()
817 checkPrecMatch False fn match
820 checkPrecMatch True op (Match (p1:p2:_) _ _)
821 -- True indicates an infix lhs
822 = getModeRn `thenM` \ mode ->
823 -- See comments with rnExpr (OpApp ...)
824 if isInterfaceMode mode
826 else checkPrec op p1 False `thenM_`
829 checkPrecMatch True op _ = panic "checkPrecMatch"
831 checkPrec op (ConPatIn op1 (InfixCon _ _)) right
832 = lookupFixityRn op `thenM` \ op_fix@(Fixity op_prec op_dir) ->
833 lookupFixityRn op1 `thenM` \ op1_fix@(Fixity op1_prec op1_dir) ->
835 inf_ok = op1_prec > op_prec ||
836 (op1_prec == op_prec &&
837 (op1_dir == InfixR && op_dir == InfixR && right ||
838 op1_dir == InfixL && op_dir == InfixL && not right))
840 info = (ppr_op op, op_fix)
841 info1 = (ppr_op op1, op1_fix)
842 (infol, infor) = if right then (info, info1) else (info1, info)
844 checkErr inf_ok (precParseErr infol infor)
846 checkPrec op pat right
849 -- Check precedence of (arg op) or (op arg) respectively
850 -- If arg is itself an operator application, then either
851 -- (a) its precedence must be higher than that of op
852 -- (b) its precedency & associativity must be the same as that of op
853 checkSectionPrec direction section op arg
855 OpApp _ op fix _ -> go_for_it (ppr_op op) fix
856 NegApp _ _ -> go_for_it pp_prefix_minus negateFixity
860 go_for_it pp_arg_op arg_fix@(Fixity arg_prec assoc)
861 = lookupFixityRn op_name `thenM` \ op_fix@(Fixity op_prec _) ->
862 checkErr (op_prec < arg_prec
863 || op_prec == arg_prec && direction == assoc)
864 (sectionPrecErr (ppr_op op_name, op_fix)
865 (pp_arg_op, arg_fix) section)
869 %************************************************************************
871 \subsubsection{Assertion utils}
873 %************************************************************************
876 mkAssertErrorExpr :: RnM (RenamedHsExpr, FreeVars)
877 -- Return an expression for (assertError "Foo.hs:27")
879 = getSrcLocM `thenM` \ sloc ->
881 expr = HsApp (HsVar assertErrorName) (HsLit msg)
882 msg = HsStringPrim (mkFastString (stringToUtf8 (showSDoc (ppr sloc))))
884 returnM (expr, unitFV assertErrorName)
887 %************************************************************************
889 \subsubsection{Errors}
891 %************************************************************************
894 ppr_op op = quotes (ppr op) -- Here, op can be a Name or a (Var n), where n is a Name
895 pp_prefix_minus = ptext SLIT("prefix `-'")
899 SLIT("accepting non-standard pattern guards (-fglasgow-exts to suppress this message)")
903 = sep [ptext SLIT("Pattern syntax in expression context:"),
906 doStmtListErr do_or_lc e
907 = sep [quotes (text binder_name) <+> ptext SLIT("statements must end in expression:"),
910 binder_name = case do_or_lc of
915 = ptext SLIT("Template Haskell") <+> text what <+>
916 ptext SLIT("illegal in a stage-1 compiler")
920 = sep [quotes (ptext SLIT("with")),
921 ptext SLIT("is deprecated, use"),
922 quotes (ptext SLIT("let")),
923 ptext SLIT("instead")]