Add separate functions for querying DynFlag and ExtensionFlag options
[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 module RnExpr (
14         rnLExpr, rnExpr, rnStmts
15    ) where
16
17 #include "HsVersions.h"
18
19 #ifdef GHCI
20 import {-# SOURCE #-} TcSplice( runQuasiQuoteExpr )
21 #endif  /* GHCI */
22
23 import RnSource  ( rnSrcDecls, findSplice )
24 import RnBinds   ( rnLocalBindsAndThen, rnValBindsLHS, rnValBindsRHS,
25                    rnMatchGroup, makeMiniFixityEnv) 
26 import HsSyn
27 import TcRnMonad
28 import TcEnv            ( thRnBrack )
29 import RnEnv
30 import RnTypes          ( rnHsTypeFVs, rnSplice, checkTH,
31                           mkOpFormRn, mkOpAppRn, mkNegAppRn, checkSectionPrec)
32 import RnPat
33 import DynFlags
34 import BasicTypes       ( FixityDirection(..) )
35 import PrelNames
36
37 import Name
38 import NameSet
39 import RdrName
40 import LoadIface        ( loadInterfaceForName )
41 import UniqSet
42 import Data.List
43 import Util             ( isSingleton )
44 import ListSetOps       ( removeDups )
45 import Outputable
46 import SrcLoc
47 import FastString
48 import Control.Monad
49 \end{code}
50
51
52 \begin{code}
53 -- XXX
54 thenM :: Monad a => a b -> (b -> a c) -> a c
55 thenM = (>>=)
56
57 thenM_ :: Monad a => a b -> a c -> a c
58 thenM_ = (>>)
59 \end{code}
60
61 %************************************************************************
62 %*                                                                      *
63 \subsubsection{Expressions}
64 %*                                                                      *
65 %************************************************************************
66
67 \begin{code}
68 rnExprs :: [LHsExpr RdrName] -> RnM ([LHsExpr Name], FreeVars)
69 rnExprs ls = rnExprs' ls emptyUniqSet
70  where
71   rnExprs' [] acc = return ([], acc)
72   rnExprs' (expr:exprs) acc
73    = rnLExpr expr               `thenM` \ (expr', fvExpr) ->
74
75         -- Now we do a "seq" on the free vars because typically it's small
76         -- or empty, especially in very long lists of constants
77     let
78         acc' = acc `plusFV` fvExpr
79     in
80     acc' `seq` rnExprs' exprs acc' `thenM` \ (exprs', fvExprs) ->
81     return (expr':exprs', fvExprs)
82 \end{code}
83
84 Variables. We look up the variable and return the resulting name. 
85
86 \begin{code}
87 rnLExpr :: LHsExpr RdrName -> RnM (LHsExpr Name, FreeVars)
88 rnLExpr = wrapLocFstM rnExpr
89
90 rnExpr :: HsExpr RdrName -> RnM (HsExpr Name, FreeVars)
91
92 finishHsVar :: Name -> RnM (HsExpr Name, FreeVars)
93 -- Separated from rnExpr because it's also used
94 -- when renaming infix expressions
95 -- See Note [Adding the implicit parameter to 'assert']
96 finishHsVar name 
97  = do { ignore_asserts <- doptM Opt_IgnoreAsserts
98       ; if ignore_asserts || not (name `hasKey` assertIdKey)
99         then return (HsVar name, unitFV name)
100         else do { e <- mkAssertErrorExpr
101                 ; return (e, unitFV name) } }
102
103 rnExpr (HsVar v)
104   = do name <- lookupOccRn v
105        finishHsVar name
106
107 rnExpr (HsIPVar v)
108   = newIPNameRn v               `thenM` \ name ->
109     return (HsIPVar name, emptyFVs)
110
111 rnExpr (HsLit lit@(HsString s))
112   = do {
113          opt_OverloadedStrings <- xoptM Opt_OverloadedStrings
114        ; if opt_OverloadedStrings then
115             rnExpr (HsOverLit (mkHsIsString s placeHolderType))
116          else -- Same as below
117             rnLit lit           `thenM_`
118             return (HsLit lit, emptyFVs)
119        }
120
121 rnExpr (HsLit lit) 
122   = rnLit lit           `thenM_`
123     return (HsLit lit, emptyFVs)
124
125 rnExpr (HsOverLit lit) 
126   = rnOverLit lit               `thenM` \ (lit', fvs) ->
127     return (HsOverLit lit', fvs)
128
129 rnExpr (HsApp fun arg)
130   = rnLExpr fun         `thenM` \ (fun',fvFun) ->
131     rnLExpr arg         `thenM` \ (arg',fvArg) ->
132     return (HsApp fun' arg', fvFun `plusFV` fvArg)
133
134 rnExpr (OpApp e1 (L op_loc (HsVar op_rdr)) _ e2) 
135   = do  { (e1', fv_e1) <- rnLExpr e1
136         ; (e2', fv_e2) <- rnLExpr e2
137         ; op_name <- setSrcSpan op_loc (lookupOccRn op_rdr)
138         ; (op', fv_op) <- finishHsVar op_name
139                 -- NB: op' is usually just a variable, but might be
140                 --     an applicatoin (assert "Foo.hs:47")
141         -- Deal with fixity
142         -- When renaming code synthesised from "deriving" declarations
143         -- we used to avoid fixity stuff, but we can't easily tell any
144         -- more, so I've removed the test.  Adding HsPars in TcGenDeriv
145         -- should prevent bad things happening.
146         ; fixity <- lookupFixityRn op_name
147         ; final_e <- mkOpAppRn e1' (L op_loc op') fixity e2'
148         ; return (final_e, fv_e1 `plusFV` fv_op `plusFV` fv_e2) }
149
150 rnExpr (NegApp e _)
151   = rnLExpr e                   `thenM` \ (e', fv_e) ->
152     lookupSyntaxName negateName `thenM` \ (neg_name, fv_neg) ->
153     mkNegAppRn e' neg_name      `thenM` \ final_e ->
154     return (final_e, fv_e `plusFV` fv_neg)
155
156 ------------------------------------------
157 -- Template Haskell extensions
158 -- Don't ifdef-GHCI them because we want to fail gracefully
159 -- (not with an rnExpr crash) in a stage-1 compiler.
160 rnExpr e@(HsBracket br_body)
161   = checkTH e "bracket"         `thenM_`
162     rnBracket br_body           `thenM` \ (body', fvs_e) ->
163     return (HsBracket body', fvs_e)
164
165 rnExpr (HsSpliceE splice)
166   = rnSplice splice             `thenM` \ (splice', fvs) ->
167     return (HsSpliceE splice', fvs)
168
169 #ifndef GHCI
170 rnExpr e@(HsQuasiQuoteE _) = pprPanic "Cant do quasiquotation without GHCi" (ppr e)
171 #else
172 rnExpr (HsQuasiQuoteE qq)
173   = runQuasiQuoteExpr qq        `thenM` \ (L _ expr') ->
174     rnExpr expr'
175 #endif  /* GHCI */
176
177 ---------------------------------------------
178 --      Sections
179 -- See Note [Parsing sections] in Parser.y.pp
180 rnExpr (HsPar (L loc (section@(SectionL {}))))
181   = do  { (section', fvs) <- rnSection section
182         ; return (HsPar (L loc section'), fvs) }
183
184 rnExpr (HsPar (L loc (section@(SectionR {}))))
185   = do  { (section', fvs) <- rnSection section
186         ; return (HsPar (L loc section'), fvs) }
187
188 rnExpr (HsPar e)
189   = do  { (e', fvs_e) <- rnLExpr e
190         ; return (HsPar e', fvs_e) }
191
192 rnExpr expr@(SectionL {})
193   = do  { addErr (sectionErr expr); rnSection expr }
194 rnExpr expr@(SectionR {})
195   = do  { addErr (sectionErr expr); rnSection expr }
196
197 ---------------------------------------------
198 rnExpr (HsCoreAnn ann expr)
199   = rnLExpr expr `thenM` \ (expr', fvs_expr) ->
200     return (HsCoreAnn ann expr', fvs_expr)
201
202 rnExpr (HsSCC lbl expr)
203   = rnLExpr expr                `thenM` \ (expr', fvs_expr) ->
204     return (HsSCC lbl expr', fvs_expr)
205 rnExpr (HsTickPragma info expr)
206   = rnLExpr expr                `thenM` \ (expr', fvs_expr) ->
207     return (HsTickPragma info expr', fvs_expr)
208
209 rnExpr (HsLam matches)
210   = rnMatchGroup LambdaExpr matches     `thenM` \ (matches', fvMatch) ->
211     return (HsLam matches', fvMatch)
212
213 rnExpr (HsCase expr matches)
214   = rnLExpr expr                        `thenM` \ (new_expr, e_fvs) ->
215     rnMatchGroup CaseAlt matches        `thenM` \ (new_matches, ms_fvs) ->
216     return (HsCase new_expr new_matches, e_fvs `plusFV` ms_fvs)
217
218 rnExpr (HsLet binds expr)
219   = rnLocalBindsAndThen binds           $ \ binds' ->
220     rnLExpr expr                         `thenM` \ (expr',fvExpr) ->
221     return (HsLet binds' expr', fvExpr)
222
223 rnExpr (HsDo do_or_lc stmts body _)
224   = do  { ((stmts', body'), fvs) <- rnStmts do_or_lc stmts $
225                                     rnLExpr body
226         ; return (HsDo do_or_lc stmts' body' placeHolderType, fvs) }
227
228 rnExpr (ExplicitList _ exps)
229   = rnExprs exps                        `thenM` \ (exps', fvs) ->
230     return  (ExplicitList placeHolderType exps', fvs)
231
232 rnExpr (ExplicitPArr _ exps)
233   = rnExprs exps                        `thenM` \ (exps', fvs) ->
234     return  (ExplicitPArr placeHolderType exps', fvs)
235
236 rnExpr (ExplicitTuple tup_args boxity)
237   = do { checkTupleSection tup_args
238        ; checkTupSize (length tup_args)
239        ; (tup_args', fvs) <- mapAndUnzipM rnTupArg tup_args
240        ; return (ExplicitTuple tup_args' boxity, plusFVs fvs) }
241   where
242     rnTupArg (Present e) = do { (e',fvs) <- rnLExpr e; return (Present e', fvs) }
243     rnTupArg (Missing _) = return (Missing placeHolderType, emptyFVs)
244
245 rnExpr (RecordCon con_id _ rbinds)
246   = do  { conname <- lookupLocatedOccRn con_id
247         ; (rbinds', fvRbinds) <- rnHsRecBinds (HsRecFieldCon (unLoc conname)) rbinds
248         ; return (RecordCon conname noPostTcExpr rbinds', 
249                   fvRbinds `addOneFV` unLoc conname) }
250
251 rnExpr (RecordUpd expr rbinds _ _ _)
252   = do  { (expr', fvExpr) <- rnLExpr expr
253         ; (rbinds', fvRbinds) <- rnHsRecBinds HsRecFieldUpd rbinds
254         ; return (RecordUpd expr' rbinds' [] [] [], 
255                   fvExpr `plusFV` fvRbinds) }
256
257 rnExpr (ExprWithTySig expr pty)
258   = do  { (pty', fvTy) <- rnHsTypeFVs doc pty
259         ; (expr', fvExpr) <- bindSigTyVarsFV (hsExplicitTvs pty') $
260                              rnLExpr expr
261         ; return (ExprWithTySig expr' pty', fvExpr `plusFV` fvTy) }
262   where 
263     doc = text "In an expression type signature"
264
265 rnExpr (HsIf p b1 b2)
266   = rnLExpr p           `thenM` \ (p', fvP) ->
267     rnLExpr b1          `thenM` \ (b1', fvB1) ->
268     rnLExpr b2          `thenM` \ (b2', fvB2) ->
269     return (HsIf p' b1' b2', plusFVs [fvP, fvB1, fvB2])
270
271 rnExpr (HsType a)
272   = rnHsTypeFVs doc a   `thenM` \ (t, fvT) -> 
273     return (HsType t, fvT)
274   where 
275     doc = text "In a type argument"
276
277 rnExpr (ArithSeq _ seq)
278   = rnArithSeq seq       `thenM` \ (new_seq, fvs) ->
279     return (ArithSeq noPostTcExpr new_seq, fvs)
280
281 rnExpr (PArrSeq _ seq)
282   = rnArithSeq seq       `thenM` \ (new_seq, fvs) ->
283     return (PArrSeq noPostTcExpr new_seq, fvs)
284 \end{code}
285
286 These three are pattern syntax appearing in expressions.
287 Since all the symbols are reservedops we can simply reject them.
288 We return a (bogus) EWildPat in each case.
289
290 \begin{code}
291 rnExpr e@EWildPat      = patSynErr e
292 rnExpr e@(EAsPat {})   = patSynErr e
293 rnExpr e@(EViewPat {}) = patSynErr e
294 rnExpr e@(ELazyPat {}) = patSynErr e
295 \end{code}
296
297 %************************************************************************
298 %*                                                                      *
299         Arrow notation
300 %*                                                                      *
301 %************************************************************************
302
303 \begin{code}
304 rnExpr (HsProc pat body)
305   = newArrowScope $
306     rnPat ProcExpr pat $ \ pat' ->
307     rnCmdTop body                `thenM` \ (body',fvBody) ->
308     return (HsProc pat' body', fvBody)
309
310 rnExpr (HsArrApp arrow arg _ ho rtl)
311   = select_arrow_scope (rnLExpr arrow)  `thenM` \ (arrow',fvArrow) ->
312     rnLExpr arg                         `thenM` \ (arg',fvArg) ->
313     return (HsArrApp arrow' arg' placeHolderType ho rtl,
314              fvArrow `plusFV` fvArg)
315   where
316     select_arrow_scope tc = case ho of
317         HsHigherOrderApp -> tc
318         HsFirstOrderApp  -> escapeArrowScope tc
319
320 -- infix form
321 rnExpr (HsArrForm op (Just _) [arg1, arg2])
322   = escapeArrowScope (rnLExpr op)
323                         `thenM` \ (op'@(L _ (HsVar op_name)),fv_op) ->
324     rnCmdTop arg1       `thenM` \ (arg1',fv_arg1) ->
325     rnCmdTop arg2       `thenM` \ (arg2',fv_arg2) ->
326
327         -- Deal with fixity
328
329     lookupFixityRn op_name              `thenM` \ fixity ->
330     mkOpFormRn arg1' op' fixity arg2'   `thenM` \ final_e -> 
331
332     return (final_e,
333               fv_arg1 `plusFV` fv_op `plusFV` fv_arg2)
334
335 rnExpr (HsArrForm op fixity cmds)
336   = escapeArrowScope (rnLExpr op)       `thenM` \ (op',fvOp) ->
337     rnCmdArgs cmds                      `thenM` \ (cmds',fvCmds) ->
338     return (HsArrForm op' fixity cmds', fvOp `plusFV` fvCmds)
339
340 rnExpr other = pprPanic "rnExpr: unexpected expression" (ppr other)
341         -- HsWrap
342
343 ----------------------
344 -- See Note [Parsing sections] in Parser.y.pp
345 rnSection :: HsExpr RdrName -> RnM (HsExpr Name, FreeVars)
346 rnSection section@(SectionR op expr)
347   = do  { (op', fvs_op)     <- rnLExpr op
348         ; (expr', fvs_expr) <- rnLExpr expr
349         ; checkSectionPrec InfixR section op' expr'
350         ; return (SectionR op' expr', fvs_op `plusFV` fvs_expr) }
351
352 rnSection section@(SectionL expr op)
353   = do  { (expr', fvs_expr) <- rnLExpr expr
354         ; (op', fvs_op)     <- rnLExpr op
355         ; checkSectionPrec InfixL section op' expr'
356         ; return (SectionL expr' op', fvs_op `plusFV` fvs_expr) }
357
358 rnSection other = pprPanic "rnSection" (ppr other)
359 \end{code}
360
361 %************************************************************************
362 %*                                                                      *
363         Records
364 %*                                                                      *
365 %************************************************************************
366
367 \begin{code}
368 rnHsRecBinds :: HsRecFieldContext -> HsRecordBinds RdrName
369              -> RnM (HsRecordBinds Name, FreeVars)
370 rnHsRecBinds ctxt rec_binds@(HsRecFields { rec_dotdot = dd })
371   = do { (flds, fvs) <- rnHsRecFields1 ctxt HsVar rec_binds
372        ; (flds', fvss) <- mapAndUnzipM rn_field flds
373        ; return (HsRecFields { rec_flds = flds', rec_dotdot = dd }, 
374                  fvs `plusFV` plusFVs fvss) }
375   where 
376     rn_field fld = do { (arg', fvs) <- rnLExpr (hsRecFieldArg fld)
377                       ; return (fld { hsRecFieldArg = arg' }, fvs) }
378 \end{code}
379
380
381 %************************************************************************
382 %*                                                                      *
383         Arrow commands
384 %*                                                                      *
385 %************************************************************************
386
387 \begin{code}
388 rnCmdArgs :: [LHsCmdTop RdrName] -> RnM ([LHsCmdTop Name], FreeVars)
389 rnCmdArgs [] = return ([], emptyFVs)
390 rnCmdArgs (arg:args)
391   = rnCmdTop arg        `thenM` \ (arg',fvArg) ->
392     rnCmdArgs args      `thenM` \ (args',fvArgs) ->
393     return (arg':args', fvArg `plusFV` fvArgs)
394
395 rnCmdTop :: LHsCmdTop RdrName -> RnM (LHsCmdTop Name, FreeVars)
396 rnCmdTop = wrapLocFstM rnCmdTop'
397  where
398   rnCmdTop' (HsCmdTop cmd _ _ _) 
399    = rnLExpr (convertOpFormsLCmd cmd) `thenM` \ (cmd', fvCmd) ->
400      let 
401         cmd_names = [arrAName, composeAName, firstAName] ++
402                     nameSetToList (methodNamesCmd (unLoc cmd'))
403      in
404         -- Generate the rebindable syntax for the monad
405      lookupSyntaxTable cmd_names        `thenM` \ (cmd_names', cmd_fvs) ->
406
407      return (HsCmdTop cmd' [] placeHolderType cmd_names', 
408              fvCmd `plusFV` cmd_fvs)
409
410 ---------------------------------------------------
411 -- convert OpApp's in a command context to HsArrForm's
412
413 convertOpFormsLCmd :: LHsCmd id -> LHsCmd id
414 convertOpFormsLCmd = fmap convertOpFormsCmd
415
416 convertOpFormsCmd :: HsCmd id -> HsCmd id
417
418 convertOpFormsCmd (HsApp c e) = HsApp (convertOpFormsLCmd c) e
419 convertOpFormsCmd (HsLam match) = HsLam (convertOpFormsMatch match)
420 convertOpFormsCmd (OpApp c1 op fixity c2)
421   = let
422         arg1 = L (getLoc c1) $ HsCmdTop (convertOpFormsLCmd c1) [] placeHolderType []
423         arg2 = L (getLoc c2) $ HsCmdTop (convertOpFormsLCmd c2) [] placeHolderType []
424     in
425     HsArrForm op (Just fixity) [arg1, arg2]
426
427 convertOpFormsCmd (HsPar c) = HsPar (convertOpFormsLCmd c)
428
429 convertOpFormsCmd (HsCase exp matches)
430   = HsCase exp (convertOpFormsMatch matches)
431
432 convertOpFormsCmd (HsIf exp c1 c2)
433   = HsIf exp (convertOpFormsLCmd c1) (convertOpFormsLCmd c2)
434
435 convertOpFormsCmd (HsLet binds cmd)
436   = HsLet binds (convertOpFormsLCmd cmd)
437
438 convertOpFormsCmd (HsDo ctxt stmts body ty)
439   = HsDo ctxt (map (fmap convertOpFormsStmt) stmts)
440               (convertOpFormsLCmd body) ty
441
442 -- Anything else is unchanged.  This includes HsArrForm (already done),
443 -- things with no sub-commands, and illegal commands (which will be
444 -- caught by the type checker)
445 convertOpFormsCmd c = c
446
447 convertOpFormsStmt :: StmtLR id id -> StmtLR id id
448 convertOpFormsStmt (BindStmt pat cmd _ _)
449   = BindStmt pat (convertOpFormsLCmd cmd) noSyntaxExpr noSyntaxExpr
450 convertOpFormsStmt (ExprStmt cmd _ _)
451   = ExprStmt (convertOpFormsLCmd cmd) noSyntaxExpr placeHolderType
452 convertOpFormsStmt stmt@(RecStmt { recS_stmts = stmts })
453   = stmt { recS_stmts = map (fmap convertOpFormsStmt) stmts }
454 convertOpFormsStmt stmt = stmt
455
456 convertOpFormsMatch :: MatchGroup id -> MatchGroup id
457 convertOpFormsMatch (MatchGroup ms ty)
458   = MatchGroup (map (fmap convert) ms) ty
459  where convert (Match pat mty grhss)
460           = Match pat mty (convertOpFormsGRHSs grhss)
461
462 convertOpFormsGRHSs :: GRHSs id -> GRHSs id
463 convertOpFormsGRHSs (GRHSs grhss binds)
464   = GRHSs (map convertOpFormsGRHS grhss) binds
465
466 convertOpFormsGRHS :: Located (GRHS id) -> Located (GRHS id)
467 convertOpFormsGRHS = fmap convert
468  where 
469    convert (GRHS stmts cmd) = GRHS stmts (convertOpFormsLCmd cmd)
470
471 ---------------------------------------------------
472 type CmdNeeds = FreeVars        -- Only inhabitants are 
473                                 --      appAName, choiceAName, loopAName
474
475 -- find what methods the Cmd needs (loop, choice, apply)
476 methodNamesLCmd :: LHsCmd Name -> CmdNeeds
477 methodNamesLCmd = methodNamesCmd . unLoc
478
479 methodNamesCmd :: HsCmd Name -> CmdNeeds
480
481 methodNamesCmd (HsArrApp _arrow _arg _ HsFirstOrderApp _rtl)
482   = emptyFVs
483 methodNamesCmd (HsArrApp _arrow _arg _ HsHigherOrderApp _rtl)
484   = unitFV appAName
485 methodNamesCmd (HsArrForm {}) = emptyFVs
486
487 methodNamesCmd (HsPar c) = methodNamesLCmd c
488
489 methodNamesCmd (HsIf _ c1 c2)
490   = methodNamesLCmd c1 `plusFV` methodNamesLCmd c2 `addOneFV` choiceAName
491
492 methodNamesCmd (HsLet _ c) = methodNamesLCmd c
493
494 methodNamesCmd (HsDo _ stmts body _) 
495   = methodNamesStmts stmts `plusFV` methodNamesLCmd body
496
497 methodNamesCmd (HsApp c _) = methodNamesLCmd c
498
499 methodNamesCmd (HsLam match) = methodNamesMatch match
500
501 methodNamesCmd (HsCase _ matches)
502   = methodNamesMatch matches `addOneFV` choiceAName
503
504 methodNamesCmd _ = emptyFVs
505    -- Other forms can't occur in commands, but it's not convenient 
506    -- to error here so we just do what's convenient.
507    -- The type checker will complain later
508
509 ---------------------------------------------------
510 methodNamesMatch :: MatchGroup Name -> FreeVars
511 methodNamesMatch (MatchGroup ms _)
512   = plusFVs (map do_one ms)
513  where 
514     do_one (L _ (Match _ _ grhss)) = methodNamesGRHSs grhss
515
516 -------------------------------------------------
517 -- gaw 2004
518 methodNamesGRHSs :: GRHSs Name -> FreeVars
519 methodNamesGRHSs (GRHSs grhss _) = plusFVs (map methodNamesGRHS grhss)
520
521 -------------------------------------------------
522
523 methodNamesGRHS :: Located (GRHS Name) -> CmdNeeds
524 methodNamesGRHS (L _ (GRHS _ rhs)) = methodNamesLCmd rhs
525
526 ---------------------------------------------------
527 methodNamesStmts :: [Located (StmtLR Name Name)] -> FreeVars
528 methodNamesStmts stmts = plusFVs (map methodNamesLStmt stmts)
529
530 ---------------------------------------------------
531 methodNamesLStmt :: Located (StmtLR Name Name) -> FreeVars
532 methodNamesLStmt = methodNamesStmt . unLoc
533
534 methodNamesStmt :: StmtLR Name Name -> FreeVars
535 methodNamesStmt (ExprStmt cmd _ _)               = methodNamesLCmd cmd
536 methodNamesStmt (BindStmt _ cmd _ _)             = methodNamesLCmd cmd
537 methodNamesStmt (RecStmt { recS_stmts = stmts }) = methodNamesStmts stmts `addOneFV` loopAName
538 methodNamesStmt (LetStmt _)                      = emptyFVs
539 methodNamesStmt (ParStmt _)                      = emptyFVs
540 methodNamesStmt (TransformStmt {})               = emptyFVs
541 methodNamesStmt (GroupStmt {})                   = emptyFVs
542    -- ParStmt, TransformStmt and GroupStmt can't occur in commands, but it's not convenient to error 
543    -- here so we just do what's convenient
544 \end{code}
545
546
547 %************************************************************************
548 %*                                                                      *
549         Arithmetic sequences
550 %*                                                                      *
551 %************************************************************************
552
553 \begin{code}
554 rnArithSeq :: ArithSeqInfo RdrName -> RnM (ArithSeqInfo Name, FreeVars)
555 rnArithSeq (From expr)
556  = rnLExpr expr         `thenM` \ (expr', fvExpr) ->
557    return (From expr', fvExpr)
558
559 rnArithSeq (FromThen expr1 expr2)
560  = rnLExpr expr1        `thenM` \ (expr1', fvExpr1) ->
561    rnLExpr expr2        `thenM` \ (expr2', fvExpr2) ->
562    return (FromThen expr1' expr2', fvExpr1 `plusFV` fvExpr2)
563
564 rnArithSeq (FromTo expr1 expr2)
565  = rnLExpr expr1        `thenM` \ (expr1', fvExpr1) ->
566    rnLExpr expr2        `thenM` \ (expr2', fvExpr2) ->
567    return (FromTo expr1' expr2', fvExpr1 `plusFV` fvExpr2)
568
569 rnArithSeq (FromThenTo expr1 expr2 expr3)
570  = rnLExpr expr1        `thenM` \ (expr1', fvExpr1) ->
571    rnLExpr expr2        `thenM` \ (expr2', fvExpr2) ->
572    rnLExpr expr3        `thenM` \ (expr3', fvExpr3) ->
573    return (FromThenTo expr1' expr2' expr3',
574             plusFVs [fvExpr1, fvExpr2, fvExpr3])
575 \end{code}
576
577 %************************************************************************
578 %*                                                                      *
579         Template Haskell brackets
580 %*                                                                      *
581 %************************************************************************
582
583 \begin{code}
584 rnBracket :: HsBracket RdrName -> RnM (HsBracket Name, FreeVars)
585 rnBracket (VarBr n) = do { name <- lookupOccRn n
586                          ; this_mod <- getModule
587                          ; unless (nameIsLocalOrFrom this_mod name) $   -- Reason: deprecation checking asumes the
588                            do { _ <- loadInterfaceForName msg name      -- home interface is loaded, and this is the
589                               ; return () }                             -- only way that is going to happen
590                          ; return (VarBr name, unitFV name) }
591                     where
592                       msg = ptext (sLit "Need interface for Template Haskell quoted Name")
593
594 rnBracket (ExpBr e) = do { (e', fvs) <- rnLExpr e
595                          ; return (ExpBr e', fvs) }
596
597 rnBracket (PatBr p) = rnPat ThPatQuote p $ \ p' -> return (PatBr p', emptyFVs)
598
599 rnBracket (TypBr t) = do { (t', fvs) <- rnHsTypeFVs doc t
600                          ; return (TypBr t', fvs) }
601                     where
602                       doc = ptext (sLit "In a Template-Haskell quoted type")
603
604 rnBracket (DecBrL decls) 
605   = do { (group, mb_splice) <- findSplice decls
606        ; case mb_splice of
607            Nothing -> return ()
608            Just (SpliceDecl (L loc _) _, _)  
609               -> setSrcSpan loc $
610                  addErr (ptext (sLit "Declaration splices are not permitted inside declaration brackets"))
611                 -- Why not?  See Section 7.3 of the TH paper.  
612
613        ; gbl_env  <- getGblEnv
614        ; let new_gbl_env = gbl_env { tcg_dus = emptyDUs }
615                           -- The emptyDUs is so that we just collect uses for this
616                           -- group alone in the call to rnSrcDecls below
617        ; (tcg_env, group') <- setGblEnv new_gbl_env $ 
618                               setStage thRnBrack $
619                               rnSrcDecls group      
620
621               -- Discard the tcg_env; it contains only extra info about fixity
622         ; traceRn (text "rnBracket dec" <+> (ppr (tcg_dus tcg_env) $$ ppr (duUses (tcg_dus tcg_env))))
623         ; return (DecBrG group', duUses (tcg_dus tcg_env)) }
624
625 rnBracket (DecBrG _) = panic "rnBracket: unexpected DecBrG"
626 \end{code}
627
628 %************************************************************************
629 %*                                                                      *
630 \subsubsection{@Stmt@s: in @do@ expressions}
631 %*                                                                      *
632 %************************************************************************
633
634 \begin{code}
635 rnStmts :: HsStmtContext Name -> [LStmt RdrName] 
636         -> RnM (thing, FreeVars)
637         -> RnM (([LStmt Name], thing), FreeVars)
638 -- Variables bound by the Stmts, and mentioned in thing_inside,
639 -- do not appear in the result FreeVars
640
641 rnStmts (MDoExpr _) stmts thing_inside = rnMDoStmts    stmts thing_inside
642 rnStmts ctxt        stmts thing_inside = rnNormalStmts ctxt stmts (\ _ -> thing_inside)
643
644 rnNormalStmts :: HsStmtContext Name -> [LStmt RdrName]
645               -> ([Name] -> RnM (thing, FreeVars))
646               -> RnM (([LStmt Name], thing), FreeVars)  
647 -- Variables bound by the Stmts, and mentioned in thing_inside,
648 -- do not appear in the result FreeVars
649 --
650 -- Renaming a single RecStmt can give a sequence of smaller Stmts
651
652 rnNormalStmts _ [] thing_inside 
653   = do { (res, fvs) <- thing_inside []
654        ; return (([], res), fvs) }
655
656 rnNormalStmts ctxt (stmt@(L loc _) : stmts) thing_inside
657   = do { ((stmts1, (stmts2, thing)), fvs) 
658             <- setSrcSpan loc           $
659                rnStmt ctxt stmt         $ \ bndrs1 ->
660                rnNormalStmts ctxt stmts $ \ bndrs2 ->
661                thing_inside (bndrs1 ++ bndrs2)
662         ; return (((stmts1 ++ stmts2), thing), fvs) }
663
664
665 rnStmt :: HsStmtContext Name -> LStmt RdrName
666        -> ([Name] -> RnM (thing, FreeVars))
667        -> RnM (([LStmt Name], thing), FreeVars)
668 -- Variables bound by the Stmt, and mentioned in thing_inside,
669 -- do not appear in the result FreeVars
670
671 rnStmt _ (L loc (ExprStmt expr _ _)) thing_inside
672   = do  { (expr', fv_expr) <- rnLExpr expr
673         ; (then_op, fvs1)  <- lookupSyntaxName thenMName
674         ; (thing, fvs2)    <- thing_inside []
675         ; return (([L loc (ExprStmt expr' then_op placeHolderType)], thing),
676                   fv_expr `plusFV` fvs1 `plusFV` fvs2) }
677
678 rnStmt ctxt (L loc (BindStmt pat expr _ _)) thing_inside
679   = do  { (expr', fv_expr) <- rnLExpr expr
680                 -- The binders do not scope over the expression
681         ; (bind_op, fvs1) <- lookupSyntaxName bindMName
682         ; (fail_op, fvs2) <- lookupSyntaxName failMName
683         ; rnPat (StmtCtxt ctxt) pat $ \ pat' -> do
684         { (thing, fvs3) <- thing_inside (collectPatBinders pat')
685         ; return (([L loc (BindStmt pat' expr' bind_op fail_op)], thing),
686                   fv_expr `plusFV` fvs1 `plusFV` fvs2 `plusFV` fvs3) }}
687        -- fv_expr shouldn't really be filtered by the rnPatsAndThen
688         -- but it does not matter because the names are unique
689
690 rnStmt ctxt (L loc (LetStmt binds)) thing_inside 
691   = do  { checkLetStmt ctxt binds
692         ; rnLocalBindsAndThen binds $ \binds' -> do
693         { (thing, fvs) <- thing_inside (collectLocalBinders binds')
694         ; return (([L loc (LetStmt binds')], thing), fvs) }  }
695
696 rnStmt ctxt (L _ (RecStmt { recS_stmts = rec_stmts })) thing_inside
697   = do  { checkRecStmt ctxt
698
699         -- Step1: Bring all the binders of the mdo into scope
700         -- (Remember that this also removes the binders from the
701         -- finally-returned free-vars.)
702         -- And rename each individual stmt, making a
703         -- singleton segment.  At this stage the FwdRefs field
704         -- isn't finished: it's empty for all except a BindStmt
705         -- for which it's the fwd refs within the bind itself
706         -- (This set may not be empty, because we're in a recursive 
707         -- context.)
708         ; rn_rec_stmts_and_then rec_stmts       $ \ segs -> do
709
710         { let bndrs = nameSetToList $ foldr (unionNameSets . (\(ds,_,_,_) -> ds)) 
711                                             emptyNameSet segs
712         ; (thing, fvs_later) <- thing_inside bndrs
713         ; (return_op, fvs1)  <- lookupSyntaxName returnMName
714         ; (mfix_op,   fvs2)  <- lookupSyntaxName mfixName
715         ; (bind_op,   fvs3)  <- lookupSyntaxName bindMName
716         ; let
717                 -- Step 2: Fill in the fwd refs.
718                 --         The segments are all singletons, but their fwd-ref
719                 --         field mentions all the things used by the segment
720                 --         that are bound after their use
721             segs_w_fwd_refs          = addFwdRefs segs
722
723                 -- Step 3: Group together the segments to make bigger segments
724                 --         Invariant: in the result, no segment uses a variable
725                 --                    bound in a later segment
726             grouped_segs = glomSegments segs_w_fwd_refs
727
728                 -- Step 4: Turn the segments into Stmts
729                 --         Use RecStmt when and only when there are fwd refs
730                 --         Also gather up the uses from the end towards the
731                 --         start, so we can tell the RecStmt which things are
732                 --         used 'after' the RecStmt
733             empty_rec_stmt = emptyRecStmt { recS_ret_fn  = return_op
734                                           , recS_mfix_fn = mfix_op
735                                           , recS_bind_fn = bind_op }
736             (rec_stmts', fvs) = segsToStmts empty_rec_stmt grouped_segs fvs_later
737
738         ; return ((rec_stmts', thing), fvs `plusFV` fvs1 `plusFV` fvs2 `plusFV` fvs3) } }
739
740 rnStmt ctxt (L loc (ParStmt segs)) thing_inside
741   = do  { checkParStmt ctxt
742         ; ((segs', thing), fvs) <- rnParallelStmts (ParStmtCtxt ctxt) segs thing_inside
743         ; return (([L loc (ParStmt segs')], thing), fvs) }
744
745 rnStmt ctxt (L loc (TransformStmt stmts _ using by)) thing_inside
746   = do { checkTransformStmt ctxt
747     
748        ; (using', fvs1) <- rnLExpr using
749
750        ; ((stmts', (by', used_bndrs, thing)), fvs2)
751              <- rnNormalStmts (TransformStmtCtxt ctxt) stmts $ \ bndrs ->
752                 do { (by', fvs_by) <- case by of
753                                         Nothing -> return (Nothing, emptyFVs)
754                                         Just e  -> do { (e', fvs) <- rnLExpr e; return (Just e', fvs) }
755                    ; (thing, fvs_thing) <- thing_inside bndrs
756                    ; let fvs        = fvs_by `plusFV` fvs_thing
757                          used_bndrs = filter (`elemNameSet` fvs_thing) bndrs
758                    ; return ((by', used_bndrs, thing), fvs) }
759
760        ; return (([L loc (TransformStmt stmts' used_bndrs using' by')], thing), 
761                  fvs1 `plusFV` fvs2) }
762         
763 rnStmt ctxt (L loc (GroupStmt stmts _ by using)) thing_inside
764   = do { checkTransformStmt ctxt
765     
766          -- Rename the 'using' expression in the context before the transform is begun
767        ; (using', fvs1) <- case using of
768                              Left e  -> do { (e', fvs) <- rnLExpr e; return (Left e', fvs) }
769                              Right _ -> do { (e', fvs) <- lookupSyntaxName groupWithName
770                                            ; return (Right e', fvs) }
771
772          -- Rename the stmts and the 'by' expression
773          -- Keep track of the variables mentioned in the 'by' expression
774        ; ((stmts', (by', used_bndrs, thing)), fvs2) 
775              <- rnNormalStmts (TransformStmtCtxt ctxt) stmts $ \ bndrs ->
776                 do { (by',   fvs_by) <- mapMaybeFvRn rnLExpr by
777                    ; (thing, fvs_thing) <- thing_inside bndrs
778                    ; let fvs = fvs_by `plusFV` fvs_thing
779                          used_bndrs = filter (`elemNameSet` fvs) bndrs
780                    ; return ((by', used_bndrs, thing), fvs) }
781
782        ; let all_fvs  = fvs1 `plusFV` fvs2 
783              bndr_map = used_bndrs `zip` used_bndrs
784              -- See Note [GroupStmt binder map] in HsExpr
785
786        ; traceRn (text "rnStmt: implicitly rebound these used binders:" <+> ppr bndr_map)
787        ; return (([L loc (GroupStmt stmts' bndr_map by' using')], thing), all_fvs) }
788
789
790 type ParSeg id = ([LStmt id], [id])        -- The Names are bound by the Stmts
791
792 rnParallelStmts :: forall thing. HsStmtContext Name 
793                 -> [ParSeg RdrName]
794                 -> ([Name] -> RnM (thing, FreeVars))
795                 -> RnM (([ParSeg Name], thing), FreeVars)
796 -- Note [Renaming parallel Stmts]
797 rnParallelStmts ctxt segs thing_inside
798   = do { orig_lcl_env <- getLocalRdrEnv
799        ; rn_segs orig_lcl_env [] segs }
800   where
801     rn_segs :: LocalRdrEnv
802             -> [Name] -> [ParSeg RdrName]
803             -> RnM (([ParSeg Name], thing), FreeVars)
804     rn_segs _ bndrs_so_far [] 
805       = do { let (bndrs', dups) = removeDups cmpByOcc bndrs_so_far
806            ; mapM_ dupErr dups
807            ; (thing, fvs) <- bindLocalNames bndrs' (thing_inside bndrs')
808            ; return (([], thing), fvs) }
809
810     rn_segs env bndrs_so_far ((stmts,_) : segs) 
811       = do { ((stmts', (used_bndrs, segs', thing)), fvs)
812                     <- rnNormalStmts ctxt stmts $ \ bndrs ->
813                        setLocalRdrEnv env       $ do
814                        { ((segs', thing), fvs) <- rn_segs env (bndrs ++ bndrs_so_far) segs
815                        ; let used_bndrs = filter (`elemNameSet` fvs) bndrs
816                        ; return ((used_bndrs, segs', thing), fvs) }
817                        
818            ; let seg' = (stmts', used_bndrs)
819            ; return ((seg':segs', thing), fvs) }
820
821     cmpByOcc n1 n2 = nameOccName n1 `compare` nameOccName n2
822     dupErr vs = addErr (ptext (sLit "Duplicate binding in parallel list comprehension for:")
823                     <+> quotes (ppr (head vs)))
824 \end{code}
825
826 Note [Renaming parallel Stmts]
827 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
828 Renaming parallel statements is painful.  Given, say  
829      [ a+c | a <- as, bs <- bss
830            | c <- bs, a <- ds ]
831 Note that
832   (a) In order to report "Defined by not used" about 'bs', we must rename
833       each group of Stmts with a thing_inside whose FreeVars include at least {a,c}
834    
835   (b) We want to report that 'a' is illegally bound in both branches
836
837   (c) The 'bs' in the second group must obviously not be captured by 
838       the binding in the first group
839
840 To satisfy (a) we nest the segements. 
841 To satisfy (b) we check for duplicates just before thing_inside.
842 To satisfy (c) we reset the LocalRdrEnv each time.
843
844 %************************************************************************
845 %*                                                                      *
846 \subsubsection{mdo expressions}
847 %*                                                                      *
848 %************************************************************************
849
850 \begin{code}
851 type FwdRefs = NameSet
852 type Segment stmts = (Defs,
853                       Uses,     -- May include defs
854                       FwdRefs,  -- A subset of uses that are 
855                                 --   (a) used before they are bound in this segment, or 
856                                 --   (b) used here, and bound in subsequent segments
857                       stmts)    -- Either Stmt or [Stmt]
858
859
860 ----------------------------------------------------
861
862 rnMDoStmts :: [LStmt RdrName]
863            -> RnM (thing, FreeVars)
864            -> RnM (([LStmt Name], thing), FreeVars)     
865 rnMDoStmts stmts thing_inside
866   = rn_rec_stmts_and_then stmts $ \ segs -> do
867     { (thing, fvs_later) <- thing_inside
868     ; let   segs_w_fwd_refs = addFwdRefs segs
869             grouped_segs = glomSegments segs_w_fwd_refs
870             (stmts', fvs) = segsToStmts emptyRecStmt grouped_segs fvs_later
871     ; return ((stmts', thing), fvs) }
872
873 ---------------------------------------------
874
875 -- wrapper that does both the left- and right-hand sides
876 rn_rec_stmts_and_then :: [LStmt RdrName]
877                          -- assumes that the FreeVars returned includes
878                          -- the FreeVars of the Segments
879                       -> ([Segment (LStmt Name)] -> RnM (a, FreeVars))
880                       -> RnM (a, FreeVars)
881 rn_rec_stmts_and_then s cont
882   = do  { -- (A) Make the mini fixity env for all of the stmts
883           fix_env <- makeMiniFixityEnv (collectRecStmtsFixities s)
884
885           -- (B) Do the LHSes
886         ; new_lhs_and_fv <- rn_rec_stmts_lhs fix_env s
887
888           --    ...bring them and their fixities into scope
889         ; let bound_names = collectLStmtsBinders (map fst new_lhs_and_fv)
890         ; bindLocalNamesFV bound_names $
891           addLocalFixities fix_env bound_names $ do
892
893           -- (C) do the right-hand-sides and thing-inside
894         { segs <- rn_rec_stmts bound_names new_lhs_and_fv
895         ; (res, fvs) <- cont segs 
896         ; warnUnusedLocalBinds bound_names fvs
897         ; return (res, fvs) }}
898
899 -- get all the fixity decls in any Let stmt
900 collectRecStmtsFixities :: [LStmtLR RdrName RdrName] -> [LFixitySig RdrName]
901 collectRecStmtsFixities l = 
902     foldr (\ s -> \acc -> case s of 
903                             (L _ (LetStmt (HsValBinds (ValBindsIn _ sigs)))) -> 
904                                 foldr (\ sig -> \ acc -> case sig of 
905                                                            (L loc (FixSig s)) -> (L loc s) : acc
906                                                            _ -> acc) acc sigs
907                             _ -> acc) [] l
908                              
909 -- left-hand sides
910
911 rn_rec_stmt_lhs :: MiniFixityEnv
912                 -> LStmt RdrName
913                    -- rename LHS, and return its FVs
914                    -- Warning: we will only need the FreeVars below in the case of a BindStmt,
915                    -- so we don't bother to compute it accurately in the other cases
916                 -> RnM [(LStmtLR Name RdrName, FreeVars)]
917
918 rn_rec_stmt_lhs _ (L loc (ExprStmt expr a b)) = return [(L loc (ExprStmt expr a b), 
919                                                        -- this is actually correct
920                                                        emptyFVs)]
921
922 rn_rec_stmt_lhs fix_env (L loc (BindStmt pat expr a b)) 
923   = do 
924       -- should the ctxt be MDo instead?
925       (pat', fv_pat) <- rnBindPat (localRecNameMaker fix_env) pat 
926       return [(L loc (BindStmt pat' expr a b),
927                fv_pat)]
928
929 rn_rec_stmt_lhs _ (L _ (LetStmt binds@(HsIPBinds _)))
930   = failWith (badIpBinds (ptext (sLit "an mdo expression")) binds)
931
932 rn_rec_stmt_lhs fix_env (L loc (LetStmt (HsValBinds binds))) 
933     = do (_bound_names, binds') <- rnValBindsLHS fix_env binds
934          return [(L loc (LetStmt (HsValBinds binds')),
935                  -- Warning: this is bogus; see function invariant
936                  emptyFVs
937                  )]
938
939 -- XXX Do we need to do something with the return and mfix names?
940 rn_rec_stmt_lhs fix_env (L _ (RecStmt { recS_stmts = stmts }))  -- Flatten Rec inside Rec
941     = rn_rec_stmts_lhs fix_env stmts
942
943 rn_rec_stmt_lhs _ stmt@(L _ (ParStmt _))        -- Syntactically illegal in mdo
944   = pprPanic "rn_rec_stmt" (ppr stmt)
945   
946 rn_rec_stmt_lhs _ stmt@(L _ (TransformStmt {})) -- Syntactically illegal in mdo
947   = pprPanic "rn_rec_stmt" (ppr stmt)
948   
949 rn_rec_stmt_lhs _ stmt@(L _ (GroupStmt {}))     -- Syntactically illegal in mdo
950   = pprPanic "rn_rec_stmt" (ppr stmt)
951
952 rn_rec_stmt_lhs _ (L _ (LetStmt EmptyLocalBinds))
953   = panic "rn_rec_stmt LetStmt EmptyLocalBinds"
954
955 rn_rec_stmts_lhs :: MiniFixityEnv
956                  -> [LStmt RdrName] 
957                  -> RnM [(LStmtLR Name RdrName, FreeVars)]
958 rn_rec_stmts_lhs fix_env stmts
959   = do { ls <- concatMapM (rn_rec_stmt_lhs fix_env) stmts
960        ; let boundNames = collectLStmtsBinders (map fst ls)
961             -- First do error checking: we need to check for dups here because we
962             -- don't bind all of the variables from the Stmt at once
963             -- with bindLocatedLocals.
964        ; checkDupNames boundNames
965        ; return ls }
966
967
968 -- right-hand-sides
969
970 rn_rec_stmt :: [Name] -> LStmtLR Name RdrName -> FreeVars -> RnM [Segment (LStmt Name)]
971         -- Rename a Stmt that is inside a RecStmt (or mdo)
972         -- Assumes all binders are already in scope
973         -- Turns each stmt into a singleton Stmt
974 rn_rec_stmt _ (L loc (ExprStmt expr _ _)) _
975   = rnLExpr expr `thenM` \ (expr', fvs) ->
976     lookupSyntaxName thenMName  `thenM` \ (then_op, fvs1) ->
977     return [(emptyNameSet, fvs `plusFV` fvs1, emptyNameSet,
978               L loc (ExprStmt expr' then_op placeHolderType))]
979
980 rn_rec_stmt _ (L loc (BindStmt pat' expr _ _)) fv_pat
981   = rnLExpr expr                `thenM` \ (expr', fv_expr) ->
982     lookupSyntaxName bindMName  `thenM` \ (bind_op, fvs1) ->
983     lookupSyntaxName failMName  `thenM` \ (fail_op, fvs2) ->
984     let
985         bndrs = mkNameSet (collectPatBinders pat')
986         fvs   = fv_expr `plusFV` fv_pat `plusFV` fvs1 `plusFV` fvs2
987     in
988     return [(bndrs, fvs, bndrs `intersectNameSet` fvs,
989               L loc (BindStmt pat' expr' bind_op fail_op))]
990
991 rn_rec_stmt _ (L _ (LetStmt binds@(HsIPBinds _))) _
992   = failWith (badIpBinds (ptext (sLit "an mdo expression")) binds)
993
994 rn_rec_stmt all_bndrs (L loc (LetStmt (HsValBinds binds'))) _ = do 
995   (binds', du_binds) <- 
996       -- fixities and unused are handled above in rn_rec_stmts_and_then
997       rnValBindsRHS (mkNameSet all_bndrs) binds'
998   return [(duDefs du_binds, allUses du_binds, 
999            emptyNameSet, L loc (LetStmt (HsValBinds binds')))]
1000
1001 -- no RecStmt case becuase they get flattened above when doing the LHSes
1002 rn_rec_stmt _ stmt@(L _ (RecStmt {})) _
1003   = pprPanic "rn_rec_stmt: RecStmt" (ppr stmt)
1004
1005 rn_rec_stmt _ stmt@(L _ (ParStmt {})) _ -- Syntactically illegal in mdo
1006   = pprPanic "rn_rec_stmt: ParStmt" (ppr stmt)
1007
1008 rn_rec_stmt _ stmt@(L _ (TransformStmt {})) _   -- Syntactically illegal in mdo
1009   = pprPanic "rn_rec_stmt: TransformStmt" (ppr stmt)
1010
1011 rn_rec_stmt _ stmt@(L _ (GroupStmt {})) _       -- Syntactically illegal in mdo
1012   = pprPanic "rn_rec_stmt: GroupStmt" (ppr stmt)
1013
1014 rn_rec_stmt _ (L _ (LetStmt EmptyLocalBinds)) _
1015   = panic "rn_rec_stmt: LetStmt EmptyLocalBinds"
1016
1017 rn_rec_stmts :: [Name] -> [(LStmtLR Name RdrName, FreeVars)] -> RnM [Segment (LStmt Name)]
1018 rn_rec_stmts bndrs stmts = mapM (uncurry (rn_rec_stmt bndrs)) stmts     `thenM` \ segs_s ->
1019                            return (concat segs_s)
1020
1021 ---------------------------------------------
1022 addFwdRefs :: [Segment a] -> [Segment a]
1023 -- So far the segments only have forward refs *within* the Stmt
1024 --      (which happens for bind:  x <- ...x...)
1025 -- This function adds the cross-seg fwd ref info
1026
1027 addFwdRefs pairs 
1028   = fst (foldr mk_seg ([], emptyNameSet) pairs)
1029   where
1030     mk_seg (defs, uses, fwds, stmts) (segs, later_defs)
1031         = (new_seg : segs, all_defs)
1032         where
1033           new_seg = (defs, uses, new_fwds, stmts)
1034           all_defs = later_defs `unionNameSets` defs
1035           new_fwds = fwds `unionNameSets` (uses `intersectNameSet` later_defs)
1036                 -- Add the downstream fwd refs here
1037
1038 ----------------------------------------------------
1039 --      Glomming the singleton segments of an mdo into 
1040 --      minimal recursive groups.
1041 --
1042 -- At first I thought this was just strongly connected components, but
1043 -- there's an important constraint: the order of the stmts must not change.
1044 --
1045 -- Consider
1046 --      mdo { x <- ...y...
1047 --            p <- z
1048 --            y <- ...x...
1049 --            q <- x
1050 --            z <- y
1051 --            r <- x }
1052 --
1053 -- Here, the first stmt mention 'y', which is bound in the third.  
1054 -- But that means that the innocent second stmt (p <- z) gets caught
1055 -- up in the recursion.  And that in turn means that the binding for
1056 -- 'z' has to be included... and so on.
1057 --
1058 -- Start at the tail { r <- x }
1059 -- Now add the next one { z <- y ; r <- x }
1060 -- Now add one more     { q <- x ; z <- y ; r <- x }
1061 -- Now one more... but this time we have to group a bunch into rec
1062 --      { rec { y <- ...x... ; q <- x ; z <- y } ; r <- x }
1063 -- Now one more, which we can add on without a rec
1064 --      { p <- z ; 
1065 --        rec { y <- ...x... ; q <- x ; z <- y } ; 
1066 --        r <- x }
1067 -- Finally we add the last one; since it mentions y we have to
1068 -- glom it togeher with the first two groups
1069 --      { rec { x <- ...y...; p <- z ; y <- ...x... ; 
1070 --              q <- x ; z <- y } ; 
1071 --        r <- x }
1072
1073 glomSegments :: [Segment (LStmt Name)] -> [Segment [LStmt Name]]
1074
1075 glomSegments [] = []
1076 glomSegments ((defs,uses,fwds,stmt) : segs)
1077         -- Actually stmts will always be a singleton
1078   = (seg_defs, seg_uses, seg_fwds, seg_stmts)  : others
1079   where
1080     segs'            = glomSegments segs
1081     (extras, others) = grab uses segs'
1082     (ds, us, fs, ss) = unzip4 extras
1083     
1084     seg_defs  = plusFVs ds `plusFV` defs
1085     seg_uses  = plusFVs us `plusFV` uses
1086     seg_fwds  = plusFVs fs `plusFV` fwds
1087     seg_stmts = stmt : concat ss
1088
1089     grab :: NameSet             -- The client
1090          -> [Segment a]
1091          -> ([Segment a],       -- Needed by the 'client'
1092              [Segment a])       -- Not needed by the client
1093         -- The result is simply a split of the input
1094     grab uses dus 
1095         = (reverse yeses, reverse noes)
1096         where
1097           (noes, yeses)           = span not_needed (reverse dus)
1098           not_needed (defs,_,_,_) = not (intersectsNameSet defs uses)
1099
1100
1101 ----------------------------------------------------
1102 segsToStmts :: Stmt Name                -- A RecStmt with the SyntaxOps filled in
1103             -> [Segment [LStmt Name]] 
1104             -> FreeVars                 -- Free vars used 'later'
1105             -> ([LStmt Name], FreeVars)
1106
1107 segsToStmts _ [] fvs_later = ([], fvs_later)
1108 segsToStmts empty_rec_stmt ((defs, uses, fwds, ss) : segs) fvs_later
1109   = ASSERT( not (null ss) )
1110     (new_stmt : later_stmts, later_uses `plusFV` uses)
1111   where
1112     (later_stmts, later_uses) = segsToStmts empty_rec_stmt segs fvs_later
1113     new_stmt | non_rec   = head ss
1114              | otherwise = L (getLoc (head ss)) rec_stmt 
1115     rec_stmt = empty_rec_stmt { recS_stmts     = ss
1116                               , recS_later_ids = nameSetToList used_later
1117                               , recS_rec_ids   = nameSetToList fwds }
1118     non_rec    = isSingleton ss && isEmptyNameSet fwds
1119     used_later = defs `intersectNameSet` later_uses
1120                                 -- The ones needed after the RecStmt
1121 \end{code}
1122
1123 %************************************************************************
1124 %*                                                                      *
1125 \subsubsection{Assertion utils}
1126 %*                                                                      *
1127 %************************************************************************
1128
1129 \begin{code}
1130 srcSpanPrimLit :: SrcSpan -> HsExpr Name
1131 srcSpanPrimLit span = HsLit (HsStringPrim (mkFastString (showSDocOneLine (ppr span))))
1132
1133 mkAssertErrorExpr :: RnM (HsExpr Name)
1134 -- Return an expression for (assertError "Foo.hs:27")
1135 mkAssertErrorExpr
1136   = getSrcSpanM                         `thenM` \ sloc ->
1137     return (HsApp (L sloc (HsVar assertErrorName)) 
1138                   (L sloc (srcSpanPrimLit sloc)))
1139 \end{code}
1140
1141 Note [Adding the implicit parameter to 'assert']
1142 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1143 The renamer transforms (assert e1 e2) to (assert "Foo.hs:27" e1 e2).
1144 By doing this in the renamer we allow the typechecker to just see the
1145 expanded application and do the right thing. But it's not really 
1146 the Right Thing because there's no way to "undo" if you want to see
1147 the original source code.  We'll have fix this in due course, when
1148 we care more about being able to reconstruct the exact original 
1149 program.
1150
1151 %************************************************************************
1152 %*                                                                      *
1153 \subsubsection{Errors}
1154 %*                                                                      *
1155 %************************************************************************
1156
1157 \begin{code}
1158
1159 ---------------------- 
1160 -- Checking when a particular Stmt is ok
1161 checkLetStmt :: HsStmtContext Name -> HsLocalBinds RdrName -> RnM ()
1162 checkLetStmt (ParStmtCtxt _) (HsIPBinds binds) = addErr (badIpBinds (ptext (sLit "a parallel list comprehension:")) binds)
1163 checkLetStmt _ctxt           _binds            = return ()
1164         -- We do not allow implicit-parameter bindings in a parallel
1165         -- list comprehension.  I'm not sure what it might mean.
1166
1167 ---------
1168 checkRecStmt :: HsStmtContext Name -> RnM ()
1169 checkRecStmt (MDoExpr {}) = return ()   -- Recursive stmt ok in 'mdo'
1170 checkRecStmt (DoExpr {})  = return ()   -- and in 'do'
1171 checkRecStmt ctxt         = addErr msg
1172   where
1173     msg = ptext (sLit "Illegal 'rec' stmt in") <+> pprStmtContext ctxt
1174
1175 ---------
1176 checkParStmt :: HsStmtContext Name -> RnM ()
1177 checkParStmt _
1178   = do  { parallel_list_comp <- xoptM Opt_ParallelListComp
1179         ; checkErr parallel_list_comp msg }
1180   where
1181     msg = ptext (sLit "Illegal parallel list comprehension: use -XParallelListComp")
1182
1183 ---------
1184 checkTransformStmt :: HsStmtContext Name -> RnM ()
1185 checkTransformStmt ListComp  -- Ensure we are really within a list comprehension because otherwise the
1186                              -- desugarer will break when we come to operate on a parallel array
1187   = do  { transform_list_comp <- xoptM Opt_TransformListComp
1188         ; checkErr transform_list_comp msg }
1189   where
1190     msg = ptext (sLit "Illegal transform or grouping list comprehension: use -XTransformListComp")
1191 checkTransformStmt (ParStmtCtxt       ctxt) = checkTransformStmt ctxt   -- Ok to nest inside a parallel comprehension
1192 checkTransformStmt (TransformStmtCtxt ctxt) = checkTransformStmt ctxt   -- Ok to nest inside a parallel comprehension
1193 checkTransformStmt ctxt = addErr msg
1194   where
1195     msg = ptext (sLit "Illegal transform or grouping in") <+> pprStmtContext ctxt
1196
1197 ---------
1198 checkTupleSection :: [HsTupArg RdrName] -> RnM ()
1199 checkTupleSection args
1200   = do  { tuple_section <- xoptM Opt_TupleSections
1201         ; checkErr (all tupArgPresent args || tuple_section) msg }
1202   where
1203     msg = ptext (sLit "Illegal tuple section: use -XTupleSections")
1204
1205 ---------
1206 sectionErr :: HsExpr RdrName -> SDoc
1207 sectionErr expr
1208   = hang (ptext (sLit "A section must be enclosed in parentheses"))
1209        2 (ptext (sLit "thus:") <+> (parens (ppr expr)))
1210
1211 patSynErr :: HsExpr RdrName -> RnM (HsExpr Name, FreeVars)
1212 patSynErr e = do { addErr (sep [ptext (sLit "Pattern syntax in expression context:"),
1213                                 nest 4 (ppr e)])
1214                  ; return (EWildPat, emptyFVs) }
1215
1216 badIpBinds :: Outputable a => SDoc -> a -> SDoc
1217 badIpBinds what binds
1218   = hang (ptext (sLit "Implicit-parameter bindings illegal in") <+> what)
1219          2 (ppr binds)
1220 \end{code}