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