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