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, rnLExpr, rnExpr, rnStmts,
15 checkPrecMatch, checkTH
18 #include "HsVersions.h"
20 import {-# SOURCE #-} RnSource ( rnSrcDecls, rnBindGroupsAndThen, rnBindGroups, rnSplice )
22 -- RnSource imports RnBinds.rnTopMonoBinds, RnExpr.rnExpr
23 -- RnBinds imports RnExpr.rnMatch, etc
24 -- RnExpr imports [boot] RnSource.rnSrcDecls, RnSource.rnBinds
30 import OccName ( plusOccEnv )
31 import RnNames ( importsFromLocalDecls )
32 import RnTypes ( rnHsTypeFVs, rnLPat, rnOverLit, rnPatsAndThen, rnLit,
33 dupFieldErr, precParseErr, sectionPrecErr, patSigErr,
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 RdrName ( RdrName )
43 import UnicodeUtil ( stringToUtf8 )
44 import UniqFM ( isNullUFM )
45 import UniqSet ( emptyUniqSet )
46 import Util ( isSingleton )
47 import ListSetOps ( removeDups )
49 import SrcLoc ( Located(..), unLoc, getLoc, combineLocs, cmpLocated )
52 import List ( unzip4 )
56 ************************************************************************
60 ************************************************************************
63 rnMatch :: HsMatchContext Name -> LMatch RdrName -> RnM (LMatch Name, FreeVars)
64 rnMatch ctxt = wrapLocFstM (rnMatch' ctxt)
66 rnMatch' ctxt match@(Match pats maybe_rhs_sig grhss)
68 -- Deal with the rhs type signature
69 bindPatSigTyVarsFV rhs_sig_tys $
70 doptM Opt_GlasgowExts `thenM` \ opt_GlasgowExts ->
71 (case maybe_rhs_sig of
72 Nothing -> returnM (Nothing, emptyFVs)
73 Just ty | opt_GlasgowExts -> rnHsTypeFVs doc_sig ty `thenM` \ (ty', ty_fvs) ->
74 returnM (Just ty', ty_fvs)
75 | otherwise -> addLocErr ty patSigErr `thenM_`
76 returnM (Nothing, emptyFVs)
77 ) `thenM` \ (maybe_rhs_sig', ty_fvs) ->
80 rnPatsAndThen ctxt True pats $ \ pats' ->
81 rnGRHSs ctxt grhss `thenM` \ (grhss', grhss_fvs) ->
83 returnM (Match pats' maybe_rhs_sig' grhss', grhss_fvs `plusFV` ty_fvs)
84 -- The bindPatSigTyVarsFV and rnPatsAndThen will remove the bound FVs
86 rhs_sig_tys = case maybe_rhs_sig of
89 doc_sig = text "In a result type-signature"
93 %************************************************************************
95 \subsubsection{Guarded right-hand sides (GRHSs)}
97 %************************************************************************
100 rnGRHSs :: HsMatchContext Name -> GRHSs RdrName -> RnM (GRHSs Name, FreeVars)
102 rnGRHSs ctxt (GRHSs grhss binds _)
103 = rnBindGroupsAndThen binds $ \ binds' ->
104 mapFvRn (rnGRHS ctxt) grhss `thenM` \ (grhss', fvGRHSs) ->
105 returnM (GRHSs grhss' binds' placeHolderType, fvGRHSs)
107 rnGRHS :: HsMatchContext Name -> LGRHS RdrName -> RnM (LGRHS Name, FreeVars)
108 rnGRHS ctxt = wrapLocFstM (rnGRHS' ctxt)
110 rnGRHS' ctxt (GRHS guarded)
111 = doptM Opt_GlasgowExts `thenM` \ opt_GlasgowExts ->
112 checkM (opt_GlasgowExts || is_standard_guard guarded)
113 (addWarn (nonStdGuardErr guarded)) `thenM_`
115 rnStmts (PatGuard ctxt) guarded `thenM` \ (guarded', fvs) ->
116 returnM (GRHS guarded', fvs)
118 -- Standard Haskell 1.4 guards are just a single boolean
119 -- expression, rather than a list of qualifiers as in the
121 is_standard_guard [L _ (ResultStmt _)] = True
122 is_standard_guard [L _ (ExprStmt _ _), L _ (ResultStmt _)] = True
123 is_standard_guard other = False
126 %************************************************************************
128 \subsubsection{Expressions}
130 %************************************************************************
133 rnExprs :: [LHsExpr RdrName] -> RnM ([LHsExpr Name], FreeVars)
134 rnExprs ls = rnExprs' ls emptyUniqSet
136 rnExprs' [] acc = returnM ([], acc)
137 rnExprs' (expr:exprs) acc
138 = rnLExpr expr `thenM` \ (expr', fvExpr) ->
140 -- Now we do a "seq" on the free vars because typically it's small
141 -- or empty, especially in very long lists of constants
143 acc' = acc `plusFV` fvExpr
145 (grubby_seqNameSet acc' rnExprs') exprs acc' `thenM` \ (exprs', fvExprs) ->
146 returnM (expr':exprs', fvExprs)
148 -- Grubby little function to do "seq" on namesets; replace by proper seq when GHC can do seq
149 grubby_seqNameSet ns result | isNullUFM ns = result
153 Variables. We look up the variable and return the resulting name.
156 rnLExpr :: LHsExpr RdrName -> RnM (LHsExpr Name, FreeVars)
157 rnLExpr = wrapLocFstM rnExpr
159 rnExpr :: HsExpr RdrName -> RnM (HsExpr Name, FreeVars)
162 = lookupOccRn v `thenM` \ name ->
163 doptM Opt_IgnoreAsserts `thenM` \ ignore_asserts ->
164 if name `hasKey` assertIdKey && not ignore_asserts then
165 -- We expand it to (GHC.Err.assertError location_string)
166 mkAssertErrorExpr `thenM` \ (e, fvs) ->
167 returnM (e, fvs `addOneFV` name)
168 -- Keep 'assert' as a free var, to ensure it's not reported as unused!
170 -- The normal case. Even if the Id was 'assert', if we are
171 -- ignoring assertions we leave it as GHC.Base.assert;
172 -- this function just ignores its first arg.
173 returnM (HsVar name, unitFV name)
176 = newIPNameRn v `thenM` \ name ->
177 returnM (HsIPVar name, emptyFVs)
181 returnM (HsLit lit, emptyFVs)
183 rnExpr (HsOverLit lit)
184 = rnOverLit lit `thenM` \ (lit', fvs) ->
185 returnM (HsOverLit lit', fvs)
188 = rnMatch LambdaExpr match `thenM` \ (match', fvMatch) ->
189 returnM (HsLam match', fvMatch)
191 rnExpr (HsApp fun arg)
192 = rnLExpr fun `thenM` \ (fun',fvFun) ->
193 rnLExpr arg `thenM` \ (arg',fvArg) ->
194 returnM (HsApp fun' arg', fvFun `plusFV` fvArg)
196 rnExpr (OpApp e1 op _ e2)
197 = rnLExpr e1 `thenM` \ (e1', fv_e1) ->
198 rnLExpr e2 `thenM` \ (e2', fv_e2) ->
199 rnLExpr op `thenM` \ (op'@(L _ (HsVar op_name)), fv_op) ->
202 -- When renaming code synthesised from "deriving" declarations
203 -- we used to avoid fixity stuff, but we can't easily tell any
204 -- more, so I've removed the test. Adding HsPars in TcGenDeriv
205 -- should prevent bad things happening.
206 lookupFixityRn op_name `thenM` \ fixity ->
207 mkOpAppRn e1' op' fixity e2' `thenM` \ final_e ->
210 fv_e1 `plusFV` fv_op `plusFV` fv_e2)
213 = rnLExpr e `thenM` \ (e', fv_e) ->
214 lookupSyntaxName negateName `thenM` \ (neg_name, fv_neg) ->
215 mkNegAppRn e' neg_name `thenM` \ final_e ->
216 returnM (final_e, fv_e `plusFV` fv_neg)
219 = rnLExpr e `thenM` \ (e', fvs_e) ->
220 returnM (HsPar e', fvs_e)
222 -- Template Haskell extensions
223 -- Don't ifdef-GHCI them because we want to fail gracefully
224 -- (not with an rnExpr crash) in a stage-1 compiler.
225 rnExpr e@(HsBracket br_body)
226 = checkTH e "bracket" `thenM_`
227 rnBracket br_body `thenM` \ (body', fvs_e) ->
228 returnM (HsBracket body', fvs_e)
230 rnExpr e@(HsSpliceE splice)
231 = rnSplice splice `thenM` \ (splice', fvs) ->
232 returnM (HsSpliceE splice', fvs)
234 rnExpr section@(SectionL expr op)
235 = rnLExpr expr `thenM` \ (expr', fvs_expr) ->
236 rnLExpr op `thenM` \ (op', fvs_op) ->
237 checkSectionPrec InfixL section op' expr' `thenM_`
238 returnM (SectionL expr' op', fvs_op `plusFV` fvs_expr)
240 rnExpr section@(SectionR op expr)
241 = rnLExpr op `thenM` \ (op', fvs_op) ->
242 rnLExpr expr `thenM` \ (expr', fvs_expr) ->
243 checkSectionPrec InfixR section op' expr' `thenM_`
244 returnM (SectionR op' expr', fvs_op `plusFV` fvs_expr)
246 rnExpr (HsCoreAnn ann expr)
247 = rnLExpr expr `thenM` \ (expr', fvs_expr) ->
248 returnM (HsCoreAnn ann expr', fvs_expr)
250 rnExpr (HsSCC lbl expr)
251 = rnLExpr expr `thenM` \ (expr', fvs_expr) ->
252 returnM (HsSCC lbl expr', fvs_expr)
254 rnExpr (HsCase expr ms)
255 = rnLExpr expr `thenM` \ (new_expr, e_fvs) ->
256 mapFvRn (rnMatch CaseAlt) ms `thenM` \ (new_ms, ms_fvs) ->
257 returnM (HsCase new_expr new_ms, e_fvs `plusFV` ms_fvs)
259 rnExpr (HsLet binds expr)
260 = rnBindGroupsAndThen binds $ \ binds' ->
261 rnLExpr expr `thenM` \ (expr',fvExpr) ->
262 returnM (HsLet binds' expr', fvExpr)
264 rnExpr e@(HsDo do_or_lc stmts _ _)
265 = rnStmts do_or_lc stmts `thenM` \ (stmts', fvs) ->
267 -- Check the statement list ends in an expression
268 case last stmts' of {
269 L _ (ResultStmt _) -> returnM () ;
270 other -> addLocErr other (doStmtListErr do_or_lc)
273 -- Generate the rebindable syntax for the monad
274 lookupSyntaxNames syntax_names `thenM` \ (syntax_names', monad_fvs) ->
276 returnM (HsDo do_or_lc stmts' syntax_names' placeHolderType, 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 = lookupLocatedOccRn con_id `thenM` \ conname ->
301 rnRbinds "construction" rbinds `thenM` \ (rbinds', fvRbinds) ->
302 returnM (RecordCon conname rbinds', fvRbinds `addOneFV` unLoc conname)
304 rnExpr (RecordUpd expr rbinds)
305 = rnLExpr 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 = rnLExpr 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)
317 = rnLExpr p `thenM` \ (p', fvP) ->
318 rnLExpr b1 `thenM` \ (b1', fvB1) ->
319 rnLExpr b2 `thenM` \ (b2', fvB2) ->
320 returnM (HsIf p' b1' b2', plusFVs [fvP, fvB1, fvB2])
323 = rnHsTypeFVs doc a `thenM` \ (t, fvT) ->
324 returnM (HsType t, fvT)
326 doc = text "In a type argument"
328 rnExpr (ArithSeqIn seq)
329 = rnArithSeq seq `thenM` \ (new_seq, fvs) ->
330 returnM (ArithSeqIn new_seq, fvs)
332 rnExpr (PArrSeqIn seq)
333 = rnArithSeq seq `thenM` \ (new_seq, fvs) ->
334 returnM (PArrSeqIn new_seq, fvs)
337 These three are pattern syntax appearing in expressions.
338 Since all the symbols are reservedops we can simply reject them.
339 We return a (bogus) EWildPat in each case.
342 rnExpr e@EWildPat = addErr (patSynErr e) `thenM_`
343 returnM (EWildPat, emptyFVs)
345 rnExpr e@(EAsPat _ _) = addErr (patSynErr e) `thenM_`
346 returnM (EWildPat, emptyFVs)
348 rnExpr e@(ELazyPat _) = addErr (patSynErr e) `thenM_`
349 returnM (EWildPat, emptyFVs)
352 %************************************************************************
356 %************************************************************************
359 rnExpr (HsProc pat body)
360 = rnPatsAndThen ProcExpr True [pat] $ \ [pat'] ->
361 rnCmdTop body `thenM` \ (body',fvBody) ->
362 returnM (HsProc pat' body', fvBody)
364 rnExpr (HsArrApp arrow arg _ ho rtl)
365 = rnLExpr arrow `thenM` \ (arrow',fvArrow) ->
366 rnLExpr arg `thenM` \ (arg',fvArg) ->
367 returnM (HsArrApp arrow' arg' placeHolderType ho rtl,
368 fvArrow `plusFV` fvArg)
371 rnExpr (HsArrForm op (Just _) [arg1, arg2])
372 = rnLExpr op `thenM` \ (op'@(L _ (HsVar op_name)),fv_op) ->
373 rnCmdTop arg1 `thenM` \ (arg1',fv_arg1) ->
374 rnCmdTop arg2 `thenM` \ (arg2',fv_arg2) ->
378 lookupFixityRn op_name `thenM` \ fixity ->
379 mkOpFormRn arg1' op' fixity arg2' `thenM` \ final_e ->
382 fv_arg1 `plusFV` fv_op `plusFV` fv_arg2)
384 rnExpr (HsArrForm op fixity cmds)
385 = rnLExpr op `thenM` \ (op',fvOp) ->
386 rnCmdArgs cmds `thenM` \ (cmds',fvCmds) ->
387 returnM (HsArrForm op' fixity cmds', fvOp `plusFV` fvCmds)
389 ---------------------------
390 -- Deal with fixity (cf mkOpAppRn for the method)
392 mkOpFormRn :: LHsCmdTop Name -- Left operand; already rearranged
393 -> LHsExpr Name -> Fixity -- Operator and fixity
394 -> LHsCmdTop Name -- Right operand (not an infix)
397 ---------------------------
398 -- (e11 `op1` e12) `op2` e2
399 mkOpFormRn a1@(L loc (HsCmdTop (L _ (HsArrForm op1 (Just fix1) [a11,a12])) _ _ _))
402 = addErr (precParseErr (ppr_op op1,fix1) (ppr_op op2,fix2)) `thenM_`
403 returnM (HsArrForm op2 (Just fix2) [a1, a2])
406 = mkOpFormRn a12 op2 fix2 a2 `thenM` \ new_c ->
407 returnM (HsArrForm op1 (Just fix1)
408 [a11, L loc (HsCmdTop (L loc new_c) [] placeHolderType [])])
409 -- TODO: locs are wrong
411 (nofix_error, associate_right) = compareFixity fix1 fix2
413 ---------------------------
415 mkOpFormRn arg1 op fix arg2 -- Default case, no rearrangment
416 = returnM (HsArrForm op (Just fix) [arg1, arg2])
421 %************************************************************************
425 %************************************************************************
428 rnCmdArgs [] = returnM ([], emptyFVs)
430 = rnCmdTop arg `thenM` \ (arg',fvArg) ->
431 rnCmdArgs args `thenM` \ (args',fvArgs) ->
432 returnM (arg':args', fvArg `plusFV` fvArgs)
435 rnCmdTop = wrapLocFstM rnCmdTop'
437 rnCmdTop' (HsCmdTop cmd _ _ _)
438 = rnLExpr (convertOpFormsLCmd cmd) `thenM` \ (cmd', fvCmd) ->
440 cmd_names = [arrAName, composeAName, firstAName] ++
441 nameSetToList (methodNamesCmd (unLoc cmd'))
443 -- Generate the rebindable syntax for the monad
444 lookupSyntaxNames cmd_names `thenM` \ (cmd_names', cmd_fvs) ->
446 returnM (HsCmdTop cmd' [] placeHolderType cmd_names',
447 fvCmd `plusFV` cmd_fvs)
449 ---------------------------------------------------
450 -- convert OpApp's in a command context to HsArrForm's
452 convertOpFormsLCmd :: LHsCmd id -> LHsCmd id
453 convertOpFormsLCmd = fmap convertOpFormsCmd
455 convertOpFormsCmd :: HsCmd id -> HsCmd id
457 convertOpFormsCmd (HsApp c e) = HsApp (convertOpFormsLCmd c) e
459 convertOpFormsCmd (HsLam match) = HsLam (convertOpFormsMatch match)
461 convertOpFormsCmd (OpApp c1 op fixity c2)
463 arg1 = L (getLoc c1) $ HsCmdTop (convertOpFormsLCmd c1) [] placeHolderType []
464 arg2 = L (getLoc c2) $ HsCmdTop (convertOpFormsLCmd c2) [] placeHolderType []
466 HsArrForm op (Just fixity) [arg1, arg2]
468 convertOpFormsCmd (HsPar c) = HsPar (convertOpFormsLCmd c)
470 convertOpFormsCmd (HsCase exp matches)
471 = HsCase exp (map convertOpFormsMatch matches)
473 convertOpFormsCmd (HsIf exp c1 c2)
474 = HsIf exp (convertOpFormsLCmd c1) (convertOpFormsLCmd c2)
476 convertOpFormsCmd (HsLet binds cmd)
477 = HsLet binds (convertOpFormsLCmd cmd)
479 convertOpFormsCmd (HsDo ctxt stmts ids ty)
480 = HsDo ctxt (map (fmap convertOpFormsStmt) stmts) ids ty
482 -- Anything else is unchanged. This includes HsArrForm (already done),
483 -- things with no sub-commands, and illegal commands (which will be
484 -- caught by the type checker)
485 convertOpFormsCmd c = c
487 convertOpFormsStmt (BindStmt pat cmd)
488 = BindStmt pat (convertOpFormsLCmd cmd)
489 convertOpFormsStmt (ResultStmt cmd)
490 = ResultStmt (convertOpFormsLCmd cmd)
491 convertOpFormsStmt (ExprStmt cmd ty)
492 = ExprStmt (convertOpFormsLCmd cmd) ty
493 convertOpFormsStmt (RecStmt stmts lvs rvs es)
494 = RecStmt (map (fmap convertOpFormsStmt) stmts) lvs rvs es
495 convertOpFormsStmt stmt = stmt
497 convertOpFormsMatch = fmap convert
498 where convert (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 = fmap convert
505 where convert (GRHS stmts)
507 (L loc (ResultStmt cmd)) = last stmts
509 GRHS (init stmts ++ [L loc (ResultStmt (convertOpFormsLCmd cmd))])
511 ---------------------------------------------------
512 type CmdNeeds = FreeVars -- Only inhabitants are
513 -- appAName, choiceAName, loopAName
515 -- find what methods the Cmd needs (loop, choice, apply)
516 methodNamesLCmd :: LHsCmd Name -> CmdNeeds
517 methodNamesLCmd = methodNamesCmd . unLoc
519 methodNamesCmd :: HsCmd Name -> CmdNeeds
521 methodNamesCmd cmd@(HsArrApp _arrow _arg _ HsFirstOrderApp _rtl)
523 methodNamesCmd cmd@(HsArrApp _arrow _arg _ HsHigherOrderApp _rtl)
525 methodNamesCmd cmd@(HsArrForm {}) = emptyFVs
527 methodNamesCmd (HsPar c) = methodNamesLCmd c
529 methodNamesCmd (HsIf p c1 c2)
530 = methodNamesLCmd c1 `plusFV` methodNamesLCmd c2 `addOneFV` choiceAName
532 methodNamesCmd (HsLet b c) = methodNamesLCmd c
534 methodNamesCmd (HsDo sc stmts rbs ty) = methodNamesStmts stmts
536 methodNamesCmd (HsApp c e) = methodNamesLCmd c
538 methodNamesCmd (HsLam match) = methodNamesMatch match
540 methodNamesCmd (HsCase scrut matches)
541 = plusFVs (map methodNamesMatch matches) `addOneFV` choiceAName
543 methodNamesCmd other = emptyFVs
544 -- Other forms can't occur in commands, but it's not convenient
545 -- to error here so we just do what's convenient.
546 -- The type checker will complain later
548 ---------------------------------------------------
549 methodNamesMatch (L _ (Match pats sig_ty grhss)) = methodNamesGRHSs grhss
551 -------------------------------------------------
552 methodNamesGRHSs (GRHSs grhss binds ty) = plusFVs (map methodNamesGRHS grhss)
554 -------------------------------------------------
555 methodNamesGRHS (L _ (GRHS stmts)) = methodNamesLStmt (last stmts)
557 ---------------------------------------------------
558 methodNamesStmts stmts = plusFVs (map methodNamesLStmt stmts)
560 ---------------------------------------------------
561 methodNamesLStmt = methodNamesStmt . unLoc
563 methodNamesStmt (ResultStmt cmd) = methodNamesLCmd cmd
564 methodNamesStmt (ExprStmt cmd ty) = methodNamesLCmd cmd
565 methodNamesStmt (BindStmt pat cmd ) = methodNamesLCmd cmd
566 methodNamesStmt (RecStmt stmts lvs rvs es)
567 = methodNamesStmts stmts `addOneFV` loopAName
568 methodNamesStmt (LetStmt b) = emptyFVs
569 methodNamesStmt (ParStmt ss) = emptyFVs
570 -- ParStmt can't occur in commands, but it's not convenient to error
571 -- here so we just do what's convenient
575 %************************************************************************
579 %************************************************************************
582 rnArithSeq (From expr)
583 = rnLExpr expr `thenM` \ (expr', fvExpr) ->
584 returnM (From expr', fvExpr)
586 rnArithSeq (FromThen expr1 expr2)
587 = rnLExpr expr1 `thenM` \ (expr1', fvExpr1) ->
588 rnLExpr expr2 `thenM` \ (expr2', fvExpr2) ->
589 returnM (FromThen expr1' expr2', fvExpr1 `plusFV` fvExpr2)
591 rnArithSeq (FromTo expr1 expr2)
592 = rnLExpr expr1 `thenM` \ (expr1', fvExpr1) ->
593 rnLExpr expr2 `thenM` \ (expr2', fvExpr2) ->
594 returnM (FromTo expr1' expr2', fvExpr1 `plusFV` fvExpr2)
596 rnArithSeq (FromThenTo expr1 expr2 expr3)
597 = rnLExpr expr1 `thenM` \ (expr1', fvExpr1) ->
598 rnLExpr expr2 `thenM` \ (expr2', fvExpr2) ->
599 rnLExpr expr3 `thenM` \ (expr3', fvExpr3) ->
600 returnM (FromThenTo expr1' expr2' expr3',
601 plusFVs [fvExpr1, fvExpr2, fvExpr3])
605 %************************************************************************
607 \subsubsection{@Rbinds@s and @Rpats@s: in record expressions}
609 %************************************************************************
613 = mappM_ field_dup_err dup_fields `thenM_`
614 mapFvRn rn_rbind rbinds `thenM` \ (rbinds', fvRbind) ->
615 returnM (rbinds', fvRbind)
617 (_, dup_fields) = removeDups cmpLocated [ f | (f,_) <- rbinds ]
619 field_dup_err dups = mappM_ (\f -> addLocErr f (dupFieldErr str)) dups
621 rn_rbind (field, expr)
622 = lookupLocatedGlobalOccRn field `thenM` \ fieldname ->
623 rnLExpr expr `thenM` \ (expr', fvExpr) ->
624 returnM ((fieldname, expr'), fvExpr `addOneFV` unLoc fieldname)
627 %************************************************************************
629 Template Haskell brackets
631 %************************************************************************
634 rnBracket (VarBr n) = lookupOccRn n `thenM` \ name ->
635 returnM (VarBr name, unitFV name)
636 rnBracket (ExpBr e) = rnLExpr e `thenM` \ (e', fvs) ->
637 returnM (ExpBr e', fvs)
638 rnBracket (PatBr p) = rnLPat p `thenM` \ (p', fvs) ->
639 returnM (PatBr p', fvs)
640 rnBracket (TypBr t) = rnHsTypeFVs doc t `thenM` \ (t', fvs) ->
641 returnM (TypBr t', fvs)
643 doc = ptext SLIT("In a Template-Haskell quoted type")
644 rnBracket (DecBr group)
645 = importsFromLocalDecls group `thenM` \ (rdr_env, avails) ->
646 -- Discard avails (not useful here)
648 updGblEnv (\gbl -> gbl { tcg_rdr_env = tcg_rdr_env gbl `plusOccEnv` rdr_env}) $
649 -- Notice plusOccEnv, not plusGlobalRdrEnv. In this situation we want
650 -- to *shadow* top-level bindings. E.g.
652 -- bar = [d| foo = 1|]
653 -- So we drop down to plusOccEnv. (Perhaps there should be a fn in RdrName.)
655 rnSrcDecls group `thenM` \ (tcg_env, group') ->
656 -- Discard the tcg_env; it contains only extra info about fixity
658 dus = tcg_dus tcg_env
660 returnM (DecBr group', allUses dus)
663 %************************************************************************
665 \subsubsection{@Stmt@s: in @do@ expressions}
667 %************************************************************************
670 rnStmts :: HsStmtContext Name -> [LStmt RdrName] -> RnM ([LStmt Name], FreeVars)
672 rnStmts MDoExpr = rnMDoStmts
673 rnStmts ctxt = rnNormalStmts ctxt
675 rnNormalStmts :: HsStmtContext Name -> [LStmt RdrName] -> RnM ([LStmt Name], FreeVars)
676 -- Used for cases *other* than recursive mdo
677 -- Implements nested scopes
679 rnNormalStmts ctxt [] = returnM ([], emptyFVs)
680 -- Happens at the end of the sub-lists of a ParStmts
682 rnNormalStmts ctxt (L loc (ExprStmt expr _) : stmts)
683 = rnLExpr expr `thenM` \ (expr', fv_expr) ->
684 rnNormalStmts ctxt stmts `thenM` \ (stmts', fvs) ->
685 returnM (L loc (ExprStmt expr' placeHolderType) : stmts',
686 fv_expr `plusFV` fvs)
688 rnNormalStmts ctxt [L loc (ResultStmt expr)]
689 = rnLExpr expr `thenM` \ (expr', fv_expr) ->
690 returnM ([L loc (ResultStmt expr')], fv_expr)
692 rnNormalStmts ctxt (L loc (BindStmt pat expr) : stmts)
693 = rnLExpr expr `thenM` \ (expr', fv_expr) ->
694 -- The binders do not scope over the expression
699 ParStmtCtxt{} -> False
702 rnPatsAndThen (StmtCtxt ctxt) reportUnused [pat] $ \ [pat'] ->
703 rnNormalStmts ctxt stmts `thenM` \ (stmts', fvs) ->
704 returnM (L loc (BindStmt pat' expr') : stmts',
705 fv_expr `plusFV` fvs) -- fv_expr shouldn't really be filtered by
706 -- the rnPatsAndThen, but it does not matter
708 rnNormalStmts ctxt (L loc (LetStmt binds) : stmts)
709 = checkErr (ok ctxt binds) (badIpBinds binds) `thenM_`
710 rnBindGroupsAndThen binds ( \ binds' ->
711 rnNormalStmts ctxt stmts `thenM` \ (stmts', fvs) ->
712 returnM (L loc (LetStmt binds') : stmts', fvs))
714 -- We do not allow implicit-parameter bindings in a parallel
715 -- list comprehension. I'm not sure what it might mean.
716 ok (ParStmtCtxt _) binds = not (any is_ip_bind binds)
719 is_ip_bind (HsIPBinds _) = True
722 rnNormalStmts ctxt (L loc (ParStmt stmtss) : stmts)
723 = doptM Opt_GlasgowExts `thenM` \ opt_GlasgowExts ->
724 checkM opt_GlasgowExts parStmtErr `thenM_`
725 mapFvRn rn_branch stmtss `thenM` \ (stmtss', fv_stmtss) ->
727 bndrss :: [[Name]] -- NB: Name, not RdrName
728 bndrss = map (map unLoc . collectStmtsBinders) stmtss'
729 (bndrs, dups) = removeDups cmpByOcc (concat bndrss)
731 mappM dupErr dups `thenM` \ _ ->
732 bindLocalNamesFV bndrs $
733 -- Note: binders are returned in scope order, so one may
734 -- shadow the next; e.g. x <- xs; x <- ys
735 rnNormalStmts ctxt stmts `thenM` \ (stmts', fvs) ->
737 -- Cut down the exported binders to just the ones needed in the body
739 used_bndrs_s = map (filter (`elemNameSet` fvs)) bndrss
740 unused_bndrs = filter (not . (`elemNameSet` fvs)) bndrs
742 -- With processing of the branches and the tail of comprehension done,
743 -- we can finally compute&report any unused ParStmt binders.
744 warnUnusedMatches unused_bndrs `thenM_`
745 returnM (L loc (ParStmt (stmtss' `zip` used_bndrs_s)) : stmts',
746 fv_stmtss `plusFV` fvs)
748 rn_branch (stmts, _) = rnNormalStmts (ParStmtCtxt ctxt) stmts
750 cmpByOcc n1 n2 = nameOccName n1 `compare` nameOccName n2
751 dupErr (v:_) = addErr (ptext SLIT("Duplicate binding in parallel list comprehension for:")
754 rnNormalStmts ctxt (L loc (RecStmt rec_stmts _ _ _) : stmts)
755 = bindLocatedLocalsRn doc (collectStmtsBinders rec_stmts) $ \ _ ->
756 rn_rec_stmts rec_stmts `thenM` \ segs ->
757 rnNormalStmts ctxt stmts `thenM` \ (stmts', fvs) ->
759 segs_w_fwd_refs = addFwdRefs segs
760 (ds, us, fs, rec_stmts') = unzip4 segs_w_fwd_refs
761 later_vars = nameSetToList (plusFVs ds `intersectNameSet` fvs)
762 fwd_vars = nameSetToList (plusFVs fs)
765 returnM (L loc (RecStmt rec_stmts' later_vars fwd_vars []) : stmts',
768 doc = text "In a recursive do statement"
772 %************************************************************************
774 \subsubsection{mdo expressions}
776 %************************************************************************
779 type FwdRefs = NameSet
780 type Segment stmts = (Defs,
781 Uses, -- May include defs
782 FwdRefs, -- A subset of uses that are
783 -- (a) used before they are bound in this segment, or
784 -- (b) used here, and bound in subsequent segments
785 stmts) -- Either Stmt or [Stmt]
788 ----------------------------------------------------
789 rnMDoStmts :: [LStmt RdrName] -> RnM ([LStmt Name], FreeVars)
791 = -- Step1: bring all the binders of the mdo into scope
792 -- Remember that this also removes the binders from the
793 -- finally-returned free-vars
794 bindLocatedLocalsRn doc (collectStmtsBinders stmts) $ \ _ ->
796 -- Step 2: Rename each individual stmt, making a
797 -- singleton segment. At this stage the FwdRefs field
798 -- isn't finished: it's empty for all except a BindStmt
799 -- for which it's the fwd refs within the bind itself
800 -- (This set may not be empty, because we're in a recursive
802 rn_rec_stmts stmts `thenM` \ segs ->
804 -- Step 3: Fill in the fwd refs.
805 -- The segments are all singletons, but their fwd-ref
806 -- field mentions all the things used by the segment
807 -- that are bound after their use
808 segs_w_fwd_refs = addFwdRefs segs
810 -- Step 4: Group together the segments to make bigger segments
811 -- Invariant: in the result, no segment uses a variable
812 -- bound in a later segment
813 grouped_segs = glomSegments segs_w_fwd_refs
815 -- Step 5: Turn the segments into Stmts
816 -- Use RecStmt when and only when there are fwd refs
817 -- Also gather up the uses from the end towards the
818 -- start, so we can tell the RecStmt which things are
819 -- used 'after' the RecStmt
820 stmts_w_fvs = segsToStmts grouped_segs
824 doc = text "In a mdo-expression"
827 ----------------------------------------------------
828 rn_rec_stmt :: LStmt RdrName -> RnM [Segment (LStmt Name)]
829 -- Rename a Stmt that is inside a RecStmt (or mdo)
830 -- Assumes all binders are already in scope
831 -- Turns each stmt into a singleton Stmt
833 rn_rec_stmt (L loc (ExprStmt expr _))
834 = rnLExpr expr `thenM` \ (expr', fvs) ->
835 returnM [(emptyNameSet, fvs, emptyNameSet,
836 L loc (ExprStmt expr' placeHolderType))]
838 rn_rec_stmt (L loc (ResultStmt expr))
839 = rnLExpr expr `thenM` \ (expr', fvs) ->
840 returnM [(emptyNameSet, fvs, emptyNameSet,
841 L loc (ResultStmt expr'))]
843 rn_rec_stmt (L loc (BindStmt pat expr))
844 = rnLExpr expr `thenM` \ (expr', fv_expr) ->
845 rnLPat pat `thenM` \ (pat', fv_pat) ->
847 bndrs = mkNameSet (collectPatBinders pat')
848 fvs = fv_expr `plusFV` fv_pat
850 returnM [(bndrs, fvs, bndrs `intersectNameSet` fvs,
851 L loc (BindStmt pat' expr'))]
853 rn_rec_stmt (L loc (LetStmt binds))
854 = rnBindGroups binds `thenM` \ (binds', du_binds) ->
855 returnM [(duDefs du_binds, duUses du_binds,
856 emptyNameSet, L loc (LetStmt binds'))]
858 rn_rec_stmt (L loc (RecStmt stmts _ _ _)) -- Flatten Rec inside Rec
861 rn_rec_stmt stmt@(L _ (ParStmt _)) -- Syntactically illegal in mdo
862 = pprPanic "rn_rec_stmt" (ppr stmt)
864 ---------------------------------------------
865 rn_rec_stmts :: [LStmt RdrName] -> RnM [Segment (LStmt Name)]
866 rn_rec_stmts stmts = mappM rn_rec_stmt stmts `thenM` \ segs_s ->
867 returnM (concat segs_s)
870 ---------------------------------------------
871 addFwdRefs :: [Segment a] -> [Segment a]
872 -- So far the segments only have forward refs *within* the Stmt
873 -- (which happens for bind: x <- ...x...)
874 -- This function adds the cross-seg fwd ref info
877 = fst (foldr mk_seg ([], emptyNameSet) pairs)
879 mk_seg (defs, uses, fwds, stmts) (segs, later_defs)
880 = (new_seg : segs, all_defs)
882 new_seg = (defs, uses, new_fwds, stmts)
883 all_defs = later_defs `unionNameSets` defs
884 new_fwds = fwds `unionNameSets` (uses `intersectNameSet` later_defs)
885 -- Add the downstream fwd refs here
887 ----------------------------------------------------
888 -- Glomming the singleton segments of an mdo into
889 -- minimal recursive groups.
891 -- At first I thought this was just strongly connected components, but
892 -- there's an important constraint: the order of the stmts must not change.
895 -- mdo { x <- ...y...
902 -- Here, the first stmt mention 'y', which is bound in the third.
903 -- But that means that the innocent second stmt (p <- z) gets caught
904 -- up in the recursion. And that in turn means that the binding for
905 -- 'z' has to be included... and so on.
907 -- Start at the tail { r <- x }
908 -- Now add the next one { z <- y ; r <- x }
909 -- Now add one more { q <- x ; z <- y ; r <- x }
910 -- Now one more... but this time we have to group a bunch into rec
911 -- { rec { y <- ...x... ; q <- x ; z <- y } ; r <- x }
912 -- Now one more, which we can add on without a rec
914 -- rec { y <- ...x... ; q <- x ; z <- y } ;
916 -- Finally we add the last one; since it mentions y we have to
917 -- glom it togeher with the first two groups
918 -- { rec { x <- ...y...; p <- z ; y <- ...x... ;
919 -- q <- x ; z <- y } ;
922 glomSegments :: [Segment (LStmt Name)] -> [Segment [LStmt Name]]
925 glomSegments ((defs,uses,fwds,stmt) : segs)
926 -- Actually stmts will always be a singleton
927 = (seg_defs, seg_uses, seg_fwds, seg_stmts) : others
929 segs' = glomSegments segs
930 (extras, others) = grab uses segs'
931 (ds, us, fs, ss) = unzip4 extras
933 seg_defs = plusFVs ds `plusFV` defs
934 seg_uses = plusFVs us `plusFV` uses
935 seg_fwds = plusFVs fs `plusFV` fwds
936 seg_stmts = stmt : concat ss
938 grab :: NameSet -- The client
940 -> ([Segment a], -- Needed by the 'client'
941 [Segment a]) -- Not needed by the client
942 -- The result is simply a split of the input
944 = (reverse yeses, reverse noes)
946 (noes, yeses) = span not_needed (reverse dus)
947 not_needed (defs,_,_,_) = not (intersectsNameSet defs uses)
950 ----------------------------------------------------
951 segsToStmts :: [Segment [LStmt Name]] -> ([LStmt Name], FreeVars)
953 segsToStmts [] = ([], emptyFVs)
954 segsToStmts ((defs, uses, fwds, ss) : segs)
955 = ASSERT( not (null ss) )
956 (new_stmt : later_stmts, later_uses `plusFV` uses)
958 (later_stmts, later_uses) = segsToStmts segs
959 new_stmt | non_rec = head ss
960 | otherwise = L (getLoc (head ss)) $
961 RecStmt ss (nameSetToList used_later) (nameSetToList fwds) []
963 non_rec = isSingleton ss && isEmptyNameSet fwds
964 used_later = defs `intersectNameSet` later_uses
965 -- The ones needed after the RecStmt
968 %************************************************************************
970 \subsubsection{Precedence Parsing}
972 %************************************************************************
974 @mkOpAppRn@ deals with operator fixities. The argument expressions
975 are assumed to be already correctly arranged. It needs the fixities
976 recorded in the OpApp nodes, because fixity info applies to the things
977 the programmer actually wrote, so you can't find it out from the Name.
979 Furthermore, the second argument is guaranteed not to be another
980 operator application. Why? Because the parser parses all
981 operator appications left-associatively, EXCEPT negation, which
982 we need to handle specially.
985 mkOpAppRn :: LHsExpr Name -- Left operand; already rearranged
986 -> LHsExpr Name -> Fixity -- Operator and fixity
987 -> LHsExpr Name -- Right operand (not an OpApp, but might
991 ---------------------------
992 -- (e11 `op1` e12) `op2` e2
993 mkOpAppRn e1@(L _ (OpApp e11 op1 fix1 e12)) op2 fix2 e2
995 = addErr (precParseErr (ppr_op op1,fix1) (ppr_op op2,fix2)) `thenM_`
996 returnM (OpApp e1 op2 fix2 e2)
999 = mkOpAppRn e12 op2 fix2 e2 `thenM` \ new_e ->
1000 returnM (OpApp e11 op1 fix1 (L loc' new_e))
1002 loc'= combineLocs e12 e2
1003 (nofix_error, associate_right) = compareFixity fix1 fix2
1005 ---------------------------
1006 -- (- neg_arg) `op` e2
1007 mkOpAppRn e1@(L _ (NegApp neg_arg neg_name)) op2 fix2 e2
1009 = addErr (precParseErr (pp_prefix_minus,negateFixity) (ppr_op op2,fix2)) `thenM_`
1010 returnM (OpApp e1 op2 fix2 e2)
1013 = mkOpAppRn neg_arg op2 fix2 e2 `thenM` \ new_e ->
1014 returnM (NegApp (L loc' new_e) neg_name)
1016 loc' = combineLocs neg_arg e2
1017 (nofix_error, associate_right) = compareFixity negateFixity fix2
1019 ---------------------------
1020 -- e1 `op` - neg_arg
1021 mkOpAppRn e1 op1 fix1 e2@(L _ (NegApp neg_arg _)) -- NegApp can occur on the right
1022 | not associate_right -- We *want* right association
1023 = addErr (precParseErr (ppr_op op1, fix1) (pp_prefix_minus, negateFixity)) `thenM_`
1024 returnM (OpApp e1 op1 fix1 e2)
1026 (_, associate_right) = compareFixity fix1 negateFixity
1028 ---------------------------
1030 mkOpAppRn e1 op fix e2 -- Default case, no rearrangment
1031 = ASSERT2( right_op_ok fix (unLoc e2),
1032 ppr e1 $$ text "---" $$ ppr op $$ text "---" $$ ppr fix $$ text "---" $$ ppr e2
1034 returnM (OpApp e1 op fix e2)
1036 -- Parser left-associates everything, but
1037 -- derived instances may have correctly-associated things to
1038 -- in the right operarand. So we just check that the right operand is OK
1039 right_op_ok fix1 (OpApp _ _ fix2 _)
1040 = not error_please && associate_right
1042 (error_please, associate_right) = compareFixity fix1 fix2
1043 right_op_ok fix1 other
1046 -- Parser initially makes negation bind more tightly than any other operator
1047 -- And "deriving" code should respect this (use HsPar if not)
1048 mkNegAppRn :: LHsExpr id -> SyntaxName -> RnM (HsExpr id)
1049 mkNegAppRn neg_arg neg_name
1050 = ASSERT( not_op_app (unLoc neg_arg) )
1051 returnM (NegApp neg_arg neg_name)
1053 not_op_app (OpApp _ _ _ _) = False
1054 not_op_app other = True
1058 checkPrecMatch :: Bool -> Name -> LMatch Name -> RnM ()
1060 checkPrecMatch False fn match
1063 checkPrecMatch True op (L _ (Match (p1:p2:_) _ _))
1064 -- True indicates an infix lhs
1065 = -- See comments with rnExpr (OpApp ...) about "deriving"
1066 checkPrec op (unLoc p1) False `thenM_`
1067 checkPrec op (unLoc p2) True
1069 checkPrecMatch True op _ = panic "checkPrecMatch"
1071 checkPrec op (ConPatIn op1 (InfixCon _ _)) right
1072 = lookupFixityRn op `thenM` \ op_fix@(Fixity op_prec op_dir) ->
1073 lookupFixityRn (unLoc op1) `thenM` \ op1_fix@(Fixity op1_prec op1_dir) ->
1075 inf_ok = op1_prec > op_prec ||
1076 (op1_prec == op_prec &&
1077 (op1_dir == InfixR && op_dir == InfixR && right ||
1078 op1_dir == InfixL && op_dir == InfixL && not right))
1080 info = (ppr_op op, op_fix)
1081 info1 = (ppr_op op1, op1_fix)
1082 (infol, infor) = if right then (info, info1) else (info1, info)
1084 checkErr inf_ok (precParseErr infol infor)
1086 checkPrec op pat right
1089 -- Check precedence of (arg op) or (op arg) respectively
1090 -- If arg is itself an operator application, then either
1091 -- (a) its precedence must be higher than that of op
1092 -- (b) its precedency & associativity must be the same as that of op
1093 checkSectionPrec :: FixityDirection -> HsExpr RdrName
1094 -> LHsExpr Name -> LHsExpr Name -> RnM ()
1095 checkSectionPrec direction section op arg
1097 OpApp _ op fix _ -> go_for_it (ppr_op op) fix
1098 NegApp _ _ -> go_for_it pp_prefix_minus negateFixity
1101 L _ (HsVar op_name) = op
1102 go_for_it pp_arg_op arg_fix@(Fixity arg_prec assoc)
1103 = lookupFixityRn op_name `thenM` \ op_fix@(Fixity op_prec _) ->
1104 checkErr (op_prec < arg_prec
1105 || op_prec == arg_prec && direction == assoc)
1106 (sectionPrecErr (ppr_op op_name, op_fix)
1107 (pp_arg_op, arg_fix) section)
1111 %************************************************************************
1113 \subsubsection{Assertion utils}
1115 %************************************************************************
1118 mkAssertErrorExpr :: RnM (HsExpr Name, FreeVars)
1119 -- Return an expression for (assertError "Foo.hs:27")
1121 = getSrcSpanM `thenM` \ sloc ->
1123 expr = HsApp (L sloc (HsVar assertErrorName)) (L sloc (HsLit msg))
1124 msg = HsStringPrim (mkFastString (stringToUtf8 (showSDoc (ppr sloc))))
1126 returnM (expr, emptyFVs)
1129 %************************************************************************
1131 \subsubsection{Errors}
1133 %************************************************************************
1136 ppr_op op = quotes (ppr op) -- Here, op can be a Name or a (Var n), where n is a Name
1137 pp_prefix_minus = ptext SLIT("prefix `-'")
1139 nonStdGuardErr guard
1141 SLIT("accepting non-standard pattern guards (-fglasgow-exts to suppress this message)")
1145 = sep [ptext SLIT("Pattern syntax in expression context:"),
1148 doStmtListErr do_or_lc e
1149 = sep [quotes (text binder_name) <+> ptext SLIT("statements must end in expression:"),
1152 binder_name = case do_or_lc of
1157 checkTH e what = returnM () -- OK
1159 checkTH e what -- Raise an error in a stage-1 compiler
1160 = addErr (vcat [ptext SLIT("Template Haskell") <+> text what <+>
1161 ptext SLIT("illegal in a stage-1 compiler"),
1165 parStmtErr = addErr (ptext SLIT("Illegal parallel list comprehension: use -fglasgow-exts"))
1168 = hang (ptext SLIT("Implicit-parameter bindings illegal in a parallel list comprehension:")) 4