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