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