Groom comments related to StaticPointers.
[ghc.git] / compiler / rename / RnExpr.hs
1 {-
2 (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
3
4 \section[RnExpr]{Renaming of expressions}
5
6 Basically dependency analysis.
7
8 Handles @Match@, @GRHSs@, @HsExpr@, and @Qualifier@ datatypes. In
9 general, all of these functions return a renamed thing, and a set of
10 free variables.
11 -}
12
13 {-# LANGUAGE CPP, ScopedTypeVariables #-}
14
15 module RnExpr (
16 rnLExpr, rnExpr, rnStmts
17 ) where
18
19 #include "HsVersions.h"
20
21 import {-# SOURCE #-} TcSplice( runQuasiQuoteExpr )
22
23 import RnBinds ( rnLocalBindsAndThen, rnLocalValBindsLHS, rnLocalValBindsRHS,
24 rnMatchGroup, rnGRHS, makeMiniFixityEnv)
25 import HsSyn
26 import TcRnMonad
27 import Module ( getModule )
28 import RnEnv
29 import RnSplice ( rnBracket, rnSpliceExpr, checkThLocalName )
30 import RnTypes
31 import RnPat
32 import DynFlags
33 import BasicTypes ( FixityDirection(..) )
34 import PrelNames
35
36 import Name
37 import NameSet
38 import RdrName
39 import UniqSet
40 import Data.List
41 import Util
42 import ListSetOps ( removeDups )
43 import ErrUtils
44 import Outputable
45 import SrcLoc
46 import FastString
47 import Control.Monad
48 import TysWiredIn ( nilDataConName )
49
50 {-
51 ************************************************************************
52 * *
53 \subsubsection{Expressions}
54 * *
55 ************************************************************************
56 -}
57
58 rnExprs :: [LHsExpr RdrName] -> RnM ([LHsExpr Name], FreeVars)
59 rnExprs ls = rnExprs' ls emptyUniqSet
60 where
61 rnExprs' [] acc = return ([], acc)
62 rnExprs' (expr:exprs) acc =
63 do { (expr', fvExpr) <- rnLExpr expr
64 -- Now we do a "seq" on the free vars because typically it's small
65 -- or empty, especially in very long lists of constants
66 ; let acc' = acc `plusFV` fvExpr
67 ; (exprs', fvExprs) <- acc' `seq` rnExprs' exprs acc'
68 ; return (expr':exprs', fvExprs) }
69
70 -- Variables. We look up the variable and return the resulting name.
71
72 rnLExpr :: LHsExpr RdrName -> RnM (LHsExpr Name, FreeVars)
73 rnLExpr = wrapLocFstM rnExpr
74
75 rnExpr :: HsExpr RdrName -> RnM (HsExpr Name, FreeVars)
76
77 finishHsVar :: Name -> RnM (HsExpr Name, FreeVars)
78 -- Separated from rnExpr because it's also used
79 -- when renaming infix expressions
80 finishHsVar name
81 = do { this_mod <- getModule
82 ; when (nameIsLocalOrFrom this_mod name) $
83 checkThLocalName name
84 ; return (HsVar name, unitFV name) }
85
86 rnExpr (HsVar v)
87 = do { mb_name <- lookupOccRn_maybe v
88 ; case mb_name of {
89 Nothing -> do { if startsWithUnderscore (rdrNameOcc v)
90 then return (HsUnboundVar v, emptyFVs)
91 else do { n <- reportUnboundName v; finishHsVar n } } ;
92 Just name
93 | name == nilDataConName -- Treat [] as an ExplicitList, so that
94 -- OverloadedLists works correctly
95 -> rnExpr (ExplicitList placeHolderType Nothing [])
96
97 | otherwise
98 -> finishHsVar name }}
99
100 rnExpr (HsIPVar v)
101 = return (HsIPVar v, emptyFVs)
102
103 rnExpr (HsLit lit@(HsString src s))
104 = do { opt_OverloadedStrings <- xoptM Opt_OverloadedStrings
105 ; if opt_OverloadedStrings then
106 rnExpr (HsOverLit (mkHsIsString src s placeHolderType))
107 else do {
108 ; rnLit lit
109 ; return (HsLit lit, emptyFVs) } }
110
111 rnExpr (HsLit lit)
112 = do { rnLit lit
113 ; return (HsLit lit, emptyFVs) }
114
115 rnExpr (HsOverLit lit)
116 = do { (lit', fvs) <- rnOverLit lit
117 ; return (HsOverLit lit', fvs) }
118
119 rnExpr (HsApp fun arg)
120 = do { (fun',fvFun) <- rnLExpr fun
121 ; (arg',fvArg) <- rnLExpr arg
122 ; return (HsApp fun' arg', fvFun `plusFV` fvArg) }
123
124 rnExpr (OpApp e1 (L op_loc (HsVar op_rdr)) _ e2)
125 = do { (e1', fv_e1) <- rnLExpr e1
126 ; (e2', fv_e2) <- rnLExpr e2
127 ; op_name <- setSrcSpan op_loc (lookupOccRn op_rdr)
128 ; (op', fv_op) <- finishHsVar op_name
129 -- NB: op' is usually just a variable, but might be
130 -- an applicatoin (assert "Foo.hs:47")
131 -- Deal with fixity
132 -- When renaming code synthesised from "deriving" declarations
133 -- we used to avoid fixity stuff, but we can't easily tell any
134 -- more, so I've removed the test. Adding HsPars in TcGenDeriv
135 -- should prevent bad things happening.
136 ; fixity <- lookupFixityRn op_name
137 ; final_e <- mkOpAppRn e1' (L op_loc op') fixity e2'
138 ; return (final_e, fv_e1 `plusFV` fv_op `plusFV` fv_e2) }
139 rnExpr (OpApp _ other_op _ _)
140 = failWith (vcat [ hang (ptext (sLit "Infix application with a non-variable operator:"))
141 2 (ppr other_op)
142 , ptext (sLit "(Probably resulting from a Template Haskell splice)") ])
143
144 rnExpr (NegApp e _)
145 = do { (e', fv_e) <- rnLExpr e
146 ; (neg_name, fv_neg) <- lookupSyntaxName negateName
147 ; final_e <- mkNegAppRn e' neg_name
148 ; return (final_e, fv_e `plusFV` fv_neg) }
149
150 ------------------------------------------
151 -- Template Haskell extensions
152 -- Don't ifdef-GHCI them because we want to fail gracefully
153 -- (not with an rnExpr crash) in a stage-1 compiler.
154 rnExpr e@(HsBracket br_body) = rnBracket e br_body
155
156 rnExpr (HsSpliceE is_typed splice) = rnSpliceExpr is_typed splice
157
158
159 rnExpr (HsQuasiQuoteE qq)
160 = do { lexpr' <- runQuasiQuoteExpr qq
161 -- Wrap the result of the quasi-quoter in parens so that we don't
162 -- lose the outermost location set by runQuasiQuote (#7918)
163 ; rnExpr (HsPar lexpr') }
164
165 ---------------------------------------------
166 -- Sections
167 -- See Note [Parsing sections] in Parser.y
168 rnExpr (HsPar (L loc (section@(SectionL {}))))
169 = do { (section', fvs) <- rnSection section
170 ; return (HsPar (L loc section'), fvs) }
171
172 rnExpr (HsPar (L loc (section@(SectionR {}))))
173 = do { (section', fvs) <- rnSection section
174 ; return (HsPar (L loc section'), fvs) }
175
176 rnExpr (HsPar e)
177 = do { (e', fvs_e) <- rnLExpr e
178 ; return (HsPar e', fvs_e) }
179
180 rnExpr expr@(SectionL {})
181 = do { addErr (sectionErr expr); rnSection expr }
182 rnExpr expr@(SectionR {})
183 = do { addErr (sectionErr expr); rnSection expr }
184
185 ---------------------------------------------
186 rnExpr (HsCoreAnn ann expr)
187 = do { (expr', fvs_expr) <- rnLExpr expr
188 ; return (HsCoreAnn ann expr', fvs_expr) }
189
190 rnExpr (HsSCC lbl expr)
191 = do { (expr', fvs_expr) <- rnLExpr expr
192 ; return (HsSCC lbl expr', fvs_expr) }
193 rnExpr (HsTickPragma info expr)
194 = do { (expr', fvs_expr) <- rnLExpr expr
195 ; return (HsTickPragma info expr', fvs_expr) }
196
197 rnExpr (HsLam matches)
198 = do { (matches', fvMatch) <- rnMatchGroup LambdaExpr rnLExpr matches
199 ; return (HsLam matches', fvMatch) }
200
201 rnExpr (HsLamCase _arg matches)
202 = do { (matches', fvs_ms) <- rnMatchGroup CaseAlt rnLExpr matches
203 -- ; return (HsLamCase arg matches', fvs_ms) }
204 ; return (HsLamCase placeHolderType matches', fvs_ms) }
205
206 rnExpr (HsCase expr matches)
207 = do { (new_expr, e_fvs) <- rnLExpr expr
208 ; (new_matches, ms_fvs) <- rnMatchGroup CaseAlt rnLExpr matches
209 ; return (HsCase new_expr new_matches, e_fvs `plusFV` ms_fvs) }
210
211 rnExpr (HsLet binds expr)
212 = rnLocalBindsAndThen binds $ \binds' -> do
213 { (expr',fvExpr) <- rnLExpr expr
214 ; return (HsLet binds' expr', fvExpr) }
215
216 rnExpr (HsDo do_or_lc stmts _)
217 = do { ((stmts', _), fvs) <- rnStmts do_or_lc rnLExpr stmts (\ _ -> return ((), emptyFVs))
218 ; return ( HsDo do_or_lc stmts' placeHolderType, fvs ) }
219
220 rnExpr (ExplicitList _ _ exps)
221 = do { opt_OverloadedLists <- xoptM Opt_OverloadedLists
222 ; (exps', fvs) <- rnExprs exps
223 ; if opt_OverloadedLists
224 then do {
225 ; (from_list_n_name, fvs') <- lookupSyntaxName fromListNName
226 ; return (ExplicitList placeHolderType (Just from_list_n_name) exps'
227 , fvs `plusFV` fvs') }
228 else
229 return (ExplicitList placeHolderType Nothing exps', fvs) }
230
231 rnExpr (ExplicitPArr _ exps)
232 = do { (exps', fvs) <- rnExprs exps
233 ; return (ExplicitPArr placeHolderType exps', fvs) }
234
235 rnExpr (ExplicitTuple tup_args boxity)
236 = do { checkTupleSection tup_args
237 ; checkTupSize (length tup_args)
238 ; (tup_args', fvs) <- mapAndUnzipM rnTupArg tup_args
239 ; return (ExplicitTuple tup_args' boxity, plusFVs fvs) }
240 where
241 rnTupArg (L l (Present e)) = do { (e',fvs) <- rnLExpr e
242 ; return (L l (Present e'), fvs) }
243 rnTupArg (L l (Missing _)) = return (L l (Missing placeHolderType)
244 , emptyFVs)
245
246 rnExpr (RecordCon con_id _ rbinds)
247 = do { conname <- lookupLocatedOccRn con_id
248 ; (rbinds', fvRbinds) <- rnHsRecBinds (HsRecFieldCon (unLoc conname)) rbinds
249 ; return (RecordCon conname noPostTcExpr rbinds',
250 fvRbinds `addOneFV` unLoc conname) }
251
252 rnExpr (RecordUpd expr rbinds _ _ _)
253 = do { (expr', fvExpr) <- rnLExpr expr
254 ; (rbinds', fvRbinds) <- rnHsRecBinds HsRecFieldUpd rbinds
255 ; return (RecordUpd expr' rbinds' [] [] [],
256 fvExpr `plusFV` fvRbinds) }
257
258 rnExpr (ExprWithTySig expr pty PlaceHolder)
259 = do { (wcs, pty') <- extractWildcards pty
260 ; bindLocatedLocalsFV wcs $ \wcs_new -> do {
261 (pty'', fvTy) <- rnLHsType ExprWithTySigCtx pty'
262 ; (expr', fvExpr) <- bindSigTyVarsFV (hsExplicitTvs pty'') $
263 rnLExpr expr
264 ; return (ExprWithTySig expr' pty'' wcs_new, fvExpr `plusFV` fvTy) } }
265
266 rnExpr (HsIf _ p b1 b2)
267 = do { (p', fvP) <- rnLExpr p
268 ; (b1', fvB1) <- rnLExpr b1
269 ; (b2', fvB2) <- rnLExpr b2
270 ; (mb_ite, fvITE) <- lookupIfThenElse
271 ; return (HsIf mb_ite p' b1' b2', plusFVs [fvITE, fvP, fvB1, fvB2]) }
272
273 rnExpr (HsMultiIf _ty alts)
274 = do { (alts', fvs) <- mapFvRn (rnGRHS IfAlt rnLExpr) alts
275 -- ; return (HsMultiIf ty alts', fvs) }
276 ; return (HsMultiIf placeHolderType alts', fvs) }
277
278 rnExpr (HsType a)
279 = do { (t, fvT) <- rnLHsType HsTypeCtx a
280 ; return (HsType t, fvT) }
281
282 rnExpr (ArithSeq _ _ seq)
283 = do { opt_OverloadedLists <- xoptM Opt_OverloadedLists
284 ; (new_seq, fvs) <- rnArithSeq seq
285 ; if opt_OverloadedLists
286 then do {
287 ; (from_list_name, fvs') <- lookupSyntaxName fromListName
288 ; return (ArithSeq noPostTcExpr (Just from_list_name) new_seq, fvs `plusFV` fvs') }
289 else
290 return (ArithSeq noPostTcExpr Nothing new_seq, fvs) }
291
292 rnExpr (PArrSeq _ seq)
293 = do { (new_seq, fvs) <- rnArithSeq seq
294 ; return (PArrSeq noPostTcExpr new_seq, fvs) }
295
296 {-
297 These three are pattern syntax appearing in expressions.
298 Since all the symbols are reservedops we can simply reject them.
299 We return a (bogus) EWildPat in each case.
300 -}
301
302 rnExpr EWildPat = return (hsHoleExpr, emptyFVs)
303 rnExpr e@(EAsPat {}) = patSynErr e
304 rnExpr e@(EViewPat {}) = patSynErr e
305 rnExpr e@(ELazyPat {}) = patSynErr e
306
307 {-
308 ************************************************************************
309 * *
310 Static values
311 * *
312 ************************************************************************
313
314 For the static form we check that the free variables are all top-level
315 value bindings. This is done by checking that the name is external or
316 wired-in. See the Notes about the NameSorts in Name.hs.
317 -}
318
319 rnExpr e@(HsStatic expr) = do
320 (expr',fvExpr) <- rnLExpr expr
321 stage <- getStage
322 case stage of
323 Brack _ _ -> return () -- Don't check names if we are inside brackets.
324 -- We don't want to reject cases like:
325 -- \e -> [| static $(e) |]
326 -- if $(e) turns out to produce a legal expression.
327 Splice _ -> addErr $ sep
328 [ text "static forms cannot be used in splices:"
329 , nest 2 $ ppr e
330 ]
331 _ -> do
332 let isTopLevelName n = isExternalName n || isWiredInName n
333 case nameSetElems $ filterNameSet (not . isTopLevelName) fvExpr of
334 [] -> return ()
335 fvNonGlobal -> addErr $ cat
336 [ text $ "Only identifiers of top-level bindings can "
337 ++ "appear in the body of the static form:"
338 , nest 2 $ ppr e
339 , text "but the following identifiers were found instead:"
340 , nest 2 $ vcat $ map ppr fvNonGlobal
341 ]
342 return (HsStatic expr', fvExpr)
343
344 {-
345 ************************************************************************
346 * *
347 Arrow notation
348 * *
349 ************************************************************************
350 -}
351
352 rnExpr (HsProc pat body)
353 = newArrowScope $
354 rnPat ProcExpr pat $ \ pat' -> do
355 { (body',fvBody) <- rnCmdTop body
356 ; return (HsProc pat' body', fvBody) }
357
358 -- Ideally, these would be done in parsing, but to keep parsing simple, we do it here.
359 rnExpr e@(HsArrApp {}) = arrowFail e
360 rnExpr e@(HsArrForm {}) = arrowFail e
361
362 rnExpr other = pprPanic "rnExpr: unexpected expression" (ppr other)
363 -- HsWrap
364
365 hsHoleExpr :: HsExpr Name
366 hsHoleExpr = HsUnboundVar (mkRdrUnqual (mkVarOcc "_"))
367
368 arrowFail :: HsExpr RdrName -> RnM (HsExpr Name, FreeVars)
369 arrowFail e
370 = do { addErr (vcat [ ptext (sLit "Arrow command found where an expression was expected:")
371 , nest 2 (ppr e) ])
372 -- Return a place-holder hole, so that we can carry on
373 -- to report other errors
374 ; return (hsHoleExpr, emptyFVs) }
375
376 ----------------------
377 -- See Note [Parsing sections] in Parser.y
378 rnSection :: HsExpr RdrName -> RnM (HsExpr Name, FreeVars)
379 rnSection section@(SectionR op expr)
380 = do { (op', fvs_op) <- rnLExpr op
381 ; (expr', fvs_expr) <- rnLExpr expr
382 ; checkSectionPrec InfixR section op' expr'
383 ; return (SectionR op' expr', fvs_op `plusFV` fvs_expr) }
384
385 rnSection section@(SectionL expr op)
386 = do { (expr', fvs_expr) <- rnLExpr expr
387 ; (op', fvs_op) <- rnLExpr op
388 ; checkSectionPrec InfixL section op' expr'
389 ; return (SectionL expr' op', fvs_op `plusFV` fvs_expr) }
390
391 rnSection other = pprPanic "rnSection" (ppr other)
392
393 {-
394 ************************************************************************
395 * *
396 Records
397 * *
398 ************************************************************************
399 -}
400
401 rnHsRecBinds :: HsRecFieldContext -> HsRecordBinds RdrName
402 -> RnM (HsRecordBinds Name, FreeVars)
403 rnHsRecBinds ctxt rec_binds@(HsRecFields { rec_dotdot = dd })
404 = do { (flds, fvs) <- rnHsRecFields ctxt HsVar rec_binds
405 ; (flds', fvss) <- mapAndUnzipM rn_field flds
406 ; return (HsRecFields { rec_flds = flds', rec_dotdot = dd },
407 fvs `plusFV` plusFVs fvss) }
408 where
409 rn_field (L l fld) = do { (arg', fvs) <- rnLExpr (hsRecFieldArg fld)
410 ; return (L l (fld { hsRecFieldArg = arg' }), fvs) }
411
412 {-
413 ************************************************************************
414 * *
415 Arrow commands
416 * *
417 ************************************************************************
418 -}
419
420 rnCmdArgs :: [LHsCmdTop RdrName] -> RnM ([LHsCmdTop Name], FreeVars)
421 rnCmdArgs [] = return ([], emptyFVs)
422 rnCmdArgs (arg:args)
423 = do { (arg',fvArg) <- rnCmdTop arg
424 ; (args',fvArgs) <- rnCmdArgs args
425 ; return (arg':args', fvArg `plusFV` fvArgs) }
426
427 rnCmdTop :: LHsCmdTop RdrName -> RnM (LHsCmdTop Name, FreeVars)
428 rnCmdTop = wrapLocFstM rnCmdTop'
429 where
430 rnCmdTop' (HsCmdTop cmd _ _ _)
431 = do { (cmd', fvCmd) <- rnLCmd cmd
432 ; let cmd_names = [arrAName, composeAName, firstAName] ++
433 nameSetElems (methodNamesCmd (unLoc cmd'))
434 -- Generate the rebindable syntax for the monad
435 ; (cmd_names', cmd_fvs) <- lookupSyntaxNames cmd_names
436
437 ; return (HsCmdTop cmd' placeHolderType placeHolderType
438 (cmd_names `zip` cmd_names'),
439 fvCmd `plusFV` cmd_fvs) }
440
441 rnLCmd :: LHsCmd RdrName -> RnM (LHsCmd Name, FreeVars)
442 rnLCmd = wrapLocFstM rnCmd
443
444 rnCmd :: HsCmd RdrName -> RnM (HsCmd Name, FreeVars)
445
446 rnCmd (HsCmdArrApp arrow arg _ ho rtl)
447 = do { (arrow',fvArrow) <- select_arrow_scope (rnLExpr arrow)
448 ; (arg',fvArg) <- rnLExpr arg
449 ; return (HsCmdArrApp arrow' arg' placeHolderType ho rtl,
450 fvArrow `plusFV` fvArg) }
451 where
452 select_arrow_scope tc = case ho of
453 HsHigherOrderApp -> tc
454 HsFirstOrderApp -> escapeArrowScope tc
455 -- See Note [Escaping the arrow scope] in TcRnTypes
456 -- Before renaming 'arrow', use the environment of the enclosing
457 -- proc for the (-<) case.
458 -- Local bindings, inside the enclosing proc, are not in scope
459 -- inside 'arrow'. In the higher-order case (-<<), they are.
460
461 -- infix form
462 rnCmd (HsCmdArrForm op (Just _) [arg1, arg2])
463 = do { (op',fv_op) <- escapeArrowScope (rnLExpr op)
464 ; let L _ (HsVar op_name) = op'
465 ; (arg1',fv_arg1) <- rnCmdTop arg1
466 ; (arg2',fv_arg2) <- rnCmdTop arg2
467 -- Deal with fixity
468 ; fixity <- lookupFixityRn op_name
469 ; final_e <- mkOpFormRn arg1' op' fixity arg2'
470 ; return (final_e, fv_arg1 `plusFV` fv_op `plusFV` fv_arg2) }
471
472 rnCmd (HsCmdArrForm op fixity cmds)
473 = do { (op',fvOp) <- escapeArrowScope (rnLExpr op)
474 ; (cmds',fvCmds) <- rnCmdArgs cmds
475 ; return (HsCmdArrForm op' fixity cmds', fvOp `plusFV` fvCmds) }
476
477 rnCmd (HsCmdApp fun arg)
478 = do { (fun',fvFun) <- rnLCmd fun
479 ; (arg',fvArg) <- rnLExpr arg
480 ; return (HsCmdApp fun' arg', fvFun `plusFV` fvArg) }
481
482 rnCmd (HsCmdLam matches)
483 = do { (matches', fvMatch) <- rnMatchGroup LambdaExpr rnLCmd matches
484 ; return (HsCmdLam matches', fvMatch) }
485
486 rnCmd (HsCmdPar e)
487 = do { (e', fvs_e) <- rnLCmd e
488 ; return (HsCmdPar e', fvs_e) }
489
490 rnCmd (HsCmdCase expr matches)
491 = do { (new_expr, e_fvs) <- rnLExpr expr
492 ; (new_matches, ms_fvs) <- rnMatchGroup CaseAlt rnLCmd matches
493 ; return (HsCmdCase new_expr new_matches, e_fvs `plusFV` ms_fvs) }
494
495 rnCmd (HsCmdIf _ p b1 b2)
496 = do { (p', fvP) <- rnLExpr p
497 ; (b1', fvB1) <- rnLCmd b1
498 ; (b2', fvB2) <- rnLCmd b2
499 ; (mb_ite, fvITE) <- lookupIfThenElse
500 ; return (HsCmdIf mb_ite p' b1' b2', plusFVs [fvITE, fvP, fvB1, fvB2]) }
501
502 rnCmd (HsCmdLet binds cmd)
503 = rnLocalBindsAndThen binds $ \ binds' -> do
504 { (cmd',fvExpr) <- rnLCmd cmd
505 ; return (HsCmdLet binds' cmd', fvExpr) }
506
507 rnCmd (HsCmdDo stmts _)
508 = do { ((stmts', _), fvs) <- rnStmts ArrowExpr rnLCmd stmts (\ _ -> return ((), emptyFVs))
509 ; return ( HsCmdDo stmts' placeHolderType, fvs ) }
510
511 rnCmd cmd@(HsCmdCast {}) = pprPanic "rnCmd" (ppr cmd)
512
513 ---------------------------------------------------
514 type CmdNeeds = FreeVars -- Only inhabitants are
515 -- appAName, choiceAName, loopAName
516
517 -- find what methods the Cmd needs (loop, choice, apply)
518 methodNamesLCmd :: LHsCmd Name -> CmdNeeds
519 methodNamesLCmd = methodNamesCmd . unLoc
520
521 methodNamesCmd :: HsCmd Name -> CmdNeeds
522
523 methodNamesCmd (HsCmdArrApp _arrow _arg _ HsFirstOrderApp _rtl)
524 = emptyFVs
525 methodNamesCmd (HsCmdArrApp _arrow _arg _ HsHigherOrderApp _rtl)
526 = unitFV appAName
527 methodNamesCmd (HsCmdArrForm {}) = emptyFVs
528 methodNamesCmd (HsCmdCast _ cmd) = methodNamesCmd cmd
529
530 methodNamesCmd (HsCmdPar c) = methodNamesLCmd c
531
532 methodNamesCmd (HsCmdIf _ _ c1 c2)
533 = methodNamesLCmd c1 `plusFV` methodNamesLCmd c2 `addOneFV` choiceAName
534
535 methodNamesCmd (HsCmdLet _ c) = methodNamesLCmd c
536 methodNamesCmd (HsCmdDo stmts _) = methodNamesStmts stmts
537 methodNamesCmd (HsCmdApp c _) = methodNamesLCmd c
538 methodNamesCmd (HsCmdLam match) = methodNamesMatch match
539
540 methodNamesCmd (HsCmdCase _ matches)
541 = methodNamesMatch matches `addOneFV` choiceAName
542
543 --methodNamesCmd _ = 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
547
548 ---------------------------------------------------
549 methodNamesMatch :: MatchGroup Name (LHsCmd Name) -> FreeVars
550 methodNamesMatch (MG { mg_alts = ms })
551 = plusFVs (map do_one ms)
552 where
553 do_one (L _ (Match _ _ grhss)) = methodNamesGRHSs grhss
554
555 -------------------------------------------------
556 -- gaw 2004
557 methodNamesGRHSs :: GRHSs Name (LHsCmd Name) -> FreeVars
558 methodNamesGRHSs (GRHSs grhss _) = plusFVs (map methodNamesGRHS grhss)
559
560 -------------------------------------------------
561
562 methodNamesGRHS :: Located (GRHS Name (LHsCmd Name)) -> CmdNeeds
563 methodNamesGRHS (L _ (GRHS _ rhs)) = methodNamesLCmd rhs
564
565 ---------------------------------------------------
566 methodNamesStmts :: [Located (StmtLR Name Name (LHsCmd Name))] -> FreeVars
567 methodNamesStmts stmts = plusFVs (map methodNamesLStmt stmts)
568
569 ---------------------------------------------------
570 methodNamesLStmt :: Located (StmtLR Name Name (LHsCmd Name)) -> FreeVars
571 methodNamesLStmt = methodNamesStmt . unLoc
572
573 methodNamesStmt :: StmtLR Name Name (LHsCmd Name) -> FreeVars
574 methodNamesStmt (LastStmt cmd _) = methodNamesLCmd cmd
575 methodNamesStmt (BodyStmt cmd _ _ _) = methodNamesLCmd cmd
576 methodNamesStmt (BindStmt _ cmd _ _) = methodNamesLCmd cmd
577 methodNamesStmt (RecStmt { recS_stmts = stmts }) = methodNamesStmts stmts `addOneFV` loopAName
578 methodNamesStmt (LetStmt {}) = emptyFVs
579 methodNamesStmt (ParStmt {}) = emptyFVs
580 methodNamesStmt (TransStmt {}) = emptyFVs
581 -- ParStmt and TransStmt can't occur in commands, but it's not convenient to error
582 -- here so we just do what's convenient
583
584 {-
585 ************************************************************************
586 * *
587 Arithmetic sequences
588 * *
589 ************************************************************************
590 -}
591
592 rnArithSeq :: ArithSeqInfo RdrName -> RnM (ArithSeqInfo Name, FreeVars)
593 rnArithSeq (From expr)
594 = do { (expr', fvExpr) <- rnLExpr expr
595 ; return (From expr', fvExpr) }
596
597 rnArithSeq (FromThen expr1 expr2)
598 = do { (expr1', fvExpr1) <- rnLExpr expr1
599 ; (expr2', fvExpr2) <- rnLExpr expr2
600 ; return (FromThen expr1' expr2', fvExpr1 `plusFV` fvExpr2) }
601
602 rnArithSeq (FromTo expr1 expr2)
603 = do { (expr1', fvExpr1) <- rnLExpr expr1
604 ; (expr2', fvExpr2) <- rnLExpr expr2
605 ; return (FromTo expr1' expr2', fvExpr1 `plusFV` fvExpr2) }
606
607 rnArithSeq (FromThenTo expr1 expr2 expr3)
608 = do { (expr1', fvExpr1) <- rnLExpr expr1
609 ; (expr2', fvExpr2) <- rnLExpr expr2
610 ; (expr3', fvExpr3) <- rnLExpr expr3
611 ; return (FromThenTo expr1' expr2' expr3',
612 plusFVs [fvExpr1, fvExpr2, fvExpr3]) }
613
614 {-
615 ************************************************************************
616 * *
617 \subsubsection{@Stmt@s: in @do@ expressions}
618 * *
619 ************************************************************************
620 -}
621
622 rnStmts :: Outputable (body RdrName) => HsStmtContext Name
623 -> (Located (body RdrName) -> RnM (Located (body Name), FreeVars))
624 -> [LStmt RdrName (Located (body RdrName))]
625 -> ([Name] -> RnM (thing, FreeVars))
626 -> RnM (([LStmt Name (Located (body Name))], thing), FreeVars)
627 -- Variables bound by the Stmts, and mentioned in thing_inside,
628 -- do not appear in the result FreeVars
629
630 rnStmts ctxt _ [] thing_inside
631 = do { checkEmptyStmts ctxt
632 ; (thing, fvs) <- thing_inside []
633 ; return (([], thing), fvs) }
634
635 rnStmts MDoExpr rnBody stmts thing_inside -- Deal with mdo
636 = -- Behave like do { rec { ...all but last... }; last }
637 do { ((stmts1, (stmts2, thing)), fvs)
638 <- rnStmt MDoExpr rnBody (noLoc $ mkRecStmt all_but_last) $ \ _ ->
639 do { last_stmt' <- checkLastStmt MDoExpr last_stmt
640 ; rnStmt MDoExpr rnBody last_stmt' thing_inside }
641 ; return (((stmts1 ++ stmts2), thing), fvs) }
642 where
643 Just (all_but_last, last_stmt) = snocView stmts
644
645 rnStmts ctxt rnBody (lstmt@(L loc _) : lstmts) thing_inside
646 | null lstmts
647 = setSrcSpan loc $
648 do { lstmt' <- checkLastStmt ctxt lstmt
649 ; rnStmt ctxt rnBody lstmt' thing_inside }
650
651 | otherwise
652 = do { ((stmts1, (stmts2, thing)), fvs)
653 <- setSrcSpan loc $
654 do { checkStmt ctxt lstmt
655 ; rnStmt ctxt rnBody lstmt $ \ bndrs1 ->
656 rnStmts ctxt rnBody lstmts $ \ bndrs2 ->
657 thing_inside (bndrs1 ++ bndrs2) }
658 ; return (((stmts1 ++ stmts2), thing), fvs) }
659
660 ----------------------
661 rnStmt :: Outputable (body RdrName) => HsStmtContext Name
662 -> (Located (body RdrName) -> RnM (Located (body Name), FreeVars))
663 -> LStmt RdrName (Located (body RdrName))
664 -> ([Name] -> RnM (thing, FreeVars))
665 -> RnM (([LStmt Name (Located (body Name))], thing), FreeVars)
666 -- Variables bound by the Stmt, and mentioned in thing_inside,
667 -- do not appear in the result FreeVars
668
669 rnStmt ctxt rnBody (L loc (LastStmt body _)) thing_inside
670 = do { (body', fv_expr) <- rnBody body
671 ; (ret_op, fvs1) <- lookupStmtName ctxt returnMName
672 ; (thing, fvs3) <- thing_inside []
673 ; return (([L loc (LastStmt body' ret_op)], thing),
674 fv_expr `plusFV` fvs1 `plusFV` fvs3) }
675
676 rnStmt ctxt rnBody (L loc (BodyStmt body _ _ _)) thing_inside
677 = do { (body', fv_expr) <- rnBody body
678 ; (then_op, fvs1) <- lookupStmtName ctxt thenMName
679 ; (guard_op, fvs2) <- if isListCompExpr ctxt
680 then lookupStmtName ctxt guardMName
681 else return (noSyntaxExpr, emptyFVs)
682 -- Only list/parr/monad comprehensions use 'guard'
683 -- Also for sub-stmts of same eg [ e | x<-xs, gd | blah ]
684 -- Here "gd" is a guard
685 ; (thing, fvs3) <- thing_inside []
686 ; return (([L loc (BodyStmt body' then_op guard_op placeHolderType)], thing),
687 fv_expr `plusFV` fvs1 `plusFV` fvs2 `plusFV` fvs3) }
688
689 rnStmt ctxt rnBody (L loc (BindStmt pat body _ _)) thing_inside
690 = do { (body', fv_expr) <- rnBody body
691 -- The binders do not scope over the expression
692 ; (bind_op, fvs1) <- lookupStmtName ctxt bindMName
693 ; (fail_op, fvs2) <- lookupStmtName ctxt failMName
694 ; rnPat (StmtCtxt ctxt) pat $ \ pat' -> do
695 { (thing, fvs3) <- thing_inside (collectPatBinders pat')
696 ; return (([L loc (BindStmt pat' body' bind_op fail_op)], thing),
697 fv_expr `plusFV` fvs1 `plusFV` fvs2 `plusFV` fvs3) }}
698 -- fv_expr shouldn't really be filtered by the rnPatsAndThen
699 -- but it does not matter because the names are unique
700
701 rnStmt _ _ (L loc (LetStmt binds)) thing_inside
702 = do { rnLocalBindsAndThen binds $ \binds' -> do
703 { (thing, fvs) <- thing_inside (collectLocalBinders binds')
704 ; return (([L loc (LetStmt binds')], thing), fvs) } }
705
706 rnStmt ctxt rnBody (L _ (RecStmt { recS_stmts = rec_stmts })) thing_inside
707 = do { (return_op, fvs1) <- lookupStmtName ctxt returnMName
708 ; (mfix_op, fvs2) <- lookupStmtName ctxt mfixName
709 ; (bind_op, fvs3) <- lookupStmtName ctxt bindMName
710 ; let empty_rec_stmt = emptyRecStmtName { recS_ret_fn = return_op
711 , recS_mfix_fn = mfix_op
712 , recS_bind_fn = bind_op }
713
714 -- Step1: Bring all the binders of the mdo into scope
715 -- (Remember that this also removes the binders from the
716 -- finally-returned free-vars.)
717 -- And rename each individual stmt, making a
718 -- singleton segment. At this stage the FwdRefs field
719 -- isn't finished: it's empty for all except a BindStmt
720 -- for which it's the fwd refs within the bind itself
721 -- (This set may not be empty, because we're in a recursive
722 -- context.)
723 ; rnRecStmtsAndThen rnBody rec_stmts $ \ segs -> do
724 { let bndrs = nameSetElems $ foldr (unionNameSet . (\(ds,_,_,_) -> ds))
725 emptyNameSet segs
726 ; (thing, fvs_later) <- thing_inside bndrs
727 ; let (rec_stmts', fvs) = segmentRecStmts ctxt empty_rec_stmt segs fvs_later
728 ; return ((rec_stmts', thing), fvs `plusFV` fvs1 `plusFV` fvs2 `plusFV` fvs3) } }
729
730 rnStmt ctxt _ (L loc (ParStmt segs _ _)) thing_inside
731 = do { (mzip_op, fvs1) <- lookupStmtName ctxt mzipName
732 ; (bind_op, fvs2) <- lookupStmtName ctxt bindMName
733 ; (return_op, fvs3) <- lookupStmtName ctxt returnMName
734 ; ((segs', thing), fvs4) <- rnParallelStmts (ParStmtCtxt ctxt) return_op segs thing_inside
735 ; return ( ([L loc (ParStmt segs' mzip_op bind_op)], thing)
736 , fvs1 `plusFV` fvs2 `plusFV` fvs3 `plusFV` fvs4) }
737
738 rnStmt ctxt _ (L loc (TransStmt { trS_stmts = stmts, trS_by = by, trS_form = form
739 , trS_using = using })) thing_inside
740 = do { -- Rename the 'using' expression in the context before the transform is begun
741 (using', fvs1) <- rnLExpr using
742
743 -- Rename the stmts and the 'by' expression
744 -- Keep track of the variables mentioned in the 'by' expression
745 ; ((stmts', (by', used_bndrs, thing)), fvs2)
746 <- rnStmts (TransStmtCtxt ctxt) rnLExpr stmts $ \ bndrs ->
747 do { (by', fvs_by) <- mapMaybeFvRn rnLExpr by
748 ; (thing, fvs_thing) <- thing_inside bndrs
749 ; let fvs = fvs_by `plusFV` fvs_thing
750 used_bndrs = filter (`elemNameSet` fvs) bndrs
751 -- The paper (Fig 5) has a bug here; we must treat any free varaible
752 -- of the "thing inside", **or of the by-expression**, as used
753 ; return ((by', used_bndrs, thing), fvs) }
754
755 -- Lookup `return`, `(>>=)` and `liftM` for monad comprehensions
756 ; (return_op, fvs3) <- lookupStmtName ctxt returnMName
757 ; (bind_op, fvs4) <- lookupStmtName ctxt bindMName
758 ; (fmap_op, fvs5) <- case form of
759 ThenForm -> return (noSyntaxExpr, emptyFVs)
760 _ -> lookupStmtName ctxt fmapName
761
762 ; let all_fvs = fvs1 `plusFV` fvs2 `plusFV` fvs3
763 `plusFV` fvs4 `plusFV` fvs5
764 bndr_map = used_bndrs `zip` used_bndrs
765 -- See Note [TransStmt binder map] in HsExpr
766
767 ; traceRn (text "rnStmt: implicitly rebound these used binders:" <+> ppr bndr_map)
768 ; return (([L loc (TransStmt { trS_stmts = stmts', trS_bndrs = bndr_map
769 , trS_by = by', trS_using = using', trS_form = form
770 , trS_ret = return_op, trS_bind = bind_op
771 , trS_fmap = fmap_op })], thing), all_fvs) }
772
773 rnParallelStmts :: forall thing. HsStmtContext Name
774 -> SyntaxExpr Name
775 -> [ParStmtBlock RdrName RdrName]
776 -> ([Name] -> RnM (thing, FreeVars))
777 -> RnM (([ParStmtBlock Name Name], thing), FreeVars)
778 -- Note [Renaming parallel Stmts]
779 rnParallelStmts ctxt return_op segs thing_inside
780 = do { orig_lcl_env <- getLocalRdrEnv
781 ; rn_segs orig_lcl_env [] segs }
782 where
783 rn_segs :: LocalRdrEnv
784 -> [Name] -> [ParStmtBlock RdrName RdrName]
785 -> RnM (([ParStmtBlock Name Name], thing), FreeVars)
786 rn_segs _ bndrs_so_far []
787 = do { let (bndrs', dups) = removeDups cmpByOcc bndrs_so_far
788 ; mapM_ dupErr dups
789 ; (thing, fvs) <- bindLocalNames bndrs' (thing_inside bndrs')
790 ; return (([], thing), fvs) }
791
792 rn_segs env bndrs_so_far (ParStmtBlock stmts _ _ : segs)
793 = do { ((stmts', (used_bndrs, segs', thing)), fvs)
794 <- rnStmts ctxt rnLExpr stmts $ \ bndrs ->
795 setLocalRdrEnv env $ do
796 { ((segs', thing), fvs) <- rn_segs env (bndrs ++ bndrs_so_far) segs
797 ; let used_bndrs = filter (`elemNameSet` fvs) bndrs
798 ; return ((used_bndrs, segs', thing), fvs) }
799
800 ; let seg' = ParStmtBlock stmts' used_bndrs return_op
801 ; return ((seg':segs', thing), fvs) }
802
803 cmpByOcc n1 n2 = nameOccName n1 `compare` nameOccName n2
804 dupErr vs = addErr (ptext (sLit "Duplicate binding in parallel list comprehension for:")
805 <+> quotes (ppr (head vs)))
806
807 lookupStmtName :: HsStmtContext Name -> Name -> RnM (HsExpr Name, FreeVars)
808 -- Like lookupSyntaxName, but ListComp/PArrComp are never rebindable
809 -- Neither is ArrowExpr, which has its own desugarer in DsArrows
810 lookupStmtName ctxt n
811 = case ctxt of
812 ListComp -> not_rebindable
813 PArrComp -> not_rebindable
814 ArrowExpr -> not_rebindable
815 PatGuard {} -> not_rebindable
816
817 DoExpr -> rebindable
818 MDoExpr -> rebindable
819 MonadComp -> rebindable
820 GhciStmtCtxt -> rebindable -- I suppose?
821
822 ParStmtCtxt c -> lookupStmtName c n -- Look inside to
823 TransStmtCtxt c -> lookupStmtName c n -- the parent context
824 where
825 rebindable = lookupSyntaxName n
826 not_rebindable = return (HsVar n, emptyFVs)
827
828 {-
829 Note [Renaming parallel Stmts]
830 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
831 Renaming parallel statements is painful. Given, say
832 [ a+c | a <- as, bs <- bss
833 | c <- bs, a <- ds ]
834 Note that
835 (a) In order to report "Defined by not used" about 'bs', we must rename
836 each group of Stmts with a thing_inside whose FreeVars include at least {a,c}
837
838 (b) We want to report that 'a' is illegally bound in both branches
839
840 (c) The 'bs' in the second group must obviously not be captured by
841 the binding in the first group
842
843 To satisfy (a) we nest the segements.
844 To satisfy (b) we check for duplicates just before thing_inside.
845 To satisfy (c) we reset the LocalRdrEnv each time.
846
847 ************************************************************************
848 * *
849 \subsubsection{mdo expressions}
850 * *
851 ************************************************************************
852 -}
853
854 type FwdRefs = NameSet
855 type Segment stmts = (Defs,
856 Uses, -- May include defs
857 FwdRefs, -- A subset of uses that are
858 -- (a) used before they are bound in this segment, or
859 -- (b) used here, and bound in subsequent segments
860 stmts) -- Either Stmt or [Stmt]
861
862
863 -- wrapper that does both the left- and right-hand sides
864 rnRecStmtsAndThen :: Outputable (body RdrName) =>
865 (Located (body RdrName) -> RnM (Located (body Name), FreeVars))
866 -> [LStmt RdrName (Located (body RdrName))]
867 -- assumes that the FreeVars returned includes
868 -- the FreeVars of the Segments
869 -> ([Segment (LStmt Name (Located (body Name)))] -> RnM (a, FreeVars))
870 -> RnM (a, FreeVars)
871 rnRecStmtsAndThen rnBody s cont
872 = do { -- (A) Make the mini fixity env for all of the stmts
873 fix_env <- makeMiniFixityEnv (collectRecStmtsFixities s)
874
875 -- (B) Do the LHSes
876 ; new_lhs_and_fv <- rn_rec_stmts_lhs fix_env s
877
878 -- ...bring them and their fixities into scope
879 ; let bound_names = collectLStmtsBinders (map fst new_lhs_and_fv)
880 -- Fake uses of variables introduced implicitly (warning suppression, see #4404)
881 implicit_uses = lStmtsImplicits (map fst new_lhs_and_fv)
882 ; bindLocalNamesFV bound_names $
883 addLocalFixities fix_env bound_names $ do
884
885 -- (C) do the right-hand-sides and thing-inside
886 { segs <- rn_rec_stmts rnBody bound_names new_lhs_and_fv
887 ; (res, fvs) <- cont segs
888 ; warnUnusedLocalBinds bound_names (fvs `unionNameSet` implicit_uses)
889 ; return (res, fvs) }}
890
891 -- get all the fixity decls in any Let stmt
892 collectRecStmtsFixities :: [LStmtLR RdrName RdrName body] -> [LFixitySig RdrName]
893 collectRecStmtsFixities l =
894 foldr (\ s -> \acc -> case s of
895 (L _ (LetStmt (HsValBinds (ValBindsIn _ sigs)))) ->
896 foldr (\ sig -> \ acc -> case sig of
897 (L loc (FixSig s)) -> (L loc s) : acc
898 _ -> acc) acc sigs
899 _ -> acc) [] l
900
901 -- left-hand sides
902
903 rn_rec_stmt_lhs :: Outputable body => MiniFixityEnv
904 -> LStmt RdrName body
905 -- rename LHS, and return its FVs
906 -- Warning: we will only need the FreeVars below in the case of a BindStmt,
907 -- so we don't bother to compute it accurately in the other cases
908 -> RnM [(LStmtLR Name RdrName body, FreeVars)]
909
910 rn_rec_stmt_lhs _ (L loc (BodyStmt body a b c))
911 = return [(L loc (BodyStmt body a b c), emptyFVs)]
912
913 rn_rec_stmt_lhs _ (L loc (LastStmt body a))
914 = return [(L loc (LastStmt body a), emptyFVs)]
915
916 rn_rec_stmt_lhs fix_env (L loc (BindStmt pat body a b))
917 = do
918 -- should the ctxt be MDo instead?
919 (pat', fv_pat) <- rnBindPat (localRecNameMaker fix_env) pat
920 return [(L loc (BindStmt pat' body a b),
921 fv_pat)]
922
923 rn_rec_stmt_lhs _ (L _ (LetStmt binds@(HsIPBinds _)))
924 = failWith (badIpBinds (ptext (sLit "an mdo expression")) binds)
925
926 rn_rec_stmt_lhs fix_env (L loc (LetStmt (HsValBinds binds)))
927 = do (_bound_names, binds') <- rnLocalValBindsLHS fix_env binds
928 return [(L loc (LetStmt (HsValBinds binds')),
929 -- Warning: this is bogus; see function invariant
930 emptyFVs
931 )]
932
933 -- XXX Do we need to do something with the return and mfix names?
934 rn_rec_stmt_lhs fix_env (L _ (RecStmt { recS_stmts = stmts })) -- Flatten Rec inside Rec
935 = rn_rec_stmts_lhs fix_env stmts
936
937 rn_rec_stmt_lhs _ stmt@(L _ (ParStmt {})) -- Syntactically illegal in mdo
938 = pprPanic "rn_rec_stmt" (ppr stmt)
939
940 rn_rec_stmt_lhs _ stmt@(L _ (TransStmt {})) -- Syntactically illegal in mdo
941 = pprPanic "rn_rec_stmt" (ppr stmt)
942
943 rn_rec_stmt_lhs _ (L _ (LetStmt EmptyLocalBinds))
944 = panic "rn_rec_stmt LetStmt EmptyLocalBinds"
945
946 rn_rec_stmts_lhs :: Outputable body => MiniFixityEnv
947 -> [LStmt RdrName body]
948 -> RnM [(LStmtLR Name RdrName body, FreeVars)]
949 rn_rec_stmts_lhs fix_env stmts
950 = do { ls <- concatMapM (rn_rec_stmt_lhs fix_env) stmts
951 ; let boundNames = collectLStmtsBinders (map fst ls)
952 -- First do error checking: we need to check for dups here because we
953 -- don't bind all of the variables from the Stmt at once
954 -- with bindLocatedLocals.
955 ; checkDupNames boundNames
956 ; return ls }
957
958
959 -- right-hand-sides
960
961 rn_rec_stmt :: (Outputable (body RdrName)) =>
962 (Located (body RdrName) -> RnM (Located (body Name), FreeVars))
963 -> [Name] -> LStmtLR Name RdrName (Located (body RdrName))
964 -> FreeVars -> RnM [Segment (LStmt Name (Located (body Name)))]
965 -- Rename a Stmt that is inside a RecStmt (or mdo)
966 -- Assumes all binders are already in scope
967 -- Turns each stmt into a singleton Stmt
968 rn_rec_stmt rnBody _ (L loc (LastStmt body _)) _
969 = do { (body', fv_expr) <- rnBody body
970 ; (ret_op, fvs1) <- lookupSyntaxName returnMName
971 ; return [(emptyNameSet, fv_expr `plusFV` fvs1, emptyNameSet,
972 L loc (LastStmt body' ret_op))] }
973
974 rn_rec_stmt rnBody _ (L loc (BodyStmt body _ _ _)) _
975 = do { (body', fvs) <- rnBody body
976 ; (then_op, fvs1) <- lookupSyntaxName thenMName
977 ; return [(emptyNameSet, fvs `plusFV` fvs1, emptyNameSet,
978 L loc (BodyStmt body' then_op noSyntaxExpr placeHolderType))] }
979
980 rn_rec_stmt rnBody _ (L loc (BindStmt pat' body _ _)) fv_pat
981 = do { (body', fv_expr) <- rnBody body
982 ; (bind_op, fvs1) <- lookupSyntaxName bindMName
983 ; (fail_op, fvs2) <- lookupSyntaxName failMName
984 ; let bndrs = mkNameSet (collectPatBinders pat')
985 fvs = fv_expr `plusFV` fv_pat `plusFV` fvs1 `plusFV` fvs2
986 ; return [(bndrs, fvs, bndrs `intersectNameSet` fvs,
987 L loc (BindStmt pat' body' bind_op fail_op))] }
988
989 rn_rec_stmt _ _ (L _ (LetStmt binds@(HsIPBinds _))) _
990 = failWith (badIpBinds (ptext (sLit "an mdo expression")) binds)
991
992 rn_rec_stmt _ all_bndrs (L loc (LetStmt (HsValBinds binds'))) _ = do
993 (binds', du_binds) <-
994 -- fixities and unused are handled above in rnRecStmtsAndThen
995 rnLocalValBindsRHS (mkNameSet all_bndrs) binds'
996 return [(duDefs du_binds, allUses du_binds,
997 emptyNameSet, L loc (LetStmt (HsValBinds binds')))]
998
999 -- no RecStmt case because they get flattened above when doing the LHSes
1000 rn_rec_stmt _ _ stmt@(L _ (RecStmt {})) _
1001 = pprPanic "rn_rec_stmt: RecStmt" (ppr stmt)
1002
1003 rn_rec_stmt _ _ stmt@(L _ (ParStmt {})) _ -- Syntactically illegal in mdo
1004 = pprPanic "rn_rec_stmt: ParStmt" (ppr stmt)
1005
1006 rn_rec_stmt _ _ stmt@(L _ (TransStmt {})) _ -- Syntactically illegal in mdo
1007 = pprPanic "rn_rec_stmt: TransStmt" (ppr stmt)
1008
1009 rn_rec_stmt _ _ (L _ (LetStmt EmptyLocalBinds)) _
1010 = panic "rn_rec_stmt: LetStmt EmptyLocalBinds"
1011
1012 rn_rec_stmts :: Outputable (body RdrName) =>
1013 (Located (body RdrName) -> RnM (Located (body Name), FreeVars))
1014 -> [Name]
1015 -> [(LStmtLR Name RdrName (Located (body RdrName)), FreeVars)]
1016 -> RnM [Segment (LStmt Name (Located (body Name)))]
1017 rn_rec_stmts rnBody bndrs stmts
1018 = do { segs_s <- mapM (uncurry (rn_rec_stmt rnBody bndrs)) stmts
1019 ; return (concat segs_s) }
1020
1021 ---------------------------------------------
1022 segmentRecStmts :: HsStmtContext Name
1023 -> Stmt Name body
1024 -> [Segment (LStmt Name body)] -> FreeVars
1025 -> ([LStmt Name body], FreeVars)
1026
1027 segmentRecStmts ctxt empty_rec_stmt segs fvs_later
1028 | MDoExpr <- ctxt
1029 = segsToStmts empty_rec_stmt grouped_segs fvs_later
1030 -- Step 4: Turn the segments into Stmts
1031 -- Use RecStmt when and only when there are fwd refs
1032 -- Also gather up the uses from the end towards the
1033 -- start, so we can tell the RecStmt which things are
1034 -- used 'after' the RecStmt
1035
1036 | otherwise
1037 = ([ L (getLoc (head ss)) $
1038 empty_rec_stmt { recS_stmts = ss
1039 , recS_later_ids = nameSetElems (defs `intersectNameSet` fvs_later)
1040 , recS_rec_ids = nameSetElems (defs `intersectNameSet` uses) }]
1041 , uses `plusFV` fvs_later)
1042
1043 where
1044 (defs_s, uses_s, _, ss) = unzip4 segs
1045 defs = plusFVs defs_s
1046 uses = plusFVs uses_s
1047
1048 -- Step 2: Fill in the fwd refs.
1049 -- The segments are all singletons, but their fwd-ref
1050 -- field mentions all the things used by the segment
1051 -- that are bound after their use
1052 segs_w_fwd_refs = addFwdRefs segs
1053
1054 -- Step 3: Group together the segments to make bigger segments
1055 -- Invariant: in the result, no segment uses a variable
1056 -- bound in a later segment
1057 grouped_segs = glomSegments ctxt segs_w_fwd_refs
1058
1059 ----------------------------
1060 addFwdRefs :: [Segment a] -> [Segment a]
1061 -- So far the segments only have forward refs *within* the Stmt
1062 -- (which happens for bind: x <- ...x...)
1063 -- This function adds the cross-seg fwd ref info
1064
1065 addFwdRefs segs
1066 = fst (foldr mk_seg ([], emptyNameSet) segs)
1067 where
1068 mk_seg (defs, uses, fwds, stmts) (segs, later_defs)
1069 = (new_seg : segs, all_defs)
1070 where
1071 new_seg = (defs, uses, new_fwds, stmts)
1072 all_defs = later_defs `unionNameSet` defs
1073 new_fwds = fwds `unionNameSet` (uses `intersectNameSet` later_defs)
1074 -- Add the downstream fwd refs here
1075
1076 {-
1077 Note [Segmenting mdo]
1078 ~~~~~~~~~~~~~~~~~~~~~
1079 NB. June 7 2012: We only glom segments that appear in an explicit mdo;
1080 and leave those found in "do rec"'s intact. See
1081 http://ghc.haskell.org/trac/ghc/ticket/4148 for the discussion
1082 leading to this design choice. Hence the test in segmentRecStmts.
1083
1084 Note [Glomming segments]
1085 ~~~~~~~~~~~~~~~~~~~~~~~~
1086 Glomming the singleton segments of an mdo into minimal recursive groups.
1087
1088 At first I thought this was just strongly connected components, but
1089 there's an important constraint: the order of the stmts must not change.
1090
1091 Consider
1092 mdo { x <- ...y...
1093 p <- z
1094 y <- ...x...
1095 q <- x
1096 z <- y
1097 r <- x }
1098
1099 Here, the first stmt mention 'y', which is bound in the third.
1100 But that means that the innocent second stmt (p <- z) gets caught
1101 up in the recursion. And that in turn means that the binding for
1102 'z' has to be included... and so on.
1103
1104 Start at the tail { r <- x }
1105 Now add the next one { z <- y ; r <- x }
1106 Now add one more { q <- x ; z <- y ; r <- x }
1107 Now one more... but this time we have to group a bunch into rec
1108 { rec { y <- ...x... ; q <- x ; z <- y } ; r <- x }
1109 Now one more, which we can add on without a rec
1110 { p <- z ;
1111 rec { y <- ...x... ; q <- x ; z <- y } ;
1112 r <- x }
1113 Finally we add the last one; since it mentions y we have to
1114 glom it together with the first two groups
1115 { rec { x <- ...y...; p <- z ; y <- ...x... ;
1116 q <- x ; z <- y } ;
1117 r <- x }
1118 -}
1119
1120 glomSegments :: HsStmtContext Name -> [Segment (LStmt Name body)] -> [Segment [LStmt Name body]]
1121 -- See Note [Glomming segments]
1122
1123 glomSegments _ [] = []
1124 glomSegments ctxt ((defs,uses,fwds,stmt) : segs)
1125 -- Actually stmts will always be a singleton
1126 = (seg_defs, seg_uses, seg_fwds, seg_stmts) : others
1127 where
1128 segs' = glomSegments ctxt segs
1129 (extras, others) = grab uses segs'
1130 (ds, us, fs, ss) = unzip4 extras
1131
1132 seg_defs = plusFVs ds `plusFV` defs
1133 seg_uses = plusFVs us `plusFV` uses
1134 seg_fwds = plusFVs fs `plusFV` fwds
1135 seg_stmts = stmt : concat ss
1136
1137 grab :: NameSet -- The client
1138 -> [Segment a]
1139 -> ([Segment a], -- Needed by the 'client'
1140 [Segment a]) -- Not needed by the client
1141 -- The result is simply a split of the input
1142 grab uses dus
1143 = (reverse yeses, reverse noes)
1144 where
1145 (noes, yeses) = span not_needed (reverse dus)
1146 not_needed (defs,_,_,_) = not (intersectsNameSet defs uses)
1147
1148 ----------------------------------------------------
1149 segsToStmts :: Stmt Name body -- A RecStmt with the SyntaxOps filled in
1150 -> [Segment [LStmt Name body]]
1151 -> FreeVars -- Free vars used 'later'
1152 -> ([LStmt Name body], FreeVars)
1153
1154 segsToStmts _ [] fvs_later = ([], fvs_later)
1155 segsToStmts empty_rec_stmt ((defs, uses, fwds, ss) : segs) fvs_later
1156 = ASSERT( not (null ss) )
1157 (new_stmt : later_stmts, later_uses `plusFV` uses)
1158 where
1159 (later_stmts, later_uses) = segsToStmts empty_rec_stmt segs fvs_later
1160 new_stmt | non_rec = head ss
1161 | otherwise = L (getLoc (head ss)) rec_stmt
1162 rec_stmt = empty_rec_stmt { recS_stmts = ss
1163 , recS_later_ids = nameSetElems used_later
1164 , recS_rec_ids = nameSetElems fwds }
1165 non_rec = isSingleton ss && isEmptyNameSet fwds
1166 used_later = defs `intersectNameSet` later_uses
1167 -- The ones needed after the RecStmt
1168
1169 {-
1170 ************************************************************************
1171 * *
1172 \subsubsection{Errors}
1173 * *
1174 ************************************************************************
1175 -}
1176
1177 checkEmptyStmts :: HsStmtContext Name -> RnM ()
1178 -- We've seen an empty sequence of Stmts... is that ok?
1179 checkEmptyStmts ctxt
1180 = unless (okEmpty ctxt) (addErr (emptyErr ctxt))
1181
1182 okEmpty :: HsStmtContext a -> Bool
1183 okEmpty (PatGuard {}) = True
1184 okEmpty _ = False
1185
1186 emptyErr :: HsStmtContext Name -> SDoc
1187 emptyErr (ParStmtCtxt {}) = ptext (sLit "Empty statement group in parallel comprehension")
1188 emptyErr (TransStmtCtxt {}) = ptext (sLit "Empty statement group preceding 'group' or 'then'")
1189 emptyErr ctxt = ptext (sLit "Empty") <+> pprStmtContext ctxt
1190
1191 ----------------------
1192 checkLastStmt :: Outputable (body RdrName) => HsStmtContext Name
1193 -> LStmt RdrName (Located (body RdrName))
1194 -> RnM (LStmt RdrName (Located (body RdrName)))
1195 checkLastStmt ctxt lstmt@(L loc stmt)
1196 = case ctxt of
1197 ListComp -> check_comp
1198 MonadComp -> check_comp
1199 PArrComp -> check_comp
1200 ArrowExpr -> check_do
1201 DoExpr -> check_do
1202 MDoExpr -> check_do
1203 _ -> check_other
1204 where
1205 check_do -- Expect BodyStmt, and change it to LastStmt
1206 = case stmt of
1207 BodyStmt e _ _ _ -> return (L loc (mkLastStmt e))
1208 LastStmt {} -> return lstmt -- "Deriving" clauses may generate a
1209 -- LastStmt directly (unlike the parser)
1210 _ -> do { addErr (hang last_error 2 (ppr stmt)); return lstmt }
1211 last_error = (ptext (sLit "The last statement in") <+> pprAStmtContext ctxt
1212 <+> ptext (sLit "must be an expression"))
1213
1214 check_comp -- Expect LastStmt; this should be enforced by the parser!
1215 = case stmt of
1216 LastStmt {} -> return lstmt
1217 _ -> pprPanic "checkLastStmt" (ppr lstmt)
1218
1219 check_other -- Behave just as if this wasn't the last stmt
1220 = do { checkStmt ctxt lstmt; return lstmt }
1221
1222 -- Checking when a particular Stmt is ok
1223 checkStmt :: HsStmtContext Name
1224 -> LStmt RdrName (Located (body RdrName))
1225 -> RnM ()
1226 checkStmt ctxt (L _ stmt)
1227 = do { dflags <- getDynFlags
1228 ; case okStmt dflags ctxt stmt of
1229 IsValid -> return ()
1230 NotValid extra -> addErr (msg $$ extra) }
1231 where
1232 msg = sep [ ptext (sLit "Unexpected") <+> pprStmtCat stmt <+> ptext (sLit "statement")
1233 , ptext (sLit "in") <+> pprAStmtContext ctxt ]
1234
1235 pprStmtCat :: Stmt a body -> SDoc
1236 pprStmtCat (TransStmt {}) = ptext (sLit "transform")
1237 pprStmtCat (LastStmt {}) = ptext (sLit "return expression")
1238 pprStmtCat (BodyStmt {}) = ptext (sLit "body")
1239 pprStmtCat (BindStmt {}) = ptext (sLit "binding")
1240 pprStmtCat (LetStmt {}) = ptext (sLit "let")
1241 pprStmtCat (RecStmt {}) = ptext (sLit "rec")
1242 pprStmtCat (ParStmt {}) = ptext (sLit "parallel")
1243
1244 ------------
1245 emptyInvalid :: Validity -- Payload is the empty document
1246 emptyInvalid = NotValid Outputable.empty
1247
1248 okStmt, okDoStmt, okCompStmt, okParStmt, okPArrStmt
1249 :: DynFlags -> HsStmtContext Name
1250 -> Stmt RdrName (Located (body RdrName)) -> Validity
1251 -- Return Nothing if OK, (Just extra) if not ok
1252 -- The "extra" is an SDoc that is appended to an generic error message
1253
1254 okStmt dflags ctxt stmt
1255 = case ctxt of
1256 PatGuard {} -> okPatGuardStmt stmt
1257 ParStmtCtxt ctxt -> okParStmt dflags ctxt stmt
1258 DoExpr -> okDoStmt dflags ctxt stmt
1259 MDoExpr -> okDoStmt dflags ctxt stmt
1260 ArrowExpr -> okDoStmt dflags ctxt stmt
1261 GhciStmtCtxt -> okDoStmt dflags ctxt stmt
1262 ListComp -> okCompStmt dflags ctxt stmt
1263 MonadComp -> okCompStmt dflags ctxt stmt
1264 PArrComp -> okPArrStmt dflags ctxt stmt
1265 TransStmtCtxt ctxt -> okStmt dflags ctxt stmt
1266
1267 -------------
1268 okPatGuardStmt :: Stmt RdrName (Located (body RdrName)) -> Validity
1269 okPatGuardStmt stmt
1270 = case stmt of
1271 BodyStmt {} -> IsValid
1272 BindStmt {} -> IsValid
1273 LetStmt {} -> IsValid
1274 _ -> emptyInvalid
1275
1276 -------------
1277 okParStmt dflags ctxt stmt
1278 = case stmt of
1279 LetStmt (HsIPBinds {}) -> emptyInvalid
1280 _ -> okStmt dflags ctxt stmt
1281
1282 ----------------
1283 okDoStmt dflags ctxt stmt
1284 = case stmt of
1285 RecStmt {}
1286 | Opt_RecursiveDo `xopt` dflags -> IsValid
1287 | ArrowExpr <- ctxt -> IsValid -- Arrows allows 'rec'
1288 | otherwise -> NotValid (ptext (sLit "Use RecursiveDo"))
1289 BindStmt {} -> IsValid
1290 LetStmt {} -> IsValid
1291 BodyStmt {} -> IsValid
1292 _ -> emptyInvalid
1293
1294 ----------------
1295 okCompStmt dflags _ stmt
1296 = case stmt of
1297 BindStmt {} -> IsValid
1298 LetStmt {} -> IsValid
1299 BodyStmt {} -> IsValid
1300 ParStmt {}
1301 | Opt_ParallelListComp `xopt` dflags -> IsValid
1302 | otherwise -> NotValid (ptext (sLit "Use ParallelListComp"))
1303 TransStmt {}
1304 | Opt_TransformListComp `xopt` dflags -> IsValid
1305 | otherwise -> NotValid (ptext (sLit "Use TransformListComp"))
1306 RecStmt {} -> emptyInvalid
1307 LastStmt {} -> emptyInvalid -- Should not happen (dealt with by checkLastStmt)
1308
1309 ----------------
1310 okPArrStmt dflags _ stmt
1311 = case stmt of
1312 BindStmt {} -> IsValid
1313 LetStmt {} -> IsValid
1314 BodyStmt {} -> IsValid
1315 ParStmt {}
1316 | Opt_ParallelListComp `xopt` dflags -> IsValid
1317 | otherwise -> NotValid (ptext (sLit "Use ParallelListComp"))
1318 TransStmt {} -> emptyInvalid
1319 RecStmt {} -> emptyInvalid
1320 LastStmt {} -> emptyInvalid -- Should not happen (dealt with by checkLastStmt)
1321
1322 ---------
1323 checkTupleSection :: [LHsTupArg RdrName] -> RnM ()
1324 checkTupleSection args
1325 = do { tuple_section <- xoptM Opt_TupleSections
1326 ; checkErr (all tupArgPresent args || tuple_section) msg }
1327 where
1328 msg = ptext (sLit "Illegal tuple section: use TupleSections")
1329
1330 ---------
1331 sectionErr :: HsExpr RdrName -> SDoc
1332 sectionErr expr
1333 = hang (ptext (sLit "A section must be enclosed in parentheses"))
1334 2 (ptext (sLit "thus:") <+> (parens (ppr expr)))
1335
1336 patSynErr :: HsExpr RdrName -> RnM (HsExpr Name, FreeVars)
1337 patSynErr e = do { addErr (sep [ptext (sLit "Pattern syntax in expression context:"),
1338 nest 4 (ppr e)])
1339 ; return (EWildPat, emptyFVs) }
1340
1341 badIpBinds :: Outputable a => SDoc -> a -> SDoc
1342 badIpBinds what binds
1343 = hang (ptext (sLit "Implicit-parameter bindings illegal in") <+> what)
1344 2 (ppr binds)