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