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