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 OccName ( plusOccEnv )
32 import RnNames ( importsFromLocalDecls )
33 import RnTypes ( rnHsTypeFVs, rnPat, litFVs, rnOverLit, rnPatsAndThen,
34 dupFieldErr, precParseErr, sectionPrecErr, patSigErr, checkTupSize )
35 import CmdLineOpts ( DynFlag(..) )
36 import BasicTypes ( Fixity(..), FixityDirection(..), negateFixity, compareFixity )
37 import PrelNames ( hasKey, assertIdKey, assertErrorName,
38 loopAName, choiceAName, appAName, arrAName, composeAName, firstAName,
39 negateName, monadNames, mfixName )
40 import Name ( Name, nameOccName )
42 import UnicodeUtil ( stringToUtf8 )
43 import UniqFM ( isNullUFM )
44 import UniqSet ( emptyUniqSet )
45 import Util ( isSingleton )
46 import List ( unzip4 )
47 import ListSetOps ( removeDups )
49 import SrcLoc ( noSrcLoc )
54 ************************************************************************
58 ************************************************************************
61 rnMatch :: HsMatchContext Name -> RdrNameMatch -> RnM (RenamedMatch, FreeVars)
63 rnMatch ctxt match@(Match pats maybe_rhs_sig grhss)
64 = addSrcLoc (getMatchLoc match) $
66 -- Deal with the rhs type signature
67 bindPatSigTyVarsFV rhs_sig_tys $
68 doptM Opt_GlasgowExts `thenM` \ opt_GlasgowExts ->
69 (case maybe_rhs_sig of
70 Nothing -> returnM (Nothing, emptyFVs)
71 Just ty | opt_GlasgowExts -> rnHsTypeFVs doc_sig ty `thenM` \ (ty', ty_fvs) ->
72 returnM (Just ty', ty_fvs)
73 | otherwise -> addErr (patSigErr ty) `thenM_`
74 returnM (Nothing, emptyFVs)
75 ) `thenM` \ (maybe_rhs_sig', ty_fvs) ->
78 rnPatsAndThen ctxt True pats $ \ pats' ->
79 rnGRHSs ctxt grhss `thenM` \ (grhss', grhss_fvs) ->
81 returnM (Match pats' maybe_rhs_sig' grhss', grhss_fvs `plusFV` ty_fvs)
82 -- The bindPatSigTyVarsFV and rnPatsAndThen will remove the bound FVs
84 rhs_sig_tys = case maybe_rhs_sig of
87 doc_sig = text "In a result type-signature"
91 %************************************************************************
93 \subsubsection{Guarded right-hand sides (GRHSs)}
95 %************************************************************************
98 rnGRHSs :: HsMatchContext Name -> RdrNameGRHSs -> RnM (RenamedGRHSs, FreeVars)
100 rnGRHSs ctxt (GRHSs grhss binds _)
101 = rnBindsAndThen binds $ \ binds' ->
102 mapFvRn (rnGRHS ctxt) grhss `thenM` \ (grhss', fvGRHSs) ->
103 returnM (GRHSs grhss' binds' placeHolderType, fvGRHSs)
105 rnGRHS ctxt (GRHS guarded locn)
107 doptM Opt_GlasgowExts `thenM` \ opt_GlasgowExts ->
108 checkM (opt_GlasgowExts || is_standard_guard guarded)
109 (addWarn (nonStdGuardErr guarded)) `thenM_`
111 rnStmts (PatGuard ctxt) guarded `thenM` \ (guarded', fvs) ->
112 returnM (GRHS guarded' locn, fvs)
114 -- Standard Haskell 1.4 guards are just a single boolean
115 -- expression, rather than a list of qualifiers as in the
117 is_standard_guard [ResultStmt _ _] = True
118 is_standard_guard [ExprStmt _ _ _, ResultStmt _ _] = True
119 is_standard_guard other = False
122 %************************************************************************
124 \subsubsection{Expressions}
126 %************************************************************************
129 rnExprs :: [RdrNameHsExpr] -> RnM ([RenamedHsExpr], FreeVars)
130 rnExprs ls = rnExprs' ls emptyUniqSet
132 rnExprs' [] acc = returnM ([], acc)
133 rnExprs' (expr:exprs) acc
134 = rnExpr expr `thenM` \ (expr', fvExpr) ->
136 -- Now we do a "seq" on the free vars because typically it's small
137 -- or empty, especially in very long lists of constants
139 acc' = acc `plusFV` fvExpr
141 (grubby_seqNameSet acc' rnExprs') exprs acc' `thenM` \ (exprs', fvExprs) ->
142 returnM (expr':exprs', fvExprs)
144 -- Grubby little function to do "seq" on namesets; replace by proper seq when GHC can do seq
145 grubby_seqNameSet ns result | isNullUFM ns = result
149 Variables. We look up the variable and return the resulting name.
152 rnExpr :: RdrNameHsExpr -> RnM (RenamedHsExpr, FreeVars)
155 = lookupOccRn v `thenM` \ name ->
156 doptM Opt_IgnoreAsserts `thenM` \ ignore_asserts ->
157 if name `hasKey` assertIdKey && not ignore_asserts then
158 -- We expand it to (GHC.Err.assertError location_string)
159 mkAssertErrorExpr `thenM` \ (e, fvs) ->
160 returnM (e, fvs `addOneFV` name)
161 -- Keep 'assert' as a free var, to ensure it's not reported as unused!
163 -- The normal case. Even if the Id was 'assert', if we are
164 -- ignoring assertions we leave it as GHC.Base.assert;
165 -- this function just ignores its first arg.
166 returnM (HsVar name, unitFV name)
169 = newIPNameRn v `thenM` \ name ->
170 returnM (HsIPVar name, emptyFVs)
173 = litFVs lit `thenM` \ fvs ->
174 returnM (HsLit lit, fvs)
176 rnExpr (HsOverLit lit)
177 = rnOverLit lit `thenM` \ (lit', fvs) ->
178 returnM (HsOverLit lit', fvs)
181 = rnMatch LambdaExpr match `thenM` \ (match', fvMatch) ->
182 returnM (HsLam match', fvMatch)
184 rnExpr (HsApp fun arg)
185 = rnExpr fun `thenM` \ (fun',fvFun) ->
186 rnExpr arg `thenM` \ (arg',fvArg) ->
187 returnM (HsApp fun' arg', fvFun `plusFV` fvArg)
189 rnExpr (OpApp e1 op _ e2)
190 = rnExpr e1 `thenM` \ (e1', fv_e1) ->
191 rnExpr e2 `thenM` \ (e2', fv_e2) ->
192 rnExpr op `thenM` \ (op'@(HsVar op_name), fv_op) ->
195 -- When renaming code synthesised from "deriving" declarations
196 -- we used to avoid fixity stuff, but we can't easily tell any
197 -- more, so I've removed the test. Adding HsPars in TcGenDeriv
198 -- should prevent bad things happening.
199 lookupFixityRn op_name `thenM` \ fixity ->
200 mkOpAppRn e1' op' fixity e2' `thenM` \ final_e ->
203 fv_e1 `plusFV` fv_op `plusFV` fv_e2)
206 = rnExpr e `thenM` \ (e', fv_e) ->
207 lookupSyntaxName negateName `thenM` \ (neg_name, fv_neg) ->
208 mkNegAppRn e' neg_name `thenM` \ final_e ->
209 returnM (final_e, fv_e `plusFV` fv_neg)
212 = rnExpr e `thenM` \ (e', fvs_e) ->
213 returnM (HsPar e', fvs_e)
215 -- Template Haskell extensions
216 -- Don't ifdef-GHCI them because we want to fail gracefully
217 -- (not with an rnExpr crash) in a stage-1 compiler.
218 rnExpr e@(HsBracket br_body loc)
220 checkTH e "bracket" `thenM_`
221 rnBracket br_body `thenM` \ (body', fvs_e) ->
222 returnM (HsBracket body' loc, fvs_e)
224 rnExpr e@(HsSplice n splice loc)
226 checkTH e "splice" `thenM_`
227 newLocalsRn [(n,loc)] `thenM` \ [n'] ->
228 rnExpr splice `thenM` \ (splice', fvs_e) ->
229 returnM (HsSplice n' splice' loc, fvs_e)
231 rnExpr e@(HsReify (Reify flavour name))
232 = checkTH e "reify" `thenM_`
233 lookupGlobalOccRn name `thenM` \ name' ->
234 -- For now, we can only reify top-level things
235 returnM (HsReify (Reify flavour name'), unitFV name')
237 rnExpr section@(SectionL expr op)
238 = rnExpr expr `thenM` \ (expr', fvs_expr) ->
239 rnExpr op `thenM` \ (op', fvs_op) ->
240 checkSectionPrec InfixL section op' expr' `thenM_`
241 returnM (SectionL expr' op', fvs_op `plusFV` fvs_expr)
243 rnExpr section@(SectionR op expr)
244 = rnExpr op `thenM` \ (op', fvs_op) ->
245 rnExpr expr `thenM` \ (expr', fvs_expr) ->
246 checkSectionPrec InfixR section op' expr' `thenM_`
247 returnM (SectionR op' expr', fvs_op `plusFV` fvs_expr)
249 rnExpr (HsCoreAnn ann expr)
250 = rnExpr expr `thenM` \ (expr', fvs_expr) ->
251 returnM (HsCoreAnn ann expr', fvs_expr)
253 rnExpr (HsSCC lbl expr)
254 = rnExpr expr `thenM` \ (expr', fvs_expr) ->
255 returnM (HsSCC lbl expr', fvs_expr)
257 rnExpr (HsCase expr ms src_loc)
258 = addSrcLoc src_loc $
259 rnExpr expr `thenM` \ (new_expr, e_fvs) ->
260 mapFvRn (rnMatch CaseAlt) ms `thenM` \ (new_ms, ms_fvs) ->
261 returnM (HsCase new_expr new_ms src_loc, e_fvs `plusFV` ms_fvs)
263 rnExpr (HsLet binds expr)
264 = rnBindsAndThen binds $ \ binds' ->
265 rnExpr expr `thenM` \ (expr',fvExpr) ->
266 returnM (HsLet binds' expr', fvExpr)
268 rnExpr e@(HsDo do_or_lc stmts _ _ src_loc)
269 = addSrcLoc src_loc $
270 rnStmts do_or_lc stmts `thenM` \ (stmts', fvs) ->
272 -- Check the statement list ends in an expression
273 case last stmts' of {
274 ResultStmt _ _ -> returnM () ;
275 _ -> addErr (doStmtListErr do_or_lc e)
278 -- Generate the rebindable syntax for the monad
279 lookupSyntaxNames syntax_names `thenM` \ (syntax_names', monad_fvs) ->
281 returnM (HsDo do_or_lc stmts' syntax_names' placeHolderType src_loc,
282 fvs `plusFV` monad_fvs)
284 syntax_names = case do_or_lc of
286 MDoExpr -> monadNames ++ [mfixName]
289 rnExpr (ExplicitList _ exps)
290 = rnExprs exps `thenM` \ (exps', fvs) ->
291 returnM (ExplicitList placeHolderType exps', fvs `addOneFV` listTyCon_name)
293 rnExpr (ExplicitPArr _ exps)
294 = rnExprs exps `thenM` \ (exps', fvs) ->
295 returnM (ExplicitPArr placeHolderType exps', fvs)
297 rnExpr e@(ExplicitTuple exps boxity)
298 = checkTupSize tup_size `thenM_`
299 rnExprs exps `thenM` \ (exps', fvs) ->
300 returnM (ExplicitTuple exps' boxity, fvs `addOneFV` tycon_name)
302 tup_size = length exps
303 tycon_name = tupleTyCon_name boxity tup_size
305 rnExpr (RecordCon con_id rbinds)
306 = lookupOccRn con_id `thenM` \ conname ->
307 rnRbinds "construction" rbinds `thenM` \ (rbinds', fvRbinds) ->
308 returnM (RecordCon conname rbinds', fvRbinds `addOneFV` conname)
310 rnExpr (RecordUpd expr rbinds)
311 = rnExpr expr `thenM` \ (expr', fvExpr) ->
312 rnRbinds "update" rbinds `thenM` \ (rbinds', fvRbinds) ->
313 returnM (RecordUpd expr' rbinds', fvExpr `plusFV` fvRbinds)
315 rnExpr (ExprWithTySig expr pty)
316 = rnExpr expr `thenM` \ (expr', fvExpr) ->
317 rnHsTypeFVs doc pty `thenM` \ (pty', fvTy) ->
318 returnM (ExprWithTySig expr' pty', fvExpr `plusFV` fvTy)
320 doc = text "In an expression type signature"
322 rnExpr (HsIf p b1 b2 src_loc)
323 = addSrcLoc src_loc $
324 rnExpr p `thenM` \ (p', fvP) ->
325 rnExpr b1 `thenM` \ (b1', fvB1) ->
326 rnExpr b2 `thenM` \ (b2', fvB2) ->
327 returnM (HsIf p' b1' b2' src_loc, plusFVs [fvP, fvB1, fvB2])
330 = rnHsTypeFVs doc a `thenM` \ (t, fvT) ->
331 returnM (HsType t, fvT)
333 doc = text "In a type argument"
335 rnExpr (ArithSeqIn seq)
336 = rnArithSeq seq `thenM` \ (new_seq, fvs) ->
337 returnM (ArithSeqIn new_seq, fvs)
339 rnExpr (PArrSeqIn seq)
340 = rnArithSeq seq `thenM` \ (new_seq, fvs) ->
341 returnM (PArrSeqIn new_seq, fvs)
344 These three are pattern syntax appearing in expressions.
345 Since all the symbols are reservedops we can simply reject them.
346 We return a (bogus) EWildPat in each case.
349 rnExpr e@EWildPat = addErr (patSynErr e) `thenM_`
350 returnM (EWildPat, emptyFVs)
352 rnExpr e@(EAsPat _ _) = addErr (patSynErr e) `thenM_`
353 returnM (EWildPat, emptyFVs)
355 rnExpr e@(ELazyPat _) = addErr (patSynErr e) `thenM_`
356 returnM (EWildPat, emptyFVs)
359 %************************************************************************
363 %************************************************************************
366 rnExpr (HsProc pat body src_loc)
367 = addSrcLoc src_loc $
368 rnPatsAndThen ProcExpr True [pat] $ \ [pat'] ->
369 rnCmdTop body `thenM` \ (body',fvBody) ->
370 returnM (HsProc pat' body' src_loc, fvBody)
372 rnExpr (HsArrApp arrow arg _ ho rtl srcloc)
373 = rnExpr arrow `thenM` \ (arrow',fvArrow) ->
374 rnExpr arg `thenM` \ (arg',fvArg) ->
375 returnM (HsArrApp arrow' arg' placeHolderType ho rtl srcloc,
376 fvArrow `plusFV` fvArg)
379 rnExpr (HsArrForm op (Just _) [arg1, arg2] srcloc)
380 = rnExpr op `thenM` \ (op'@(HsVar op_name),fv_op) ->
381 rnCmdTop arg1 `thenM` \ (arg1',fv_arg1) ->
382 rnCmdTop arg2 `thenM` \ (arg2',fv_arg2) ->
386 lookupFixityRn op_name `thenM` \ fixity ->
387 mkOpFormRn arg1' op' fixity arg2' `thenM` \ final_e ->
390 fv_arg1 `plusFV` fv_op `plusFV` fv_arg2)
392 rnExpr (HsArrForm op fixity cmds srcloc)
393 = rnExpr op `thenM` \ (op',fvOp) ->
394 rnCmdArgs cmds `thenM` \ (cmds',fvCmds) ->
395 returnM (HsArrForm op' fixity cmds' srcloc,
396 fvOp `plusFV` fvCmds)
398 ---------------------------
399 -- Deal with fixity (cf mkOpAppRn for the method)
401 mkOpFormRn :: RenamedHsCmdTop -- Left operand; already rearranged
402 -> RenamedHsExpr -> Fixity -- Operator and fixity
403 -> RenamedHsCmdTop -- Right operand (not an infix)
406 ---------------------------
407 -- (e11 `op1` e12) `op2` e2
408 mkOpFormRn a1@(HsCmdTop (HsArrForm op1 (Just fix1) [a11,a12] loc1) _ _ _) op2 fix2 a2
410 = addErr (precParseErr (ppr_op op1,fix1) (ppr_op op2,fix2)) `thenM_`
411 returnM (HsArrForm op2 (Just fix2) [a1, a2] loc1)
414 = mkOpFormRn a12 op2 fix2 a2 `thenM` \ new_c ->
415 returnM (HsArrForm op1 (Just fix1)
416 [a11, HsCmdTop new_c [] placeHolderType []] loc1)
418 (nofix_error, associate_right) = compareFixity fix1 fix2
420 ---------------------------
422 mkOpFormRn arg1 op fix arg2 -- Default case, no rearrangment
423 = returnM (HsArrForm op (Just fix) [arg1, arg2] noSrcLoc)
428 %************************************************************************
432 %************************************************************************
435 rnCmdArgs [] = returnM ([], emptyFVs)
437 = rnCmdTop arg `thenM` \ (arg',fvArg) ->
438 rnCmdArgs args `thenM` \ (args',fvArgs) ->
439 returnM (arg':args', fvArg `plusFV` fvArgs)
441 rnCmdTop (HsCmdTop cmd _ _ _)
442 = rnExpr (convertOpFormsCmd cmd) `thenM` \ (cmd', fvCmd) ->
444 cmd_names = [arrAName, composeAName, firstAName] ++
445 nameSetToList (methodNamesCmd cmd')
447 -- Generate the rebindable syntax for the monad
448 lookupSyntaxNames cmd_names `thenM` \ (cmd_names', cmd_fvs) ->
450 returnM (HsCmdTop cmd' [] placeHolderType cmd_names',
451 fvCmd `plusFV` cmd_fvs)
453 ---------------------------------------------------
454 -- convert OpApp's in a command context to HsArrForm's
456 convertOpFormsCmd :: HsCmd id -> HsCmd id
458 convertOpFormsCmd (HsApp c e) = HsApp (convertOpFormsCmd c) e
460 convertOpFormsCmd (HsLam match) = HsLam (convertOpFormsMatch match)
462 convertOpFormsCmd (OpApp c1 op fixity c2)
464 arg1 = HsCmdTop (convertOpFormsCmd c1) [] placeHolderType []
465 arg2 = HsCmdTop (convertOpFormsCmd c2) [] placeHolderType []
467 HsArrForm op (Just fixity) [arg1, arg2] noSrcLoc
469 convertOpFormsCmd (HsPar c) = HsPar (convertOpFormsCmd c)
471 convertOpFormsCmd (HsCase exp matches locn)
472 = HsCase exp (map convertOpFormsMatch matches) locn
474 convertOpFormsCmd (HsIf exp c1 c2 locn)
475 = HsIf exp (convertOpFormsCmd c1) (convertOpFormsCmd c2) locn
477 convertOpFormsCmd (HsLet binds cmd)
478 = HsLet binds (convertOpFormsCmd cmd)
480 convertOpFormsCmd (HsDo ctxt stmts ids ty locn)
481 = HsDo ctxt (map convertOpFormsStmt stmts) ids ty locn
483 -- Anything else is unchanged. This includes HsArrForm (already done),
484 -- things with no sub-commands, and illegal commands (which will be
485 -- caught by the type checker)
486 convertOpFormsCmd c = c
488 convertOpFormsStmt (BindStmt pat cmd locn)
489 = BindStmt pat (convertOpFormsCmd cmd) locn
490 convertOpFormsStmt (ResultStmt cmd locn)
491 = ResultStmt (convertOpFormsCmd cmd) locn
492 convertOpFormsStmt (ExprStmt cmd ty locn)
493 = ExprStmt (convertOpFormsCmd cmd) ty locn
494 convertOpFormsStmt (RecStmt stmts lvs rvs es)
495 = RecStmt (map convertOpFormsStmt stmts) lvs rvs es
496 convertOpFormsStmt stmt = stmt
498 convertOpFormsMatch (Match pat mty grhss)
499 = Match pat mty (convertOpFormsGRHSs grhss)
501 convertOpFormsGRHSs (GRHSs grhss binds ty)
502 = GRHSs (map convertOpFormsGRHS grhss) binds ty
504 convertOpFormsGRHS (GRHS stmts locn)
506 (ResultStmt cmd locn') = last stmts
508 GRHS (init stmts ++ [ResultStmt (convertOpFormsCmd cmd) locn']) locn
510 ---------------------------------------------------
511 type CmdNeeds = FreeVars -- Only inhabitants are
512 -- appAName, choiceAName, loopAName
514 -- find what methods the Cmd needs (loop, choice, apply)
515 methodNamesCmd :: HsCmd Name -> CmdNeeds
517 methodNamesCmd cmd@(HsArrApp _arrow _arg _ HsFirstOrderApp _rtl _srcloc)
519 methodNamesCmd cmd@(HsArrApp _arrow _arg _ HsHigherOrderApp _rtl _srcloc)
521 methodNamesCmd cmd@(HsArrForm {}) = emptyFVs
523 methodNamesCmd (HsPar c) = methodNamesCmd c
525 methodNamesCmd (HsIf p c1 c2 loc)
526 = methodNamesCmd c1 `plusFV` methodNamesCmd c2 `addOneFV` choiceAName
528 methodNamesCmd (HsLet b c) = methodNamesCmd c
530 methodNamesCmd (HsDo sc stmts rbs ty loc) = methodNamesStmts stmts
532 methodNamesCmd (HsApp c e) = methodNamesCmd c
534 methodNamesCmd (HsLam match) = methodNamesMatch match
536 methodNamesCmd (HsCase scrut matches loc)
537 = plusFVs (map methodNamesMatch matches) `addOneFV` choiceAName
539 methodNamesCmd other = emptyFVs
540 -- Other forms can't occur in commands, but it's not convenient
541 -- to error here so we just do what's convenient.
542 -- The type checker will complain later
544 ---------------------------------------------------
545 methodNamesMatch (Match pats sig_ty grhss) = methodNamesGRHSs grhss
547 -------------------------------------------------
548 methodNamesGRHSs (GRHSs grhss binds ty) = plusFVs (map methodNamesGRHS grhss)
550 -------------------------------------------------
551 methodNamesGRHS (GRHS stmts loc) = methodNamesStmt (last stmts)
553 ---------------------------------------------------
554 methodNamesStmts stmts = plusFVs (map methodNamesStmt stmts)
556 ---------------------------------------------------
557 methodNamesStmt (ResultStmt cmd loc) = methodNamesCmd cmd
558 methodNamesStmt (ExprStmt cmd ty loc) = methodNamesCmd cmd
559 methodNamesStmt (BindStmt pat cmd loc) = methodNamesCmd cmd
560 methodNamesStmt (RecStmt stmts lvs rvs es)
561 = methodNamesStmts stmts `addOneFV` loopAName
562 methodNamesStmt (LetStmt b) = emptyFVs
563 methodNamesStmt (ParStmt ss) = emptyFVs
564 -- ParStmt can't occur in commands, but it's not convenient to error
565 -- here so we just do what's convenient
569 %************************************************************************
573 %************************************************************************
576 rnArithSeq (From expr)
577 = rnExpr expr `thenM` \ (expr', fvExpr) ->
578 returnM (From expr', fvExpr)
580 rnArithSeq (FromThen expr1 expr2)
581 = rnExpr expr1 `thenM` \ (expr1', fvExpr1) ->
582 rnExpr expr2 `thenM` \ (expr2', fvExpr2) ->
583 returnM (FromThen expr1' expr2', fvExpr1 `plusFV` fvExpr2)
585 rnArithSeq (FromTo expr1 expr2)
586 = rnExpr expr1 `thenM` \ (expr1', fvExpr1) ->
587 rnExpr expr2 `thenM` \ (expr2', fvExpr2) ->
588 returnM (FromTo expr1' expr2', fvExpr1 `plusFV` fvExpr2)
590 rnArithSeq (FromThenTo expr1 expr2 expr3)
591 = rnExpr expr1 `thenM` \ (expr1', fvExpr1) ->
592 rnExpr expr2 `thenM` \ (expr2', fvExpr2) ->
593 rnExpr expr3 `thenM` \ (expr3', fvExpr3) ->
594 returnM (FromThenTo expr1' expr2' expr3',
595 plusFVs [fvExpr1, fvExpr2, fvExpr3])
599 %************************************************************************
601 \subsubsection{@Rbinds@s and @Rpats@s: in record expressions}
603 %************************************************************************
607 = mappM_ field_dup_err dup_fields `thenM_`
608 mapFvRn rn_rbind rbinds `thenM` \ (rbinds', fvRbind) ->
609 returnM (rbinds', fvRbind)
611 (_, dup_fields) = removeDups compare [ f | (f,_) <- rbinds ]
613 field_dup_err dups = addErr (dupFieldErr str dups)
615 rn_rbind (field, expr)
616 = lookupGlobalOccRn field `thenM` \ fieldname ->
617 rnExpr expr `thenM` \ (expr', fvExpr) ->
618 returnM ((fieldname, expr'), fvExpr `addOneFV` fieldname)
621 %************************************************************************
623 Template Haskell brackets
625 %************************************************************************
628 rnBracket (ExpBr e) = rnExpr e `thenM` \ (e', fvs) ->
629 returnM (ExpBr e', fvs)
630 rnBracket (PatBr p) = rnPat p `thenM` \ (p', fvs) ->
631 returnM (PatBr p', fvs)
632 rnBracket (TypBr t) = rnHsTypeFVs doc t `thenM` \ (t', fvs) ->
633 returnM (TypBr t', fvs)
635 doc = ptext SLIT("In a Template-Haskell quoted type")
636 rnBracket (DecBr group)
637 = importsFromLocalDecls group `thenM` \ (rdr_env, avails) ->
638 -- Discard avails (not useful here)
640 updGblEnv (\gbl -> gbl { tcg_rdr_env = tcg_rdr_env gbl `plusOccEnv` rdr_env}) $
641 -- Notice plusOccEnv, not plusGlobalRdrEnv. In this situation we want
642 -- to *shadow* top-level bindings. E.g.
644 -- bar = [d| foo = 1|]
645 -- So we drop down to plusOccEnv. (Perhaps there should be a fn in RdrName.)
647 rnSrcDecls group `thenM` \ (tcg_env, group') ->
648 -- Discard the tcg_env; it contains only extra info about fixity
650 dus = tcg_dus tcg_env
652 returnM (DecBr group', duUses dus `minusNameSet` duDefs dus)
655 %************************************************************************
657 \subsubsection{@Stmt@s: in @do@ expressions}
659 %************************************************************************
662 rnStmts :: HsStmtContext Name -> [RdrNameStmt] -> RnM ([RenamedStmt], FreeVars)
664 rnStmts MDoExpr stmts = rnMDoStmts stmts
665 rnStmts ctxt stmts = rnNormalStmts ctxt stmts
667 rnNormalStmts :: HsStmtContext Name -> [RdrNameStmt] -> RnM ([RenamedStmt], FreeVars)
668 -- Used for cases *other* than recursive mdo
669 -- Implements nested scopes
671 rnNormalStmts ctxt [] = returnM ([], emptyFVs)
672 -- Happens at the end of the sub-lists of a ParStmts
674 rnNormalStmts ctxt (ExprStmt expr _ src_loc : stmts)
675 = addSrcLoc src_loc $
676 rnExpr expr `thenM` \ (expr', fv_expr) ->
677 rnNormalStmts ctxt stmts `thenM` \ (stmts', fvs) ->
678 returnM (ExprStmt expr' placeHolderType src_loc : stmts',
679 fv_expr `plusFV` fvs)
681 rnNormalStmts ctxt [ResultStmt expr src_loc]
682 = addSrcLoc src_loc $
683 rnExpr expr `thenM` \ (expr', fv_expr) ->
684 returnM ([ResultStmt expr' src_loc], fv_expr)
686 rnNormalStmts ctxt (BindStmt pat expr src_loc : stmts)
687 = addSrcLoc src_loc $
688 rnExpr expr `thenM` \ (expr', fv_expr) ->
689 -- The binders do not scope over the expression
694 ParStmtCtxt{} -> False
697 rnPatsAndThen (StmtCtxt ctxt) reportUnused [pat] $ \ [pat'] ->
698 rnNormalStmts ctxt stmts `thenM` \ (stmts', fvs) ->
699 returnM (BindStmt pat' expr' src_loc : stmts',
700 fv_expr `plusFV` fvs) -- fv_expr shouldn't really be filtered by
701 -- the rnPatsAndThen, but it does not matter
703 rnNormalStmts ctxt (LetStmt binds : stmts)
704 = checkErr (ok ctxt binds) (badIpBinds binds) `thenM_`
705 rnBindsAndThen binds ( \ binds' ->
706 rnNormalStmts ctxt stmts `thenM` \ (stmts', fvs) ->
707 returnM (LetStmt binds' : stmts', fvs))
709 -- We do not allow implicit-parameter bindings in a parallel
710 -- list comprehension. I'm not sure what it might mean.
711 ok (ParStmtCtxt _) (IPBinds _) = False
714 rnNormalStmts ctxt (ParStmt stmtss : stmts)
715 = doptM Opt_GlasgowExts `thenM` \ opt_GlasgowExts ->
716 checkM opt_GlasgowExts parStmtErr `thenM_`
717 mapFvRn rn_branch stmtss `thenM` \ (stmtss', fv_stmtss) ->
719 bndrss :: [[Name]] -- NB: Name, not RdrName
720 bndrss = map collectStmtsBinders stmtss'
721 (bndrs, dups) = removeDups cmpByOcc (concat bndrss)
723 mappM dupErr dups `thenM` \ _ ->
724 bindLocalNamesFV bndrs $
725 -- Note: binders are returned in scope order, so one may
726 -- shadow the next; e.g. x <- xs; x <- ys
727 rnNormalStmts ctxt stmts `thenM` \ (stmts', fvs) ->
729 -- Cut down the exported binders to just the ones needed in the body
731 used_bndrs_s = map (filter (`elemNameSet` fvs)) bndrss
732 unused_bndrs = filter (not . (`elemNameSet` fvs)) bndrs
734 -- With processing of the branches and the tail of comprehension done,
735 -- we can finally compute&report any unused ParStmt binders.
736 warnUnusedMatches unused_bndrs `thenM_`
737 returnM (ParStmt (stmtss' `zip` used_bndrs_s) : stmts',
738 fv_stmtss `plusFV` fvs)
740 rn_branch (stmts, _) = rnNormalStmts (ParStmtCtxt ctxt) stmts
742 cmpByOcc n1 n2 = nameOccName n1 `compare` nameOccName n2
743 dupErr (v:_) = addErr (ptext SLIT("Duplicate binding in parallel list comprehension for:")
746 rnNormalStmts ctxt (RecStmt rec_stmts _ _ _ : stmts)
747 = bindLocalsRn doc (collectStmtsBinders rec_stmts) $ \ _ ->
748 rn_rec_stmts rec_stmts `thenM` \ segs ->
749 rnNormalStmts ctxt stmts `thenM` \ (stmts', fvs) ->
751 segs_w_fwd_refs = addFwdRefs segs
752 (ds, us, fs, rec_stmts') = unzip4 segs_w_fwd_refs
753 later_vars = nameSetToList (plusFVs ds `intersectNameSet` fvs)
754 fwd_vars = nameSetToList (plusFVs fs)
757 returnM (RecStmt rec_stmts' later_vars fwd_vars [] : stmts', uses `plusFV` fvs)
759 doc = text "In a recursive do statement"
763 %************************************************************************
765 \subsubsection{mdo expressions}
767 %************************************************************************
770 type FwdRefs = NameSet
771 type Segment stmts = (Defs,
772 Uses, -- May include defs
773 FwdRefs, -- A subset of uses that are
774 -- (a) used before they are bound in this segment, or
775 -- (b) used here, and bound in subsequent segments
776 stmts) -- Either Stmt or [Stmt]
779 ----------------------------------------------------
780 rnMDoStmts :: [RdrNameStmt] -> RnM ([RenamedStmt], FreeVars)
782 = -- Step1: bring all the binders of the mdo into scope
783 -- Remember that this also removes the binders from the
784 -- finally-returned free-vars
785 bindLocalsRn doc (collectStmtsBinders stmts) $ \ _ ->
787 -- Step 2: Rename each individual stmt, making a
788 -- singleton segment. At this stage the FwdRefs field
789 -- isn't finished: it's empty for all except a BindStmt
790 -- for which it's the fwd refs within the bind itself
791 -- (This set may not be empty, because we're in a recursive
793 rn_rec_stmts stmts `thenM` \ segs ->
795 -- Step 3: Fill in the fwd refs.
796 -- The segments are all singletons, but their fwd-ref
797 -- field mentions all the things used by the segment
798 -- that are bound after their use
799 segs_w_fwd_refs = addFwdRefs segs
801 -- Step 4: Group together the segments to make bigger segments
802 -- Invariant: in the result, no segment uses a variable
803 -- bound in a later segment
804 grouped_segs = glomSegments segs_w_fwd_refs
806 -- Step 5: Turn the segments into Stmts
807 -- Use RecStmt when and only when there are fwd refs
808 -- Also gather up the uses from the end towards the
809 -- start, so we can tell the RecStmt which things are
810 -- used 'after' the RecStmt
811 stmts_w_fvs = segsToStmts grouped_segs
815 doc = text "In a mdo-expression"
818 ----------------------------------------------------
819 rn_rec_stmt :: RdrNameStmt -> RnM [Segment RenamedStmt]
820 -- Rename a Stmt that is inside a RecStmt (or mdo)
821 -- Assumes all binders are already in scope
822 -- Turns each stmt into a singleton Stmt
824 rn_rec_stmt (ExprStmt expr _ src_loc)
825 = addSrcLoc src_loc (rnExpr expr) `thenM` \ (expr', fvs) ->
826 returnM [(emptyNameSet, fvs, emptyNameSet,
827 ExprStmt expr' placeHolderType src_loc)]
829 rn_rec_stmt (ResultStmt expr src_loc)
830 = addSrcLoc src_loc (rnExpr expr) `thenM` \ (expr', fvs) ->
831 returnM [(emptyNameSet, fvs, emptyNameSet,
832 ResultStmt expr' src_loc)]
834 rn_rec_stmt (BindStmt pat expr src_loc)
835 = addSrcLoc src_loc $
836 rnExpr expr `thenM` \ (expr', fv_expr) ->
837 rnPat pat `thenM` \ (pat', fv_pat) ->
839 bndrs = mkNameSet (collectPatBinders pat')
840 fvs = fv_expr `plusFV` fv_pat
842 returnM [(bndrs, fvs, bndrs `intersectNameSet` fvs,
843 BindStmt pat' expr' src_loc)]
845 rn_rec_stmt (LetStmt binds)
846 = rnBinds binds `thenM` \ (binds', du_binds) ->
847 returnM [(duDefs du_binds, duUses du_binds,
848 emptyNameSet, LetStmt binds')]
850 rn_rec_stmt (RecStmt stmts _ _ _) -- Flatten Rec inside Rec
853 rn_rec_stmt stmt@(ParStmt _) -- Syntactically illegal in mdo
854 = pprPanic "rn_rec_stmt" (ppr stmt)
856 ---------------------------------------------
857 rn_rec_stmts :: [RdrNameStmt] -> RnM [Segment RenamedStmt]
858 rn_rec_stmts stmts = mappM rn_rec_stmt stmts `thenM` \ segs_s ->
859 returnM (concat segs_s)
862 ---------------------------------------------
863 addFwdRefs :: [Segment a] -> [Segment a]
864 -- So far the segments only have forward refs *within* the Stmt
865 -- (which happens for bind: x <- ...x...)
866 -- This function adds the cross-seg fwd ref info
869 = fst (foldr mk_seg ([], emptyNameSet) pairs)
871 mk_seg (defs, uses, fwds, stmts) (segs, later_defs)
872 = (new_seg : segs, all_defs)
874 new_seg = (defs, uses, new_fwds, stmts)
875 all_defs = later_defs `unionNameSets` defs
876 new_fwds = fwds `unionNameSets` (uses `intersectNameSet` later_defs)
877 -- Add the downstream fwd refs here
879 ----------------------------------------------------
880 -- Glomming the singleton segments of an mdo into
881 -- minimal recursive groups.
883 -- At first I thought this was just strongly connected components, but
884 -- there's an important constraint: the order of the stmts must not change.
887 -- mdo { x <- ...y...
894 -- Here, the first stmt mention 'y', which is bound in the third.
895 -- But that means that the innocent second stmt (p <- z) gets caught
896 -- up in the recursion. And that in turn means that the binding for
897 -- 'z' has to be included... and so on.
899 -- Start at the tail { r <- x }
900 -- Now add the next one { z <- y ; r <- x }
901 -- Now add one more { q <- x ; z <- y ; r <- x }
902 -- Now one more... but this time we have to group a bunch into rec
903 -- { rec { y <- ...x... ; q <- x ; z <- y } ; r <- x }
904 -- Now one more, which we can add on without a rec
906 -- rec { y <- ...x... ; q <- x ; z <- y } ;
908 -- Finally we add the last one; since it mentions y we have to
909 -- glom it togeher with the first two groups
910 -- { rec { x <- ...y...; p <- z ; y <- ...x... ;
911 -- q <- x ; z <- y } ;
914 glomSegments :: [Segment RenamedStmt] -> [Segment [RenamedStmt]]
917 glomSegments ((defs,uses,fwds,stmt) : segs)
918 -- Actually stmts will always be a singleton
919 = (seg_defs, seg_uses, seg_fwds, seg_stmts) : others
921 segs' = glomSegments segs
922 (extras, others) = grab uses segs'
923 (ds, us, fs, ss) = unzip4 extras
925 seg_defs = plusFVs ds `plusFV` defs
926 seg_uses = plusFVs us `plusFV` uses
927 seg_fwds = plusFVs fs `plusFV` fwds
928 seg_stmts = stmt : concat ss
930 grab :: NameSet -- The client
932 -> ([Segment a], -- Needed by the 'client'
933 [Segment a]) -- Not needed by the client
934 -- The result is simply a split of the input
936 = (reverse yeses, reverse noes)
938 (noes, yeses) = span not_needed (reverse dus)
939 not_needed (defs,_,_,_) = not (intersectsNameSet defs uses)
942 ----------------------------------------------------
943 segsToStmts :: [Segment [RenamedStmt]] -> ([RenamedStmt], FreeVars)
945 segsToStmts [] = ([], emptyFVs)
946 segsToStmts ((defs, uses, fwds, ss) : segs)
947 = (new_stmt : later_stmts, later_uses `plusFV` uses)
949 (later_stmts, later_uses) = segsToStmts segs
950 new_stmt | non_rec = head ss
951 | otherwise = RecStmt ss (nameSetToList used_later) (nameSetToList fwds) []
953 non_rec = isSingleton ss && isEmptyNameSet fwds
954 used_later = defs `intersectNameSet` later_uses
955 -- The ones needed after the RecStmt
958 %************************************************************************
960 \subsubsection{Precedence Parsing}
962 %************************************************************************
964 @mkOpAppRn@ deals with operator fixities. The argument expressions
965 are assumed to be already correctly arranged. It needs the fixities
966 recorded in the OpApp nodes, because fixity info applies to the things
967 the programmer actually wrote, so you can't find it out from the Name.
969 Furthermore, the second argument is guaranteed not to be another
970 operator application. Why? Because the parser parses all
971 operator appications left-associatively, EXCEPT negation, which
972 we need to handle specially.
975 mkOpAppRn :: RenamedHsExpr -- Left operand; already rearranged
976 -> RenamedHsExpr -> Fixity -- Operator and fixity
977 -> RenamedHsExpr -- Right operand (not an OpApp, but might
981 ---------------------------
982 -- (e11 `op1` e12) `op2` e2
983 mkOpAppRn e1@(OpApp e11 op1 fix1 e12) op2 fix2 e2
985 = addErr (precParseErr (ppr_op op1,fix1) (ppr_op op2,fix2)) `thenM_`
986 returnM (OpApp e1 op2 fix2 e2)
989 = mkOpAppRn e12 op2 fix2 e2 `thenM` \ new_e ->
990 returnM (OpApp e11 op1 fix1 new_e)
992 (nofix_error, associate_right) = compareFixity fix1 fix2
994 ---------------------------
995 -- (- neg_arg) `op` e2
996 mkOpAppRn e1@(NegApp neg_arg neg_name) op2 fix2 e2
998 = addErr (precParseErr (pp_prefix_minus,negateFixity) (ppr_op op2,fix2)) `thenM_`
999 returnM (OpApp e1 op2 fix2 e2)
1002 = mkOpAppRn neg_arg op2 fix2 e2 `thenM` \ new_e ->
1003 returnM (NegApp new_e neg_name)
1005 (nofix_error, associate_right) = compareFixity negateFixity fix2
1007 ---------------------------
1008 -- e1 `op` - neg_arg
1009 mkOpAppRn e1 op1 fix1 e2@(NegApp neg_arg _) -- NegApp can occur on the right
1010 | not associate_right -- We *want* right association
1011 = addErr (precParseErr (ppr_op op1, fix1) (pp_prefix_minus, negateFixity)) `thenM_`
1012 returnM (OpApp e1 op1 fix1 e2)
1014 (_, associate_right) = compareFixity fix1 negateFixity
1016 ---------------------------
1018 mkOpAppRn e1 op fix e2 -- Default case, no rearrangment
1019 = ASSERT2( right_op_ok fix e2,
1020 ppr e1 $$ text "---" $$ ppr op $$ text "---" $$ ppr fix $$ text "---" $$ ppr e2
1022 returnM (OpApp e1 op fix e2)
1024 -- Parser left-associates everything, but
1025 -- derived instances may have correctly-associated things to
1026 -- in the right operarand. So we just check that the right operand is OK
1027 right_op_ok fix1 (OpApp _ _ fix2 _)
1028 = not error_please && associate_right
1030 (error_please, associate_right) = compareFixity fix1 fix2
1031 right_op_ok fix1 other
1034 -- Parser initially makes negation bind more tightly than any other operator
1035 -- And "deriving" code should respect this (use HsPar if not)
1036 mkNegAppRn neg_arg neg_name
1037 = ASSERT( not_op_app neg_arg )
1038 returnM (NegApp neg_arg neg_name)
1040 not_op_app (OpApp _ _ _ _) = False
1041 not_op_app other = True
1045 checkPrecMatch :: Bool -> Name -> RenamedMatch -> RnM ()
1047 checkPrecMatch False fn match
1050 checkPrecMatch True op (Match (p1:p2:_) _ _)
1051 -- True indicates an infix lhs
1052 = -- See comments with rnExpr (OpApp ...) about "deriving"
1053 checkPrec op p1 False `thenM_`
1054 checkPrec op p2 True
1056 checkPrecMatch True op _ = panic "checkPrecMatch"
1058 checkPrec op (ConPatIn op1 (InfixCon _ _)) right
1059 = lookupFixityRn op `thenM` \ op_fix@(Fixity op_prec op_dir) ->
1060 lookupFixityRn op1 `thenM` \ op1_fix@(Fixity op1_prec op1_dir) ->
1062 inf_ok = op1_prec > op_prec ||
1063 (op1_prec == op_prec &&
1064 (op1_dir == InfixR && op_dir == InfixR && right ||
1065 op1_dir == InfixL && op_dir == InfixL && not right))
1067 info = (ppr_op op, op_fix)
1068 info1 = (ppr_op op1, op1_fix)
1069 (infol, infor) = if right then (info, info1) else (info1, info)
1071 checkErr inf_ok (precParseErr infol infor)
1073 checkPrec op pat right
1076 -- Check precedence of (arg op) or (op arg) respectively
1077 -- If arg is itself an operator application, then either
1078 -- (a) its precedence must be higher than that of op
1079 -- (b) its precedency & associativity must be the same as that of op
1080 checkSectionPrec direction section op arg
1082 OpApp _ op fix _ -> go_for_it (ppr_op op) fix
1083 NegApp _ _ -> go_for_it pp_prefix_minus negateFixity
1087 go_for_it pp_arg_op arg_fix@(Fixity arg_prec assoc)
1088 = lookupFixityRn op_name `thenM` \ op_fix@(Fixity op_prec _) ->
1089 checkErr (op_prec < arg_prec
1090 || op_prec == arg_prec && direction == assoc)
1091 (sectionPrecErr (ppr_op op_name, op_fix)
1092 (pp_arg_op, arg_fix) section)
1096 %************************************************************************
1098 \subsubsection{Assertion utils}
1100 %************************************************************************
1103 mkAssertErrorExpr :: RnM (RenamedHsExpr, FreeVars)
1104 -- Return an expression for (assertError "Foo.hs:27")
1106 = getSrcLocM `thenM` \ sloc ->
1108 expr = HsApp (HsVar assertErrorName) (HsLit msg)
1109 msg = HsStringPrim (mkFastString (stringToUtf8 (showSDoc (ppr sloc))))
1111 returnM (expr, emptyFVs)
1114 %************************************************************************
1116 \subsubsection{Errors}
1118 %************************************************************************
1121 ppr_op op = quotes (ppr op) -- Here, op can be a Name or a (Var n), where n is a Name
1122 pp_prefix_minus = ptext SLIT("prefix `-'")
1124 nonStdGuardErr guard
1126 SLIT("accepting non-standard pattern guards (-fglasgow-exts to suppress this message)")
1130 = sep [ptext SLIT("Pattern syntax in expression context:"),
1133 doStmtListErr do_or_lc e
1134 = sep [quotes (text binder_name) <+> ptext SLIT("statements must end in expression:"),
1137 binder_name = case do_or_lc of
1142 checkTH e what = returnM () -- OK
1144 checkTH e what -- Raise an error in a stage-1 compiler
1145 = addErr (vcat [ptext SLIT("Template Haskell") <+> text what <+>
1146 ptext SLIT("illegal in a stage-1 compiler"),
1150 parStmtErr = addErr (ptext SLIT("Illegal parallel list comprehension: use -fglasgow-exts"))
1153 = hang (ptext SLIT("Implicit-parameter bindings illegal in a parallel list comprehension:")) 4