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, 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 section@(SectionL expr op)
232 = rnExpr expr `thenM` \ (expr', fvs_expr) ->
233 rnExpr op `thenM` \ (op', fvs_op) ->
234 checkSectionPrec InfixL section op' expr' `thenM_`
235 returnM (SectionL expr' op', fvs_op `plusFV` fvs_expr)
237 rnExpr section@(SectionR op expr)
238 = rnExpr op `thenM` \ (op', fvs_op) ->
239 rnExpr expr `thenM` \ (expr', fvs_expr) ->
240 checkSectionPrec InfixR section op' expr' `thenM_`
241 returnM (SectionR op' expr', fvs_op `plusFV` fvs_expr)
243 rnExpr (HsCoreAnn ann expr)
244 = rnExpr expr `thenM` \ (expr', fvs_expr) ->
245 returnM (HsCoreAnn ann expr', fvs_expr)
247 rnExpr (HsSCC lbl expr)
248 = rnExpr expr `thenM` \ (expr', fvs_expr) ->
249 returnM (HsSCC lbl expr', fvs_expr)
251 rnExpr (HsCase expr ms src_loc)
252 = addSrcLoc src_loc $
253 rnExpr expr `thenM` \ (new_expr, e_fvs) ->
254 mapFvRn (rnMatch CaseAlt) ms `thenM` \ (new_ms, ms_fvs) ->
255 returnM (HsCase new_expr new_ms src_loc, e_fvs `plusFV` ms_fvs)
257 rnExpr (HsLet binds expr)
258 = rnBindsAndThen binds $ \ binds' ->
259 rnExpr expr `thenM` \ (expr',fvExpr) ->
260 returnM (HsLet binds' expr', fvExpr)
262 rnExpr e@(HsDo do_or_lc stmts _ _ src_loc)
263 = addSrcLoc src_loc $
264 rnStmts do_or_lc stmts `thenM` \ (stmts', fvs) ->
266 -- Check the statement list ends in an expression
267 case last stmts' of {
268 ResultStmt _ _ -> returnM () ;
269 _ -> addErr (doStmtListErr do_or_lc e)
272 -- Generate the rebindable syntax for the monad
273 lookupSyntaxNames syntax_names `thenM` \ (syntax_names', monad_fvs) ->
275 returnM (HsDo do_or_lc stmts' syntax_names' placeHolderType src_loc,
276 fvs `plusFV` monad_fvs)
278 syntax_names = case do_or_lc of
280 MDoExpr -> monadNames ++ [mfixName]
283 rnExpr (ExplicitList _ exps)
284 = rnExprs exps `thenM` \ (exps', fvs) ->
285 returnM (ExplicitList placeHolderType exps', fvs `addOneFV` listTyCon_name)
287 rnExpr (ExplicitPArr _ exps)
288 = rnExprs exps `thenM` \ (exps', fvs) ->
289 returnM (ExplicitPArr placeHolderType exps', fvs)
291 rnExpr e@(ExplicitTuple exps boxity)
292 = checkTupSize tup_size `thenM_`
293 rnExprs exps `thenM` \ (exps', fvs) ->
294 returnM (ExplicitTuple exps' boxity, fvs `addOneFV` tycon_name)
296 tup_size = length exps
297 tycon_name = tupleTyCon_name boxity tup_size
299 rnExpr (RecordCon con_id rbinds)
300 = lookupOccRn con_id `thenM` \ conname ->
301 rnRbinds "construction" rbinds `thenM` \ (rbinds', fvRbinds) ->
302 returnM (RecordCon conname rbinds', fvRbinds `addOneFV` conname)
304 rnExpr (RecordUpd expr rbinds)
305 = rnExpr expr `thenM` \ (expr', fvExpr) ->
306 rnRbinds "update" rbinds `thenM` \ (rbinds', fvRbinds) ->
307 returnM (RecordUpd expr' rbinds', fvExpr `plusFV` fvRbinds)
309 rnExpr (ExprWithTySig expr pty)
310 = rnExpr expr `thenM` \ (expr', fvExpr) ->
311 rnHsTypeFVs doc pty `thenM` \ (pty', fvTy) ->
312 returnM (ExprWithTySig expr' pty', fvExpr `plusFV` fvTy)
314 doc = text "In an expression type signature"
316 rnExpr (HsIf p b1 b2 src_loc)
317 = addSrcLoc src_loc $
318 rnExpr p `thenM` \ (p', fvP) ->
319 rnExpr b1 `thenM` \ (b1', fvB1) ->
320 rnExpr b2 `thenM` \ (b2', fvB2) ->
321 returnM (HsIf p' b1' b2' src_loc, plusFVs [fvP, fvB1, fvB2])
324 = rnHsTypeFVs doc a `thenM` \ (t, fvT) ->
325 returnM (HsType t, fvT)
327 doc = text "In a type argument"
329 rnExpr (ArithSeqIn seq)
330 = rnArithSeq seq `thenM` \ (new_seq, fvs) ->
331 returnM (ArithSeqIn new_seq, fvs)
333 rnExpr (PArrSeqIn seq)
334 = rnArithSeq seq `thenM` \ (new_seq, fvs) ->
335 returnM (PArrSeqIn new_seq, fvs)
338 These three are pattern syntax appearing in expressions.
339 Since all the symbols are reservedops we can simply reject them.
340 We return a (bogus) EWildPat in each case.
343 rnExpr e@EWildPat = addErr (patSynErr e) `thenM_`
344 returnM (EWildPat, emptyFVs)
346 rnExpr e@(EAsPat _ _) = addErr (patSynErr e) `thenM_`
347 returnM (EWildPat, emptyFVs)
349 rnExpr e@(ELazyPat _) = addErr (patSynErr e) `thenM_`
350 returnM (EWildPat, emptyFVs)
353 %************************************************************************
357 %************************************************************************
360 rnExpr (HsProc pat body src_loc)
361 = addSrcLoc src_loc $
362 rnPatsAndThen ProcExpr True [pat] $ \ [pat'] ->
363 rnCmdTop body `thenM` \ (body',fvBody) ->
364 returnM (HsProc pat' body' src_loc, fvBody)
366 rnExpr (HsArrApp arrow arg _ ho rtl srcloc)
367 = rnExpr arrow `thenM` \ (arrow',fvArrow) ->
368 rnExpr arg `thenM` \ (arg',fvArg) ->
369 returnM (HsArrApp arrow' arg' placeHolderType ho rtl srcloc,
370 fvArrow `plusFV` fvArg)
373 rnExpr (HsArrForm op (Just _) [arg1, arg2] srcloc)
374 = rnExpr op `thenM` \ (op'@(HsVar op_name),fv_op) ->
375 rnCmdTop arg1 `thenM` \ (arg1',fv_arg1) ->
376 rnCmdTop arg2 `thenM` \ (arg2',fv_arg2) ->
380 lookupFixityRn op_name `thenM` \ fixity ->
381 mkOpFormRn arg1' op' fixity arg2' `thenM` \ final_e ->
384 fv_arg1 `plusFV` fv_op `plusFV` fv_arg2)
386 rnExpr (HsArrForm op fixity cmds srcloc)
387 = rnExpr op `thenM` \ (op',fvOp) ->
388 rnCmdArgs cmds `thenM` \ (cmds',fvCmds) ->
389 returnM (HsArrForm op' fixity cmds' srcloc,
390 fvOp `plusFV` fvCmds)
392 ---------------------------
393 -- Deal with fixity (cf mkOpAppRn for the method)
395 mkOpFormRn :: RenamedHsCmdTop -- Left operand; already rearranged
396 -> RenamedHsExpr -> Fixity -- Operator and fixity
397 -> RenamedHsCmdTop -- Right operand (not an infix)
400 ---------------------------
401 -- (e11 `op1` e12) `op2` e2
402 mkOpFormRn a1@(HsCmdTop (HsArrForm op1 (Just fix1) [a11,a12] loc1) _ _ _) op2 fix2 a2
404 = addErr (precParseErr (ppr_op op1,fix1) (ppr_op op2,fix2)) `thenM_`
405 returnM (HsArrForm op2 (Just fix2) [a1, a2] loc1)
408 = mkOpFormRn a12 op2 fix2 a2 `thenM` \ new_c ->
409 returnM (HsArrForm op1 (Just fix1)
410 [a11, HsCmdTop new_c [] placeHolderType []] loc1)
412 (nofix_error, associate_right) = compareFixity fix1 fix2
414 ---------------------------
416 mkOpFormRn arg1 op fix arg2 -- Default case, no rearrangment
417 = returnM (HsArrForm op (Just fix) [arg1, arg2] noSrcLoc)
422 %************************************************************************
426 %************************************************************************
429 rnCmdArgs [] = returnM ([], emptyFVs)
431 = rnCmdTop arg `thenM` \ (arg',fvArg) ->
432 rnCmdArgs args `thenM` \ (args',fvArgs) ->
433 returnM (arg':args', fvArg `plusFV` fvArgs)
435 rnCmdTop (HsCmdTop cmd _ _ _)
436 = rnExpr (convertOpFormsCmd cmd) `thenM` \ (cmd', fvCmd) ->
438 cmd_names = [arrAName, composeAName, firstAName] ++
439 nameSetToList (methodNamesCmd cmd')
441 -- Generate the rebindable syntax for the monad
442 lookupSyntaxNames cmd_names `thenM` \ (cmd_names', cmd_fvs) ->
444 returnM (HsCmdTop cmd' [] placeHolderType cmd_names',
445 fvCmd `plusFV` cmd_fvs)
447 ---------------------------------------------------
448 -- convert OpApp's in a command context to HsArrForm's
450 convertOpFormsCmd :: HsCmd id -> HsCmd id
452 convertOpFormsCmd (HsApp c e) = HsApp (convertOpFormsCmd c) e
454 convertOpFormsCmd (HsLam match) = HsLam (convertOpFormsMatch match)
456 convertOpFormsCmd (OpApp c1 op fixity c2)
458 arg1 = HsCmdTop (convertOpFormsCmd c1) [] placeHolderType []
459 arg2 = HsCmdTop (convertOpFormsCmd c2) [] placeHolderType []
461 HsArrForm op (Just fixity) [arg1, arg2] noSrcLoc
463 convertOpFormsCmd (HsPar c) = HsPar (convertOpFormsCmd c)
465 convertOpFormsCmd (HsCase exp matches locn)
466 = HsCase exp (map convertOpFormsMatch matches) locn
468 convertOpFormsCmd (HsIf exp c1 c2 locn)
469 = HsIf exp (convertOpFormsCmd c1) (convertOpFormsCmd c2) locn
471 convertOpFormsCmd (HsLet binds cmd)
472 = HsLet binds (convertOpFormsCmd cmd)
474 convertOpFormsCmd (HsDo ctxt stmts ids ty locn)
475 = HsDo ctxt (map convertOpFormsStmt stmts) ids ty locn
477 -- Anything else is unchanged. This includes HsArrForm (already done),
478 -- things with no sub-commands, and illegal commands (which will be
479 -- caught by the type checker)
480 convertOpFormsCmd c = c
482 convertOpFormsStmt (BindStmt pat cmd locn)
483 = BindStmt pat (convertOpFormsCmd cmd) locn
484 convertOpFormsStmt (ResultStmt cmd locn)
485 = ResultStmt (convertOpFormsCmd cmd) locn
486 convertOpFormsStmt (ExprStmt cmd ty locn)
487 = ExprStmt (convertOpFormsCmd cmd) ty locn
488 convertOpFormsStmt (RecStmt stmts lvs rvs es)
489 = RecStmt (map convertOpFormsStmt stmts) lvs rvs es
490 convertOpFormsStmt stmt = stmt
492 convertOpFormsMatch (Match pat mty grhss)
493 = Match pat mty (convertOpFormsGRHSs grhss)
495 convertOpFormsGRHSs (GRHSs grhss binds ty)
496 = GRHSs (map convertOpFormsGRHS grhss) binds ty
498 convertOpFormsGRHS (GRHS stmts locn)
500 (ResultStmt cmd locn') = last stmts
502 GRHS (init stmts ++ [ResultStmt (convertOpFormsCmd cmd) locn']) locn
504 ---------------------------------------------------
505 type CmdNeeds = FreeVars -- Only inhabitants are
506 -- appAName, choiceAName, loopAName
508 -- find what methods the Cmd needs (loop, choice, apply)
509 methodNamesCmd :: HsCmd Name -> CmdNeeds
511 methodNamesCmd cmd@(HsArrApp _arrow _arg _ HsFirstOrderApp _rtl _srcloc)
513 methodNamesCmd cmd@(HsArrApp _arrow _arg _ HsHigherOrderApp _rtl _srcloc)
515 methodNamesCmd cmd@(HsArrForm {}) = emptyFVs
517 methodNamesCmd (HsPar c) = methodNamesCmd c
519 methodNamesCmd (HsIf p c1 c2 loc)
520 = methodNamesCmd c1 `plusFV` methodNamesCmd c2 `addOneFV` choiceAName
522 methodNamesCmd (HsLet b c) = methodNamesCmd c
524 methodNamesCmd (HsDo sc stmts rbs ty loc) = methodNamesStmts stmts
526 methodNamesCmd (HsApp c e) = methodNamesCmd c
528 methodNamesCmd (HsLam match) = methodNamesMatch match
530 methodNamesCmd (HsCase scrut matches loc)
531 = plusFVs (map methodNamesMatch matches) `addOneFV` choiceAName
533 methodNamesCmd other = emptyFVs
534 -- Other forms can't occur in commands, but it's not convenient
535 -- to error here so we just do what's convenient.
536 -- The type checker will complain later
538 ---------------------------------------------------
539 methodNamesMatch (Match pats sig_ty grhss) = methodNamesGRHSs grhss
541 -------------------------------------------------
542 methodNamesGRHSs (GRHSs grhss binds ty) = plusFVs (map methodNamesGRHS grhss)
544 -------------------------------------------------
545 methodNamesGRHS (GRHS stmts loc) = methodNamesStmt (last stmts)
547 ---------------------------------------------------
548 methodNamesStmts stmts = plusFVs (map methodNamesStmt stmts)
550 ---------------------------------------------------
551 methodNamesStmt (ResultStmt cmd loc) = methodNamesCmd cmd
552 methodNamesStmt (ExprStmt cmd ty loc) = methodNamesCmd cmd
553 methodNamesStmt (BindStmt pat cmd loc) = methodNamesCmd cmd
554 methodNamesStmt (RecStmt stmts lvs rvs es)
555 = methodNamesStmts stmts `addOneFV` loopAName
556 methodNamesStmt (LetStmt b) = emptyFVs
557 methodNamesStmt (ParStmt ss) = emptyFVs
558 -- ParStmt can't occur in commands, but it's not convenient to error
559 -- here so we just do what's convenient
563 %************************************************************************
567 %************************************************************************
570 rnArithSeq (From expr)
571 = rnExpr expr `thenM` \ (expr', fvExpr) ->
572 returnM (From expr', fvExpr)
574 rnArithSeq (FromThen expr1 expr2)
575 = rnExpr expr1 `thenM` \ (expr1', fvExpr1) ->
576 rnExpr expr2 `thenM` \ (expr2', fvExpr2) ->
577 returnM (FromThen expr1' expr2', fvExpr1 `plusFV` fvExpr2)
579 rnArithSeq (FromTo expr1 expr2)
580 = rnExpr expr1 `thenM` \ (expr1', fvExpr1) ->
581 rnExpr expr2 `thenM` \ (expr2', fvExpr2) ->
582 returnM (FromTo expr1' expr2', fvExpr1 `plusFV` fvExpr2)
584 rnArithSeq (FromThenTo expr1 expr2 expr3)
585 = rnExpr expr1 `thenM` \ (expr1', fvExpr1) ->
586 rnExpr expr2 `thenM` \ (expr2', fvExpr2) ->
587 rnExpr expr3 `thenM` \ (expr3', fvExpr3) ->
588 returnM (FromThenTo expr1' expr2' expr3',
589 plusFVs [fvExpr1, fvExpr2, fvExpr3])
593 %************************************************************************
595 \subsubsection{@Rbinds@s and @Rpats@s: in record expressions}
597 %************************************************************************
601 = mappM_ field_dup_err dup_fields `thenM_`
602 mapFvRn rn_rbind rbinds `thenM` \ (rbinds', fvRbind) ->
603 returnM (rbinds', fvRbind)
605 (_, dup_fields) = removeDups compare [ f | (f,_) <- rbinds ]
607 field_dup_err dups = addErr (dupFieldErr str dups)
609 rn_rbind (field, expr)
610 = lookupGlobalOccRn field `thenM` \ fieldname ->
611 rnExpr expr `thenM` \ (expr', fvExpr) ->
612 returnM ((fieldname, expr'), fvExpr `addOneFV` fieldname)
615 %************************************************************************
617 Template Haskell brackets
619 %************************************************************************
622 rnBracket (VarBr n) = lookupOccRn n `thenM` \ name ->
623 returnM (VarBr name, unitFV name)
624 rnBracket (ExpBr e) = rnExpr e `thenM` \ (e', fvs) ->
625 returnM (ExpBr e', fvs)
626 rnBracket (PatBr p) = rnPat p `thenM` \ (p', fvs) ->
627 returnM (PatBr p', fvs)
628 rnBracket (TypBr t) = rnHsTypeFVs doc t `thenM` \ (t', fvs) ->
629 returnM (TypBr t', fvs)
631 doc = ptext SLIT("In a Template-Haskell quoted type")
632 rnBracket (DecBr group)
633 = importsFromLocalDecls group `thenM` \ (rdr_env, avails) ->
634 -- Discard avails (not useful here)
636 updGblEnv (\gbl -> gbl { tcg_rdr_env = tcg_rdr_env gbl `plusOccEnv` rdr_env}) $
637 -- Notice plusOccEnv, not plusGlobalRdrEnv. In this situation we want
638 -- to *shadow* top-level bindings. E.g.
640 -- bar = [d| foo = 1|]
641 -- So we drop down to plusOccEnv. (Perhaps there should be a fn in RdrName.)
643 rnSrcDecls group `thenM` \ (tcg_env, group') ->
644 -- Discard the tcg_env; it contains only extra info about fixity
646 dus = tcg_dus tcg_env
648 returnM (DecBr group', allUses dus)
651 %************************************************************************
653 \subsubsection{@Stmt@s: in @do@ expressions}
655 %************************************************************************
658 rnStmts :: HsStmtContext Name -> [RdrNameStmt] -> RnM ([RenamedStmt], FreeVars)
660 rnStmts MDoExpr stmts = rnMDoStmts stmts
661 rnStmts ctxt stmts = rnNormalStmts ctxt stmts
663 rnNormalStmts :: HsStmtContext Name -> [RdrNameStmt] -> RnM ([RenamedStmt], FreeVars)
664 -- Used for cases *other* than recursive mdo
665 -- Implements nested scopes
667 rnNormalStmts ctxt [] = returnM ([], emptyFVs)
668 -- Happens at the end of the sub-lists of a ParStmts
670 rnNormalStmts ctxt (ExprStmt expr _ src_loc : stmts)
671 = addSrcLoc src_loc $
672 rnExpr expr `thenM` \ (expr', fv_expr) ->
673 rnNormalStmts ctxt stmts `thenM` \ (stmts', fvs) ->
674 returnM (ExprStmt expr' placeHolderType src_loc : stmts',
675 fv_expr `plusFV` fvs)
677 rnNormalStmts ctxt [ResultStmt expr src_loc]
678 = addSrcLoc src_loc $
679 rnExpr expr `thenM` \ (expr', fv_expr) ->
680 returnM ([ResultStmt expr' src_loc], fv_expr)
682 rnNormalStmts ctxt (BindStmt pat expr src_loc : stmts)
683 = addSrcLoc src_loc $
684 rnExpr expr `thenM` \ (expr', fv_expr) ->
685 -- The binders do not scope over the expression
690 ParStmtCtxt{} -> False
693 rnPatsAndThen (StmtCtxt ctxt) reportUnused [pat] $ \ [pat'] ->
694 rnNormalStmts ctxt stmts `thenM` \ (stmts', fvs) ->
695 returnM (BindStmt pat' expr' src_loc : stmts',
696 fv_expr `plusFV` fvs) -- fv_expr shouldn't really be filtered by
697 -- the rnPatsAndThen, but it does not matter
699 rnNormalStmts ctxt (LetStmt binds : stmts)
700 = checkErr (ok ctxt binds) (badIpBinds binds) `thenM_`
701 rnBindsAndThen binds ( \ binds' ->
702 rnNormalStmts ctxt stmts `thenM` \ (stmts', fvs) ->
703 returnM (LetStmt binds' : stmts', fvs))
705 -- We do not allow implicit-parameter bindings in a parallel
706 -- list comprehension. I'm not sure what it might mean.
707 ok (ParStmtCtxt _) (IPBinds _) = False
710 rnNormalStmts ctxt (ParStmt stmtss : stmts)
711 = doptM Opt_GlasgowExts `thenM` \ opt_GlasgowExts ->
712 checkM opt_GlasgowExts parStmtErr `thenM_`
713 mapFvRn rn_branch stmtss `thenM` \ (stmtss', fv_stmtss) ->
715 bndrss :: [[Name]] -- NB: Name, not RdrName
716 bndrss = map collectStmtsBinders stmtss'
717 (bndrs, dups) = removeDups cmpByOcc (concat bndrss)
719 mappM dupErr dups `thenM` \ _ ->
720 bindLocalNamesFV bndrs $
721 -- Note: binders are returned in scope order, so one may
722 -- shadow the next; e.g. x <- xs; x <- ys
723 rnNormalStmts ctxt stmts `thenM` \ (stmts', fvs) ->
725 -- Cut down the exported binders to just the ones needed in the body
727 used_bndrs_s = map (filter (`elemNameSet` fvs)) bndrss
728 unused_bndrs = filter (not . (`elemNameSet` fvs)) bndrs
730 -- With processing of the branches and the tail of comprehension done,
731 -- we can finally compute&report any unused ParStmt binders.
732 warnUnusedMatches unused_bndrs `thenM_`
733 returnM (ParStmt (stmtss' `zip` used_bndrs_s) : stmts',
734 fv_stmtss `plusFV` fvs)
736 rn_branch (stmts, _) = rnNormalStmts (ParStmtCtxt ctxt) stmts
738 cmpByOcc n1 n2 = nameOccName n1 `compare` nameOccName n2
739 dupErr (v:_) = addErr (ptext SLIT("Duplicate binding in parallel list comprehension for:")
742 rnNormalStmts ctxt (RecStmt rec_stmts _ _ _ : stmts)
743 = bindLocalsRn doc (collectStmtsBinders rec_stmts) $ \ _ ->
744 rn_rec_stmts rec_stmts `thenM` \ segs ->
745 rnNormalStmts ctxt stmts `thenM` \ (stmts', fvs) ->
747 segs_w_fwd_refs = addFwdRefs segs
748 (ds, us, fs, rec_stmts') = unzip4 segs_w_fwd_refs
749 later_vars = nameSetToList (plusFVs ds `intersectNameSet` fvs)
750 fwd_vars = nameSetToList (plusFVs fs)
753 returnM (RecStmt rec_stmts' later_vars fwd_vars [] : stmts', uses `plusFV` fvs)
755 doc = text "In a recursive do statement"
759 %************************************************************************
761 \subsubsection{mdo expressions}
763 %************************************************************************
766 type FwdRefs = NameSet
767 type Segment stmts = (Defs,
768 Uses, -- May include defs
769 FwdRefs, -- A subset of uses that are
770 -- (a) used before they are bound in this segment, or
771 -- (b) used here, and bound in subsequent segments
772 stmts) -- Either Stmt or [Stmt]
775 ----------------------------------------------------
776 rnMDoStmts :: [RdrNameStmt] -> RnM ([RenamedStmt], FreeVars)
778 = -- Step1: bring all the binders of the mdo into scope
779 -- Remember that this also removes the binders from the
780 -- finally-returned free-vars
781 bindLocalsRn doc (collectStmtsBinders stmts) $ \ _ ->
783 -- Step 2: Rename each individual stmt, making a
784 -- singleton segment. At this stage the FwdRefs field
785 -- isn't finished: it's empty for all except a BindStmt
786 -- for which it's the fwd refs within the bind itself
787 -- (This set may not be empty, because we're in a recursive
789 rn_rec_stmts stmts `thenM` \ segs ->
791 -- Step 3: Fill in the fwd refs.
792 -- The segments are all singletons, but their fwd-ref
793 -- field mentions all the things used by the segment
794 -- that are bound after their use
795 segs_w_fwd_refs = addFwdRefs segs
797 -- Step 4: Group together the segments to make bigger segments
798 -- Invariant: in the result, no segment uses a variable
799 -- bound in a later segment
800 grouped_segs = glomSegments segs_w_fwd_refs
802 -- Step 5: Turn the segments into Stmts
803 -- Use RecStmt when and only when there are fwd refs
804 -- Also gather up the uses from the end towards the
805 -- start, so we can tell the RecStmt which things are
806 -- used 'after' the RecStmt
807 stmts_w_fvs = segsToStmts grouped_segs
811 doc = text "In a mdo-expression"
814 ----------------------------------------------------
815 rn_rec_stmt :: RdrNameStmt -> RnM [Segment RenamedStmt]
816 -- Rename a Stmt that is inside a RecStmt (or mdo)
817 -- Assumes all binders are already in scope
818 -- Turns each stmt into a singleton Stmt
820 rn_rec_stmt (ExprStmt expr _ src_loc)
821 = addSrcLoc src_loc (rnExpr expr) `thenM` \ (expr', fvs) ->
822 returnM [(emptyNameSet, fvs, emptyNameSet,
823 ExprStmt expr' placeHolderType src_loc)]
825 rn_rec_stmt (ResultStmt expr src_loc)
826 = addSrcLoc src_loc (rnExpr expr) `thenM` \ (expr', fvs) ->
827 returnM [(emptyNameSet, fvs, emptyNameSet,
828 ResultStmt expr' src_loc)]
830 rn_rec_stmt (BindStmt pat expr src_loc)
831 = addSrcLoc src_loc $
832 rnExpr expr `thenM` \ (expr', fv_expr) ->
833 rnPat pat `thenM` \ (pat', fv_pat) ->
835 bndrs = mkNameSet (collectPatBinders pat')
836 fvs = fv_expr `plusFV` fv_pat
838 returnM [(bndrs, fvs, bndrs `intersectNameSet` fvs,
839 BindStmt pat' expr' src_loc)]
841 rn_rec_stmt (LetStmt binds)
842 = rnBinds binds `thenM` \ (binds', du_binds) ->
843 returnM [(duDefs du_binds, duUses du_binds,
844 emptyNameSet, LetStmt binds')]
846 rn_rec_stmt (RecStmt stmts _ _ _) -- Flatten Rec inside Rec
849 rn_rec_stmt stmt@(ParStmt _) -- Syntactically illegal in mdo
850 = pprPanic "rn_rec_stmt" (ppr stmt)
852 ---------------------------------------------
853 rn_rec_stmts :: [RdrNameStmt] -> RnM [Segment RenamedStmt]
854 rn_rec_stmts stmts = mappM rn_rec_stmt stmts `thenM` \ segs_s ->
855 returnM (concat segs_s)
858 ---------------------------------------------
859 addFwdRefs :: [Segment a] -> [Segment a]
860 -- So far the segments only have forward refs *within* the Stmt
861 -- (which happens for bind: x <- ...x...)
862 -- This function adds the cross-seg fwd ref info
865 = fst (foldr mk_seg ([], emptyNameSet) pairs)
867 mk_seg (defs, uses, fwds, stmts) (segs, later_defs)
868 = (new_seg : segs, all_defs)
870 new_seg = (defs, uses, new_fwds, stmts)
871 all_defs = later_defs `unionNameSets` defs
872 new_fwds = fwds `unionNameSets` (uses `intersectNameSet` later_defs)
873 -- Add the downstream fwd refs here
875 ----------------------------------------------------
876 -- Glomming the singleton segments of an mdo into
877 -- minimal recursive groups.
879 -- At first I thought this was just strongly connected components, but
880 -- there's an important constraint: the order of the stmts must not change.
883 -- mdo { x <- ...y...
890 -- Here, the first stmt mention 'y', which is bound in the third.
891 -- But that means that the innocent second stmt (p <- z) gets caught
892 -- up in the recursion. And that in turn means that the binding for
893 -- 'z' has to be included... and so on.
895 -- Start at the tail { r <- x }
896 -- Now add the next one { z <- y ; r <- x }
897 -- Now add one more { q <- x ; z <- y ; r <- x }
898 -- Now one more... but this time we have to group a bunch into rec
899 -- { rec { y <- ...x... ; q <- x ; z <- y } ; r <- x }
900 -- Now one more, which we can add on without a rec
902 -- rec { y <- ...x... ; q <- x ; z <- y } ;
904 -- Finally we add the last one; since it mentions y we have to
905 -- glom it togeher with the first two groups
906 -- { rec { x <- ...y...; p <- z ; y <- ...x... ;
907 -- q <- x ; z <- y } ;
910 glomSegments :: [Segment RenamedStmt] -> [Segment [RenamedStmt]]
913 glomSegments ((defs,uses,fwds,stmt) : segs)
914 -- Actually stmts will always be a singleton
915 = (seg_defs, seg_uses, seg_fwds, seg_stmts) : others
917 segs' = glomSegments segs
918 (extras, others) = grab uses segs'
919 (ds, us, fs, ss) = unzip4 extras
921 seg_defs = plusFVs ds `plusFV` defs
922 seg_uses = plusFVs us `plusFV` uses
923 seg_fwds = plusFVs fs `plusFV` fwds
924 seg_stmts = stmt : concat ss
926 grab :: NameSet -- The client
928 -> ([Segment a], -- Needed by the 'client'
929 [Segment a]) -- Not needed by the client
930 -- The result is simply a split of the input
932 = (reverse yeses, reverse noes)
934 (noes, yeses) = span not_needed (reverse dus)
935 not_needed (defs,_,_,_) = not (intersectsNameSet defs uses)
938 ----------------------------------------------------
939 segsToStmts :: [Segment [RenamedStmt]] -> ([RenamedStmt], FreeVars)
941 segsToStmts [] = ([], emptyFVs)
942 segsToStmts ((defs, uses, fwds, ss) : segs)
943 = (new_stmt : later_stmts, later_uses `plusFV` uses)
945 (later_stmts, later_uses) = segsToStmts segs
946 new_stmt | non_rec = head ss
947 | otherwise = RecStmt ss (nameSetToList used_later) (nameSetToList fwds) []
949 non_rec = isSingleton ss && isEmptyNameSet fwds
950 used_later = defs `intersectNameSet` later_uses
951 -- The ones needed after the RecStmt
954 %************************************************************************
956 \subsubsection{Precedence Parsing}
958 %************************************************************************
960 @mkOpAppRn@ deals with operator fixities. The argument expressions
961 are assumed to be already correctly arranged. It needs the fixities
962 recorded in the OpApp nodes, because fixity info applies to the things
963 the programmer actually wrote, so you can't find it out from the Name.
965 Furthermore, the second argument is guaranteed not to be another
966 operator application. Why? Because the parser parses all
967 operator appications left-associatively, EXCEPT negation, which
968 we need to handle specially.
971 mkOpAppRn :: RenamedHsExpr -- Left operand; already rearranged
972 -> RenamedHsExpr -> Fixity -- Operator and fixity
973 -> RenamedHsExpr -- Right operand (not an OpApp, but might
977 ---------------------------
978 -- (e11 `op1` e12) `op2` e2
979 mkOpAppRn e1@(OpApp e11 op1 fix1 e12) op2 fix2 e2
981 = addErr (precParseErr (ppr_op op1,fix1) (ppr_op op2,fix2)) `thenM_`
982 returnM (OpApp e1 op2 fix2 e2)
985 = mkOpAppRn e12 op2 fix2 e2 `thenM` \ new_e ->
986 returnM (OpApp e11 op1 fix1 new_e)
988 (nofix_error, associate_right) = compareFixity fix1 fix2
990 ---------------------------
991 -- (- neg_arg) `op` e2
992 mkOpAppRn e1@(NegApp neg_arg neg_name) op2 fix2 e2
994 = addErr (precParseErr (pp_prefix_minus,negateFixity) (ppr_op op2,fix2)) `thenM_`
995 returnM (OpApp e1 op2 fix2 e2)
998 = mkOpAppRn neg_arg op2 fix2 e2 `thenM` \ new_e ->
999 returnM (NegApp new_e neg_name)
1001 (nofix_error, associate_right) = compareFixity negateFixity fix2
1003 ---------------------------
1004 -- e1 `op` - neg_arg
1005 mkOpAppRn e1 op1 fix1 e2@(NegApp neg_arg _) -- NegApp can occur on the right
1006 | not associate_right -- We *want* right association
1007 = addErr (precParseErr (ppr_op op1, fix1) (pp_prefix_minus, negateFixity)) `thenM_`
1008 returnM (OpApp e1 op1 fix1 e2)
1010 (_, associate_right) = compareFixity fix1 negateFixity
1012 ---------------------------
1014 mkOpAppRn e1 op fix e2 -- Default case, no rearrangment
1015 = ASSERT2( right_op_ok fix e2,
1016 ppr e1 $$ text "---" $$ ppr op $$ text "---" $$ ppr fix $$ text "---" $$ ppr e2
1018 returnM (OpApp e1 op fix e2)
1020 -- Parser left-associates everything, but
1021 -- derived instances may have correctly-associated things to
1022 -- in the right operarand. So we just check that the right operand is OK
1023 right_op_ok fix1 (OpApp _ _ fix2 _)
1024 = not error_please && associate_right
1026 (error_please, associate_right) = compareFixity fix1 fix2
1027 right_op_ok fix1 other
1030 -- Parser initially makes negation bind more tightly than any other operator
1031 -- And "deriving" code should respect this (use HsPar if not)
1032 mkNegAppRn neg_arg neg_name
1033 = ASSERT( not_op_app neg_arg )
1034 returnM (NegApp neg_arg neg_name)
1036 not_op_app (OpApp _ _ _ _) = False
1037 not_op_app other = True
1041 checkPrecMatch :: Bool -> Name -> RenamedMatch -> RnM ()
1043 checkPrecMatch False fn match
1046 checkPrecMatch True op (Match (p1:p2:_) _ _)
1047 -- True indicates an infix lhs
1048 = -- See comments with rnExpr (OpApp ...) about "deriving"
1049 checkPrec op p1 False `thenM_`
1050 checkPrec op p2 True
1052 checkPrecMatch True op _ = panic "checkPrecMatch"
1054 checkPrec op (ConPatIn op1 (InfixCon _ _)) right
1055 = lookupFixityRn op `thenM` \ op_fix@(Fixity op_prec op_dir) ->
1056 lookupFixityRn op1 `thenM` \ op1_fix@(Fixity op1_prec op1_dir) ->
1058 inf_ok = op1_prec > op_prec ||
1059 (op1_prec == op_prec &&
1060 (op1_dir == InfixR && op_dir == InfixR && right ||
1061 op1_dir == InfixL && op_dir == InfixL && not right))
1063 info = (ppr_op op, op_fix)
1064 info1 = (ppr_op op1, op1_fix)
1065 (infol, infor) = if right then (info, info1) else (info1, info)
1067 checkErr inf_ok (precParseErr infol infor)
1069 checkPrec op pat right
1072 -- Check precedence of (arg op) or (op arg) respectively
1073 -- If arg is itself an operator application, then either
1074 -- (a) its precedence must be higher than that of op
1075 -- (b) its precedency & associativity must be the same as that of op
1076 checkSectionPrec direction section op arg
1078 OpApp _ op fix _ -> go_for_it (ppr_op op) fix
1079 NegApp _ _ -> go_for_it pp_prefix_minus negateFixity
1083 go_for_it pp_arg_op arg_fix@(Fixity arg_prec assoc)
1084 = lookupFixityRn op_name `thenM` \ op_fix@(Fixity op_prec _) ->
1085 checkErr (op_prec < arg_prec
1086 || op_prec == arg_prec && direction == assoc)
1087 (sectionPrecErr (ppr_op op_name, op_fix)
1088 (pp_arg_op, arg_fix) section)
1092 %************************************************************************
1094 \subsubsection{Assertion utils}
1096 %************************************************************************
1099 mkAssertErrorExpr :: RnM (RenamedHsExpr, FreeVars)
1100 -- Return an expression for (assertError "Foo.hs:27")
1102 = getSrcLocM `thenM` \ sloc ->
1104 expr = HsApp (HsVar assertErrorName) (HsLit msg)
1105 msg = HsStringPrim (mkFastString (stringToUtf8 (showSDoc (ppr sloc))))
1107 returnM (expr, emptyFVs)
1110 %************************************************************************
1112 \subsubsection{Errors}
1114 %************************************************************************
1117 ppr_op op = quotes (ppr op) -- Here, op can be a Name or a (Var n), where n is a Name
1118 pp_prefix_minus = ptext SLIT("prefix `-'")
1120 nonStdGuardErr guard
1122 SLIT("accepting non-standard pattern guards (-fglasgow-exts to suppress this message)")
1126 = sep [ptext SLIT("Pattern syntax in expression context:"),
1129 doStmtListErr do_or_lc e
1130 = sep [quotes (text binder_name) <+> ptext SLIT("statements must end in expression:"),
1133 binder_name = case do_or_lc of
1138 checkTH e what = returnM () -- OK
1140 checkTH e what -- Raise an error in a stage-1 compiler
1141 = addErr (vcat [ptext SLIT("Template Haskell") <+> text what <+>
1142 ptext SLIT("illegal in a stage-1 compiler"),
1146 parStmtErr = addErr (ptext SLIT("Illegal parallel list comprehension: use -fglasgow-exts"))
1149 = hang (ptext SLIT("Implicit-parameter bindings illegal in a parallel list comprehension:")) 4