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 rnMatchGroup, 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 rnMatchGroup :: HsMatchContext Name -> MatchGroup RdrName -> RnM (MatchGroup Name, FreeVars)
64 rnMatchGroup ctxt (MatchGroup ms _)
65 = mapFvRn (rnMatch ctxt) ms `thenM` \ (new_ms, ms_fvs) ->
66 returnM (MatchGroup new_ms placeHolderType, ms_fvs)
68 rnMatch :: HsMatchContext Name -> LMatch RdrName -> RnM (LMatch Name, FreeVars)
69 rnMatch ctxt = wrapLocFstM (rnMatch' ctxt)
71 rnMatch' ctxt match@(Match pats maybe_rhs_sig grhss)
73 -- Deal with the rhs type signature
74 bindPatSigTyVarsFV rhs_sig_tys $
75 doptM Opt_GlasgowExts `thenM` \ opt_GlasgowExts ->
76 (case maybe_rhs_sig of
77 Nothing -> returnM (Nothing, emptyFVs)
78 Just ty | opt_GlasgowExts -> rnHsTypeFVs doc_sig ty `thenM` \ (ty', ty_fvs) ->
79 returnM (Just ty', ty_fvs)
80 | otherwise -> addLocErr ty patSigErr `thenM_`
81 returnM (Nothing, emptyFVs)
82 ) `thenM` \ (maybe_rhs_sig', ty_fvs) ->
85 rnPatsAndThen ctxt True pats $ \ pats' ->
86 rnGRHSs ctxt grhss `thenM` \ (grhss', grhss_fvs) ->
88 returnM (Match pats' maybe_rhs_sig' grhss', grhss_fvs `plusFV` ty_fvs)
89 -- The bindPatSigTyVarsFV and rnPatsAndThen will remove the bound FVs
91 rhs_sig_tys = case maybe_rhs_sig of
94 doc_sig = text "In a result type-signature"
98 %************************************************************************
100 \subsubsection{Guarded right-hand sides (GRHSs)}
102 %************************************************************************
105 rnGRHSs :: HsMatchContext Name -> GRHSs RdrName -> RnM (GRHSs Name, FreeVars)
108 rnGRHSs ctxt (GRHSs grhss binds)
109 = rnBindGroupsAndThen binds $ \ binds' ->
110 mapFvRn (rnGRHS ctxt) grhss `thenM` \ (grhss', fvGRHSs) ->
111 returnM (GRHSs grhss' binds', fvGRHSs)
113 rnGRHS :: HsMatchContext Name -> LGRHS RdrName -> RnM (LGRHS Name, FreeVars)
114 rnGRHS ctxt = wrapLocFstM (rnGRHS' ctxt)
116 rnGRHS' ctxt (GRHS guarded)
117 = doptM Opt_GlasgowExts `thenM` \ opt_GlasgowExts ->
118 checkM (opt_GlasgowExts || is_standard_guard guarded)
119 (addWarn (nonStdGuardErr guarded)) `thenM_`
121 rnStmts (PatGuard ctxt) guarded `thenM` \ (guarded', fvs) ->
122 returnM (GRHS guarded', fvs)
124 -- Standard Haskell 1.4 guards are just a single boolean
125 -- expression, rather than a list of qualifiers as in the
127 is_standard_guard [L _ (ResultStmt _)] = True
128 is_standard_guard [L _ (ExprStmt _ _), L _ (ResultStmt _)] = True
129 is_standard_guard other = False
132 %************************************************************************
134 \subsubsection{Expressions}
136 %************************************************************************
139 rnExprs :: [LHsExpr RdrName] -> RnM ([LHsExpr Name], FreeVars)
140 rnExprs ls = rnExprs' ls emptyUniqSet
142 rnExprs' [] acc = returnM ([], acc)
143 rnExprs' (expr:exprs) acc
144 = rnLExpr expr `thenM` \ (expr', fvExpr) ->
146 -- Now we do a "seq" on the free vars because typically it's small
147 -- or empty, especially in very long lists of constants
149 acc' = acc `plusFV` fvExpr
151 (grubby_seqNameSet acc' rnExprs') exprs acc' `thenM` \ (exprs', fvExprs) ->
152 returnM (expr':exprs', fvExprs)
154 -- Grubby little function to do "seq" on namesets; replace by proper seq when GHC can do seq
155 grubby_seqNameSet ns result | isNullUFM ns = result
159 Variables. We look up the variable and return the resulting name.
162 rnLExpr :: LHsExpr RdrName -> RnM (LHsExpr Name, FreeVars)
163 rnLExpr = wrapLocFstM rnExpr
165 rnExpr :: HsExpr RdrName -> RnM (HsExpr Name, FreeVars)
168 = lookupOccRn v `thenM` \ name ->
169 doptM Opt_IgnoreAsserts `thenM` \ ignore_asserts ->
170 if name `hasKey` assertIdKey && not ignore_asserts then
171 -- We expand it to (GHC.Err.assertError location_string)
172 mkAssertErrorExpr `thenM` \ (e, fvs) ->
173 returnM (e, fvs `addOneFV` name)
174 -- Keep 'assert' as a free var, to ensure it's not reported as unused!
176 -- The normal case. Even if the Id was 'assert', if we are
177 -- ignoring assertions we leave it as GHC.Base.assert;
178 -- this function just ignores its first arg.
179 returnM (HsVar name, unitFV name)
182 = newIPNameRn v `thenM` \ name ->
183 returnM (HsIPVar name, emptyFVs)
187 returnM (HsLit lit, emptyFVs)
189 rnExpr (HsOverLit lit)
190 = rnOverLit lit `thenM` \ (lit', fvs) ->
191 returnM (HsOverLit lit', fvs)
193 rnExpr (HsApp fun arg)
194 = rnLExpr fun `thenM` \ (fun',fvFun) ->
195 rnLExpr arg `thenM` \ (arg',fvArg) ->
196 returnM (HsApp fun' arg', fvFun `plusFV` fvArg)
198 rnExpr (OpApp e1 op _ e2)
199 = rnLExpr e1 `thenM` \ (e1', fv_e1) ->
200 rnLExpr e2 `thenM` \ (e2', fv_e2) ->
201 rnLExpr op `thenM` \ (op'@(L _ (HsVar op_name)), fv_op) ->
204 -- When renaming code synthesised from "deriving" declarations
205 -- we used to avoid fixity stuff, but we can't easily tell any
206 -- more, so I've removed the test. Adding HsPars in TcGenDeriv
207 -- should prevent bad things happening.
208 lookupFixityRn op_name `thenM` \ fixity ->
209 mkOpAppRn e1' op' fixity e2' `thenM` \ final_e ->
212 fv_e1 `plusFV` fv_op `plusFV` fv_e2)
215 = rnLExpr e `thenM` \ (e', fv_e) ->
216 lookupSyntaxName negateName `thenM` \ (neg_name, fv_neg) ->
217 mkNegAppRn e' neg_name `thenM` \ final_e ->
218 returnM (final_e, fv_e `plusFV` fv_neg)
221 = rnLExpr e `thenM` \ (e', fvs_e) ->
222 returnM (HsPar e', fvs_e)
224 -- Template Haskell extensions
225 -- Don't ifdef-GHCI them because we want to fail gracefully
226 -- (not with an rnExpr crash) in a stage-1 compiler.
227 rnExpr e@(HsBracket br_body)
228 = checkTH e "bracket" `thenM_`
229 rnBracket br_body `thenM` \ (body', fvs_e) ->
230 returnM (HsBracket body', fvs_e)
232 rnExpr e@(HsSpliceE splice)
233 = rnSplice splice `thenM` \ (splice', fvs) ->
234 returnM (HsSpliceE splice', fvs)
236 rnExpr section@(SectionL expr op)
237 = rnLExpr expr `thenM` \ (expr', fvs_expr) ->
238 rnLExpr op `thenM` \ (op', fvs_op) ->
239 checkSectionPrec InfixL section op' expr' `thenM_`
240 returnM (SectionL expr' op', fvs_op `plusFV` fvs_expr)
242 rnExpr section@(SectionR op expr)
243 = rnLExpr op `thenM` \ (op', fvs_op) ->
244 rnLExpr expr `thenM` \ (expr', fvs_expr) ->
245 checkSectionPrec InfixR section op' expr' `thenM_`
246 returnM (SectionR op' expr', fvs_op `plusFV` fvs_expr)
248 rnExpr (HsCoreAnn ann expr)
249 = rnLExpr expr `thenM` \ (expr', fvs_expr) ->
250 returnM (HsCoreAnn ann expr', fvs_expr)
252 rnExpr (HsSCC lbl expr)
253 = rnLExpr expr `thenM` \ (expr', fvs_expr) ->
254 returnM (HsSCC lbl expr', fvs_expr)
256 rnExpr (HsLam matches)
257 = rnMatchGroup LambdaExpr matches `thenM` \ (matches', fvMatch) ->
258 returnM (HsLam matches', fvMatch)
260 rnExpr (HsCase expr matches)
261 = rnLExpr expr `thenM` \ (new_expr, e_fvs) ->
262 rnMatchGroup CaseAlt matches `thenM` \ (new_matches, ms_fvs) ->
263 returnM (HsCase new_expr new_matches, e_fvs `plusFV` ms_fvs)
265 rnExpr (HsLet binds expr)
266 = rnBindGroupsAndThen binds $ \ binds' ->
267 rnLExpr expr `thenM` \ (expr',fvExpr) ->
268 returnM (HsLet binds' expr', fvExpr)
270 rnExpr e@(HsDo do_or_lc stmts _ _)
271 = rnStmts do_or_lc stmts `thenM` \ (stmts', fvs) ->
273 -- Check the statement list ends in an expression
274 case last stmts' of {
275 L _ (ResultStmt _) -> returnM () ;
276 other -> addLocErr other (doStmtListErr do_or_lc)
279 -- Generate the rebindable syntax for the monad
280 lookupSyntaxNames syntax_names `thenM` \ (syntax_names', monad_fvs) ->
282 returnM (HsDo do_or_lc stmts' syntax_names' placeHolderType, 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 = lookupLocatedOccRn con_id `thenM` \ conname ->
307 rnRbinds "construction" rbinds `thenM` \ (rbinds', fvRbinds) ->
308 returnM (RecordCon conname rbinds', fvRbinds `addOneFV` unLoc conname)
310 rnExpr (RecordUpd expr rbinds)
311 = rnLExpr 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 = rnLExpr 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)
323 = rnLExpr p `thenM` \ (p', fvP) ->
324 rnLExpr b1 `thenM` \ (b1', fvB1) ->
325 rnLExpr b2 `thenM` \ (b2', fvB2) ->
326 returnM (HsIf p' b1' b2', plusFVs [fvP, fvB1, fvB2])
329 = rnHsTypeFVs doc a `thenM` \ (t, fvT) ->
330 returnM (HsType t, fvT)
332 doc = text "In a type argument"
334 rnExpr (ArithSeqIn seq)
335 = rnArithSeq seq `thenM` \ (new_seq, fvs) ->
336 returnM (ArithSeqIn new_seq, fvs)
338 rnExpr (PArrSeqIn seq)
339 = rnArithSeq seq `thenM` \ (new_seq, fvs) ->
340 returnM (PArrSeqIn new_seq, fvs)
343 These three are pattern syntax appearing in expressions.
344 Since all the symbols are reservedops we can simply reject them.
345 We return a (bogus) EWildPat in each case.
348 rnExpr e@EWildPat = addErr (patSynErr e) `thenM_`
349 returnM (EWildPat, emptyFVs)
351 rnExpr e@(EAsPat _ _) = addErr (patSynErr e) `thenM_`
352 returnM (EWildPat, emptyFVs)
354 rnExpr e@(ELazyPat _) = addErr (patSynErr e) `thenM_`
355 returnM (EWildPat, emptyFVs)
358 %************************************************************************
362 %************************************************************************
365 rnExpr (HsProc pat body)
366 = rnPatsAndThen ProcExpr True [pat] $ \ [pat'] ->
367 rnCmdTop body `thenM` \ (body',fvBody) ->
368 returnM (HsProc pat' body', fvBody)
370 rnExpr (HsArrApp arrow arg _ ho rtl)
371 = rnLExpr arrow `thenM` \ (arrow',fvArrow) ->
372 rnLExpr arg `thenM` \ (arg',fvArg) ->
373 returnM (HsArrApp arrow' arg' placeHolderType ho rtl,
374 fvArrow `plusFV` fvArg)
377 rnExpr (HsArrForm op (Just _) [arg1, arg2])
378 = rnLExpr op `thenM` \ (op'@(L _ (HsVar op_name)),fv_op) ->
379 rnCmdTop arg1 `thenM` \ (arg1',fv_arg1) ->
380 rnCmdTop arg2 `thenM` \ (arg2',fv_arg2) ->
384 lookupFixityRn op_name `thenM` \ fixity ->
385 mkOpFormRn arg1' op' fixity arg2' `thenM` \ final_e ->
388 fv_arg1 `plusFV` fv_op `plusFV` fv_arg2)
390 rnExpr (HsArrForm op fixity cmds)
391 = rnLExpr op `thenM` \ (op',fvOp) ->
392 rnCmdArgs cmds `thenM` \ (cmds',fvCmds) ->
393 returnM (HsArrForm op' fixity cmds', fvOp `plusFV` fvCmds)
395 ---------------------------
396 -- Deal with fixity (cf mkOpAppRn for the method)
398 mkOpFormRn :: LHsCmdTop Name -- Left operand; already rearranged
399 -> LHsExpr Name -> Fixity -- Operator and fixity
400 -> LHsCmdTop Name -- Right operand (not an infix)
403 ---------------------------
404 -- (e11 `op1` e12) `op2` e2
405 mkOpFormRn a1@(L loc (HsCmdTop (L _ (HsArrForm op1 (Just fix1) [a11,a12])) _ _ _))
408 = addErr (precParseErr (ppr_op op1,fix1) (ppr_op op2,fix2)) `thenM_`
409 returnM (HsArrForm op2 (Just fix2) [a1, a2])
412 = mkOpFormRn a12 op2 fix2 a2 `thenM` \ new_c ->
413 returnM (HsArrForm op1 (Just fix1)
414 [a11, L loc (HsCmdTop (L loc new_c) [] placeHolderType [])])
415 -- TODO: locs are wrong
417 (nofix_error, associate_right) = compareFixity fix1 fix2
419 ---------------------------
421 mkOpFormRn arg1 op fix arg2 -- Default case, no rearrangment
422 = returnM (HsArrForm op (Just fix) [arg1, arg2])
427 %************************************************************************
431 %************************************************************************
434 rnCmdArgs [] = returnM ([], emptyFVs)
436 = rnCmdTop arg `thenM` \ (arg',fvArg) ->
437 rnCmdArgs args `thenM` \ (args',fvArgs) ->
438 returnM (arg':args', fvArg `plusFV` fvArgs)
441 rnCmdTop = wrapLocFstM rnCmdTop'
443 rnCmdTop' (HsCmdTop cmd _ _ _)
444 = rnLExpr (convertOpFormsLCmd cmd) `thenM` \ (cmd', fvCmd) ->
446 cmd_names = [arrAName, composeAName, firstAName] ++
447 nameSetToList (methodNamesCmd (unLoc cmd'))
449 -- Generate the rebindable syntax for the monad
450 lookupSyntaxNames cmd_names `thenM` \ (cmd_names', cmd_fvs) ->
452 returnM (HsCmdTop cmd' [] placeHolderType cmd_names',
453 fvCmd `plusFV` cmd_fvs)
455 ---------------------------------------------------
456 -- convert OpApp's in a command context to HsArrForm's
458 convertOpFormsLCmd :: LHsCmd id -> LHsCmd id
459 convertOpFormsLCmd = fmap convertOpFormsCmd
461 convertOpFormsCmd :: HsCmd id -> HsCmd id
463 convertOpFormsCmd (HsApp c e) = HsApp (convertOpFormsLCmd c) e
464 convertOpFormsCmd (HsLam match) = HsLam (convertOpFormsMatch match)
465 convertOpFormsCmd (OpApp c1 op fixity c2)
467 arg1 = L (getLoc c1) $ HsCmdTop (convertOpFormsLCmd c1) [] placeHolderType []
468 arg2 = L (getLoc c2) $ HsCmdTop (convertOpFormsLCmd c2) [] placeHolderType []
470 HsArrForm op (Just fixity) [arg1, arg2]
472 convertOpFormsCmd (HsPar c) = HsPar (convertOpFormsLCmd c)
475 convertOpFormsCmd (HsCase exp matches)
476 = HsCase exp (convertOpFormsMatch matches)
478 convertOpFormsCmd (HsIf exp c1 c2)
479 = HsIf exp (convertOpFormsLCmd c1) (convertOpFormsLCmd c2)
481 convertOpFormsCmd (HsLet binds cmd)
482 = HsLet binds (convertOpFormsLCmd cmd)
484 convertOpFormsCmd (HsDo ctxt stmts ids ty)
485 = HsDo ctxt (map (fmap convertOpFormsStmt) stmts) ids ty
487 -- Anything else is unchanged. This includes HsArrForm (already done),
488 -- things with no sub-commands, and illegal commands (which will be
489 -- caught by the type checker)
490 convertOpFormsCmd c = c
492 convertOpFormsStmt (BindStmt pat cmd)
493 = BindStmt pat (convertOpFormsLCmd cmd)
494 convertOpFormsStmt (ResultStmt cmd)
495 = ResultStmt (convertOpFormsLCmd cmd)
496 convertOpFormsStmt (ExprStmt cmd ty)
497 = ExprStmt (convertOpFormsLCmd cmd) ty
498 convertOpFormsStmt (RecStmt stmts lvs rvs es)
499 = RecStmt (map (fmap convertOpFormsStmt) stmts) lvs rvs es
500 convertOpFormsStmt stmt = stmt
502 convertOpFormsMatch (MatchGroup ms ty)
503 = MatchGroup (map (fmap convert) ms) ty
504 where convert (Match pat mty grhss)
505 = Match pat mty (convertOpFormsGRHSs grhss)
507 convertOpFormsGRHSs (GRHSs grhss binds)
508 = GRHSs (map convertOpFormsGRHS grhss) binds
510 convertOpFormsGRHS = fmap convert
511 where convert (GRHS stmts)
513 (L loc (ResultStmt cmd)) = last stmts
515 GRHS (init stmts ++ [L loc (ResultStmt (convertOpFormsLCmd cmd))])
517 ---------------------------------------------------
518 type CmdNeeds = FreeVars -- Only inhabitants are
519 -- appAName, choiceAName, loopAName
521 -- find what methods the Cmd needs (loop, choice, apply)
522 methodNamesLCmd :: LHsCmd Name -> CmdNeeds
523 methodNamesLCmd = methodNamesCmd . unLoc
525 methodNamesCmd :: HsCmd Name -> CmdNeeds
527 methodNamesCmd cmd@(HsArrApp _arrow _arg _ HsFirstOrderApp _rtl)
529 methodNamesCmd cmd@(HsArrApp _arrow _arg _ HsHigherOrderApp _rtl)
531 methodNamesCmd cmd@(HsArrForm {}) = emptyFVs
533 methodNamesCmd (HsPar c) = methodNamesLCmd c
535 methodNamesCmd (HsIf p c1 c2)
536 = methodNamesLCmd c1 `plusFV` methodNamesLCmd c2 `addOneFV` choiceAName
538 methodNamesCmd (HsLet b c) = methodNamesLCmd c
540 methodNamesCmd (HsDo sc stmts rbs ty) = methodNamesStmts stmts
542 methodNamesCmd (HsApp c e) = methodNamesLCmd c
544 methodNamesCmd (HsLam match) = methodNamesMatch match
546 methodNamesCmd (HsCase scrut matches)
547 = methodNamesMatch matches `addOneFV` choiceAName
549 methodNamesCmd other = emptyFVs
550 -- Other forms can't occur in commands, but it's not convenient
551 -- to error here so we just do what's convenient.
552 -- The type checker will complain later
554 ---------------------------------------------------
555 methodNamesMatch (MatchGroup ms ty)
556 = plusFVs (map do_one ms)
558 do_one (L _ (Match pats sig_ty grhss)) = methodNamesGRHSs grhss
560 -------------------------------------------------
562 methodNamesGRHSs (GRHSs grhss binds) = plusFVs (map methodNamesGRHS grhss)
564 -------------------------------------------------
565 methodNamesGRHS (L _ (GRHS stmts)) = methodNamesLStmt (last stmts)
567 ---------------------------------------------------
568 methodNamesStmts stmts = plusFVs (map methodNamesLStmt stmts)
570 ---------------------------------------------------
571 methodNamesLStmt = methodNamesStmt . unLoc
573 methodNamesStmt (ResultStmt cmd) = methodNamesLCmd cmd
574 methodNamesStmt (ExprStmt cmd ty) = methodNamesLCmd cmd
575 methodNamesStmt (BindStmt pat cmd ) = methodNamesLCmd cmd
576 methodNamesStmt (RecStmt stmts lvs rvs es)
577 = methodNamesStmts stmts `addOneFV` loopAName
578 methodNamesStmt (LetStmt b) = emptyFVs
579 methodNamesStmt (ParStmt ss) = emptyFVs
580 -- ParStmt can't occur in commands, but it's not convenient to error
581 -- here so we just do what's convenient
585 %************************************************************************
589 %************************************************************************
592 rnArithSeq (From expr)
593 = rnLExpr expr `thenM` \ (expr', fvExpr) ->
594 returnM (From expr', fvExpr)
596 rnArithSeq (FromThen expr1 expr2)
597 = rnLExpr expr1 `thenM` \ (expr1', fvExpr1) ->
598 rnLExpr expr2 `thenM` \ (expr2', fvExpr2) ->
599 returnM (FromThen expr1' expr2', fvExpr1 `plusFV` fvExpr2)
601 rnArithSeq (FromTo expr1 expr2)
602 = rnLExpr expr1 `thenM` \ (expr1', fvExpr1) ->
603 rnLExpr expr2 `thenM` \ (expr2', fvExpr2) ->
604 returnM (FromTo expr1' expr2', fvExpr1 `plusFV` fvExpr2)
606 rnArithSeq (FromThenTo expr1 expr2 expr3)
607 = rnLExpr expr1 `thenM` \ (expr1', fvExpr1) ->
608 rnLExpr expr2 `thenM` \ (expr2', fvExpr2) ->
609 rnLExpr expr3 `thenM` \ (expr3', fvExpr3) ->
610 returnM (FromThenTo expr1' expr2' expr3',
611 plusFVs [fvExpr1, fvExpr2, fvExpr3])
615 %************************************************************************
617 \subsubsection{@Rbinds@s and @Rpats@s: in record expressions}
619 %************************************************************************
623 = mappM_ field_dup_err dup_fields `thenM_`
624 mapFvRn rn_rbind rbinds `thenM` \ (rbinds', fvRbind) ->
625 returnM (rbinds', fvRbind)
627 (_, dup_fields) = removeDups cmpLocated [ f | (f,_) <- rbinds ]
629 field_dup_err dups = mappM_ (\f -> addLocErr f (dupFieldErr str)) dups
631 rn_rbind (field, expr)
632 = lookupLocatedGlobalOccRn field `thenM` \ fieldname ->
633 rnLExpr expr `thenM` \ (expr', fvExpr) ->
634 returnM ((fieldname, expr'), fvExpr `addOneFV` unLoc fieldname)
637 %************************************************************************
639 Template Haskell brackets
641 %************************************************************************
644 rnBracket (VarBr n) = lookupOccRn n `thenM` \ name ->
645 returnM (VarBr name, unitFV name)
646 rnBracket (ExpBr e) = rnLExpr e `thenM` \ (e', fvs) ->
647 returnM (ExpBr e', fvs)
648 rnBracket (PatBr p) = rnLPat p `thenM` \ (p', fvs) ->
649 returnM (PatBr p', fvs)
650 rnBracket (TypBr t) = rnHsTypeFVs doc t `thenM` \ (t', fvs) ->
651 returnM (TypBr t', fvs)
653 doc = ptext SLIT("In a Template-Haskell quoted type")
654 rnBracket (DecBr group)
655 = importsFromLocalDecls group `thenM` \ (rdr_env, avails) ->
656 -- Discard avails (not useful here)
658 updGblEnv (\gbl -> gbl { tcg_rdr_env = tcg_rdr_env gbl `plusOccEnv` rdr_env}) $
659 -- Notice plusOccEnv, not plusGlobalRdrEnv. In this situation we want
660 -- to *shadow* top-level bindings. E.g.
662 -- bar = [d| foo = 1|]
663 -- So we drop down to plusOccEnv. (Perhaps there should be a fn in RdrName.)
665 rnSrcDecls group `thenM` \ (tcg_env, group') ->
666 -- Discard the tcg_env; it contains only extra info about fixity
668 dus = tcg_dus tcg_env
670 returnM (DecBr group', allUses dus)
673 %************************************************************************
675 \subsubsection{@Stmt@s: in @do@ expressions}
677 %************************************************************************
680 rnStmts :: HsStmtContext Name -> [LStmt RdrName] -> RnM ([LStmt Name], FreeVars)
682 rnStmts MDoExpr = rnMDoStmts
683 rnStmts ctxt = rnNormalStmts ctxt
685 rnNormalStmts :: HsStmtContext Name -> [LStmt RdrName] -> RnM ([LStmt Name], FreeVars)
686 -- Used for cases *other* than recursive mdo
687 -- Implements nested scopes
689 rnNormalStmts ctxt [] = returnM ([], emptyFVs)
690 -- Happens at the end of the sub-lists of a ParStmts
692 rnNormalStmts ctxt (L loc (ExprStmt expr _) : stmts)
693 = rnLExpr expr `thenM` \ (expr', fv_expr) ->
694 rnNormalStmts ctxt stmts `thenM` \ (stmts', fvs) ->
695 returnM (L loc (ExprStmt expr' placeHolderType) : stmts',
696 fv_expr `plusFV` fvs)
698 rnNormalStmts ctxt [L loc (ResultStmt expr)]
699 = rnLExpr expr `thenM` \ (expr', fv_expr) ->
700 returnM ([L loc (ResultStmt expr')], fv_expr)
702 rnNormalStmts ctxt (L loc (BindStmt pat expr) : stmts)
703 = rnLExpr expr `thenM` \ (expr', fv_expr) ->
704 -- The binders do not scope over the expression
709 ParStmtCtxt{} -> False
712 rnPatsAndThen (StmtCtxt ctxt) reportUnused [pat] $ \ [pat'] ->
713 rnNormalStmts ctxt stmts `thenM` \ (stmts', fvs) ->
714 returnM (L loc (BindStmt pat' expr') : stmts',
715 fv_expr `plusFV` fvs) -- fv_expr shouldn't really be filtered by
716 -- the rnPatsAndThen, but it does not matter
718 rnNormalStmts ctxt (L loc (LetStmt binds) : stmts)
719 = checkErr (ok ctxt binds) (badIpBinds binds) `thenM_`
720 rnBindGroupsAndThen binds ( \ binds' ->
721 rnNormalStmts ctxt stmts `thenM` \ (stmts', fvs) ->
722 returnM (L loc (LetStmt binds') : stmts', fvs))
724 -- We do not allow implicit-parameter bindings in a parallel
725 -- list comprehension. I'm not sure what it might mean.
726 ok (ParStmtCtxt _) binds = not (any is_ip_bind binds)
729 is_ip_bind (HsIPBinds _) = True
732 rnNormalStmts ctxt (L loc (ParStmt stmtss) : stmts)
733 = doptM Opt_GlasgowExts `thenM` \ opt_GlasgowExts ->
734 checkM opt_GlasgowExts parStmtErr `thenM_`
735 mapFvRn rn_branch stmtss `thenM` \ (stmtss', fv_stmtss) ->
737 bndrss :: [[Name]] -- NB: Name, not RdrName
738 bndrss = map (map unLoc . collectStmtsBinders) stmtss'
739 (bndrs, dups) = removeDups cmpByOcc (concat bndrss)
741 mappM dupErr dups `thenM` \ _ ->
742 bindLocalNamesFV bndrs $
743 -- Note: binders are returned in scope order, so one may
744 -- shadow the next; e.g. x <- xs; x <- ys
745 rnNormalStmts ctxt stmts `thenM` \ (stmts', fvs) ->
747 -- Cut down the exported binders to just the ones needed in the body
749 used_bndrs_s = map (filter (`elemNameSet` fvs)) bndrss
750 unused_bndrs = filter (not . (`elemNameSet` fvs)) bndrs
752 -- With processing of the branches and the tail of comprehension done,
753 -- we can finally compute&report any unused ParStmt binders.
754 warnUnusedMatches unused_bndrs `thenM_`
755 returnM (L loc (ParStmt (stmtss' `zip` used_bndrs_s)) : stmts',
756 fv_stmtss `plusFV` fvs)
758 rn_branch (stmts, _) = rnNormalStmts (ParStmtCtxt ctxt) stmts
760 cmpByOcc n1 n2 = nameOccName n1 `compare` nameOccName n2
761 dupErr (v:_) = addErr (ptext SLIT("Duplicate binding in parallel list comprehension for:")
764 rnNormalStmts ctxt (L loc (RecStmt rec_stmts _ _ _) : stmts)
765 = bindLocatedLocalsRn doc (collectStmtsBinders rec_stmts) $ \ _ ->
766 rn_rec_stmts rec_stmts `thenM` \ segs ->
767 rnNormalStmts ctxt stmts `thenM` \ (stmts', fvs) ->
769 segs_w_fwd_refs = addFwdRefs segs
770 (ds, us, fs, rec_stmts') = unzip4 segs_w_fwd_refs
771 later_vars = nameSetToList (plusFVs ds `intersectNameSet` fvs)
772 fwd_vars = nameSetToList (plusFVs fs)
775 returnM (L loc (RecStmt rec_stmts' later_vars fwd_vars []) : stmts',
778 doc = text "In a recursive do statement"
782 %************************************************************************
784 \subsubsection{mdo expressions}
786 %************************************************************************
789 type FwdRefs = NameSet
790 type Segment stmts = (Defs,
791 Uses, -- May include defs
792 FwdRefs, -- A subset of uses that are
793 -- (a) used before they are bound in this segment, or
794 -- (b) used here, and bound in subsequent segments
795 stmts) -- Either Stmt or [Stmt]
798 ----------------------------------------------------
799 rnMDoStmts :: [LStmt RdrName] -> RnM ([LStmt Name], FreeVars)
801 = -- Step1: bring all the binders of the mdo into scope
802 -- Remember that this also removes the binders from the
803 -- finally-returned free-vars
804 bindLocatedLocalsRn doc (collectStmtsBinders stmts) $ \ _ ->
806 -- Step 2: Rename each individual stmt, making a
807 -- singleton segment. At this stage the FwdRefs field
808 -- isn't finished: it's empty for all except a BindStmt
809 -- for which it's the fwd refs within the bind itself
810 -- (This set may not be empty, because we're in a recursive
812 rn_rec_stmts stmts `thenM` \ segs ->
814 -- Step 3: Fill in the fwd refs.
815 -- The segments are all singletons, but their fwd-ref
816 -- field mentions all the things used by the segment
817 -- that are bound after their use
818 segs_w_fwd_refs = addFwdRefs segs
820 -- Step 4: Group together the segments to make bigger segments
821 -- Invariant: in the result, no segment uses a variable
822 -- bound in a later segment
823 grouped_segs = glomSegments segs_w_fwd_refs
825 -- Step 5: Turn the segments into Stmts
826 -- Use RecStmt when and only when there are fwd refs
827 -- Also gather up the uses from the end towards the
828 -- start, so we can tell the RecStmt which things are
829 -- used 'after' the RecStmt
830 stmts_w_fvs = segsToStmts grouped_segs
835 doc = text "In a recursive mdo-expression"
838 ----------------------------------------------------
839 rn_rec_stmt :: LStmt RdrName -> RnM [Segment (LStmt Name)]
840 -- Rename a Stmt that is inside a RecStmt (or mdo)
841 -- Assumes all binders are already in scope
842 -- Turns each stmt into a singleton Stmt
844 rn_rec_stmt (L loc (ExprStmt expr _))
845 = rnLExpr expr `thenM` \ (expr', fvs) ->
846 returnM [(emptyNameSet, fvs, emptyNameSet,
847 L loc (ExprStmt expr' placeHolderType))]
849 rn_rec_stmt (L loc (ResultStmt expr))
850 = rnLExpr expr `thenM` \ (expr', fvs) ->
851 returnM [(emptyNameSet, fvs, emptyNameSet,
852 L loc (ResultStmt expr'))]
854 rn_rec_stmt (L loc (BindStmt pat expr))
855 = rnLExpr expr `thenM` \ (expr', fv_expr) ->
856 rnLPat pat `thenM` \ (pat', fv_pat) ->
858 bndrs = mkNameSet (collectPatBinders pat')
859 fvs = fv_expr `plusFV` fv_pat
861 returnM [(bndrs, fvs, bndrs `intersectNameSet` fvs,
862 L loc (BindStmt pat' expr'))]
864 rn_rec_stmt (L loc (LetStmt binds))
865 = rnBindGroups binds `thenM` \ (binds', du_binds) ->
866 returnM [(duDefs du_binds, duUses du_binds,
867 emptyNameSet, L loc (LetStmt binds'))]
869 rn_rec_stmt (L loc (RecStmt stmts _ _ _)) -- Flatten Rec inside Rec
872 rn_rec_stmt stmt@(L _ (ParStmt _)) -- Syntactically illegal in mdo
873 = pprPanic "rn_rec_stmt" (ppr stmt)
875 ---------------------------------------------
876 rn_rec_stmts :: [LStmt RdrName] -> RnM [Segment (LStmt Name)]
877 rn_rec_stmts stmts = mappM rn_rec_stmt stmts `thenM` \ segs_s ->
878 returnM (concat segs_s)
881 ---------------------------------------------
882 addFwdRefs :: [Segment a] -> [Segment a]
883 -- So far the segments only have forward refs *within* the Stmt
884 -- (which happens for bind: x <- ...x...)
885 -- This function adds the cross-seg fwd ref info
888 = fst (foldr mk_seg ([], emptyNameSet) pairs)
890 mk_seg (defs, uses, fwds, stmts) (segs, later_defs)
891 = (new_seg : segs, all_defs)
893 new_seg = (defs, uses, new_fwds, stmts)
894 all_defs = later_defs `unionNameSets` defs
895 new_fwds = fwds `unionNameSets` (uses `intersectNameSet` later_defs)
896 -- Add the downstream fwd refs here
898 ----------------------------------------------------
899 -- Glomming the singleton segments of an mdo into
900 -- minimal recursive groups.
902 -- At first I thought this was just strongly connected components, but
903 -- there's an important constraint: the order of the stmts must not change.
906 -- mdo { x <- ...y...
913 -- Here, the first stmt mention 'y', which is bound in the third.
914 -- But that means that the innocent second stmt (p <- z) gets caught
915 -- up in the recursion. And that in turn means that the binding for
916 -- 'z' has to be included... and so on.
918 -- Start at the tail { r <- x }
919 -- Now add the next one { z <- y ; r <- x }
920 -- Now add one more { q <- x ; z <- y ; r <- x }
921 -- Now one more... but this time we have to group a bunch into rec
922 -- { rec { y <- ...x... ; q <- x ; z <- y } ; r <- x }
923 -- Now one more, which we can add on without a rec
925 -- rec { y <- ...x... ; q <- x ; z <- y } ;
927 -- Finally we add the last one; since it mentions y we have to
928 -- glom it togeher with the first two groups
929 -- { rec { x <- ...y...; p <- z ; y <- ...x... ;
930 -- q <- x ; z <- y } ;
933 glomSegments :: [Segment (LStmt Name)] -> [Segment [LStmt Name]]
936 glomSegments ((defs,uses,fwds,stmt) : segs)
937 -- Actually stmts will always be a singleton
938 = (seg_defs, seg_uses, seg_fwds, seg_stmts) : others
940 segs' = glomSegments segs
941 (extras, others) = grab uses segs'
942 (ds, us, fs, ss) = unzip4 extras
944 seg_defs = plusFVs ds `plusFV` defs
945 seg_uses = plusFVs us `plusFV` uses
946 seg_fwds = plusFVs fs `plusFV` fwds
947 seg_stmts = stmt : concat ss
949 grab :: NameSet -- The client
951 -> ([Segment a], -- Needed by the 'client'
952 [Segment a]) -- Not needed by the client
953 -- The result is simply a split of the input
955 = (reverse yeses, reverse noes)
957 (noes, yeses) = span not_needed (reverse dus)
958 not_needed (defs,_,_,_) = not (intersectsNameSet defs uses)
961 ----------------------------------------------------
962 segsToStmts :: [Segment [LStmt Name]] -> ([LStmt Name], FreeVars)
964 segsToStmts [] = ([], emptyFVs)
965 segsToStmts ((defs, uses, fwds, ss) : segs)
966 = ASSERT( not (null ss) )
967 (new_stmt : later_stmts, later_uses `plusFV` uses)
969 (later_stmts, later_uses) = segsToStmts segs
970 new_stmt | non_rec = head ss
971 | otherwise = L (getLoc (head ss)) $
972 RecStmt ss (nameSetToList used_later) (nameSetToList fwds) []
974 non_rec = isSingleton ss && isEmptyNameSet fwds
975 used_later = defs `intersectNameSet` later_uses
976 -- The ones needed after the RecStmt
979 %************************************************************************
981 \subsubsection{Precedence Parsing}
983 %************************************************************************
985 @mkOpAppRn@ deals with operator fixities. The argument expressions
986 are assumed to be already correctly arranged. It needs the fixities
987 recorded in the OpApp nodes, because fixity info applies to the things
988 the programmer actually wrote, so you can't find it out from the Name.
990 Furthermore, the second argument is guaranteed not to be another
991 operator application. Why? Because the parser parses all
992 operator appications left-associatively, EXCEPT negation, which
993 we need to handle specially.
996 mkOpAppRn :: LHsExpr Name -- Left operand; already rearranged
997 -> LHsExpr Name -> Fixity -- Operator and fixity
998 -> LHsExpr Name -- Right operand (not an OpApp, but might
1000 -> RnM (HsExpr Name)
1002 ---------------------------
1003 -- (e11 `op1` e12) `op2` e2
1004 mkOpAppRn e1@(L _ (OpApp e11 op1 fix1 e12)) op2 fix2 e2
1006 = addErr (precParseErr (ppr_op op1,fix1) (ppr_op op2,fix2)) `thenM_`
1007 returnM (OpApp e1 op2 fix2 e2)
1010 = mkOpAppRn e12 op2 fix2 e2 `thenM` \ new_e ->
1011 returnM (OpApp e11 op1 fix1 (L loc' new_e))
1013 loc'= combineLocs e12 e2
1014 (nofix_error, associate_right) = compareFixity fix1 fix2
1016 ---------------------------
1017 -- (- neg_arg) `op` e2
1018 mkOpAppRn e1@(L _ (NegApp neg_arg neg_name)) op2 fix2 e2
1020 = addErr (precParseErr (pp_prefix_minus,negateFixity) (ppr_op op2,fix2)) `thenM_`
1021 returnM (OpApp e1 op2 fix2 e2)
1024 = mkOpAppRn neg_arg op2 fix2 e2 `thenM` \ new_e ->
1025 returnM (NegApp (L loc' new_e) neg_name)
1027 loc' = combineLocs neg_arg e2
1028 (nofix_error, associate_right) = compareFixity negateFixity fix2
1030 ---------------------------
1031 -- e1 `op` - neg_arg
1032 mkOpAppRn e1 op1 fix1 e2@(L _ (NegApp neg_arg _)) -- NegApp can occur on the right
1033 | not associate_right -- We *want* right association
1034 = addErr (precParseErr (ppr_op op1, fix1) (pp_prefix_minus, negateFixity)) `thenM_`
1035 returnM (OpApp e1 op1 fix1 e2)
1037 (_, associate_right) = compareFixity fix1 negateFixity
1039 ---------------------------
1041 mkOpAppRn e1 op fix e2 -- Default case, no rearrangment
1042 = ASSERT2( right_op_ok fix (unLoc e2),
1043 ppr e1 $$ text "---" $$ ppr op $$ text "---" $$ ppr fix $$ text "---" $$ ppr e2
1045 returnM (OpApp e1 op fix e2)
1047 -- Parser left-associates everything, but
1048 -- derived instances may have correctly-associated things to
1049 -- in the right operarand. So we just check that the right operand is OK
1050 right_op_ok fix1 (OpApp _ _ fix2 _)
1051 = not error_please && associate_right
1053 (error_please, associate_right) = compareFixity fix1 fix2
1054 right_op_ok fix1 other
1057 -- Parser initially makes negation bind more tightly than any other operator
1058 -- And "deriving" code should respect this (use HsPar if not)
1059 mkNegAppRn :: LHsExpr id -> SyntaxName -> RnM (HsExpr id)
1060 mkNegAppRn neg_arg neg_name
1061 = ASSERT( not_op_app (unLoc neg_arg) )
1062 returnM (NegApp neg_arg neg_name)
1064 not_op_app (OpApp _ _ _ _) = False
1065 not_op_app other = True
1069 checkPrecMatch :: Bool -> Name -> MatchGroup Name -> RnM ()
1070 -- True indicates an infix lhs
1071 -- See comments with rnExpr (OpApp ...) about "deriving"
1073 checkPrecMatch False fn match
1075 checkPrecMatch True op (MatchGroup ms _)
1078 check (L _ (Match (p1:p2:_) _ _))
1079 = checkPrec op (unLoc p1) False `thenM_`
1080 checkPrec op (unLoc p2) True
1082 check _ = panic "checkPrecMatch"
1084 checkPrec op (ConPatIn op1 (InfixCon _ _)) right
1085 = lookupFixityRn op `thenM` \ op_fix@(Fixity op_prec op_dir) ->
1086 lookupFixityRn (unLoc op1) `thenM` \ op1_fix@(Fixity op1_prec op1_dir) ->
1088 inf_ok = op1_prec > op_prec ||
1089 (op1_prec == op_prec &&
1090 (op1_dir == InfixR && op_dir == InfixR && right ||
1091 op1_dir == InfixL && op_dir == InfixL && not right))
1093 info = (ppr_op op, op_fix)
1094 info1 = (ppr_op op1, op1_fix)
1095 (infol, infor) = if right then (info, info1) else (info1, info)
1097 checkErr inf_ok (precParseErr infol infor)
1099 checkPrec op pat right
1102 -- Check precedence of (arg op) or (op arg) respectively
1103 -- If arg is itself an operator application, then either
1104 -- (a) its precedence must be higher than that of op
1105 -- (b) its precedency & associativity must be the same as that of op
1106 checkSectionPrec :: FixityDirection -> HsExpr RdrName
1107 -> LHsExpr Name -> LHsExpr Name -> RnM ()
1108 checkSectionPrec direction section op arg
1110 OpApp _ op fix _ -> go_for_it (ppr_op op) fix
1111 NegApp _ _ -> go_for_it pp_prefix_minus negateFixity
1114 L _ (HsVar op_name) = op
1115 go_for_it pp_arg_op arg_fix@(Fixity arg_prec assoc)
1116 = lookupFixityRn op_name `thenM` \ op_fix@(Fixity op_prec _) ->
1117 checkErr (op_prec < arg_prec
1118 || op_prec == arg_prec && direction == assoc)
1119 (sectionPrecErr (ppr_op op_name, op_fix)
1120 (pp_arg_op, arg_fix) section)
1124 %************************************************************************
1126 \subsubsection{Assertion utils}
1128 %************************************************************************
1131 mkAssertErrorExpr :: RnM (HsExpr Name, FreeVars)
1132 -- Return an expression for (assertError "Foo.hs:27")
1134 = getSrcSpanM `thenM` \ sloc ->
1136 expr = HsApp (L sloc (HsVar assertErrorName)) (L sloc (HsLit msg))
1137 msg = HsStringPrim (mkFastString (stringToUtf8 (showSDoc (ppr sloc))))
1139 returnM (expr, emptyFVs)
1142 %************************************************************************
1144 \subsubsection{Errors}
1146 %************************************************************************
1149 ppr_op op = quotes (ppr op) -- Here, op can be a Name or a (Var n), where n is a Name
1150 pp_prefix_minus = ptext SLIT("prefix `-'")
1152 nonStdGuardErr guard
1154 SLIT("accepting non-standard pattern guards (-fglasgow-exts to suppress this message)")
1158 = sep [ptext SLIT("Pattern syntax in expression context:"),
1161 doStmtListErr do_or_lc e
1162 = sep [quotes (text binder_name) <+> ptext SLIT("statements must end in expression:"),
1165 binder_name = case do_or_lc of
1170 checkTH e what = returnM () -- OK
1172 checkTH e what -- Raise an error in a stage-1 compiler
1173 = addErr (vcat [ptext SLIT("Template Haskell") <+> text what <+>
1174 ptext SLIT("illegal in a stage-1 compiler"),
1178 parStmtErr = addErr (ptext SLIT("Illegal parallel list comprehension: use -fglasgow-exts"))
1181 = hang (ptext SLIT("Implicit-parameter bindings illegal in a parallel list comprehension:")) 4