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