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 loopAName, choiceAName, appAName, arrAName, composeAName, firstAName,
42 splitName, fstName, sndName, ioDataConName,
43 replicatePName, mapPName, filterPName,
44 crossPName, zipPName, toPName,
45 enumFromToPName, enumFromThenToPName, assertErrorName,
46 negateName, monadNames, mfixName )
47 import Name ( Name, nameOccName )
49 import UnicodeUtil ( stringToUtf8 )
50 import UniqFM ( isNullUFM )
51 import UniqSet ( emptyUniqSet )
52 import Util ( isSingleton, mapAndUnzip )
53 import List ( intersectBy, unzip4 )
54 import ListSetOps ( removeDups )
56 import SrcLoc ( noSrcLoc )
61 ************************************************************************
65 ************************************************************************
68 rnMatch :: HsMatchContext Name -> RdrNameMatch -> RnM (RenamedMatch, FreeVars)
70 rnMatch ctxt match@(Match pats maybe_rhs_sig grhss)
71 = addSrcLoc (getMatchLoc match) $
73 -- Deal with the rhs type signature
74 bindPatSigTyVarsFV rhs_sig_tys $
75 doptM Opt_GlasgowExts `thenM` \ opt_GlasgowExts ->
76 (case maybe_rhs_sig of
77 Nothing -> returnM (Nothing, emptyFVs)
78 Just ty | opt_GlasgowExts -> rnHsTypeFVs doc_sig ty `thenM` \ (ty', ty_fvs) ->
79 returnM (Just ty', ty_fvs)
80 | otherwise -> addErr (patSigErr ty) `thenM_`
81 returnM (Nothing, emptyFVs)
82 ) `thenM` \ (maybe_rhs_sig', ty_fvs) ->
85 rnPatsAndThen ctxt pats $ \ pats' ->
86 rnGRHSs ctxt grhss `thenM` \ (grhss', grhss_fvs) ->
88 returnM (Match pats' maybe_rhs_sig' grhss', grhss_fvs `plusFV` ty_fvs)
89 -- The bindPatSigTyVarsFV and rnPatsAndThen will remove the bound FVs
91 rhs_sig_tys = case maybe_rhs_sig of
94 doc_sig = text "In a result type-signature"
98 %************************************************************************
100 \subsubsection{Guarded right-hand sides (GRHSs)}
102 %************************************************************************
105 rnGRHSs :: HsMatchContext Name -> RdrNameGRHSs -> RnM (RenamedGRHSs, FreeVars)
107 rnGRHSs ctxt (GRHSs grhss binds _)
108 = rnBindsAndThen binds $ \ binds' ->
109 mapFvRn (rnGRHS ctxt) grhss `thenM` \ (grhss', fvGRHSs) ->
110 returnM (GRHSs grhss' binds' placeHolderType, fvGRHSs)
112 rnGRHS ctxt (GRHS guarded locn)
114 doptM Opt_GlasgowExts `thenM` \ opt_GlasgowExts ->
115 checkM (opt_GlasgowExts || is_standard_guard guarded)
116 (addWarn (nonStdGuardErr guarded)) `thenM_`
118 rnStmts (PatGuard ctxt) guarded `thenM` \ (guarded', fvs) ->
119 returnM (GRHS guarded' locn, fvs)
121 -- Standard Haskell 1.4 guards are just a single boolean
122 -- expression, rather than a list of qualifiers as in the
124 is_standard_guard [ResultStmt _ _] = True
125 is_standard_guard [ExprStmt _ _ _, ResultStmt _ _] = True
126 is_standard_guard other = False
129 %************************************************************************
131 \subsubsection{Expressions}
133 %************************************************************************
136 rnExprs :: [RdrNameHsExpr] -> RnM ([RenamedHsExpr], FreeVars)
137 rnExprs ls = rnExprs' ls emptyUniqSet
139 rnExprs' [] acc = returnM ([], acc)
140 rnExprs' (expr:exprs) acc
141 = rnExpr expr `thenM` \ (expr', fvExpr) ->
143 -- Now we do a "seq" on the free vars because typically it's small
144 -- or empty, especially in very long lists of constants
146 acc' = acc `plusFV` fvExpr
148 (grubby_seqNameSet acc' rnExprs') exprs acc' `thenM` \ (exprs', fvExprs) ->
149 returnM (expr':exprs', fvExprs)
151 -- Grubby little function to do "seq" on namesets; replace by proper seq when GHC can do seq
152 grubby_seqNameSet ns result | isNullUFM ns = result
156 Variables. We look up the variable and return the resulting name.
159 rnExpr :: RdrNameHsExpr -> RnM (RenamedHsExpr, FreeVars)
162 = lookupOccRn v `thenM` \ name ->
163 if name `hasKey` assertIdKey && not opt_IgnoreAsserts then
164 -- We expand it to (GHC.Err.assertError location_string)
165 mkAssertErrorExpr `thenM` \ (e, fvs) ->
166 returnM (e, fvs `addOneFV` name)
167 -- Keep 'assert' as a free var, to ensure it's not reported as unused!
169 -- The normal case. Even if the Id was 'assert', if we are
170 -- ignoring assertions we leave it as GHC.Base.assert;
171 -- this function just ignores its first arg.
172 returnM (HsVar name, unitFV name)
175 = newIPName v `thenM` \ name ->
178 Linear _ -> mkFVs [splitName, fstName, sndName]
179 Dupable _ -> emptyFVs
181 returnM (HsIPVar name, fvs)
184 = litFVs lit `thenM` \ fvs ->
185 returnM (HsLit lit, fvs)
187 rnExpr (HsOverLit lit)
188 = rnOverLit lit `thenM` \ (lit', fvs) ->
189 returnM (HsOverLit lit', fvs)
192 = rnMatch LambdaExpr match `thenM` \ (match', fvMatch) ->
193 returnM (HsLam match', fvMatch)
195 rnExpr (HsApp fun arg)
196 = rnExpr fun `thenM` \ (fun',fvFun) ->
197 rnExpr arg `thenM` \ (arg',fvArg) ->
198 returnM (HsApp fun' arg', fvFun `plusFV` fvArg)
200 rnExpr (OpApp e1 op _ e2)
201 = rnExpr e1 `thenM` \ (e1', fv_e1) ->
202 rnExpr e2 `thenM` \ (e2', fv_e2) ->
203 rnExpr op `thenM` \ (op'@(HsVar op_name), fv_op) ->
206 -- When renaming code synthesised from "deriving" declarations
207 -- we're in Interface mode, and we should ignore fixity; assume
208 -- that the deriving code generator got the association correct
209 -- Don't even look up the fixity when in interface mode
210 getModeRn `thenM` \ mode ->
211 (if isInterfaceMode mode
212 then returnM (OpApp e1' op' defaultFixity e2')
213 else lookupFixityRn op_name `thenM` \ fixity ->
214 mkOpAppRn e1' op' fixity e2'
215 ) `thenM` \ final_e ->
218 fv_e1 `plusFV` fv_op `plusFV` fv_e2)
221 = rnExpr e `thenM` \ (e', fv_e) ->
222 lookupSyntaxName negateName `thenM` \ (neg_name, fv_neg) ->
223 mkNegAppRn e' neg_name `thenM` \ final_e ->
224 returnM (final_e, fv_e `plusFV` fv_neg)
227 = rnExpr e `thenM` \ (e', fvs_e) ->
228 returnM (HsPar e', fvs_e)
230 -- Template Haskell extensions
231 -- Don't ifdef-GHCI them because we want to fail gracefully
232 -- (not with an rnExpr crash) in a stage-1 compiler.
233 rnExpr e@(HsBracket br_body loc)
235 checkTH e "bracket" `thenM_`
236 rnBracket br_body `thenM` \ (body', fvs_e) ->
237 returnM (HsBracket body' loc, fvs_e `plusFV` thProxyName)
239 rnExpr e@(HsSplice n splice loc)
241 checkTH e "splice" `thenM_`
242 newLocalsRn [(n,loc)] `thenM` \ [n'] ->
243 rnExpr splice `thenM` \ (splice', fvs_e) ->
244 returnM (HsSplice n' splice' loc, fvs_e `plusFV` thProxyName)
246 rnExpr e@(HsReify (Reify flavour name))
247 = checkTH e "reify" `thenM_`
248 lookupGlobalOccRn name `thenM` \ name' ->
249 -- For now, we can only reify top-level things
250 returnM (HsReify (Reify flavour name'), unitFV name' `plusFV` thProxyName)
252 rnExpr section@(SectionL expr op)
253 = rnExpr expr `thenM` \ (expr', fvs_expr) ->
254 rnExpr op `thenM` \ (op', fvs_op) ->
255 checkSectionPrec InfixL section op' expr' `thenM_`
256 returnM (SectionL expr' op', fvs_op `plusFV` fvs_expr)
258 rnExpr section@(SectionR op expr)
259 = rnExpr op `thenM` \ (op', fvs_op) ->
260 rnExpr expr `thenM` \ (expr', fvs_expr) ->
261 checkSectionPrec InfixR section op' expr' `thenM_`
262 returnM (SectionR op' expr', fvs_op `plusFV` fvs_expr)
264 rnExpr (HsCCall fun args may_gc is_casm _)
265 -- Check out the comment on RnIfaces.getNonWiredDataDecl about ccalls
266 = rnExprs args `thenM` \ (args', fvs_args) ->
267 returnM (HsCCall fun args' may_gc is_casm placeHolderType,
268 fvs_args `plusFV` mkFVs [cCallableClassName,
269 cReturnableClassName,
272 rnExpr (HsCoreAnn ann expr)
273 = rnExpr expr `thenM` \ (expr', fvs_expr) ->
274 returnM (HsCoreAnn ann expr', fvs_expr)
276 rnExpr (HsSCC lbl expr)
277 = rnExpr expr `thenM` \ (expr', fvs_expr) ->
278 returnM (HsSCC lbl expr', fvs_expr)
280 rnExpr (HsCase expr ms src_loc)
281 = addSrcLoc src_loc $
282 rnExpr expr `thenM` \ (new_expr, e_fvs) ->
283 mapFvRn (rnMatch CaseAlt) ms `thenM` \ (new_ms, ms_fvs) ->
284 returnM (HsCase new_expr new_ms src_loc, e_fvs `plusFV` ms_fvs)
286 rnExpr (HsLet binds expr)
287 = rnBindsAndThen binds $ \ binds' ->
288 rnExpr expr `thenM` \ (expr',fvExpr) ->
289 returnM (HsLet binds' expr', fvExpr)
291 rnExpr e@(HsDo do_or_lc stmts _ _ src_loc)
292 = addSrcLoc src_loc $
293 rnStmts do_or_lc stmts `thenM` \ (stmts', fvs) ->
295 -- Check the statement list ends in an expression
296 case last stmts' of {
297 ResultStmt _ _ -> returnM () ;
298 _ -> addErr (doStmtListErr do_or_lc e)
301 -- Generate the rebindable syntax for the monad
302 lookupSyntaxNames syntax_names `thenM` \ (syntax_names', monad_fvs) ->
304 returnM (HsDo do_or_lc stmts' syntax_names' placeHolderType src_loc,
305 fvs `plusFV` implicit_fvs do_or_lc `plusFV` 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 = case do_or_lc of
314 MDoExpr -> monadNames ++ [mfixName]
317 rnExpr (ExplicitList _ exps)
318 = rnExprs exps `thenM` \ (exps', fvs) ->
319 returnM (ExplicitList placeHolderType exps', fvs `addOneFV` listTyCon_name)
321 rnExpr (ExplicitPArr _ exps)
322 = rnExprs exps `thenM` \ (exps', fvs) ->
323 returnM (ExplicitPArr placeHolderType exps',
324 fvs `addOneFV` toPName `addOneFV` parrTyCon_name)
326 rnExpr e@(ExplicitTuple exps boxity)
327 = checkTupSize tup_size `thenM_`
328 rnExprs exps `thenM` \ (exps', fvs) ->
329 returnM (ExplicitTuple exps' boxity, fvs `addOneFV` tycon_name)
331 tup_size = length exps
332 tycon_name = tupleTyCon_name boxity tup_size
334 rnExpr (RecordCon con_id rbinds)
335 = lookupOccRn con_id `thenM` \ conname ->
336 rnRbinds "construction" rbinds `thenM` \ (rbinds', fvRbinds) ->
337 returnM (RecordCon conname rbinds', fvRbinds `addOneFV` conname)
339 rnExpr (RecordUpd expr rbinds)
340 = rnExpr expr `thenM` \ (expr', fvExpr) ->
341 rnRbinds "update" rbinds `thenM` \ (rbinds', fvRbinds) ->
342 returnM (RecordUpd expr' rbinds', fvExpr `plusFV` fvRbinds)
344 rnExpr (ExprWithTySig expr pty)
345 = rnExpr expr `thenM` \ (expr', fvExpr) ->
346 rnHsTypeFVs doc pty `thenM` \ (pty', fvTy) ->
347 returnM (ExprWithTySig expr' pty', fvExpr `plusFV` fvTy)
349 doc = text "In an expression type signature"
351 rnExpr (HsIf p b1 b2 src_loc)
352 = addSrcLoc src_loc $
353 rnExpr p `thenM` \ (p', fvP) ->
354 rnExpr b1 `thenM` \ (b1', fvB1) ->
355 rnExpr b2 `thenM` \ (b2', fvB2) ->
356 returnM (HsIf p' b1' b2' src_loc, plusFVs [fvP, fvB1, fvB2])
359 = rnHsTypeFVs doc a `thenM` \ (t, fvT) ->
360 returnM (HsType t, fvT)
362 doc = text "In a type argument"
364 rnExpr (ArithSeqIn seq)
365 = rnArithSeq seq `thenM` \ (new_seq, fvs) ->
366 returnM (ArithSeqIn new_seq, fvs `addOneFV` enumClassName)
368 rnExpr (PArrSeqIn seq)
369 = rnArithSeq seq `thenM` \ (new_seq, fvs) ->
370 returnM (PArrSeqIn new_seq,
371 fvs `plusFV` mkFVs [enumFromToPName, enumFromThenToPName])
374 These three are pattern syntax appearing in expressions.
375 Since all the symbols are reservedops we can simply reject them.
376 We return a (bogus) EWildPat in each case.
379 rnExpr e@EWildPat = addErr (patSynErr e) `thenM_`
380 returnM (EWildPat, emptyFVs)
382 rnExpr e@(EAsPat _ _) = addErr (patSynErr e) `thenM_`
383 returnM (EWildPat, emptyFVs)
385 rnExpr e@(ELazyPat _) = addErr (patSynErr e) `thenM_`
386 returnM (EWildPat, emptyFVs)
389 %************************************************************************
393 %************************************************************************
396 rnExpr (HsProc pat body src_loc)
397 = addSrcLoc src_loc $
398 rnPatsAndThen ProcExpr [pat] $ \ [pat'] ->
399 rnCmdTop body `thenM` \ (body',fvBody) ->
400 returnM (HsProc pat' body' src_loc, fvBody)
402 rnExpr (HsArrApp arrow arg _ ho rtl srcloc)
403 = rnExpr arrow `thenM` \ (arrow',fvArrow) ->
404 rnExpr arg `thenM` \ (arg',fvArg) ->
405 returnM (HsArrApp arrow' arg' placeHolderType ho rtl srcloc,
406 fvArrow `plusFV` fvArg)
409 rnExpr (HsArrForm op (Just _) [arg1, arg2] srcloc)
410 = rnExpr op `thenM` \ (op'@(HsVar op_name),fv_op) ->
411 rnCmdTop arg1 `thenM` \ (arg1',fv_arg1) ->
412 rnCmdTop arg2 `thenM` \ (arg2',fv_arg2) ->
416 lookupFixityRn op_name `thenM` \ fixity ->
417 mkOpFormRn arg1' op' fixity arg2' `thenM` \ final_e ->
420 fv_arg1 `plusFV` fv_op `plusFV` fv_arg2)
422 rnExpr (HsArrForm op fixity cmds srcloc)
423 = rnExpr op `thenM` \ (op',fvOp) ->
424 rnCmdArgs cmds `thenM` \ (cmds',fvCmds) ->
425 returnM (HsArrForm op' fixity cmds' srcloc,
426 fvOp `plusFV` fvCmds)
428 ---------------------------
429 -- Deal with fixity (cf mkOpAppRn for the method)
431 mkOpFormRn :: RenamedHsCmdTop -- Left operand; already rearranged
432 -> RenamedHsExpr -> Fixity -- Operator and fixity
433 -> RenamedHsCmdTop -- Right operand (not an infix)
436 ---------------------------
437 -- (e11 `op1` e12) `op2` e2
438 mkOpFormRn a1@(HsCmdTop (HsArrForm op1 (Just fix1) [a11,a12] loc1) _ _ _) op2 fix2 a2
440 = addErr (precParseErr (ppr_op op1,fix1) (ppr_op op2,fix2)) `thenM_`
441 returnM (HsArrForm op2 (Just fix2) [a1, a2] loc1)
444 = mkOpFormRn a12 op2 fix2 a2 `thenM` \ new_c ->
445 returnM (HsArrForm op1 (Just fix1)
446 [a11, HsCmdTop new_c [] placeHolderType []] loc1)
448 (nofix_error, associate_right) = compareFixity fix1 fix2
450 ---------------------------
452 mkOpFormRn arg1 op fix arg2 -- Default case, no rearrangment
453 = returnM (HsArrForm op (Just fix) [arg1, arg2] noSrcLoc)
458 %************************************************************************
462 %************************************************************************
465 rnCmdArgs [] = returnM ([], emptyFVs)
467 = rnCmdTop arg `thenM` \ (arg',fvArg) ->
468 rnCmdArgs args `thenM` \ (args',fvArgs) ->
469 returnM (arg':args', fvArg `plusFV` fvArgs)
471 rnCmdTop (HsCmdTop cmd _ _ _)
472 = rnExpr (convertOpFormsCmd cmd) `thenM` \ (cmd', fvCmd) ->
474 cmd_names = [arrAName, composeAName, firstAName] ++
475 nameSetToList (methodNamesCmd cmd')
477 -- Generate the rebindable syntax for the monad
478 lookupSyntaxNames cmd_names `thenM` \ (cmd_names', cmd_fvs) ->
480 returnM (HsCmdTop cmd' [] placeHolderType cmd_names',
481 fvCmd `plusFV` cmd_fvs)
483 ---------------------------------------------------
484 -- convert OpApp's in a command context to HsArrForm's
486 convertOpFormsCmd :: HsCmd id -> HsCmd id
488 convertOpFormsCmd (HsApp c e) = HsApp (convertOpFormsCmd c) e
490 convertOpFormsCmd (HsLam match) = HsLam (convertOpFormsMatch match)
492 convertOpFormsCmd (OpApp c1 op fixity c2)
494 arg1 = HsCmdTop (convertOpFormsCmd c1) [] placeHolderType []
495 arg2 = HsCmdTop (convertOpFormsCmd c2) [] placeHolderType []
497 HsArrForm op (Just fixity) [arg1, arg2] noSrcLoc
499 convertOpFormsCmd (HsPar c) = HsPar (convertOpFormsCmd c)
501 convertOpFormsCmd (HsCase exp matches locn)
502 = HsCase exp (map convertOpFormsMatch matches) locn
504 convertOpFormsCmd (HsIf exp c1 c2 locn)
505 = HsIf exp (convertOpFormsCmd c1) (convertOpFormsCmd c2) locn
507 convertOpFormsCmd (HsLet binds cmd)
508 = HsLet binds (convertOpFormsCmd cmd)
510 convertOpFormsCmd (HsDo ctxt stmts ids ty locn)
511 = HsDo ctxt (map convertOpFormsStmt stmts) ids ty locn
513 -- Anything else is unchanged. This includes HsArrForm (already done),
514 -- things with no sub-commands, and illegal commands (which will be
515 -- caught by the type checker)
516 convertOpFormsCmd c = c
518 convertOpFormsStmt (BindStmt pat cmd locn)
519 = BindStmt pat (convertOpFormsCmd cmd) locn
520 convertOpFormsStmt (ResultStmt cmd locn)
521 = ResultStmt (convertOpFormsCmd cmd) locn
522 convertOpFormsStmt (ExprStmt cmd ty locn)
523 = ExprStmt (convertOpFormsCmd cmd) ty locn
524 convertOpFormsStmt (RecStmt stmts lvs rvs es)
525 = RecStmt (map convertOpFormsStmt stmts) lvs rvs es
526 convertOpFormsStmt stmt = stmt
528 convertOpFormsMatch (Match pat mty grhss)
529 = Match pat mty (convertOpFormsGRHSs grhss)
531 convertOpFormsGRHSs (GRHSs grhss binds ty)
532 = GRHSs (map convertOpFormsGRHS grhss) binds ty
534 convertOpFormsGRHS (GRHS stmts locn)
536 (ResultStmt cmd locn') = last stmts
538 GRHS (init stmts ++ [ResultStmt (convertOpFormsCmd cmd) locn']) locn
540 ---------------------------------------------------
541 type CmdNeeds = FreeVars -- Only inhabitants are
542 -- appAName, choiceAName, loopAName
544 -- find what methods the Cmd needs (loop, choice, apply)
545 methodNamesCmd :: HsCmd Name -> CmdNeeds
547 methodNamesCmd cmd@(HsArrApp _arrow _arg _ HsFirstOrderApp _rtl _srcloc)
549 methodNamesCmd cmd@(HsArrApp _arrow _arg _ HsHigherOrderApp _rtl _srcloc)
551 methodNamesCmd cmd@(HsArrForm {}) = emptyFVs
553 methodNamesCmd (HsPar c) = methodNamesCmd c
555 methodNamesCmd (HsIf p c1 c2 loc)
556 = methodNamesCmd c1 `plusFV` methodNamesCmd c2 `addOneFV` choiceAName
558 methodNamesCmd (HsLet b c) = methodNamesCmd c
560 methodNamesCmd (HsDo sc stmts rbs ty loc) = methodNamesStmts stmts
562 methodNamesCmd (HsApp c e) = methodNamesCmd c
564 methodNamesCmd (HsLam match) = methodNamesMatch match
566 methodNamesCmd (HsCase scrut matches loc)
567 = plusFVs (map methodNamesMatch matches) `addOneFV` choiceAName
569 methodNamesCmd other = emptyFVs
570 -- Other forms can't occur in commands, but it's not convenient
571 -- to error here so we just do what's convenient.
572 -- The type checker will complain later
574 ---------------------------------------------------
575 methodNamesMatch (Match pats sig_ty grhss) = methodNamesGRHSs grhss
577 -------------------------------------------------
578 methodNamesGRHSs (GRHSs grhss binds ty) = plusFVs (map methodNamesGRHS grhss)
580 -------------------------------------------------
581 methodNamesGRHS (GRHS stmts loc) = methodNamesStmt (last stmts)
583 ---------------------------------------------------
584 methodNamesStmts stmts = plusFVs (map methodNamesStmt stmts)
586 ---------------------------------------------------
587 methodNamesStmt (ResultStmt cmd loc) = methodNamesCmd cmd
588 methodNamesStmt (ExprStmt cmd ty loc) = methodNamesCmd cmd
589 methodNamesStmt (BindStmt pat cmd loc) = methodNamesCmd cmd
590 methodNamesStmt (RecStmt stmts lvs rvs es)
591 = methodNamesStmts stmts `addOneFV` loopAName
592 methodNamesStmt (LetStmt b) = emptyFVs
593 methodNamesStmt (ParStmt ss) = emptyFVs
594 -- ParStmt can't occur in commands, but it's not convenient to error
595 -- here so we just do what's convenient
599 %************************************************************************
603 %************************************************************************
606 rnArithSeq (From expr)
607 = rnExpr expr `thenM` \ (expr', fvExpr) ->
608 returnM (From expr', fvExpr)
610 rnArithSeq (FromThen expr1 expr2)
611 = rnExpr expr1 `thenM` \ (expr1', fvExpr1) ->
612 rnExpr expr2 `thenM` \ (expr2', fvExpr2) ->
613 returnM (FromThen expr1' expr2', fvExpr1 `plusFV` fvExpr2)
615 rnArithSeq (FromTo expr1 expr2)
616 = rnExpr expr1 `thenM` \ (expr1', fvExpr1) ->
617 rnExpr expr2 `thenM` \ (expr2', fvExpr2) ->
618 returnM (FromTo expr1' expr2', fvExpr1 `plusFV` fvExpr2)
620 rnArithSeq (FromThenTo expr1 expr2 expr3)
621 = rnExpr expr1 `thenM` \ (expr1', fvExpr1) ->
622 rnExpr expr2 `thenM` \ (expr2', fvExpr2) ->
623 rnExpr expr3 `thenM` \ (expr3', fvExpr3) ->
624 returnM (FromThenTo expr1' expr2' expr3',
625 plusFVs [fvExpr1, fvExpr2, fvExpr3])
629 %************************************************************************
631 \subsubsection{@Rbinds@s and @Rpats@s: in record expressions}
633 %************************************************************************
637 = mappM_ field_dup_err dup_fields `thenM_`
638 mapFvRn rn_rbind rbinds `thenM` \ (rbinds', fvRbind) ->
639 returnM (rbinds', fvRbind)
641 (_, dup_fields) = removeDups compare [ f | (f,_) <- rbinds ]
643 field_dup_err dups = addErr (dupFieldErr str dups)
645 rn_rbind (field, expr)
646 = lookupGlobalOccRn field `thenM` \ fieldname ->
647 rnExpr expr `thenM` \ (expr', fvExpr) ->
648 returnM ((fieldname, expr'), fvExpr `addOneFV` fieldname)
651 %************************************************************************
653 Template Haskell brackets
655 %************************************************************************
658 rnBracket (ExpBr e) = rnExpr e `thenM` \ (e', fvs) ->
659 returnM (ExpBr e', fvs)
660 rnBracket (PatBr p) = rnPat p `thenM` \ (p', fvs) ->
661 returnM (PatBr p', fvs)
662 rnBracket (TypBr t) = rnHsTypeFVs doc t `thenM` \ (t', fvs) ->
663 returnM (TypBr t', fvs)
665 doc = ptext SLIT("In a Template-Haskell quoted type")
666 rnBracket (DecBr group)
667 = importsFromLocalDecls group `thenM` \ (rdr_env, avails) ->
668 -- Discard avails (not useful here)
670 updGblEnv (\gbl -> gbl { tcg_rdr_env = rdr_env `plusGlobalRdrEnv` tcg_rdr_env gbl }) $
672 rnSrcDecls group `thenM` \ (tcg_env, group', dus) ->
673 -- Discard the tcg_env; it contains only extra info about fixity
675 returnM (DecBr group', duUses dus `minusNameSet` duDefs dus)
678 %************************************************************************
680 \subsubsection{@Stmt@s: in @do@ expressions}
682 %************************************************************************
685 rnStmts :: HsStmtContext Name -> [RdrNameStmt] -> RnM ([RenamedStmt], FreeVars)
687 rnStmts MDoExpr stmts = rnMDoStmts stmts
688 rnStmts ctxt stmts = rnNormalStmts ctxt stmts
690 rnNormalStmts :: HsStmtContext Name -> [RdrNameStmt] -> RnM ([RenamedStmt], FreeVars)
691 -- Used for cases *other* than recursive mdo
692 -- Implements nested scopes
694 rnNormalStmts ctxt [] = returnM ([], emptyFVs)
695 -- Happens at the end of the sub-lists of a ParStmts
697 rnNormalStmts ctxt (ExprStmt expr _ src_loc : stmts)
698 = addSrcLoc src_loc $
699 rnExpr expr `thenM` \ (expr', fv_expr) ->
700 rnNormalStmts ctxt stmts `thenM` \ (stmts', fvs) ->
701 returnM (ExprStmt expr' placeHolderType src_loc : stmts',
702 fv_expr `plusFV` fvs)
704 rnNormalStmts ctxt [ResultStmt expr src_loc]
705 = addSrcLoc src_loc $
706 rnExpr expr `thenM` \ (expr', fv_expr) ->
707 returnM ([ResultStmt expr' src_loc], fv_expr)
709 rnNormalStmts ctxt (BindStmt pat expr src_loc : stmts)
710 = addSrcLoc src_loc $
711 rnExpr expr `thenM` \ (expr', fv_expr) ->
712 -- The binders do not scope over the expression
714 rnPatsAndThen (StmtCtxt ctxt) [pat] $ \ [pat'] ->
715 rnNormalStmts ctxt stmts `thenM` \ (stmts', fvs) ->
716 returnM (BindStmt pat' expr' src_loc : stmts',
717 fv_expr `plusFV` fvs) -- fv_expr shouldn't really be filtered by
718 -- the rnPatsAndThen, but it does not matter
720 rnNormalStmts ctxt (LetStmt binds : stmts)
721 = checkErr (ok ctxt binds) (badIpBinds binds) `thenM_`
722 rnBindsAndThen binds ( \ binds' ->
723 rnNormalStmts ctxt stmts `thenM` \ (stmts', fvs) ->
724 returnM (LetStmt binds' : stmts', fvs))
726 -- We do not allow implicit-parameter bindings in a parallel
727 -- list comprehension. I'm not sure what it might mean.
728 ok (ParStmtCtxt _) (IPBinds _ _) = False
731 rnNormalStmts ctxt (ParStmt stmtss : stmts)
732 = doptM Opt_GlasgowExts `thenM` \ opt_GlasgowExts ->
733 checkM opt_GlasgowExts parStmtErr `thenM_`
734 mapFvRn rn_branch stmtss `thenM` \ (stmtss', fv_stmtss) ->
736 bndrss :: [[Name]] -- NB: Name, not RdrName
737 bndrss = map collectStmtsBinders stmtss'
738 (bndrs, dups) = removeDups cmpByOcc (concat bndrss)
740 mappM dupErr dups `thenM` \ _ ->
741 bindLocalNamesFV bndrs $
742 -- Note: binders are returned in scope order, so one may
743 -- shadow the next; e.g. x <- xs; x <- ys
744 rnNormalStmts ctxt stmts `thenM` \ (stmts', fvs) ->
746 -- Cut down the exported binders to just the ones neede in the body
748 used_bndrs_s = map (filter (`elemNameSet` fvs)) bndrss
750 returnM (ParStmt (stmtss' `zip` used_bndrs_s) : stmts',
751 fv_stmtss `plusFV` fvs)
754 rn_branch (stmts, _) = rnNormalStmts (ParStmtCtxt ctxt) stmts
756 cmpByOcc n1 n2 = nameOccName n1 `compare` nameOccName n2
757 dupErr (v:_) = addErr (ptext SLIT("Duplicate binding in parallel list comprehension for:")
760 rnNormalStmts ctxt (RecStmt rec_stmts _ _ _ : stmts)
761 = bindLocalsRn doc (collectStmtsBinders rec_stmts) $ \ _ ->
762 rn_rec_stmts rec_stmts `thenM` \ segs ->
763 rnNormalStmts ctxt stmts `thenM` \ (stmts', fvs) ->
765 segs_w_fwd_refs = addFwdRefs segs
766 (ds, us, fs, rec_stmts') = unzip4 segs_w_fwd_refs
767 later_vars = nameSetToList (plusFVs ds `intersectNameSet` fvs)
768 fwd_vars = nameSetToList (plusFVs fs)
771 returnM (RecStmt rec_stmts' later_vars fwd_vars [] : stmts', uses `plusFV` fvs)
773 doc = text "In a recursive do statement"
777 %************************************************************************
779 \subsubsection{mdo expressions}
781 %************************************************************************
784 type FwdRefs = NameSet
785 type Segment stmts = (Defs,
786 Uses, -- May include defs
787 FwdRefs, -- A subset of uses that are
788 -- (a) used before they are bound in this segment, or
789 -- (b) used here, and bound in subsequent segments
790 stmts) -- Either Stmt or [Stmt]
793 ----------------------------------------------------
794 rnMDoStmts :: [RdrNameStmt] -> RnM ([RenamedStmt], FreeVars)
796 = -- Step1: bring all the binders of the mdo into scope
797 -- Remember that this also removes the binders from the
798 -- finally-returned free-vars
799 bindLocalsRn doc (collectStmtsBinders stmts) $ \ _ ->
801 -- Step 2: Rename each individual stmt, making a
802 -- singleton segment. At this stage the FwdRefs field
803 -- isn't finished: it's empty for all except a BindStmt
804 -- for which it's the fwd refs within the bind itself
805 -- (This set may not be empty, because we're in a recursive
807 rn_rec_stmts stmts `thenM` \ segs ->
809 -- Step 3: Fill in the fwd refs.
810 -- The segments are all singletons, but their fwd-ref
811 -- field mentions all the things used by the segment
812 -- that are bound after their use
813 segs_w_fwd_refs = addFwdRefs segs
815 -- Step 4: Group together the segments to make bigger segments
816 -- Invariant: in the result, no segment uses a variable
817 -- bound in a later segment
818 grouped_segs = glomSegments segs_w_fwd_refs
820 -- Step 5: Turn the segments into Stmts
821 -- Use RecStmt when and only when there are fwd refs
822 -- Also gather up the uses from the end towards the
823 -- start, so we can tell the RecStmt which things are
824 -- used 'after' the RecStmt
825 stmts_w_fvs = segsToStmts grouped_segs
829 doc = text "In a mdo-expression"
832 ----------------------------------------------------
833 rn_rec_stmt :: RdrNameStmt -> RnM [Segment RenamedStmt]
834 -- Rename a Stmt that is inside a RecStmt (or mdo)
835 -- Assumes all binders are already in scope
836 -- Turns each stmt into a singleton Stmt
838 rn_rec_stmt (ExprStmt expr _ src_loc)
839 = addSrcLoc src_loc (rnExpr expr) `thenM` \ (expr', fvs) ->
840 returnM [(emptyNameSet, fvs, emptyNameSet,
841 ExprStmt expr' placeHolderType src_loc)]
843 rn_rec_stmt (ResultStmt expr src_loc)
844 = addSrcLoc src_loc (rnExpr expr) `thenM` \ (expr', fvs) ->
845 returnM [(emptyNameSet, fvs, emptyNameSet,
846 ResultStmt expr' src_loc)]
848 rn_rec_stmt (BindStmt pat expr src_loc)
849 = addSrcLoc src_loc $
850 rnExpr expr `thenM` \ (expr', fv_expr) ->
851 rnPat pat `thenM` \ (pat', fv_pat) ->
853 bndrs = mkNameSet (collectPatBinders pat')
854 fvs = fv_expr `plusFV` fv_pat
856 returnM [(bndrs, fvs, bndrs `intersectNameSet` fvs,
857 BindStmt pat' expr' src_loc)]
859 rn_rec_stmt (LetStmt binds)
860 = rnBinds binds `thenM` \ (binds', du_binds) ->
861 returnM [(duDefs du_binds, duUses du_binds,
862 emptyNameSet, LetStmt binds')]
864 rn_rec_stmt (RecStmt stmts _ _ _) -- Flatten Rec inside Rec
867 rn_rec_stmt stmt@(ParStmt _) -- Syntactically illegal in mdo
868 = pprPanic "rn_rec_stmt" (ppr stmt)
870 ---------------------------------------------
871 rn_rec_stmts :: [RdrNameStmt] -> RnM [Segment RenamedStmt]
872 rn_rec_stmts stmts = mappM rn_rec_stmt stmts `thenM` \ segs_s ->
873 returnM (concat segs_s)
876 ---------------------------------------------
877 addFwdRefs :: [Segment a] -> [Segment a]
878 -- So far the segments only have forward refs *within* the Stmt
879 -- (which happens for bind: x <- ...x...)
880 -- This function adds the cross-seg fwd ref info
883 = fst (foldr mk_seg ([], emptyNameSet) pairs)
885 mk_seg (defs, uses, fwds, stmts) (segs, later_defs)
886 = (new_seg : segs, all_defs)
888 new_seg = (defs, uses, new_fwds, stmts)
889 all_defs = later_defs `unionNameSets` defs
890 new_fwds = fwds `unionNameSets` (uses `intersectNameSet` later_defs)
891 -- Add the downstream fwd refs here
893 ----------------------------------------------------
894 -- Glomming the singleton segments of an mdo into
895 -- minimal recursive groups.
897 -- At first I thought this was just strongly connected components, but
898 -- there's an important constraint: the order of the stmts must not change.
901 -- mdo { x <- ...y...
908 -- Here, the first stmt mention 'y', which is bound in the third.
909 -- But that means that the innocent second stmt (p <- z) gets caught
910 -- up in the recursion. And that in turn means that the binding for
911 -- 'z' has to be included... and so on.
913 -- Start at the tail { r <- x }
914 -- Now add the next one { z <- y ; r <- x }
915 -- Now add one more { q <- x ; z <- y ; r <- x }
916 -- Now one more... but this time we have to group a bunch into rec
917 -- { rec { y <- ...x... ; q <- x ; z <- y } ; r <- x }
918 -- Now one more, which we can add on without a rec
920 -- rec { y <- ...x... ; q <- x ; z <- y } ;
922 -- Finally we add the last one; since it mentions y we have to
923 -- glom it togeher with the first two groups
924 -- { rec { x <- ...y...; p <- z ; y <- ...x... ;
925 -- q <- x ; z <- y } ;
928 glomSegments :: [Segment RenamedStmt] -> [Segment [RenamedStmt]]
931 glomSegments ((defs,uses,fwds,stmt) : segs)
932 -- Actually stmts will always be a singleton
933 = (seg_defs, seg_uses, seg_fwds, seg_stmts) : others
935 segs' = glomSegments segs
936 (extras, others) = grab uses segs'
937 (ds, us, fs, ss) = unzip4 extras
939 seg_defs = plusFVs ds `plusFV` defs
940 seg_uses = plusFVs us `plusFV` uses
941 seg_fwds = plusFVs fs `plusFV` fwds
942 seg_stmts = stmt : concat ss
944 grab :: NameSet -- The client
946 -> ([Segment a], -- Needed by the 'client'
947 [Segment a]) -- Not needed by the client
948 -- The result is simply a split of the input
950 = (reverse yeses, reverse noes)
952 (noes, yeses) = span not_needed (reverse dus)
953 not_needed (defs,_,_,_) = not (intersectsNameSet defs uses)
956 ----------------------------------------------------
957 segsToStmts :: [Segment [RenamedStmt]] -> ([RenamedStmt], FreeVars)
959 segsToStmts [] = ([], emptyFVs)
960 segsToStmts ((defs, uses, fwds, ss) : segs)
961 = (new_stmt : later_stmts, later_uses `plusFV` uses)
963 (later_stmts, later_uses) = segsToStmts segs
964 new_stmt | non_rec = head ss
965 | otherwise = RecStmt ss (nameSetToList used_later) (nameSetToList fwds) []
967 non_rec = isSingleton ss && isEmptyNameSet fwds
968 used_later = defs `intersectNameSet` later_uses
969 -- The ones needed after the RecStmt
972 %************************************************************************
974 \subsubsection{Precedence Parsing}
976 %************************************************************************
978 @mkOpAppRn@ deals with operator fixities. The argument expressions
979 are assumed to be already correctly arranged. It needs the fixities
980 recorded in the OpApp nodes, because fixity info applies to the things
981 the programmer actually wrote, so you can't find it out from the Name.
983 Furthermore, the second argument is guaranteed not to be another
984 operator application. Why? Because the parser parses all
985 operator appications left-associatively, EXCEPT negation, which
986 we need to handle specially.
989 mkOpAppRn :: RenamedHsExpr -- Left operand; already rearranged
990 -> RenamedHsExpr -> Fixity -- Operator and fixity
991 -> RenamedHsExpr -- Right operand (not an OpApp, but might
995 ---------------------------
996 -- (e11 `op1` e12) `op2` e2
997 mkOpAppRn e1@(OpApp e11 op1 fix1 e12) op2 fix2 e2
999 = addErr (precParseErr (ppr_op op1,fix1) (ppr_op op2,fix2)) `thenM_`
1000 returnM (OpApp e1 op2 fix2 e2)
1003 = mkOpAppRn e12 op2 fix2 e2 `thenM` \ new_e ->
1004 returnM (OpApp e11 op1 fix1 new_e)
1006 (nofix_error, associate_right) = compareFixity fix1 fix2
1008 ---------------------------
1009 -- (- neg_arg) `op` e2
1010 mkOpAppRn e1@(NegApp neg_arg neg_name) op2 fix2 e2
1012 = addErr (precParseErr (pp_prefix_minus,negateFixity) (ppr_op op2,fix2)) `thenM_`
1013 returnM (OpApp e1 op2 fix2 e2)
1016 = mkOpAppRn neg_arg op2 fix2 e2 `thenM` \ new_e ->
1017 returnM (NegApp new_e neg_name)
1019 (nofix_error, associate_right) = compareFixity negateFixity fix2
1021 ---------------------------
1022 -- e1 `op` - neg_arg
1023 mkOpAppRn e1 op1 fix1 e2@(NegApp neg_arg _) -- NegApp can occur on the right
1024 | not associate_right -- We *want* right association
1025 = addErr (precParseErr (ppr_op op1, fix1) (pp_prefix_minus, negateFixity)) `thenM_`
1026 returnM (OpApp e1 op1 fix1 e2)
1028 (_, associate_right) = compareFixity fix1 negateFixity
1030 ---------------------------
1032 mkOpAppRn e1 op fix e2 -- Default case, no rearrangment
1033 = ASSERT2( right_op_ok fix e2,
1034 ppr e1 $$ text "---" $$ ppr op $$ text "---" $$ ppr fix $$ text "---" $$ ppr e2
1036 returnM (OpApp e1 op fix e2)
1038 -- Parser left-associates everything, but
1039 -- derived instances may have correctly-associated things to
1040 -- in the right operarand. So we just check that the right operand is OK
1041 right_op_ok fix1 (OpApp _ _ fix2 _)
1042 = not error_please && associate_right
1044 (error_please, associate_right) = compareFixity fix1 fix2
1045 right_op_ok fix1 other
1048 -- Parser initially makes negation bind more tightly than any other operator
1049 mkNegAppRn neg_arg neg_name
1052 getModeRn `thenM` \ mode ->
1053 ASSERT( not_op_app mode neg_arg )
1055 returnM (NegApp neg_arg neg_name)
1057 not_op_app SourceMode (OpApp _ _ _ _) = False
1058 not_op_app mode other = True
1062 checkPrecMatch :: Bool -> Name -> RenamedMatch -> RnM ()
1064 checkPrecMatch False fn match
1067 checkPrecMatch True op (Match (p1:p2:_) _ _)
1068 -- True indicates an infix lhs
1069 = getModeRn `thenM` \ mode ->
1070 -- See comments with rnExpr (OpApp ...)
1071 if isInterfaceMode mode
1073 else checkPrec op p1 False `thenM_`
1074 checkPrec op p2 True
1076 checkPrecMatch True op _ = panic "checkPrecMatch"
1078 checkPrec op (ConPatIn op1 (InfixCon _ _)) right
1079 = lookupFixityRn op `thenM` \ op_fix@(Fixity op_prec op_dir) ->
1080 lookupFixityRn op1 `thenM` \ op1_fix@(Fixity op1_prec op1_dir) ->
1082 inf_ok = op1_prec > op_prec ||
1083 (op1_prec == op_prec &&
1084 (op1_dir == InfixR && op_dir == InfixR && right ||
1085 op1_dir == InfixL && op_dir == InfixL && not right))
1087 info = (ppr_op op, op_fix)
1088 info1 = (ppr_op op1, op1_fix)
1089 (infol, infor) = if right then (info, info1) else (info1, info)
1091 checkErr inf_ok (precParseErr infol infor)
1093 checkPrec op pat right
1096 -- Check precedence of (arg op) or (op arg) respectively
1097 -- If arg is itself an operator application, then either
1098 -- (a) its precedence must be higher than that of op
1099 -- (b) its precedency & associativity must be the same as that of op
1100 checkSectionPrec direction section op arg
1102 OpApp _ op fix _ -> go_for_it (ppr_op op) fix
1103 NegApp _ _ -> go_for_it pp_prefix_minus negateFixity
1107 go_for_it pp_arg_op arg_fix@(Fixity arg_prec assoc)
1108 = lookupFixityRn op_name `thenM` \ op_fix@(Fixity op_prec _) ->
1109 checkErr (op_prec < arg_prec
1110 || op_prec == arg_prec && direction == assoc)
1111 (sectionPrecErr (ppr_op op_name, op_fix)
1112 (pp_arg_op, arg_fix) section)
1116 %************************************************************************
1118 \subsubsection{Assertion utils}
1120 %************************************************************************
1123 mkAssertErrorExpr :: RnM (RenamedHsExpr, FreeVars)
1124 -- Return an expression for (assertError "Foo.hs:27")
1126 = getSrcLocM `thenM` \ sloc ->
1128 expr = HsApp (HsVar assertErrorName) (HsLit msg)
1129 msg = HsStringPrim (mkFastString (stringToUtf8 (showSDoc (ppr sloc))))
1131 returnM (expr, unitFV assertErrorName)
1134 %************************************************************************
1136 \subsubsection{Errors}
1138 %************************************************************************
1141 ppr_op op = quotes (ppr op) -- Here, op can be a Name or a (Var n), where n is a Name
1142 pp_prefix_minus = ptext SLIT("prefix `-'")
1144 nonStdGuardErr guard
1146 SLIT("accepting non-standard pattern guards (-fglasgow-exts to suppress this message)")
1150 = sep [ptext SLIT("Pattern syntax in expression context:"),
1153 doStmtListErr do_or_lc e
1154 = sep [quotes (text binder_name) <+> ptext SLIT("statements must end in expression:"),
1157 binder_name = case do_or_lc of
1162 checkTH e what = returnM () -- OK
1164 checkTH e what -- Raise an error in a stage-1 compiler
1165 = addErr (vcat [ptext SLIT("Template Haskell") <+> text what <+>
1166 ptext SLIT("illegal in a stage-1 compiler"),
1170 parStmtErr = addErr (ptext SLIT("Illegal parallel list comprehension: use -fglagow-exts"))
1173 = hang (ptext SLIT("Implicit-parameter bindings illegal in a parallel list comprehension:")) 4