do not link with -lrt on Solaris for threaded way
[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 -- See Note [Adding the implicit parameter to 'assert']
83 finishHsVar name
84  = do { this_mod <- getModule
85       ; when (nameIsLocalOrFrom this_mod name) $
86         checkThLocalName name
87
88       ; ignore_asserts <- goptM Opt_IgnoreAsserts
89       ; if ignore_asserts || not (name `hasKey` assertIdKey)
90         then return (HsVar name, unitFV name)
91         else do { e <- mkAssertErrorExpr
92                 ; return (e, unitFV name) } }
93
94 rnExpr (HsVar v)
95   = do { mb_name <- lookupOccRn_maybe v
96        ; case mb_name of {
97            Nothing -> do { opt_TypeHoles <- woptM Opt_WarnTypedHoles
98                          ; if opt_TypeHoles && startsWithUnderscore (rdrNameOcc v)
99                            then return (HsUnboundVar v, emptyFVs)
100                            else do { n <- reportUnboundName v; finishHsVar n } } ;
101            Just name
102               | name == nilDataConName -- Treat [] as an ExplicitList, so that
103                                        -- OverloadedLists works correctly
104               -> rnExpr (ExplicitList placeHolderType Nothing [])
105
106               | otherwise
107               -> finishHsVar name }}
108
109 rnExpr (HsIPVar v)
110   = return (HsIPVar v, emptyFVs)
111
112 rnExpr (HsLit lit@(HsString s))
113   = do { opt_OverloadedStrings <- xoptM Opt_OverloadedStrings
114        ; if opt_OverloadedStrings then
115             rnExpr (HsOverLit (mkHsIsString s placeHolderType))
116          else do {
117             ; rnLit lit
118             ; return (HsLit lit, emptyFVs) } }
119
120 rnExpr (HsLit lit)
121   = do { rnLit lit
122        ; return (HsLit lit, emptyFVs) }
123
124 rnExpr (HsOverLit lit)
125   = do { (lit', fvs) <- rnOverLit lit
126        ; return (HsOverLit lit', fvs) }
127
128 rnExpr (HsApp fun arg)
129   = do { (fun',fvFun) <- rnLExpr fun
130        ; (arg',fvArg) <- rnLExpr arg
131        ; return (HsApp fun' arg', fvFun `plusFV` fvArg) }
132
133 rnExpr (OpApp e1 (L op_loc (HsVar op_rdr)) _ e2)
134   = do  { (e1', fv_e1) <- rnLExpr e1
135         ; (e2', fv_e2) <- rnLExpr e2
136         ; op_name <- setSrcSpan op_loc (lookupOccRn op_rdr)
137         ; (op', fv_op) <- finishHsVar op_name
138                 -- NB: op' is usually just a variable, but might be
139                 --     an applicatoin (assert "Foo.hs:47")
140         -- Deal with fixity
141         -- When renaming code synthesised from "deriving" declarations
142         -- we used to avoid fixity stuff, but we can't easily tell any
143         -- more, so I've removed the test.  Adding HsPars in TcGenDeriv
144         -- should prevent bad things happening.
145         ; fixity <- lookupFixityRn op_name
146         ; final_e <- mkOpAppRn e1' (L op_loc op') fixity e2'
147         ; return (final_e, fv_e1 `plusFV` fv_op `plusFV` fv_e2) }
148 rnExpr (OpApp _ other_op _ _)
149   = failWith (vcat [ hang (ptext (sLit "Infix application with a non-variable operator:"))
150                         2 (ppr other_op)
151                    , ptext (sLit "(Probably resulting from a Template Haskell splice)") ])
152
153 rnExpr (NegApp e _)
154   = do { (e', fv_e)         <- rnLExpr e
155        ; (neg_name, fv_neg) <- lookupSyntaxName negateName
156        ; final_e            <- mkNegAppRn e' neg_name
157        ; return (final_e, fv_e `plusFV` fv_neg) }
158
159 ------------------------------------------
160 -- Template Haskell extensions
161 -- Don't ifdef-GHCI them because we want to fail gracefully
162 -- (not with an rnExpr crash) in a stage-1 compiler.
163 rnExpr e@(HsBracket br_body) = rnBracket e br_body
164
165 rnExpr (HsSpliceE is_typed splice) = rnSpliceExpr is_typed splice
166
167
168 rnExpr (HsQuasiQuoteE qq)
169   = do { lexpr' <- runQuasiQuoteExpr qq
170          -- Wrap the result of the quasi-quoter in parens so that we don't
171          -- lose the outermost location set by runQuasiQuote (#7918)
172        ; rnExpr (HsPar lexpr') }
173
174 ---------------------------------------------
175 --      Sections
176 -- See Note [Parsing sections] in Parser.y.pp
177 rnExpr (HsPar (L loc (section@(SectionL {}))))
178   = do  { (section', fvs) <- rnSection section
179         ; return (HsPar (L loc section'), fvs) }
180
181 rnExpr (HsPar (L loc (section@(SectionR {}))))
182   = do  { (section', fvs) <- rnSection section
183         ; return (HsPar (L loc section'), fvs) }
184
185 rnExpr (HsPar e)
186   = do  { (e', fvs_e) <- rnLExpr e
187         ; return (HsPar e', fvs_e) }
188
189 rnExpr expr@(SectionL {})
190   = do  { addErr (sectionErr expr); rnSection expr }
191 rnExpr expr@(SectionR {})
192   = do  { addErr (sectionErr expr); rnSection expr }
193
194 ---------------------------------------------
195 rnExpr (HsCoreAnn ann expr)
196   = do { (expr', fvs_expr) <- rnLExpr expr
197        ; return (HsCoreAnn ann expr', fvs_expr) }
198
199 rnExpr (HsSCC lbl expr)
200   = do { (expr', fvs_expr) <- rnLExpr expr
201        ; return (HsSCC lbl expr', fvs_expr) }
202 rnExpr (HsTickPragma info expr)
203   = do { (expr', fvs_expr) <- rnLExpr expr
204        ; return (HsTickPragma info expr', fvs_expr) }
205
206 rnExpr (HsLam matches)
207   = do { (matches', fvMatch) <- rnMatchGroup LambdaExpr rnLExpr matches
208        ; return (HsLam matches', fvMatch) }
209
210 rnExpr (HsLamCase arg matches)
211   = do { (matches', fvs_ms) <- rnMatchGroup CaseAlt rnLExpr matches
212        ; return (HsLamCase arg matches', fvs_ms) }
213
214 rnExpr (HsCase expr matches)
215   = do { (new_expr, e_fvs) <- rnLExpr expr
216        ; (new_matches, ms_fvs) <- rnMatchGroup CaseAlt rnLExpr matches
217        ; return (HsCase new_expr new_matches, e_fvs `plusFV` ms_fvs) }
218
219 rnExpr (HsLet binds expr)
220   = rnLocalBindsAndThen binds $ \binds' -> do
221       { (expr',fvExpr) <- rnLExpr expr
222       ; return (HsLet binds' expr', fvExpr) }
223
224 rnExpr (HsDo do_or_lc stmts _)
225   = do  { ((stmts', _), fvs) <- rnStmts do_or_lc rnLExpr stmts (\ _ -> return ((), emptyFVs))
226         ; return ( HsDo do_or_lc stmts' placeHolderType, fvs ) }
227
228 rnExpr (ExplicitList _ _  exps)
229   = do  { opt_OverloadedLists <- xoptM Opt_OverloadedLists
230         ; (exps', fvs) <- rnExprs exps
231         ; if opt_OverloadedLists
232            then do {
233             ; (from_list_n_name, fvs') <- lookupSyntaxName fromListNName
234             ; return (ExplicitList placeHolderType (Just from_list_n_name) exps', fvs `plusFV` fvs') }
235            else
236             return  (ExplicitList placeHolderType Nothing exps', fvs) }
237
238 rnExpr (ExplicitPArr _ exps)
239   = do { (exps', fvs) <- rnExprs exps
240        ; return  (ExplicitPArr placeHolderType exps', fvs) }
241
242 rnExpr (ExplicitTuple tup_args boxity)
243   = do { checkTupleSection tup_args
244        ; checkTupSize (length tup_args)
245        ; (tup_args', fvs) <- mapAndUnzipM rnTupArg tup_args
246        ; return (ExplicitTuple tup_args' boxity, plusFVs fvs) }
247   where
248     rnTupArg (Present e) = do { (e',fvs) <- rnLExpr e; return (Present e', fvs) }
249     rnTupArg (Missing _) = return (Missing placeHolderType, emptyFVs)
250
251 rnExpr (RecordCon con_id _ rbinds)
252   = do  { conname <- lookupLocatedOccRn con_id
253         ; (rbinds', fvRbinds) <- rnHsRecBinds (HsRecFieldCon (unLoc conname)) rbinds
254         ; return (RecordCon conname noPostTcExpr rbinds',
255                   fvRbinds `addOneFV` unLoc conname) }
256
257 rnExpr (RecordUpd expr rbinds _ _ _)
258   = do  { (expr', fvExpr) <- rnLExpr expr
259         ; (rbinds', fvRbinds) <- rnHsRecBinds HsRecFieldUpd rbinds
260         ; return (RecordUpd expr' rbinds' [] [] [],
261                   fvExpr `plusFV` fvRbinds) }
262
263 rnExpr (ExprWithTySig expr pty)
264   = do  { (pty', fvTy) <- rnLHsType ExprWithTySigCtx pty
265         ; (expr', fvExpr) <- bindSigTyVarsFV (hsExplicitTvs pty') $
266                              rnLExpr expr
267         ; return (ExprWithTySig expr' pty', fvExpr `plusFV` fvTy) }
268
269 rnExpr (HsIf _ p b1 b2)
270   = do { (p', fvP) <- rnLExpr p
271        ; (b1', fvB1) <- rnLExpr b1
272        ; (b2', fvB2) <- rnLExpr b2
273        ; (mb_ite, fvITE) <- lookupIfThenElse
274        ; return (HsIf mb_ite p' b1' b2', plusFVs [fvITE, fvP, fvB1, fvB2]) }
275
276 rnExpr (HsMultiIf ty alts)
277   = do { (alts', fvs) <- mapFvRn (rnGRHS IfAlt rnLExpr) alts
278        ; return (HsMultiIf ty alts', fvs) }
279
280 rnExpr (HsType a)
281   = do { (t, fvT) <- rnLHsType HsTypeCtx a
282        ; return (HsType t, fvT) }
283
284 rnExpr (ArithSeq _ _ seq)
285   = do { opt_OverloadedLists <- xoptM Opt_OverloadedLists
286        ; (new_seq, fvs) <- rnArithSeq seq
287        ; if opt_OverloadedLists
288            then do {
289             ; (from_list_name, fvs') <- lookupSyntaxName fromListName
290             ; return (ArithSeq noPostTcExpr (Just from_list_name) new_seq, fvs `plusFV` fvs') }
291            else
292             return (ArithSeq noPostTcExpr Nothing new_seq, fvs) }
293
294 rnExpr (PArrSeq _ seq)
295   = do { (new_seq, fvs) <- rnArithSeq seq
296        ; return (PArrSeq noPostTcExpr new_seq, fvs) }
297 \end{code}
298
299 These three are pattern syntax appearing in expressions.
300 Since all the symbols are reservedops we can simply reject them.
301 We return a (bogus) EWildPat in each case.
302
303 \begin{code}
304 rnExpr e@EWildPat      = do { holes <- woptM Opt_WarnTypedHoles
305                             ; if holes
306                                 then return (hsHoleExpr, emptyFVs)
307                                 else patSynErr e
308                             }
309 rnExpr e@(EAsPat {})   = patSynErr e
310 rnExpr e@(EViewPat {}) = patSynErr e
311 rnExpr e@(ELazyPat {}) = patSynErr e
312 \end{code}
313
314 %************************************************************************
315 %*                                                                      *
316         Arrow notation
317 %*                                                                      *
318 %************************************************************************
319
320 \begin{code}
321 rnExpr (HsProc pat body)
322   = newArrowScope $
323     rnPat ProcExpr pat $ \ pat' -> do
324       { (body',fvBody) <- rnCmdTop body
325       ; return (HsProc pat' body', fvBody) }
326
327 -- Ideally, these would be done in parsing, but to keep parsing simple, we do it here.
328 rnExpr e@(HsArrApp {})  = arrowFail e
329 rnExpr e@(HsArrForm {}) = arrowFail e
330
331 rnExpr other = pprPanic "rnExpr: unexpected expression" (ppr other)
332         -- HsWrap
333
334 hsHoleExpr :: HsExpr Name
335 hsHoleExpr = HsUnboundVar (mkRdrUnqual (mkVarOcc "_"))
336
337 arrowFail :: HsExpr RdrName -> RnM (HsExpr Name, FreeVars)
338 arrowFail e
339   = do { addErr (vcat [ ptext (sLit "Arrow command found where an expression was expected:")
340                       , nest 2 (ppr e) ])
341          -- Return a place-holder hole, so that we can carry on
342          -- to report other errors
343        ; return (hsHoleExpr, emptyFVs) }
344
345 ----------------------
346 -- See Note [Parsing sections] in Parser.y.pp
347 rnSection :: HsExpr RdrName -> RnM (HsExpr Name, FreeVars)
348 rnSection section@(SectionR op expr)
349   = do  { (op', fvs_op)     <- rnLExpr op
350         ; (expr', fvs_expr) <- rnLExpr expr
351         ; checkSectionPrec InfixR section op' expr'
352         ; return (SectionR op' expr', fvs_op `plusFV` fvs_expr) }
353
354 rnSection section@(SectionL expr op)
355   = do  { (expr', fvs_expr) <- rnLExpr expr
356         ; (op', fvs_op)     <- rnLExpr op
357         ; checkSectionPrec InfixL section op' expr'
358         ; return (SectionL expr' op', fvs_op `plusFV` fvs_expr) }
359
360 rnSection other = pprPanic "rnSection" (ppr other)
361 \end{code}
362
363 %************************************************************************
364 %*                                                                      *
365         Records
366 %*                                                                      *
367 %************************************************************************
368
369 \begin{code}
370 rnHsRecBinds :: HsRecFieldContext -> HsRecordBinds RdrName
371              -> RnM (HsRecordBinds Name, FreeVars)
372 rnHsRecBinds ctxt rec_binds@(HsRecFields { rec_dotdot = dd })
373   = do { (flds, fvs) <- rnHsRecFields1 ctxt HsVar rec_binds
374        ; (flds', fvss) <- mapAndUnzipM rn_field flds
375        ; return (HsRecFields { rec_flds = flds', rec_dotdot = dd },
376                  fvs `plusFV` plusFVs fvss) }
377   where
378     rn_field fld = do { (arg', fvs) <- rnLExpr (hsRecFieldArg fld)
379                       ; return (fld { hsRecFieldArg = arg' }, fvs) }
380 \end{code}
381
382
383 %************************************************************************
384 %*                                                                      *
385         Arrow commands
386 %*                                                                      *
387 %************************************************************************
388
389 \begin{code}
390 rnCmdArgs :: [LHsCmdTop RdrName] -> RnM ([LHsCmdTop Name], FreeVars)
391 rnCmdArgs [] = return ([], emptyFVs)
392 rnCmdArgs (arg:args)
393   = do { (arg',fvArg) <- rnCmdTop arg
394        ; (args',fvArgs) <- rnCmdArgs args
395        ; return (arg':args', fvArg `plusFV` fvArgs) }
396
397 rnCmdTop :: LHsCmdTop RdrName -> RnM (LHsCmdTop Name, FreeVars)
398 rnCmdTop = wrapLocFstM rnCmdTop'
399  where
400   rnCmdTop' (HsCmdTop cmd _ _ _)
401    = do { (cmd', fvCmd) <- rnLCmd cmd
402         ; let cmd_names = [arrAName, composeAName, firstAName] ++
403                           nameSetToList (methodNamesCmd (unLoc cmd'))
404         -- Generate the rebindable syntax for the monad
405         ; (cmd_names', cmd_fvs) <- lookupSyntaxNames cmd_names
406
407         ; return (HsCmdTop cmd' placeHolderType placeHolderType (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 = emptyRecStmt { 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{Assertion utils}
1143 %*                                                                      *
1144 %************************************************************************
1145
1146 \begin{code}
1147 srcSpanPrimLit :: DynFlags -> SrcSpan -> HsExpr Name
1148 srcSpanPrimLit dflags span
1149     = HsLit (HsStringPrim (unsafeMkByteString (showSDocOneLine dflags (ppr span))))
1150
1151 mkAssertErrorExpr :: RnM (HsExpr Name)
1152 -- Return an expression for (assertError "Foo.hs:27")
1153 mkAssertErrorExpr
1154   = do sloc <- getSrcSpanM
1155        dflags <- getDynFlags
1156        return (HsApp (L sloc (HsVar assertErrorName))
1157                      (L sloc (srcSpanPrimLit dflags sloc)))
1158 \end{code}
1159
1160 Note [Adding the implicit parameter to 'assert']
1161 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1162 The renamer transforms (assert e1 e2) to (assert "Foo.hs:27" e1 e2).
1163 By doing this in the renamer we allow the typechecker to just see the
1164 expanded application and do the right thing. But it's not really
1165 the Right Thing because there's no way to "undo" if you want to see
1166 the original source code.  We'll have fix this in due course, when
1167 we care more about being able to reconstruct the exact original
1168 program.
1169
1170 %************************************************************************
1171 %*                                                                      *
1172 \subsubsection{Errors}
1173 %*                                                                      *
1174 %************************************************************************
1175
1176 \begin{code}
1177 checkEmptyStmts :: HsStmtContext Name -> RnM ()
1178 -- We've seen an empty sequence of Stmts... is that ok?
1179 checkEmptyStmts ctxt
1180   = unless (okEmpty ctxt) (addErr (emptyErr ctxt))
1181
1182 okEmpty :: HsStmtContext a -> Bool
1183 okEmpty (PatGuard {}) = True
1184 okEmpty _             = False
1185
1186 emptyErr :: HsStmtContext Name -> SDoc
1187 emptyErr (ParStmtCtxt {})   = ptext (sLit "Empty statement group in parallel comprehension")
1188 emptyErr (TransStmtCtxt {}) = ptext (sLit "Empty statement group preceding 'group' or 'then'")
1189 emptyErr ctxt               = ptext (sLit "Empty") <+> pprStmtContext ctxt
1190
1191 ----------------------
1192 checkLastStmt :: Outputable (body RdrName) => HsStmtContext Name
1193               -> LStmt RdrName (Located (body RdrName))
1194               -> RnM (LStmt RdrName (Located (body RdrName)))
1195 checkLastStmt ctxt lstmt@(L loc stmt)
1196   = case ctxt of
1197       ListComp  -> check_comp
1198       MonadComp -> check_comp
1199       PArrComp  -> check_comp
1200       ArrowExpr -> check_do
1201       DoExpr    -> check_do
1202       MDoExpr   -> check_do
1203       _         -> check_other
1204   where
1205     check_do    -- Expect BodyStmt, and change it to LastStmt
1206       = case stmt of
1207           BodyStmt e _ _ _ -> return (L loc (mkLastStmt e))
1208           LastStmt {}      -> return lstmt   -- "Deriving" clauses may generate a
1209                                              -- LastStmt directly (unlike the parser)
1210           _                -> do { addErr (hang last_error 2 (ppr stmt)); return lstmt }
1211     last_error = (ptext (sLit "The last statement in") <+> pprAStmtContext ctxt
1212                   <+> ptext (sLit "must be an expression"))
1213
1214     check_comp  -- Expect LastStmt; this should be enforced by the parser!
1215       = case stmt of
1216           LastStmt {} -> return lstmt
1217           _           -> pprPanic "checkLastStmt" (ppr lstmt)
1218
1219     check_other -- Behave just as if this wasn't the last stmt
1220       = do { checkStmt ctxt lstmt; return lstmt }
1221
1222 -- Checking when a particular Stmt is ok
1223 checkStmt :: HsStmtContext Name
1224           -> LStmt RdrName (Located (body RdrName))
1225           -> RnM ()
1226 checkStmt ctxt (L _ stmt)
1227   = do { dflags <- getDynFlags
1228        ; case okStmt dflags ctxt stmt of
1229            IsValid        -> return ()
1230            NotValid extra -> addErr (msg $$ extra) }
1231   where
1232    msg = sep [ ptext (sLit "Unexpected") <+> pprStmtCat stmt <+> ptext (sLit "statement")
1233              , ptext (sLit "in") <+> pprAStmtContext ctxt ]
1234
1235 pprStmtCat :: Stmt a body -> SDoc
1236 pprStmtCat (TransStmt {})     = ptext (sLit "transform")
1237 pprStmtCat (LastStmt {})      = ptext (sLit "return expression")
1238 pprStmtCat (BodyStmt {})      = ptext (sLit "body")
1239 pprStmtCat (BindStmt {})      = ptext (sLit "binding")
1240 pprStmtCat (LetStmt {})       = ptext (sLit "let")
1241 pprStmtCat (RecStmt {})       = ptext (sLit "rec")
1242 pprStmtCat (ParStmt {})       = ptext (sLit "parallel")
1243
1244 ------------
1245 emptyInvalid :: Validity  -- Payload is the empty document
1246 emptyInvalid = NotValid empty
1247
1248 okStmt, okDoStmt, okCompStmt, okParStmt, okPArrStmt
1249    :: DynFlags -> HsStmtContext Name
1250    -> Stmt RdrName (Located (body RdrName)) -> Validity
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)) -> Validity
1269 okPatGuardStmt stmt
1270   = case stmt of
1271       BodyStmt {} -> IsValid
1272       BindStmt {} -> IsValid
1273       LetStmt {}  -> IsValid
1274       _           -> emptyInvalid
1275
1276 -------------
1277 okParStmt dflags ctxt stmt
1278   = case stmt of
1279       LetStmt (HsIPBinds {}) -> emptyInvalid
1280       _                      -> okStmt dflags ctxt stmt
1281
1282 ----------------
1283 okDoStmt dflags ctxt stmt
1284   = case stmt of
1285        RecStmt {}
1286          | Opt_RecursiveDo `xopt` dflags -> IsValid
1287          | ArrowExpr <- ctxt -> IsValid    -- Arrows allows 'rec'
1288          | otherwise         -> NotValid (ptext (sLit "Use RecursiveDo"))
1289        BindStmt {} -> IsValid
1290        LetStmt {}  -> IsValid
1291        BodyStmt {} -> IsValid
1292        _           -> emptyInvalid
1293
1294 ----------------
1295 okCompStmt dflags _ stmt
1296   = case stmt of
1297        BindStmt {} -> IsValid
1298        LetStmt {}  -> IsValid
1299        BodyStmt {} -> IsValid
1300        ParStmt {}
1301          | Opt_ParallelListComp `xopt` dflags -> IsValid
1302          | otherwise -> NotValid (ptext (sLit "Use ParallelListComp"))
1303        TransStmt {}
1304          | Opt_TransformListComp `xopt` dflags -> IsValid
1305          | otherwise -> NotValid (ptext (sLit "Use TransformListComp"))
1306        RecStmt {}  -> emptyInvalid
1307        LastStmt {} -> emptyInvalid  -- Should not happen (dealt with by checkLastStmt)
1308
1309 ----------------
1310 okPArrStmt dflags _ stmt
1311   = case stmt of
1312        BindStmt {} -> IsValid
1313        LetStmt {}  -> IsValid
1314        BodyStmt {} -> IsValid
1315        ParStmt {}
1316          | Opt_ParallelListComp `xopt` dflags -> IsValid
1317          | otherwise -> NotValid (ptext (sLit "Use ParallelListComp"))
1318        TransStmt {} -> emptyInvalid
1319        RecStmt {}   -> emptyInvalid
1320        LastStmt {}  -> emptyInvalid  -- 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}