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