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