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