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 ( getLocalDeclBinders, extendRdrEnvRn )
32 import RnTypes ( rnHsTypeFVs, rnLPat, rnOverLit, rnPatsAndThen, rnLit,
33 dupFieldErr, precParseErr, sectionPrecErr, patSigErr,
35 import DynFlags ( DynFlag(..) )
36 import BasicTypes ( Fixity(..), FixityDirection(..), negateFixity, compareFixity )
37 import PrelNames ( hasKey, assertIdKey, assertErrorName,
38 loopAName, choiceAName, appAName, arrAName, composeAName, firstAName,
39 negateName, thenMName, bindMName, failMName )
40 import Name ( Name, nameOccName )
42 import RdrName ( RdrName, emptyGlobalRdrEnv )
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 guards rhs)
117 = do { opt_GlasgowExts <- doptM Opt_GlasgowExts
118 ; checkM (opt_GlasgowExts || is_standard_guard guards)
119 (addWarn (nonStdGuardErr guards))
121 ; ((guards', rhs'), fvs) <- rnStmts (PatGuard ctxt) guards $
123 ; return (GRHS guards' rhs', fvs) }
125 -- Standard Haskell 1.4 guards are just a single boolean
126 -- expression, rather than a list of qualifiers as in the
128 is_standard_guard [] = True
129 is_standard_guard [L _ (ExprStmt _ _ _)] = True
130 is_standard_guard other = False
133 %************************************************************************
135 \subsubsection{Expressions}
137 %************************************************************************
140 rnExprs :: [LHsExpr RdrName] -> RnM ([LHsExpr Name], FreeVars)
141 rnExprs ls = rnExprs' ls emptyUniqSet
143 rnExprs' [] acc = returnM ([], acc)
144 rnExprs' (expr:exprs) acc
145 = rnLExpr expr `thenM` \ (expr', fvExpr) ->
147 -- Now we do a "seq" on the free vars because typically it's small
148 -- or empty, especially in very long lists of constants
150 acc' = acc `plusFV` fvExpr
152 (grubby_seqNameSet acc' rnExprs') exprs acc' `thenM` \ (exprs', fvExprs) ->
153 returnM (expr':exprs', fvExprs)
155 -- Grubby little function to do "seq" on namesets; replace by proper seq when GHC can do seq
156 grubby_seqNameSet ns result | isNullUFM ns = result
160 Variables. We look up the variable and return the resulting name.
163 rnLExpr :: LHsExpr RdrName -> RnM (LHsExpr Name, FreeVars)
164 rnLExpr = wrapLocFstM rnExpr
166 rnExpr :: HsExpr RdrName -> RnM (HsExpr Name, FreeVars)
169 = lookupOccRn v `thenM` \ name ->
170 doptM Opt_IgnoreAsserts `thenM` \ ignore_asserts ->
171 if name `hasKey` assertIdKey && not ignore_asserts then
172 -- We expand it to (GHC.Err.assertError location_string)
173 mkAssertErrorExpr `thenM` \ (e, fvs) ->
174 returnM (e, fvs `addOneFV` name)
175 -- Keep 'assert' as a free var, to ensure it's not reported as unused!
177 -- The normal case. Even if the Id was 'assert', if we are
178 -- ignoring assertions we leave it as GHC.Base.assert;
179 -- this function just ignores its first arg.
180 returnM (HsVar name, unitFV name)
183 = newIPNameRn v `thenM` \ name ->
184 returnM (HsIPVar name, emptyFVs)
188 returnM (HsLit lit, emptyFVs)
190 rnExpr (HsOverLit lit)
191 = rnOverLit lit `thenM` \ (lit', fvs) ->
192 returnM (HsOverLit lit', fvs)
194 rnExpr (HsApp fun arg)
195 = rnLExpr fun `thenM` \ (fun',fvFun) ->
196 rnLExpr arg `thenM` \ (arg',fvArg) ->
197 returnM (HsApp fun' arg', fvFun `plusFV` fvArg)
199 rnExpr (OpApp e1 op _ e2)
200 = rnLExpr e1 `thenM` \ (e1', fv_e1) ->
201 rnLExpr e2 `thenM` \ (e2', fv_e2) ->
202 rnLExpr op `thenM` \ (op'@(L _ (HsVar op_name)), fv_op) ->
205 -- When renaming code synthesised from "deriving" declarations
206 -- we used to avoid fixity stuff, but we can't easily tell any
207 -- more, so I've removed the test. Adding HsPars in TcGenDeriv
208 -- should prevent bad things happening.
209 lookupFixityRn op_name `thenM` \ fixity ->
210 mkOpAppRn e1' op' fixity e2' `thenM` \ final_e ->
213 fv_e1 `plusFV` fv_op `plusFV` fv_e2)
216 = rnLExpr e `thenM` \ (e', fv_e) ->
217 lookupSyntaxName negateName `thenM` \ (neg_name, fv_neg) ->
218 mkNegAppRn e' neg_name `thenM` \ final_e ->
219 returnM (final_e, fv_e `plusFV` fv_neg)
222 = rnLExpr e `thenM` \ (e', fvs_e) ->
223 returnM (HsPar e', fvs_e)
225 -- Template Haskell extensions
226 -- Don't ifdef-GHCI them because we want to fail gracefully
227 -- (not with an rnExpr crash) in a stage-1 compiler.
228 rnExpr e@(HsBracket br_body)
229 = checkTH e "bracket" `thenM_`
230 rnBracket br_body `thenM` \ (body', fvs_e) ->
231 returnM (HsBracket body', fvs_e)
233 rnExpr e@(HsSpliceE splice)
234 = rnSplice splice `thenM` \ (splice', fvs) ->
235 returnM (HsSpliceE splice', fvs)
237 rnExpr section@(SectionL expr op)
238 = rnLExpr expr `thenM` \ (expr', fvs_expr) ->
239 rnLExpr op `thenM` \ (op', fvs_op) ->
240 checkSectionPrec InfixL section op' expr' `thenM_`
241 returnM (SectionL expr' op', fvs_op `plusFV` fvs_expr)
243 rnExpr section@(SectionR op expr)
244 = rnLExpr op `thenM` \ (op', fvs_op) ->
245 rnLExpr expr `thenM` \ (expr', fvs_expr) ->
246 checkSectionPrec InfixR section op' expr' `thenM_`
247 returnM (SectionR op' expr', fvs_op `plusFV` fvs_expr)
249 rnExpr (HsCoreAnn ann expr)
250 = rnLExpr expr `thenM` \ (expr', fvs_expr) ->
251 returnM (HsCoreAnn ann expr', fvs_expr)
253 rnExpr (HsSCC lbl expr)
254 = rnLExpr expr `thenM` \ (expr', fvs_expr) ->
255 returnM (HsSCC lbl expr', fvs_expr)
257 rnExpr (HsLam matches)
258 = rnMatchGroup LambdaExpr matches `thenM` \ (matches', fvMatch) ->
259 returnM (HsLam matches', fvMatch)
261 rnExpr (HsCase expr matches)
262 = rnLExpr expr `thenM` \ (new_expr, e_fvs) ->
263 rnMatchGroup CaseAlt matches `thenM` \ (new_matches, ms_fvs) ->
264 returnM (HsCase new_expr new_matches, e_fvs `plusFV` ms_fvs)
266 rnExpr (HsLet binds expr)
267 = rnBindGroupsAndThen binds $ \ binds' ->
268 rnLExpr expr `thenM` \ (expr',fvExpr) ->
269 returnM (HsLet binds' expr', fvExpr)
271 rnExpr e@(HsDo do_or_lc stmts body _)
272 = do { ((stmts', body'), fvs) <- rnStmts do_or_lc stmts $
274 ; return (HsDo do_or_lc stmts' body' placeHolderType, fvs) }
276 rnExpr (ExplicitList _ exps)
277 = rnExprs exps `thenM` \ (exps', fvs) ->
278 returnM (ExplicitList placeHolderType exps', fvs `addOneFV` listTyCon_name)
280 rnExpr (ExplicitPArr _ exps)
281 = rnExprs exps `thenM` \ (exps', fvs) ->
282 returnM (ExplicitPArr placeHolderType exps', fvs)
284 rnExpr e@(ExplicitTuple exps boxity)
285 = checkTupSize tup_size `thenM_`
286 rnExprs exps `thenM` \ (exps', fvs) ->
287 returnM (ExplicitTuple exps' boxity, fvs `addOneFV` tycon_name)
289 tup_size = length exps
290 tycon_name = tupleTyCon_name boxity tup_size
292 rnExpr (RecordCon con_id _ rbinds)
293 = lookupLocatedOccRn con_id `thenM` \ conname ->
294 rnRbinds "construction" rbinds `thenM` \ (rbinds', fvRbinds) ->
295 returnM (RecordCon conname noPostTcExpr rbinds',
296 fvRbinds `addOneFV` unLoc conname)
298 rnExpr (RecordUpd expr rbinds _ _)
299 = rnLExpr expr `thenM` \ (expr', fvExpr) ->
300 rnRbinds "update" rbinds `thenM` \ (rbinds', fvRbinds) ->
301 returnM (RecordUpd expr' rbinds' placeHolderType placeHolderType,
302 fvExpr `plusFV` fvRbinds)
304 rnExpr (ExprWithTySig expr pty)
305 = rnLExpr expr `thenM` \ (expr', fvExpr) ->
306 rnHsTypeFVs doc pty `thenM` \ (pty', fvTy) ->
307 returnM (ExprWithTySig expr' pty', fvExpr `plusFV` fvTy)
309 doc = text "In an expression type signature"
311 rnExpr (HsIf p b1 b2)
312 = rnLExpr p `thenM` \ (p', fvP) ->
313 rnLExpr b1 `thenM` \ (b1', fvB1) ->
314 rnLExpr b2 `thenM` \ (b2', fvB2) ->
315 returnM (HsIf p' b1' b2', plusFVs [fvP, fvB1, fvB2])
318 = rnHsTypeFVs doc a `thenM` \ (t, fvT) ->
319 returnM (HsType t, fvT)
321 doc = text "In a type argument"
323 rnExpr (ArithSeq _ seq)
324 = rnArithSeq seq `thenM` \ (new_seq, fvs) ->
325 returnM (ArithSeq noPostTcExpr new_seq, fvs)
327 rnExpr (PArrSeq _ seq)
328 = rnArithSeq seq `thenM` \ (new_seq, fvs) ->
329 returnM (PArrSeq noPostTcExpr new_seq, fvs)
332 These three are pattern syntax appearing in expressions.
333 Since all the symbols are reservedops we can simply reject them.
334 We return a (bogus) EWildPat in each case.
337 rnExpr e@EWildPat = addErr (patSynErr e) `thenM_`
338 returnM (EWildPat, emptyFVs)
340 rnExpr e@(EAsPat _ _) = addErr (patSynErr e) `thenM_`
341 returnM (EWildPat, emptyFVs)
343 rnExpr e@(ELazyPat _) = addErr (patSynErr e) `thenM_`
344 returnM (EWildPat, emptyFVs)
347 %************************************************************************
351 %************************************************************************
354 rnExpr (HsProc pat body)
355 = rnPatsAndThen ProcExpr True [pat] $ \ [pat'] ->
356 rnCmdTop body `thenM` \ (body',fvBody) ->
357 returnM (HsProc pat' body', fvBody)
359 rnExpr (HsArrApp arrow arg _ ho rtl)
360 = rnLExpr arrow `thenM` \ (arrow',fvArrow) ->
361 rnLExpr arg `thenM` \ (arg',fvArg) ->
362 returnM (HsArrApp arrow' arg' placeHolderType ho rtl,
363 fvArrow `plusFV` fvArg)
366 rnExpr (HsArrForm op (Just _) [arg1, arg2])
367 = rnLExpr op `thenM` \ (op'@(L _ (HsVar op_name)),fv_op) ->
368 rnCmdTop arg1 `thenM` \ (arg1',fv_arg1) ->
369 rnCmdTop arg2 `thenM` \ (arg2',fv_arg2) ->
373 lookupFixityRn op_name `thenM` \ fixity ->
374 mkOpFormRn arg1' op' fixity arg2' `thenM` \ final_e ->
377 fv_arg1 `plusFV` fv_op `plusFV` fv_arg2)
379 rnExpr (HsArrForm op fixity cmds)
380 = rnLExpr op `thenM` \ (op',fvOp) ->
381 rnCmdArgs cmds `thenM` \ (cmds',fvCmds) ->
382 returnM (HsArrForm op' fixity cmds', fvOp `plusFV` fvCmds)
384 rnExpr other = pprPanic "rnExpr: unexpected expression" (ppr other)
385 -- DictApp, DictLam, TyApp, TyLam
387 ---------------------------
388 -- Deal with fixity (cf mkOpAppRn for the method)
390 mkOpFormRn :: LHsCmdTop Name -- Left operand; already rearranged
391 -> LHsExpr Name -> Fixity -- Operator and fixity
392 -> LHsCmdTop Name -- Right operand (not an infix)
395 ---------------------------
396 -- (e11 `op1` e12) `op2` e2
397 mkOpFormRn a1@(L loc (HsCmdTop (L _ (HsArrForm op1 (Just fix1) [a11,a12])) _ _ _))
400 = addErr (precParseErr (ppr_op op1,fix1) (ppr_op op2,fix2)) `thenM_`
401 returnM (HsArrForm op2 (Just fix2) [a1, a2])
404 = mkOpFormRn a12 op2 fix2 a2 `thenM` \ new_c ->
405 returnM (HsArrForm op1 (Just fix1)
406 [a11, L loc (HsCmdTop (L loc new_c) [] placeHolderType [])])
407 -- TODO: locs are wrong
409 (nofix_error, associate_right) = compareFixity fix1 fix2
411 ---------------------------
413 mkOpFormRn arg1 op fix arg2 -- Default case, no rearrangment
414 = returnM (HsArrForm op (Just fix) [arg1, arg2])
419 %************************************************************************
423 %************************************************************************
426 rnCmdArgs [] = returnM ([], emptyFVs)
428 = rnCmdTop arg `thenM` \ (arg',fvArg) ->
429 rnCmdArgs args `thenM` \ (args',fvArgs) ->
430 returnM (arg':args', fvArg `plusFV` fvArgs)
433 rnCmdTop = wrapLocFstM rnCmdTop'
435 rnCmdTop' (HsCmdTop cmd _ _ _)
436 = rnLExpr (convertOpFormsLCmd cmd) `thenM` \ (cmd', fvCmd) ->
438 cmd_names = [arrAName, composeAName, firstAName] ++
439 nameSetToList (methodNamesCmd (unLoc cmd'))
441 -- Generate the rebindable syntax for the monad
442 lookupSyntaxTable 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 convertOpFormsLCmd :: LHsCmd id -> LHsCmd id
451 convertOpFormsLCmd = fmap convertOpFormsCmd
453 convertOpFormsCmd :: HsCmd id -> HsCmd id
455 convertOpFormsCmd (HsApp c e) = HsApp (convertOpFormsLCmd c) e
456 convertOpFormsCmd (HsLam match) = HsLam (convertOpFormsMatch match)
457 convertOpFormsCmd (OpApp c1 op fixity c2)
459 arg1 = L (getLoc c1) $ HsCmdTop (convertOpFormsLCmd c1) [] placeHolderType []
460 arg2 = L (getLoc c2) $ HsCmdTop (convertOpFormsLCmd c2) [] placeHolderType []
462 HsArrForm op (Just fixity) [arg1, arg2]
464 convertOpFormsCmd (HsPar c) = HsPar (convertOpFormsLCmd c)
467 convertOpFormsCmd (HsCase exp matches)
468 = HsCase exp (convertOpFormsMatch matches)
470 convertOpFormsCmd (HsIf exp c1 c2)
471 = HsIf exp (convertOpFormsLCmd c1) (convertOpFormsLCmd c2)
473 convertOpFormsCmd (HsLet binds cmd)
474 = HsLet binds (convertOpFormsLCmd cmd)
476 convertOpFormsCmd (HsDo ctxt stmts body ty)
477 = HsDo ctxt (map (fmap convertOpFormsStmt) stmts)
478 (convertOpFormsLCmd body) ty
480 -- Anything else is unchanged. This includes HsArrForm (already done),
481 -- things with no sub-commands, and illegal commands (which will be
482 -- caught by the type checker)
483 convertOpFormsCmd c = c
485 convertOpFormsStmt (BindStmt pat cmd _ _)
486 = BindStmt pat (convertOpFormsLCmd cmd) noSyntaxExpr noSyntaxExpr
487 convertOpFormsStmt (ExprStmt cmd _ _)
488 = ExprStmt (convertOpFormsLCmd cmd) noSyntaxExpr placeHolderType
489 convertOpFormsStmt (RecStmt stmts lvs rvs es binds)
490 = RecStmt (map (fmap convertOpFormsStmt) stmts) lvs rvs es binds
491 convertOpFormsStmt stmt = stmt
493 convertOpFormsMatch (MatchGroup ms ty)
494 = MatchGroup (map (fmap convert) ms) ty
495 where convert (Match pat mty grhss)
496 = Match pat mty (convertOpFormsGRHSs grhss)
498 convertOpFormsGRHSs (GRHSs grhss binds)
499 = GRHSs (map convertOpFormsGRHS grhss) binds
501 convertOpFormsGRHS = fmap convert
503 convert (GRHS stmts cmd) = GRHS stmts (convertOpFormsLCmd cmd)
505 ---------------------------------------------------
506 type CmdNeeds = FreeVars -- Only inhabitants are
507 -- appAName, choiceAName, loopAName
509 -- find what methods the Cmd needs (loop, choice, apply)
510 methodNamesLCmd :: LHsCmd Name -> CmdNeeds
511 methodNamesLCmd = methodNamesCmd . unLoc
513 methodNamesCmd :: HsCmd Name -> CmdNeeds
515 methodNamesCmd cmd@(HsArrApp _arrow _arg _ HsFirstOrderApp _rtl)
517 methodNamesCmd cmd@(HsArrApp _arrow _arg _ HsHigherOrderApp _rtl)
519 methodNamesCmd cmd@(HsArrForm {}) = emptyFVs
521 methodNamesCmd (HsPar c) = methodNamesLCmd c
523 methodNamesCmd (HsIf p c1 c2)
524 = methodNamesLCmd c1 `plusFV` methodNamesLCmd c2 `addOneFV` choiceAName
526 methodNamesCmd (HsLet b c) = methodNamesLCmd c
528 methodNamesCmd (HsDo sc stmts body ty)
529 = methodNamesStmts stmts `plusFV` methodNamesLCmd body
531 methodNamesCmd (HsApp c e) = methodNamesLCmd c
533 methodNamesCmd (HsLam match) = methodNamesMatch match
535 methodNamesCmd (HsCase scrut matches)
536 = methodNamesMatch matches `addOneFV` choiceAName
538 methodNamesCmd other = emptyFVs
539 -- Other forms can't occur in commands, but it's not convenient
540 -- to error here so we just do what's convenient.
541 -- The type checker will complain later
543 ---------------------------------------------------
544 methodNamesMatch (MatchGroup ms ty)
545 = plusFVs (map do_one ms)
547 do_one (L _ (Match pats sig_ty grhss)) = methodNamesGRHSs grhss
549 -------------------------------------------------
551 methodNamesGRHSs (GRHSs grhss binds) = plusFVs (map methodNamesGRHS grhss)
553 -------------------------------------------------
554 methodNamesGRHS (L _ (GRHS stmts rhs)) = methodNamesLCmd rhs
556 ---------------------------------------------------
557 methodNamesStmts stmts = plusFVs (map methodNamesLStmt stmts)
559 ---------------------------------------------------
560 methodNamesLStmt = methodNamesStmt . unLoc
562 methodNamesStmt (ExprStmt cmd _ _) = methodNamesLCmd cmd
563 methodNamesStmt (BindStmt pat cmd _ _) = methodNamesLCmd cmd
564 methodNamesStmt (RecStmt stmts _ _ _ _)
565 = methodNamesStmts stmts `addOneFV` loopAName
566 methodNamesStmt (LetStmt b) = emptyFVs
567 methodNamesStmt (ParStmt ss) = emptyFVs
568 -- ParStmt can't occur in commands, but it's not convenient to error
569 -- here so we just do what's convenient
573 %************************************************************************
577 %************************************************************************
580 rnArithSeq (From expr)
581 = rnLExpr expr `thenM` \ (expr', fvExpr) ->
582 returnM (From expr', fvExpr)
584 rnArithSeq (FromThen expr1 expr2)
585 = rnLExpr expr1 `thenM` \ (expr1', fvExpr1) ->
586 rnLExpr expr2 `thenM` \ (expr2', fvExpr2) ->
587 returnM (FromThen expr1' expr2', fvExpr1 `plusFV` fvExpr2)
589 rnArithSeq (FromTo expr1 expr2)
590 = rnLExpr expr1 `thenM` \ (expr1', fvExpr1) ->
591 rnLExpr expr2 `thenM` \ (expr2', fvExpr2) ->
592 returnM (FromTo expr1' expr2', fvExpr1 `plusFV` fvExpr2)
594 rnArithSeq (FromThenTo expr1 expr2 expr3)
595 = rnLExpr expr1 `thenM` \ (expr1', fvExpr1) ->
596 rnLExpr expr2 `thenM` \ (expr2', fvExpr2) ->
597 rnLExpr expr3 `thenM` \ (expr3', fvExpr3) ->
598 returnM (FromThenTo expr1' expr2' expr3',
599 plusFVs [fvExpr1, fvExpr2, fvExpr3])
603 %************************************************************************
605 \subsubsection{@Rbinds@s and @Rpats@s: in record expressions}
607 %************************************************************************
611 = mappM_ field_dup_err dup_fields `thenM_`
612 mapFvRn rn_rbind rbinds `thenM` \ (rbinds', fvRbind) ->
613 returnM (rbinds', fvRbind)
615 (_, dup_fields) = removeDups cmpLocated [ f | (f,_) <- rbinds ]
617 field_dup_err dups = mappM_ (\f -> addLocErr f (dupFieldErr str)) dups
619 rn_rbind (field, expr)
620 = lookupLocatedGlobalOccRn field `thenM` \ fieldname ->
621 rnLExpr expr `thenM` \ (expr', fvExpr) ->
622 returnM ((fieldname, expr'), fvExpr `addOneFV` unLoc fieldname)
625 %************************************************************************
627 Template Haskell brackets
629 %************************************************************************
632 rnBracket (VarBr n) = lookupOccRn n `thenM` \ name ->
633 returnM (VarBr name, unitFV name)
634 rnBracket (ExpBr e) = rnLExpr e `thenM` \ (e', fvs) ->
635 returnM (ExpBr e', fvs)
636 rnBracket (PatBr p) = rnLPat p `thenM` \ (p', fvs) ->
637 returnM (PatBr p', fvs)
638 rnBracket (TypBr t) = rnHsTypeFVs doc t `thenM` \ (t', fvs) ->
639 returnM (TypBr t', fvs)
641 doc = ptext SLIT("In a Template-Haskell quoted type")
642 rnBracket (DecBr group)
643 = do { gbl_env <- getGblEnv
644 ; names <- getLocalDeclBinders gbl_env group
645 ; rdr_env' <- extendRdrEnvRn (tcg_mod gbl_env) emptyGlobalRdrEnv names
647 ; setGblEnv (gbl_env { tcg_rdr_env = tcg_rdr_env gbl_env `plusOccEnv` rdr_env',
648 tcg_dus = emptyDUs }) $ do
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 -- The emptyDUs is so that we just collect uses for this group alone
657 { (tcg_env, group') <- rnSrcDecls group
658 -- Discard the tcg_env; it contains only extra info about fixity
659 ; return (DecBr group', allUses (tcg_dus tcg_env)) } }
662 %************************************************************************
664 \subsubsection{@Stmt@s: in @do@ expressions}
666 %************************************************************************
669 rnStmts :: HsStmtContext Name -> [LStmt RdrName]
670 -> RnM (thing, FreeVars)
671 -> RnM (([LStmt Name], thing), FreeVars)
673 rnStmts (MDoExpr _) = rnMDoStmts
674 rnStmts ctxt = rnNormalStmts ctxt
676 rnNormalStmts :: HsStmtContext Name -> [LStmt RdrName]
677 -> RnM (thing, FreeVars)
678 -> RnM (([LStmt Name], thing), FreeVars)
679 -- Used for cases *other* than recursive mdo
680 -- Implements nested scopes
682 rnNormalStmts ctxt [] thing_inside
683 = do { (thing, fvs) <- thing_inside
684 ; return (([],thing), fvs) }
686 rnNormalStmts ctxt (L loc stmt : stmts) thing_inside
687 = do { ((stmt', (stmts', thing)), fvs)
688 <- rnStmt ctxt stmt $
689 rnNormalStmts ctxt stmts thing_inside
690 ; return (((L loc stmt' : stmts'), thing), fvs) }
692 rnStmt :: HsStmtContext Name -> Stmt RdrName
693 -> RnM (thing, FreeVars)
694 -> RnM ((Stmt Name, thing), FreeVars)
696 rnStmt ctxt (ExprStmt expr _ _) thing_inside
697 = do { (expr', fv_expr) <- rnLExpr expr
698 ; (then_op, fvs1) <- lookupSyntaxName thenMName
699 ; (thing, fvs2) <- thing_inside
700 ; return ((ExprStmt expr' then_op placeHolderType, thing),
701 fv_expr `plusFV` fvs1 `plusFV` fvs2) }
703 rnStmt ctxt (BindStmt pat expr _ _) thing_inside
704 = do { (expr', fv_expr) <- rnLExpr expr
705 -- The binders do not scope over the expression
706 ; (bind_op, fvs1) <- lookupSyntaxName bindMName
707 ; (fail_op, fvs2) <- lookupSyntaxName failMName
709 ; let reportUnused = case ctxt of
710 ParStmtCtxt{} -> False
712 ; rnPatsAndThen (StmtCtxt ctxt) reportUnused [pat] $ \ [pat'] -> do
713 { (thing, fvs3) <- thing_inside
714 ; return ((BindStmt pat' expr' bind_op fail_op, thing),
715 fv_expr `plusFV` fvs1 `plusFV` fvs2 `plusFV` fvs3) }}
716 -- fv_expr shouldn't really be filtered by
717 -- the rnPatsAndThen, but it does not matter
719 rnStmt ctxt (LetStmt binds) thing_inside
720 = do { checkErr (ok ctxt binds) (badIpBinds binds)
721 ; rnBindGroupsAndThen binds $ \ binds' -> do
722 { (thing, fvs) <- thing_inside
723 ; return ((LetStmt binds', thing), fvs) }}
725 -- We do not allow implicit-parameter bindings in a parallel
726 -- list comprehension. I'm not sure what it might mean.
727 ok (ParStmtCtxt _) binds = not (any is_ip_bind binds)
730 is_ip_bind (HsIPBinds _) = True
733 rnStmt ctxt (ParStmt stmtss) thing_inside
734 = do { opt_GlasgowExts <- doptM Opt_GlasgowExts
735 ; checkM opt_GlasgowExts parStmtErr
736 ; (stmtss'_w_unit, fv_stmtss) <- mapFvRn rn_branch stmtss
738 bndrss :: [[Name]] -- NB: Name, not RdrName
739 bndrss = map (map unLoc . collectLStmtsBinders) stmtss'
740 (bndrs, dups) = removeDups cmpByOcc (concat bndrss)
741 stmtss' = map fst stmtss'_w_unit
744 ; bindLocalNamesFV bndrs $ do
745 { (thing, fvs) <- thing_inside
746 -- Note: binders are returned in scope order, so one may
747 -- shadow the next; e.g. x <- xs; x <- ys
749 -- Cut down the exported binders to just the ones needed in the body
750 ; let used_bndrs_s = map (filter (`elemNameSet` fvs)) bndrss
751 unused_bndrs = filter (not . (`elemNameSet` fvs)) bndrs
753 -- With processing of the branches and the tail of comprehension done,
754 -- we can finally compute&report any unused ParStmt binders.
755 ; warnUnusedMatches unused_bndrs
756 ; return ((ParStmt (stmtss' `zip` used_bndrs_s), thing),
757 fv_stmtss `plusFV` fvs) }}
759 rn_branch (stmts, _) = rnNormalStmts (ParStmtCtxt ctxt) stmts $
760 return ((), emptyFVs)
762 cmpByOcc n1 n2 = nameOccName n1 `compare` nameOccName n2
763 dupErr vs = addErr (ptext SLIT("Duplicate binding in parallel list comprehension for:")
764 <+> quotes (ppr (head vs)))
766 rnStmt ctxt (RecStmt rec_stmts _ _ _ _) thing_inside
767 = bindLocatedLocalsRn doc (collectLStmtsBinders rec_stmts) $ \ _ ->
768 rn_rec_stmts rec_stmts `thenM` \ segs ->
769 thing_inside `thenM` \ (thing, fvs) ->
771 segs_w_fwd_refs = addFwdRefs segs
772 (ds, us, fs, rec_stmts') = unzip4 segs_w_fwd_refs
773 later_vars = nameSetToList (plusFVs ds `intersectNameSet` fvs)
774 fwd_vars = nameSetToList (plusFVs fs)
776 rec_stmt = RecStmt rec_stmts' later_vars fwd_vars [] emptyLHsBinds
778 returnM ((rec_stmt, thing), uses `plusFV` fvs)
780 doc = text "In a recursive do statement"
784 %************************************************************************
786 \subsubsection{mdo expressions}
788 %************************************************************************
791 type FwdRefs = NameSet
792 type Segment stmts = (Defs,
793 Uses, -- May include defs
794 FwdRefs, -- A subset of uses that are
795 -- (a) used before they are bound in this segment, or
796 -- (b) used here, and bound in subsequent segments
797 stmts) -- Either Stmt or [Stmt]
800 ----------------------------------------------------
801 rnMDoStmts :: [LStmt RdrName]
802 -> RnM (thing, FreeVars)
803 -> RnM (([LStmt Name], thing), FreeVars)
804 rnMDoStmts stmts thing_inside
805 = -- Step1: bring all the binders of the mdo into scope
806 -- Remember that this also removes the binders from the
807 -- finally-returned free-vars
808 bindLocatedLocalsRn doc (collectLStmtsBinders stmts) $ \ _ ->
810 -- Step 2: Rename each individual stmt, making a
811 -- singleton segment. At this stage the FwdRefs field
812 -- isn't finished: it's empty for all except a BindStmt
813 -- for which it's the fwd refs within the bind itself
814 -- (This set may not be empty, because we're in a recursive
816 segs <- rn_rec_stmts stmts
818 ; (thing, fvs_later) <- thing_inside
821 -- Step 3: Fill in the fwd refs.
822 -- The segments are all singletons, but their fwd-ref
823 -- field mentions all the things used by the segment
824 -- that are bound after their use
825 segs_w_fwd_refs = addFwdRefs segs
827 -- Step 4: Group together the segments to make bigger segments
828 -- Invariant: in the result, no segment uses a variable
829 -- bound in a later segment
830 grouped_segs = glomSegments segs_w_fwd_refs
832 -- Step 5: Turn the segments into Stmts
833 -- Use RecStmt when and only when there are fwd refs
834 -- Also gather up the uses from the end towards the
835 -- start, so we can tell the RecStmt which things are
836 -- used 'after' the RecStmt
837 (stmts', fvs) = segsToStmts grouped_segs fvs_later
839 ; return ((stmts', thing), fvs) }
841 doc = text "In a recursive mdo-expression"
844 ----------------------------------------------------
845 rn_rec_stmt :: LStmt RdrName -> RnM [Segment (LStmt Name)]
846 -- Rename a Stmt that is inside a RecStmt (or mdo)
847 -- Assumes all binders are already in scope
848 -- Turns each stmt into a singleton Stmt
850 rn_rec_stmt (L loc (ExprStmt expr _ _))
851 = rnLExpr expr `thenM` \ (expr', fvs) ->
852 lookupSyntaxName thenMName `thenM` \ (then_op, fvs1) ->
853 returnM [(emptyNameSet, fvs `plusFV` fvs1, emptyNameSet,
854 L loc (ExprStmt expr' then_op placeHolderType))]
856 rn_rec_stmt (L loc (BindStmt pat expr _ _))
857 = rnLExpr expr `thenM` \ (expr', fv_expr) ->
858 rnLPat pat `thenM` \ (pat', fv_pat) ->
859 lookupSyntaxName bindMName `thenM` \ (bind_op, fvs1) ->
860 lookupSyntaxName failMName `thenM` \ (fail_op, fvs2) ->
862 bndrs = mkNameSet (collectPatBinders pat')
863 fvs = fv_expr `plusFV` fv_pat `plusFV` fvs1 `plusFV` fvs2
865 returnM [(bndrs, fvs, bndrs `intersectNameSet` fvs,
866 L loc (BindStmt pat' expr' bind_op fail_op))]
868 rn_rec_stmt (L loc (LetStmt binds))
869 = rnBindGroups binds `thenM` \ (binds', du_binds) ->
870 returnM [(duDefs du_binds, duUses du_binds,
871 emptyNameSet, L loc (LetStmt binds'))]
873 rn_rec_stmt (L loc (RecStmt stmts _ _ _ _)) -- Flatten Rec inside Rec
876 rn_rec_stmt stmt@(L _ (ParStmt _)) -- Syntactically illegal in mdo
877 = pprPanic "rn_rec_stmt" (ppr stmt)
879 ---------------------------------------------
880 rn_rec_stmts :: [LStmt RdrName] -> RnM [Segment (LStmt Name)]
881 rn_rec_stmts stmts = mappM rn_rec_stmt stmts `thenM` \ segs_s ->
882 returnM (concat segs_s)
885 ---------------------------------------------
886 addFwdRefs :: [Segment a] -> [Segment a]
887 -- So far the segments only have forward refs *within* the Stmt
888 -- (which happens for bind: x <- ...x...)
889 -- This function adds the cross-seg fwd ref info
892 = fst (foldr mk_seg ([], emptyNameSet) pairs)
894 mk_seg (defs, uses, fwds, stmts) (segs, later_defs)
895 = (new_seg : segs, all_defs)
897 new_seg = (defs, uses, new_fwds, stmts)
898 all_defs = later_defs `unionNameSets` defs
899 new_fwds = fwds `unionNameSets` (uses `intersectNameSet` later_defs)
900 -- Add the downstream fwd refs here
902 ----------------------------------------------------
903 -- Glomming the singleton segments of an mdo into
904 -- minimal recursive groups.
906 -- At first I thought this was just strongly connected components, but
907 -- there's an important constraint: the order of the stmts must not change.
910 -- mdo { x <- ...y...
917 -- Here, the first stmt mention 'y', which is bound in the third.
918 -- But that means that the innocent second stmt (p <- z) gets caught
919 -- up in the recursion. And that in turn means that the binding for
920 -- 'z' has to be included... and so on.
922 -- Start at the tail { r <- x }
923 -- Now add the next one { z <- y ; r <- x }
924 -- Now add one more { q <- x ; z <- y ; r <- x }
925 -- Now one more... but this time we have to group a bunch into rec
926 -- { rec { y <- ...x... ; q <- x ; z <- y } ; r <- x }
927 -- Now one more, which we can add on without a rec
929 -- rec { y <- ...x... ; q <- x ; z <- y } ;
931 -- Finally we add the last one; since it mentions y we have to
932 -- glom it togeher with the first two groups
933 -- { rec { x <- ...y...; p <- z ; y <- ...x... ;
934 -- q <- x ; z <- y } ;
937 glomSegments :: [Segment (LStmt Name)] -> [Segment [LStmt Name]]
940 glomSegments ((defs,uses,fwds,stmt) : segs)
941 -- Actually stmts will always be a singleton
942 = (seg_defs, seg_uses, seg_fwds, seg_stmts) : others
944 segs' = glomSegments segs
945 (extras, others) = grab uses segs'
946 (ds, us, fs, ss) = unzip4 extras
948 seg_defs = plusFVs ds `plusFV` defs
949 seg_uses = plusFVs us `plusFV` uses
950 seg_fwds = plusFVs fs `plusFV` fwds
951 seg_stmts = stmt : concat ss
953 grab :: NameSet -- The client
955 -> ([Segment a], -- Needed by the 'client'
956 [Segment a]) -- Not needed by the client
957 -- The result is simply a split of the input
959 = (reverse yeses, reverse noes)
961 (noes, yeses) = span not_needed (reverse dus)
962 not_needed (defs,_,_,_) = not (intersectsNameSet defs uses)
965 ----------------------------------------------------
966 segsToStmts :: [Segment [LStmt Name]]
967 -> FreeVars -- Free vars used 'later'
968 -> ([LStmt Name], FreeVars)
970 segsToStmts [] fvs_later = ([], fvs_later)
971 segsToStmts ((defs, uses, fwds, ss) : segs) fvs_later
972 = ASSERT( not (null ss) )
973 (new_stmt : later_stmts, later_uses `plusFV` uses)
975 (later_stmts, later_uses) = segsToStmts segs fvs_later
976 new_stmt | non_rec = head ss
977 | otherwise = L (getLoc (head ss)) $
978 RecStmt ss (nameSetToList used_later) (nameSetToList fwds)
981 non_rec = isSingleton ss && isEmptyNameSet fwds
982 used_later = defs `intersectNameSet` later_uses
983 -- The ones needed after the RecStmt
986 %************************************************************************
988 \subsubsection{Precedence Parsing}
990 %************************************************************************
992 @mkOpAppRn@ deals with operator fixities. The argument expressions
993 are assumed to be already correctly arranged. It needs the fixities
994 recorded in the OpApp nodes, because fixity info applies to the things
995 the programmer actually wrote, so you can't find it out from the Name.
997 Furthermore, the second argument is guaranteed not to be another
998 operator application. Why? Because the parser parses all
999 operator appications left-associatively, EXCEPT negation, which
1000 we need to handle specially.
1003 mkOpAppRn :: LHsExpr Name -- Left operand; already rearranged
1004 -> LHsExpr Name -> Fixity -- Operator and fixity
1005 -> LHsExpr Name -- Right operand (not an OpApp, but might
1007 -> RnM (HsExpr Name)
1009 ---------------------------
1010 -- (e11 `op1` e12) `op2` e2
1011 mkOpAppRn e1@(L _ (OpApp e11 op1 fix1 e12)) op2 fix2 e2
1013 = addErr (precParseErr (ppr_op op1,fix1) (ppr_op op2,fix2)) `thenM_`
1014 returnM (OpApp e1 op2 fix2 e2)
1017 = mkOpAppRn e12 op2 fix2 e2 `thenM` \ new_e ->
1018 returnM (OpApp e11 op1 fix1 (L loc' new_e))
1020 loc'= combineLocs e12 e2
1021 (nofix_error, associate_right) = compareFixity fix1 fix2
1023 ---------------------------
1024 -- (- neg_arg) `op` e2
1025 mkOpAppRn e1@(L _ (NegApp neg_arg neg_name)) op2 fix2 e2
1027 = addErr (precParseErr (pp_prefix_minus,negateFixity) (ppr_op op2,fix2)) `thenM_`
1028 returnM (OpApp e1 op2 fix2 e2)
1031 = mkOpAppRn neg_arg op2 fix2 e2 `thenM` \ new_e ->
1032 returnM (NegApp (L loc' new_e) neg_name)
1034 loc' = combineLocs neg_arg e2
1035 (nofix_error, associate_right) = compareFixity negateFixity fix2
1037 ---------------------------
1038 -- e1 `op` - neg_arg
1039 mkOpAppRn e1 op1 fix1 e2@(L _ (NegApp neg_arg _)) -- NegApp can occur on the right
1040 | not associate_right -- We *want* right association
1041 = addErr (precParseErr (ppr_op op1, fix1) (pp_prefix_minus, negateFixity)) `thenM_`
1042 returnM (OpApp e1 op1 fix1 e2)
1044 (_, associate_right) = compareFixity fix1 negateFixity
1046 ---------------------------
1048 mkOpAppRn e1 op fix e2 -- Default case, no rearrangment
1049 = ASSERT2( right_op_ok fix (unLoc e2),
1050 ppr e1 $$ text "---" $$ ppr op $$ text "---" $$ ppr fix $$ text "---" $$ ppr e2
1052 returnM (OpApp e1 op fix e2)
1054 -- Parser left-associates everything, but
1055 -- derived instances may have correctly-associated things to
1056 -- in the right operarand. So we just check that the right operand is OK
1057 right_op_ok fix1 (OpApp _ _ fix2 _)
1058 = not error_please && associate_right
1060 (error_please, associate_right) = compareFixity fix1 fix2
1061 right_op_ok fix1 other
1064 -- Parser initially makes negation bind more tightly than any other operator
1065 -- And "deriving" code should respect this (use HsPar if not)
1066 mkNegAppRn :: LHsExpr id -> SyntaxExpr id -> RnM (HsExpr id)
1067 mkNegAppRn neg_arg neg_name
1068 = ASSERT( not_op_app (unLoc neg_arg) )
1069 returnM (NegApp neg_arg neg_name)
1071 not_op_app (OpApp _ _ _ _) = False
1072 not_op_app other = True
1076 checkPrecMatch :: Bool -> Name -> MatchGroup Name -> RnM ()
1077 -- True indicates an infix lhs
1078 -- See comments with rnExpr (OpApp ...) about "deriving"
1080 checkPrecMatch False fn match
1082 checkPrecMatch True op (MatchGroup ms _)
1085 check (L _ (Match (p1:p2:_) _ _))
1086 = checkPrec op (unLoc p1) False `thenM_`
1087 checkPrec op (unLoc p2) True
1089 check _ = panic "checkPrecMatch"
1091 checkPrec op (ConPatIn op1 (InfixCon _ _)) right
1092 = lookupFixityRn op `thenM` \ op_fix@(Fixity op_prec op_dir) ->
1093 lookupFixityRn (unLoc op1) `thenM` \ op1_fix@(Fixity op1_prec op1_dir) ->
1095 inf_ok = op1_prec > op_prec ||
1096 (op1_prec == op_prec &&
1097 (op1_dir == InfixR && op_dir == InfixR && right ||
1098 op1_dir == InfixL && op_dir == InfixL && not right))
1100 info = (ppr_op op, op_fix)
1101 info1 = (ppr_op op1, op1_fix)
1102 (infol, infor) = if right then (info, info1) else (info1, info)
1104 checkErr inf_ok (precParseErr infol infor)
1106 checkPrec op pat right
1109 -- Check precedence of (arg op) or (op arg) respectively
1110 -- If arg is itself an operator application, then either
1111 -- (a) its precedence must be higher than that of op
1112 -- (b) its precedency & associativity must be the same as that of op
1113 checkSectionPrec :: FixityDirection -> HsExpr RdrName
1114 -> LHsExpr Name -> LHsExpr Name -> RnM ()
1115 checkSectionPrec direction section op arg
1117 OpApp _ op fix _ -> go_for_it (ppr_op op) fix
1118 NegApp _ _ -> go_for_it pp_prefix_minus negateFixity
1121 L _ (HsVar op_name) = op
1122 go_for_it pp_arg_op arg_fix@(Fixity arg_prec assoc)
1123 = lookupFixityRn op_name `thenM` \ op_fix@(Fixity op_prec _) ->
1124 checkErr (op_prec < arg_prec
1125 || op_prec == arg_prec && direction == assoc)
1126 (sectionPrecErr (ppr_op op_name, op_fix)
1127 (pp_arg_op, arg_fix) section)
1131 %************************************************************************
1133 \subsubsection{Assertion utils}
1135 %************************************************************************
1138 mkAssertErrorExpr :: RnM (HsExpr Name, FreeVars)
1139 -- Return an expression for (assertError "Foo.hs:27")
1141 = getSrcSpanM `thenM` \ sloc ->
1143 expr = HsApp (L sloc (HsVar assertErrorName)) (L sloc (HsLit msg))
1144 msg = HsStringPrim (mkFastString (stringToUtf8 (showSDoc (ppr sloc))))
1146 returnM (expr, emptyFVs)
1149 %************************************************************************
1151 \subsubsection{Errors}
1153 %************************************************************************
1156 ppr_op op = quotes (ppr op) -- Here, op can be a Name or a (Var n), where n is a Name
1157 pp_prefix_minus = ptext SLIT("prefix `-'")
1159 nonStdGuardErr guard
1161 SLIT("accepting non-standard pattern guards (-fglasgow-exts to suppress this message)")
1165 = sep [ptext SLIT("Pattern syntax in expression context:"),
1169 checkTH e what = returnM () -- OK
1171 checkTH e what -- Raise an error in a stage-1 compiler
1172 = addErr (vcat [ptext SLIT("Template Haskell") <+> text what <+>
1173 ptext SLIT("illegal in a stage-1 compiler"),
1177 parStmtErr = addErr (ptext SLIT("Illegal parallel list comprehension: use -fglasgow-exts"))
1180 = hang (ptext SLIT("Implicit-parameter bindings illegal in a parallel list comprehension:")) 4