users_guide: Various spelling fixes
[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 { (pty', fvTy, wcs) <- rnLHsTypeWithWildCards ExprWithTySigCtx pty
251 ; (expr', fvExpr) <- bindSigTyVarsFV (hsExplicitTvs pty') $
252 rnLExpr expr
253 ; return (ExprWithTySig expr' pty' wcs, fvExpr `plusFV` fvTy) }
254
255 rnExpr (HsIf _ p b1 b2)
256 = do { (p', fvP) <- rnLExpr p
257 ; (b1', fvB1) <- rnLExpr b1
258 ; (b2', fvB2) <- rnLExpr b2
259 ; (mb_ite, fvITE) <- lookupIfThenElse
260 ; return (HsIf mb_ite p' b1' b2', plusFVs [fvITE, fvP, fvB1, fvB2]) }
261
262 rnExpr (HsMultiIf _ty alts)
263 = do { (alts', fvs) <- mapFvRn (rnGRHS IfAlt rnLExpr) alts
264 -- ; return (HsMultiIf ty alts', fvs) }
265 ; return (HsMultiIf placeHolderType alts', fvs) }
266
267 rnExpr (HsType a)
268 = do { (t, fvT) <- rnLHsType HsTypeCtx a
269 ; return (HsType t, fvT) }
270
271 rnExpr (ArithSeq _ _ seq)
272 = do { opt_OverloadedLists <- xoptM Opt_OverloadedLists
273 ; (new_seq, fvs) <- rnArithSeq seq
274 ; if opt_OverloadedLists
275 then do {
276 ; (from_list_name, fvs') <- lookupSyntaxName fromListName
277 ; return (ArithSeq noPostTcExpr (Just from_list_name) new_seq, fvs `plusFV` fvs') }
278 else
279 return (ArithSeq noPostTcExpr Nothing new_seq, fvs) }
280
281 rnExpr (PArrSeq _ seq)
282 = do { (new_seq, fvs) <- rnArithSeq seq
283 ; return (PArrSeq noPostTcExpr new_seq, fvs) }
284
285 {-
286 These three are pattern syntax appearing in expressions.
287 Since all the symbols are reservedops we can simply reject them.
288 We return a (bogus) EWildPat in each case.
289 -}
290
291 rnExpr EWildPat = return (hsHoleExpr, emptyFVs)
292 rnExpr e@(EAsPat {}) = patSynErr e
293 rnExpr e@(EViewPat {}) = patSynErr e
294 rnExpr e@(ELazyPat {}) = patSynErr e
295
296 {-
297 ************************************************************************
298 * *
299 Static values
300 * *
301 ************************************************************************
302
303 For the static form we check that the free variables are all top-level
304 value bindings. This is done by checking that the name is external or
305 wired-in. See the Notes about the NameSorts in Name.hs.
306 -}
307
308 rnExpr e@(HsStatic expr) = do
309 target <- fmap hscTarget getDynFlags
310 case target of
311 -- SPT entries are expected to exist in object code so far, and this is
312 -- not the case in interpreted mode. See bug #9878.
313 HscInterpreted -> addErr $ sep
314 [ text "The static form is not supported in interpreted mode."
315 , text "Please use -fobject-code."
316 ]
317 _ -> return ()
318 (expr',fvExpr) <- rnLExpr expr
319 stage <- getStage
320 case stage of
321 Brack _ _ -> return () -- Don't check names if we are inside brackets.
322 -- We don't want to reject cases like:
323 -- \e -> [| static $(e) |]
324 -- if $(e) turns out to produce a legal expression.
325 Splice _ -> addErr $ sep
326 [ text "static forms cannot be used in splices:"
327 , nest 2 $ ppr e
328 ]
329 _ -> do
330 let isTopLevelName n = isExternalName n || isWiredInName n
331 case nameSetElems $ filterNameSet
332 (\n -> not (isTopLevelName n || isUnboundName n))
333 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 loc (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 loc 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 variable
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]
964 -> (LStmtLR Name RdrName (Located (body RdrName)), FreeVars)
965 -> RnM [Segment (LStmt Name (Located (body Name)))]
966 -- Rename a Stmt that is inside a RecStmt (or mdo)
967 -- Assumes all binders are already in scope
968 -- Turns each stmt into a singleton Stmt
969 rn_rec_stmt rnBody _ (L loc (LastStmt body _), _)
970 = do { (body', fv_expr) <- rnBody body
971 ; (ret_op, fvs1) <- lookupSyntaxName returnMName
972 ; return [(emptyNameSet, fv_expr `plusFV` fvs1, emptyNameSet,
973 L loc (LastStmt body' ret_op))] }
974
975 rn_rec_stmt rnBody _ (L loc (BodyStmt body _ _ _), _)
976 = do { (body', fvs) <- rnBody body
977 ; (then_op, fvs1) <- lookupSyntaxName thenMName
978 ; return [(emptyNameSet, fvs `plusFV` fvs1, emptyNameSet,
979 L loc (BodyStmt body' then_op noSyntaxExpr placeHolderType))] }
980
981 rn_rec_stmt rnBody _ (L loc (BindStmt pat' body _ _), fv_pat)
982 = do { (body', fv_expr) <- rnBody body
983 ; (bind_op, fvs1) <- lookupSyntaxName bindMName
984 ; (fail_op, fvs2) <- lookupSyntaxName failMName
985 ; let bndrs = mkNameSet (collectPatBinders pat')
986 fvs = fv_expr `plusFV` fv_pat `plusFV` fvs1 `plusFV` fvs2
987 ; return [(bndrs, fvs, bndrs `intersectNameSet` fvs,
988 L loc (BindStmt pat' body' bind_op fail_op))] }
989
990 rn_rec_stmt _ _ (L _ (LetStmt binds@(HsIPBinds _)), _)
991 = failWith (badIpBinds (ptext (sLit "an mdo expression")) binds)
992
993 rn_rec_stmt _ all_bndrs (L loc (LetStmt (HsValBinds binds')), _)
994 = do { (binds', du_binds) <- rnLocalValBindsRHS (mkNameSet all_bndrs) binds'
995 -- fixities and unused are handled above in rnRecStmtsAndThen
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 (rn_rec_stmt rnBody bndrs) stmts
1019 ; return (concat segs_s) }
1020
1021 ---------------------------------------------
1022 segmentRecStmts :: SrcSpan -> HsStmtContext Name
1023 -> Stmt Name body
1024 -> [Segment (LStmt Name body)] -> FreeVars
1025 -> ([LStmt Name body], FreeVars)
1026
1027 segmentRecStmts loc ctxt empty_rec_stmt segs fvs_later
1028 | null segs
1029 = ([], fvs_later)
1030
1031 | MDoExpr <- ctxt
1032 = segsToStmts empty_rec_stmt grouped_segs fvs_later
1033 -- Step 4: Turn the segments into Stmts
1034 -- Use RecStmt when and only when there are fwd refs
1035 -- Also gather up the uses from the end towards the
1036 -- start, so we can tell the RecStmt which things are
1037 -- used 'after' the RecStmt
1038
1039 | otherwise
1040 = ([ L loc $
1041 empty_rec_stmt { recS_stmts = ss
1042 , recS_later_ids = nameSetElems (defs `intersectNameSet` fvs_later)
1043 , recS_rec_ids = nameSetElems (defs `intersectNameSet` uses) }]
1044 , uses `plusFV` fvs_later)
1045
1046 where
1047 (defs_s, uses_s, _, ss) = unzip4 segs
1048 defs = plusFVs defs_s
1049 uses = plusFVs uses_s
1050
1051 -- Step 2: Fill in the fwd refs.
1052 -- The segments are all singletons, but their fwd-ref
1053 -- field mentions all the things used by the segment
1054 -- that are bound after their use
1055 segs_w_fwd_refs = addFwdRefs segs
1056
1057 -- Step 3: Group together the segments to make bigger segments
1058 -- Invariant: in the result, no segment uses a variable
1059 -- bound in a later segment
1060 grouped_segs = glomSegments ctxt segs_w_fwd_refs
1061
1062 ----------------------------
1063 addFwdRefs :: [Segment a] -> [Segment a]
1064 -- So far the segments only have forward refs *within* the Stmt
1065 -- (which happens for bind: x <- ...x...)
1066 -- This function adds the cross-seg fwd ref info
1067
1068 addFwdRefs segs
1069 = fst (foldr mk_seg ([], emptyNameSet) segs)
1070 where
1071 mk_seg (defs, uses, fwds, stmts) (segs, later_defs)
1072 = (new_seg : segs, all_defs)
1073 where
1074 new_seg = (defs, uses, new_fwds, stmts)
1075 all_defs = later_defs `unionNameSet` defs
1076 new_fwds = fwds `unionNameSet` (uses `intersectNameSet` later_defs)
1077 -- Add the downstream fwd refs here
1078
1079 {-
1080 Note [Segmenting mdo]
1081 ~~~~~~~~~~~~~~~~~~~~~
1082 NB. June 7 2012: We only glom segments that appear in an explicit mdo;
1083 and leave those found in "do rec"'s intact. See
1084 http://ghc.haskell.org/trac/ghc/ticket/4148 for the discussion
1085 leading to this design choice. Hence the test in segmentRecStmts.
1086
1087 Note [Glomming segments]
1088 ~~~~~~~~~~~~~~~~~~~~~~~~
1089 Glomming the singleton segments of an mdo into minimal recursive groups.
1090
1091 At first I thought this was just strongly connected components, but
1092 there's an important constraint: the order of the stmts must not change.
1093
1094 Consider
1095 mdo { x <- ...y...
1096 p <- z
1097 y <- ...x...
1098 q <- x
1099 z <- y
1100 r <- x }
1101
1102 Here, the first stmt mention 'y', which is bound in the third.
1103 But that means that the innocent second stmt (p <- z) gets caught
1104 up in the recursion. And that in turn means that the binding for
1105 'z' has to be included... and so on.
1106
1107 Start at the tail { r <- x }
1108 Now add the next one { z <- y ; r <- x }
1109 Now add one more { q <- x ; z <- y ; r <- x }
1110 Now one more... but this time we have to group a bunch into rec
1111 { rec { y <- ...x... ; q <- x ; z <- y } ; r <- x }
1112 Now one more, which we can add on without a rec
1113 { p <- z ;
1114 rec { y <- ...x... ; q <- x ; z <- y } ;
1115 r <- x }
1116 Finally we add the last one; since it mentions y we have to
1117 glom it together with the first two groups
1118 { rec { x <- ...y...; p <- z ; y <- ...x... ;
1119 q <- x ; z <- y } ;
1120 r <- x }
1121 -}
1122
1123 glomSegments :: HsStmtContext Name
1124 -> [Segment (LStmt Name body)]
1125 -> [Segment [LStmt Name body]] -- Each segment has a non-empty list of Stmts
1126 -- See Note [Glomming segments]
1127
1128 glomSegments _ [] = []
1129 glomSegments ctxt ((defs,uses,fwds,stmt) : segs)
1130 -- Actually stmts will always be a singleton
1131 = (seg_defs, seg_uses, seg_fwds, seg_stmts) : others
1132 where
1133 segs' = glomSegments ctxt segs
1134 (extras, others) = grab uses segs'
1135 (ds, us, fs, ss) = unzip4 extras
1136
1137 seg_defs = plusFVs ds `plusFV` defs
1138 seg_uses = plusFVs us `plusFV` uses
1139 seg_fwds = plusFVs fs `plusFV` fwds
1140 seg_stmts = stmt : concat ss
1141
1142 grab :: NameSet -- The client
1143 -> [Segment a]
1144 -> ([Segment a], -- Needed by the 'client'
1145 [Segment a]) -- Not needed by the client
1146 -- The result is simply a split of the input
1147 grab uses dus
1148 = (reverse yeses, reverse noes)
1149 where
1150 (noes, yeses) = span not_needed (reverse dus)
1151 not_needed (defs,_,_,_) = not (intersectsNameSet defs uses)
1152
1153 ----------------------------------------------------
1154 segsToStmts :: Stmt Name body -- A RecStmt with the SyntaxOps filled in
1155 -> [Segment [LStmt Name body]] -- Each Segment has a non-empty list of Stmts
1156 -> FreeVars -- Free vars used 'later'
1157 -> ([LStmt Name body], FreeVars)
1158
1159 segsToStmts _ [] fvs_later = ([], fvs_later)
1160 segsToStmts empty_rec_stmt ((defs, uses, fwds, ss) : segs) fvs_later
1161 = ASSERT( not (null ss) )
1162 (new_stmt : later_stmts, later_uses `plusFV` uses)
1163 where
1164 (later_stmts, later_uses) = segsToStmts empty_rec_stmt segs fvs_later
1165 new_stmt | non_rec = head ss
1166 | otherwise = L (getLoc (head ss)) rec_stmt
1167 rec_stmt = empty_rec_stmt { recS_stmts = ss
1168 , recS_later_ids = nameSetElems used_later
1169 , recS_rec_ids = nameSetElems fwds }
1170 non_rec = isSingleton ss && isEmptyNameSet fwds
1171 used_later = defs `intersectNameSet` later_uses
1172 -- The ones needed after the RecStmt
1173
1174 {-
1175 ************************************************************************
1176 * *
1177 \subsubsection{Errors}
1178 * *
1179 ************************************************************************
1180 -}
1181
1182 checkEmptyStmts :: HsStmtContext Name -> RnM ()
1183 -- We've seen an empty sequence of Stmts... is that ok?
1184 checkEmptyStmts ctxt
1185 = unless (okEmpty ctxt) (addErr (emptyErr ctxt))
1186
1187 okEmpty :: HsStmtContext a -> Bool
1188 okEmpty (PatGuard {}) = True
1189 okEmpty _ = False
1190
1191 emptyErr :: HsStmtContext Name -> SDoc
1192 emptyErr (ParStmtCtxt {}) = ptext (sLit "Empty statement group in parallel comprehension")
1193 emptyErr (TransStmtCtxt {}) = ptext (sLit "Empty statement group preceding 'group' or 'then'")
1194 emptyErr ctxt = ptext (sLit "Empty") <+> pprStmtContext ctxt
1195
1196 ----------------------
1197 checkLastStmt :: Outputable (body RdrName) => HsStmtContext Name
1198 -> LStmt RdrName (Located (body RdrName))
1199 -> RnM (LStmt RdrName (Located (body RdrName)))
1200 checkLastStmt ctxt lstmt@(L loc stmt)
1201 = case ctxt of
1202 ListComp -> check_comp
1203 MonadComp -> check_comp
1204 PArrComp -> check_comp
1205 ArrowExpr -> check_do
1206 DoExpr -> check_do
1207 MDoExpr -> check_do
1208 _ -> check_other
1209 where
1210 check_do -- Expect BodyStmt, and change it to LastStmt
1211 = case stmt of
1212 BodyStmt e _ _ _ -> return (L loc (mkLastStmt e))
1213 LastStmt {} -> return lstmt -- "Deriving" clauses may generate a
1214 -- LastStmt directly (unlike the parser)
1215 _ -> do { addErr (hang last_error 2 (ppr stmt)); return lstmt }
1216 last_error = (ptext (sLit "The last statement in") <+> pprAStmtContext ctxt
1217 <+> ptext (sLit "must be an expression"))
1218
1219 check_comp -- Expect LastStmt; this should be enforced by the parser!
1220 = case stmt of
1221 LastStmt {} -> return lstmt
1222 _ -> pprPanic "checkLastStmt" (ppr lstmt)
1223
1224 check_other -- Behave just as if this wasn't the last stmt
1225 = do { checkStmt ctxt lstmt; return lstmt }
1226
1227 -- Checking when a particular Stmt is ok
1228 checkStmt :: HsStmtContext Name
1229 -> LStmt RdrName (Located (body RdrName))
1230 -> RnM ()
1231 checkStmt ctxt (L _ stmt)
1232 = do { dflags <- getDynFlags
1233 ; case okStmt dflags ctxt stmt of
1234 IsValid -> return ()
1235 NotValid extra -> addErr (msg $$ extra) }
1236 where
1237 msg = sep [ ptext (sLit "Unexpected") <+> pprStmtCat stmt <+> ptext (sLit "statement")
1238 , ptext (sLit "in") <+> pprAStmtContext ctxt ]
1239
1240 pprStmtCat :: Stmt a body -> SDoc
1241 pprStmtCat (TransStmt {}) = ptext (sLit "transform")
1242 pprStmtCat (LastStmt {}) = ptext (sLit "return expression")
1243 pprStmtCat (BodyStmt {}) = ptext (sLit "body")
1244 pprStmtCat (BindStmt {}) = ptext (sLit "binding")
1245 pprStmtCat (LetStmt {}) = ptext (sLit "let")
1246 pprStmtCat (RecStmt {}) = ptext (sLit "rec")
1247 pprStmtCat (ParStmt {}) = ptext (sLit "parallel")
1248
1249 ------------
1250 emptyInvalid :: Validity -- Payload is the empty document
1251 emptyInvalid = NotValid Outputable.empty
1252
1253 okStmt, okDoStmt, okCompStmt, okParStmt, okPArrStmt
1254 :: DynFlags -> HsStmtContext Name
1255 -> Stmt RdrName (Located (body RdrName)) -> Validity
1256 -- Return Nothing if OK, (Just extra) if not ok
1257 -- The "extra" is an SDoc that is appended to an generic error message
1258
1259 okStmt dflags ctxt stmt
1260 = case ctxt of
1261 PatGuard {} -> okPatGuardStmt stmt
1262 ParStmtCtxt ctxt -> okParStmt dflags ctxt stmt
1263 DoExpr -> okDoStmt dflags ctxt stmt
1264 MDoExpr -> okDoStmt dflags ctxt stmt
1265 ArrowExpr -> okDoStmt dflags ctxt stmt
1266 GhciStmtCtxt -> okDoStmt dflags ctxt stmt
1267 ListComp -> okCompStmt dflags ctxt stmt
1268 MonadComp -> okCompStmt dflags ctxt stmt
1269 PArrComp -> okPArrStmt dflags ctxt stmt
1270 TransStmtCtxt ctxt -> okStmt dflags ctxt stmt
1271
1272 -------------
1273 okPatGuardStmt :: Stmt RdrName (Located (body RdrName)) -> Validity
1274 okPatGuardStmt stmt
1275 = case stmt of
1276 BodyStmt {} -> IsValid
1277 BindStmt {} -> IsValid
1278 LetStmt {} -> IsValid
1279 _ -> emptyInvalid
1280
1281 -------------
1282 okParStmt dflags ctxt stmt
1283 = case stmt of
1284 LetStmt (HsIPBinds {}) -> emptyInvalid
1285 _ -> okStmt dflags ctxt stmt
1286
1287 ----------------
1288 okDoStmt dflags ctxt stmt
1289 = case stmt of
1290 RecStmt {}
1291 | Opt_RecursiveDo `xopt` dflags -> IsValid
1292 | ArrowExpr <- ctxt -> IsValid -- Arrows allows 'rec'
1293 | otherwise -> NotValid (ptext (sLit "Use RecursiveDo"))
1294 BindStmt {} -> IsValid
1295 LetStmt {} -> IsValid
1296 BodyStmt {} -> IsValid
1297 _ -> emptyInvalid
1298
1299 ----------------
1300 okCompStmt dflags _ stmt
1301 = case stmt of
1302 BindStmt {} -> IsValid
1303 LetStmt {} -> IsValid
1304 BodyStmt {} -> IsValid
1305 ParStmt {}
1306 | Opt_ParallelListComp `xopt` dflags -> IsValid
1307 | otherwise -> NotValid (ptext (sLit "Use ParallelListComp"))
1308 TransStmt {}
1309 | Opt_TransformListComp `xopt` dflags -> IsValid
1310 | otherwise -> NotValid (ptext (sLit "Use TransformListComp"))
1311 RecStmt {} -> emptyInvalid
1312 LastStmt {} -> emptyInvalid -- Should not happen (dealt with by checkLastStmt)
1313
1314 ----------------
1315 okPArrStmt dflags _ stmt
1316 = case stmt of
1317 BindStmt {} -> IsValid
1318 LetStmt {} -> IsValid
1319 BodyStmt {} -> IsValid
1320 ParStmt {}
1321 | Opt_ParallelListComp `xopt` dflags -> IsValid
1322 | otherwise -> NotValid (ptext (sLit "Use ParallelListComp"))
1323 TransStmt {} -> emptyInvalid
1324 RecStmt {} -> emptyInvalid
1325 LastStmt {} -> emptyInvalid -- Should not happen (dealt with by checkLastStmt)
1326
1327 ---------
1328 checkTupleSection :: [LHsTupArg RdrName] -> RnM ()
1329 checkTupleSection args
1330 = do { tuple_section <- xoptM Opt_TupleSections
1331 ; checkErr (all tupArgPresent args || tuple_section) msg }
1332 where
1333 msg = ptext (sLit "Illegal tuple section: use TupleSections")
1334
1335 ---------
1336 sectionErr :: HsExpr RdrName -> SDoc
1337 sectionErr expr
1338 = hang (ptext (sLit "A section must be enclosed in parentheses"))
1339 2 (ptext (sLit "thus:") <+> (parens (ppr expr)))
1340
1341 patSynErr :: HsExpr RdrName -> RnM (HsExpr Name, FreeVars)
1342 patSynErr e = do { addErr (sep [ptext (sLit "Pattern syntax in expression context:"),
1343 nest 4 (ppr e)])
1344 ; return (EWildPat, emptyFVs) }
1345
1346 badIpBinds :: Outputable a => SDoc -> a -> SDoc
1347 badIpBinds what binds
1348 = hang (ptext (sLit "Implicit-parameter bindings illegal in") <+> what)
1349 2 (ppr binds)