ade117cf69cbadda94c24cff467dd9221343fb1b
[ghc.git] / compiler / rename / RnExpr.hs
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
13 {-# LANGUAGE CPP, ScopedTypeVariables, RecordWildCards #-}
14
15 module RnExpr (
16 rnLExpr, rnExpr, rnStmts
17 ) where
18
19 #include "HsVersions.h"
20
21 import RnBinds ( rnLocalBindsAndThen, rnLocalValBindsLHS, rnLocalValBindsRHS,
22 rnMatchGroup, rnGRHS, makeMiniFixityEnv)
23 import HsSyn
24 import TcRnMonad
25 import Module ( getModule )
26 import RnEnv
27 import RnSplice ( rnBracket, rnSpliceExpr, checkThLocalName )
28 import RnTypes
29 import RnPat
30 import DynFlags
31 import PrelNames
32
33 import BasicTypes
34 import Name
35 import NameSet
36 import RdrName
37 import UniqSet
38 import Data.List
39 import Util
40 import ListSetOps ( removeDups )
41 import ErrUtils
42 import Outputable
43 import SrcLoc
44 import FastString
45 import Control.Monad
46 import TysWiredIn ( nilDataConName )
47
48 {-
49 ************************************************************************
50 * *
51 \subsubsection{Expressions}
52 * *
53 ************************************************************************
54 -}
55
56 rnExprs :: [LHsExpr RdrName] -> RnM ([LHsExpr Name], FreeVars)
57 rnExprs ls = rnExprs' ls emptyUniqSet
58 where
59 rnExprs' [] acc = return ([], acc)
60 rnExprs' (expr:exprs) acc =
61 do { (expr', fvExpr) <- rnLExpr expr
62 -- Now we do a "seq" on the free vars because typically it's small
63 -- or empty, especially in very long lists of constants
64 ; let acc' = acc `plusFV` fvExpr
65 ; (exprs', fvExprs) <- acc' `seq` rnExprs' exprs acc'
66 ; return (expr':exprs', fvExprs) }
67
68 -- Variables. We look up the variable and return the resulting name.
69
70 rnLExpr :: LHsExpr RdrName -> RnM (LHsExpr Name, FreeVars)
71 rnLExpr = wrapLocFstM rnExpr
72
73 rnExpr :: HsExpr RdrName -> RnM (HsExpr Name, FreeVars)
74
75 finishHsVar :: Name -> RnM (HsExpr Name, FreeVars)
76 -- Separated from rnExpr because it's also used
77 -- when renaming infix expressions
78 finishHsVar name
79 = do { this_mod <- getModule
80 ; when (nameIsLocalOrFrom this_mod name) $
81 checkThLocalName name
82 ; return (HsVar name, unitFV name) }
83
84 rnUnboundVar :: RdrName -> RnM (HsExpr Name, FreeVars)
85 rnUnboundVar v
86 = do { stage <- getStage
87 ; if isUnqual v && not (in_untyped_bracket stage)
88 then -- Treat this as a "hole"
89 -- Do not fail right now; instead, return HsUnboundVar
90 -- and let the type checker report the error
91 return (HsUnboundVar (rdrNameOcc v), emptyFVs)
92
93 else -- Fail immediately (qualified name, or in untyped bracket)
94 do { n <- reportUnboundName v
95 ; return (HsVar n, emptyFVs) } }
96 where
97 in_untyped_bracket (Brack _ (RnPendingUntyped {})) = True
98 in_untyped_bracket _ = False
99
100 rnExpr (HsVar v)
101 = do { mb_name <- lookupOccRn_overloaded False v
102 ; case mb_name of {
103 Nothing -> rnUnboundVar v ;
104 Just (Left name)
105 | name == nilDataConName -- Treat [] as an ExplicitList, so that
106 -- OverloadedLists works correctly
107 -> rnExpr (ExplicitList placeHolderType Nothing [])
108
109 | otherwise
110 -> finishHsVar name ;
111 Just (Right (f:fs)) -> ASSERT( null fs )
112 return (HsSingleRecFld f, unitFV (selectorFieldOcc f)) ;
113 Just (Right []) -> error "runExpr/HsVar" } }
114
115 rnExpr (HsIPVar v)
116 = return (HsIPVar v, emptyFVs)
117
118 rnExpr (HsLit lit@(HsString src s))
119 = do { opt_OverloadedStrings <- xoptM Opt_OverloadedStrings
120 ; if opt_OverloadedStrings then
121 rnExpr (HsOverLit (mkHsIsString src s placeHolderType))
122 else do {
123 ; rnLit lit
124 ; return (HsLit lit, emptyFVs) } }
125
126 rnExpr (HsLit lit)
127 = do { rnLit lit
128 ; return (HsLit lit, emptyFVs) }
129
130 rnExpr (HsOverLit lit)
131 = do { (lit', fvs) <- rnOverLit lit
132 ; return (HsOverLit lit', fvs) }
133
134 rnExpr (HsApp fun arg)
135 = do { (fun',fvFun) <- rnLExpr fun
136 ; (arg',fvArg) <- rnLExpr arg
137 ; return (HsApp fun' arg', fvFun `plusFV` fvArg) }
138
139 rnExpr (OpApp e1 op _ e2)
140 = do { (e1', fv_e1) <- rnLExpr e1
141 ; (e2', fv_e2) <- rnLExpr e2
142 ; (op', fv_op) <- rnLExpr op
143
144 -- Deal with fixity
145 -- When renaming code synthesised from "deriving" declarations
146 -- we used to avoid fixity stuff, but we can't easily tell any
147 -- more, so I've removed the test. Adding HsPars in TcGenDeriv
148 -- should prevent bad things happening.
149 ; fixity <- case op' of
150 L _ (HsVar n) -> lookupFixityRn n
151 _ -> return (Fixity minPrecedence InfixL)
152 -- c.f. lookupFixity for unbound
153
154 ; final_e <- mkOpAppRn e1' op' fixity e2'
155 ; return (final_e, fv_e1 `plusFV` fv_op `plusFV` fv_e2) }
156
157 rnExpr (NegApp e _)
158 = do { (e', fv_e) <- rnLExpr e
159 ; (neg_name, fv_neg) <- lookupSyntaxName negateName
160 ; final_e <- mkNegAppRn e' neg_name
161 ; return (final_e, fv_e `plusFV` fv_neg) }
162
163 ------------------------------------------
164 -- Template Haskell extensions
165 -- Don't ifdef-GHCI them because we want to fail gracefully
166 -- (not with an rnExpr crash) in a stage-1 compiler.
167 rnExpr e@(HsBracket br_body) = rnBracket e br_body
168
169 rnExpr (HsSpliceE splice) = rnSpliceExpr splice
170
171 ---------------------------------------------
172 -- Sections
173 -- See Note [Parsing sections] in Parser.y
174 rnExpr (HsPar (L loc (section@(SectionL {}))))
175 = do { (section', fvs) <- rnSection section
176 ; return (HsPar (L loc section'), fvs) }
177
178 rnExpr (HsPar (L loc (section@(SectionR {}))))
179 = do { (section', fvs) <- rnSection section
180 ; return (HsPar (L loc section'), fvs) }
181
182 rnExpr (HsPar e)
183 = do { (e', fvs_e) <- rnLExpr e
184 ; return (HsPar e', fvs_e) }
185
186 rnExpr expr@(SectionL {})
187 = do { addErr (sectionErr expr); rnSection expr }
188 rnExpr expr@(SectionR {})
189 = do { addErr (sectionErr expr); rnSection expr }
190
191 ---------------------------------------------
192 rnExpr (HsCoreAnn src ann expr)
193 = do { (expr', fvs_expr) <- rnLExpr expr
194 ; return (HsCoreAnn src ann expr', fvs_expr) }
195
196 rnExpr (HsSCC src lbl expr)
197 = do { (expr', fvs_expr) <- rnLExpr expr
198 ; return (HsSCC src lbl expr', fvs_expr) }
199 rnExpr (HsTickPragma src info expr)
200 = do { (expr', fvs_expr) <- rnLExpr expr
201 ; return (HsTickPragma src info expr', fvs_expr) }
202
203 rnExpr (HsLam matches)
204 = do { (matches', fvMatch) <- rnMatchGroup LambdaExpr rnLExpr matches
205 ; return (HsLam matches', fvMatch) }
206
207 rnExpr (HsLamCase _arg matches)
208 = do { (matches', fvs_ms) <- rnMatchGroup CaseAlt rnLExpr matches
209 -- ; return (HsLamCase arg matches', fvs_ms) }
210 ; return (HsLamCase placeHolderType matches', fvs_ms) }
211
212 rnExpr (HsCase expr matches)
213 = do { (new_expr, e_fvs) <- rnLExpr expr
214 ; (new_matches, ms_fvs) <- rnMatchGroup CaseAlt rnLExpr matches
215 ; return (HsCase new_expr new_matches, e_fvs `plusFV` ms_fvs) }
216
217 rnExpr (HsLet binds expr)
218 = rnLocalBindsAndThen binds $ \binds' _ -> do
219 { (expr',fvExpr) <- rnLExpr expr
220 ; return (HsLet binds' expr', fvExpr) }
221
222 rnExpr (HsDo do_or_lc stmts _)
223 = do { ((stmts', _), fvs) <-
224 rnStmtsWithPostProcessing do_or_lc rnLExpr
225 postProcessStmtsForApplicativeDo stmts
226 (\ _ -> return ((), emptyFVs))
227 ; return ( HsDo do_or_lc stmts' placeHolderType, fvs ) }
228
229 rnExpr (ExplicitList _ _ exps)
230 = do { opt_OverloadedLists <- xoptM Opt_OverloadedLists
231 ; (exps', fvs) <- rnExprs exps
232 ; if opt_OverloadedLists
233 then do {
234 ; (from_list_n_name, fvs') <- lookupSyntaxName fromListNName
235 ; return (ExplicitList placeHolderType (Just from_list_n_name) exps'
236 , fvs `plusFV` fvs') }
237 else
238 return (ExplicitList placeHolderType Nothing exps', fvs) }
239
240 rnExpr (ExplicitPArr _ exps)
241 = do { (exps', fvs) <- rnExprs exps
242 ; return (ExplicitPArr placeHolderType exps', fvs) }
243
244 rnExpr (ExplicitTuple tup_args boxity)
245 = do { checkTupleSection tup_args
246 ; checkTupSize (length tup_args)
247 ; (tup_args', fvs) <- mapAndUnzipM rnTupArg tup_args
248 ; return (ExplicitTuple tup_args' boxity, plusFVs fvs) }
249 where
250 rnTupArg (L l (Present e)) = do { (e',fvs) <- rnLExpr e
251 ; return (L l (Present e'), fvs) }
252 rnTupArg (L l (Missing _)) = return (L l (Missing placeHolderType)
253 , emptyFVs)
254
255 rnExpr (RecordCon con_id _ rbinds)
256 = do { conname <- lookupLocatedOccRn con_id
257 ; (rbinds', fvRbinds) <- rnHsRecBinds (HsRecFieldCon (unLoc conname)) rbinds
258 ; return (RecordCon conname noPostTcExpr rbinds',
259 fvRbinds `addOneFV` unLoc conname) }
260
261 rnExpr (RecordUpd expr rbinds _ _ _)
262 = do { (expr', fvExpr) <- rnLExpr expr
263 ; (rbinds', fvRbinds) <- rnHsRecUpdFields rbinds
264 ; return (RecordUpd expr' rbinds' PlaceHolder PlaceHolder PlaceHolder,
265 fvExpr `plusFV` fvRbinds) }
266
267 rnExpr (ExprWithTySig expr pty PlaceHolder)
268 = do { (pty', fvTy, wcs) <- rnLHsTypeWithWildCards ExprWithTySigCtx pty
269 ; (expr', fvExpr) <- bindSigTyVarsFV (hsExplicitTvs pty') $
270 rnLExpr expr
271 ; return (ExprWithTySig expr' pty' wcs, fvExpr `plusFV` fvTy) }
272
273 rnExpr (HsIf _ p b1 b2)
274 = do { (p', fvP) <- rnLExpr p
275 ; (b1', fvB1) <- rnLExpr b1
276 ; (b2', fvB2) <- rnLExpr b2
277 ; (mb_ite, fvITE) <- lookupIfThenElse
278 ; return (HsIf mb_ite p' b1' b2', plusFVs [fvITE, fvP, fvB1, fvB2]) }
279
280 rnExpr (HsMultiIf _ty alts)
281 = do { (alts', fvs) <- mapFvRn (rnGRHS IfAlt rnLExpr) alts
282 -- ; return (HsMultiIf ty alts', fvs) }
283 ; return (HsMultiIf placeHolderType alts', fvs) }
284
285 rnExpr (HsType a)
286 = do { (t, fvT) <- rnLHsType HsTypeCtx a
287 ; return (HsType t, fvT) }
288
289 rnExpr (ArithSeq _ _ seq)
290 = do { opt_OverloadedLists <- xoptM Opt_OverloadedLists
291 ; (new_seq, fvs) <- rnArithSeq seq
292 ; if opt_OverloadedLists
293 then do {
294 ; (from_list_name, fvs') <- lookupSyntaxName fromListName
295 ; return (ArithSeq noPostTcExpr (Just from_list_name) new_seq, fvs `plusFV` fvs') }
296 else
297 return (ArithSeq noPostTcExpr Nothing new_seq, fvs) }
298
299 rnExpr (PArrSeq _ seq)
300 = do { (new_seq, fvs) <- rnArithSeq seq
301 ; return (PArrSeq noPostTcExpr new_seq, fvs) }
302
303 {-
304 These three are pattern syntax appearing in expressions.
305 Since all the symbols are reservedops we can simply reject them.
306 We return a (bogus) EWildPat in each case.
307 -}
308
309 rnExpr EWildPat = return (hsHoleExpr, emptyFVs) -- "_" is just a hole
310 rnExpr e@(EAsPat {}) = patSynErr e
311 rnExpr e@(EViewPat {}) = patSynErr e
312 rnExpr e@(ELazyPat {}) = patSynErr e
313
314 {-
315 ************************************************************************
316 * *
317 Static values
318 * *
319 ************************************************************************
320
321 For the static form we check that the free variables are all top-level
322 value bindings. This is done by checking that the name is external or
323 wired-in. See the Notes about the NameSorts in Name.hs.
324 -}
325
326 rnExpr e@(HsStatic expr) = do
327 target <- fmap hscTarget getDynFlags
328 case target of
329 -- SPT entries are expected to exist in object code so far, and this is
330 -- not the case in interpreted mode. See bug #9878.
331 HscInterpreted -> addErr $ sep
332 [ text "The static form is not supported in interpreted mode."
333 , text "Please use -fobject-code."
334 ]
335 _ -> return ()
336 (expr',fvExpr) <- rnLExpr expr
337 stage <- getStage
338 case stage of
339 Brack _ _ -> return () -- Don't check names if we are inside brackets.
340 -- We don't want to reject cases like:
341 -- \e -> [| static $(e) |]
342 -- if $(e) turns out to produce a legal expression.
343 Splice _ -> addErr $ sep
344 [ text "static forms cannot be used in splices:"
345 , nest 2 $ ppr e
346 ]
347 _ -> do
348 let isTopLevelName n = isExternalName n || isWiredInName n
349 case nameSetElems $ filterNameSet
350 (\n -> not (isTopLevelName n || isUnboundName n))
351 fvExpr of
352 [] -> return ()
353 fvNonGlobal -> addErr $ cat
354 [ text $ "Only identifiers of top-level bindings can "
355 ++ "appear in the body of the static form:"
356 , nest 2 $ ppr e
357 , text "but the following identifiers were found instead:"
358 , nest 2 $ vcat $ map ppr fvNonGlobal
359 ]
360 return (HsStatic expr', fvExpr)
361
362 {-
363 ************************************************************************
364 * *
365 Arrow notation
366 * *
367 ************************************************************************
368 -}
369
370 rnExpr (HsProc pat body)
371 = newArrowScope $
372 rnPat ProcExpr pat $ \ pat' -> do
373 { (body',fvBody) <- rnCmdTop body
374 ; return (HsProc pat' body', fvBody) }
375
376 -- Ideally, these would be done in parsing, but to keep parsing simple, we do it here.
377 rnExpr e@(HsArrApp {}) = arrowFail e
378 rnExpr e@(HsArrForm {}) = arrowFail e
379
380 rnExpr other = pprPanic "rnExpr: unexpected expression" (ppr other)
381 -- HsWrap
382
383 hsHoleExpr :: HsExpr id
384 hsHoleExpr = HsUnboundVar (mkVarOcc "_")
385
386 arrowFail :: HsExpr RdrName -> RnM (HsExpr Name, FreeVars)
387 arrowFail e
388 = do { addErr (vcat [ ptext (sLit "Arrow command found where an expression was expected:")
389 , nest 2 (ppr e) ])
390 -- Return a place-holder hole, so that we can carry on
391 -- to report other errors
392 ; return (hsHoleExpr, emptyFVs) }
393
394 ----------------------
395 -- See Note [Parsing sections] in Parser.y
396 rnSection :: HsExpr RdrName -> RnM (HsExpr Name, FreeVars)
397 rnSection section@(SectionR op expr)
398 = do { (op', fvs_op) <- rnLExpr op
399 ; (expr', fvs_expr) <- rnLExpr expr
400 ; checkSectionPrec InfixR section op' expr'
401 ; return (SectionR op' expr', fvs_op `plusFV` fvs_expr) }
402
403 rnSection section@(SectionL expr op)
404 = do { (expr', fvs_expr) <- rnLExpr expr
405 ; (op', fvs_op) <- rnLExpr op
406 ; checkSectionPrec InfixL section op' expr'
407 ; return (SectionL expr' op', fvs_op `plusFV` fvs_expr) }
408
409 rnSection other = pprPanic "rnSection" (ppr other)
410
411 {-
412 ************************************************************************
413 * *
414 Records
415 * *
416 ************************************************************************
417 -}
418
419 rnHsRecBinds :: HsRecFieldContext -> HsRecordBinds RdrName
420 -> RnM (HsRecordBinds Name, FreeVars)
421 rnHsRecBinds ctxt rec_binds@(HsRecFields { rec_dotdot = dd })
422 = do { (flds, fvs) <- rnHsRecFields ctxt HsVar rec_binds
423 ; (flds', fvss) <- mapAndUnzipM rn_field flds
424 ; return (HsRecFields { rec_flds = flds', rec_dotdot = dd },
425 fvs `plusFV` plusFVs fvss) }
426 where
427 rn_field (L l fld) = do { (arg', fvs) <- rnLExpr (hsRecFieldArg fld)
428 ; return (L l (fld { hsRecFieldArg = arg' }), fvs) }
429
430 {-
431 ************************************************************************
432 * *
433 Arrow commands
434 * *
435 ************************************************************************
436 -}
437
438 rnCmdArgs :: [LHsCmdTop RdrName] -> RnM ([LHsCmdTop Name], FreeVars)
439 rnCmdArgs [] = return ([], emptyFVs)
440 rnCmdArgs (arg:args)
441 = do { (arg',fvArg) <- rnCmdTop arg
442 ; (args',fvArgs) <- rnCmdArgs args
443 ; return (arg':args', fvArg `plusFV` fvArgs) }
444
445 rnCmdTop :: LHsCmdTop RdrName -> RnM (LHsCmdTop Name, FreeVars)
446 rnCmdTop = wrapLocFstM rnCmdTop'
447 where
448 rnCmdTop' (HsCmdTop cmd _ _ _)
449 = do { (cmd', fvCmd) <- rnLCmd cmd
450 ; let cmd_names = [arrAName, composeAName, firstAName] ++
451 nameSetElems (methodNamesCmd (unLoc cmd'))
452 -- Generate the rebindable syntax for the monad
453 ; (cmd_names', cmd_fvs) <- lookupSyntaxNames cmd_names
454
455 ; return (HsCmdTop cmd' placeHolderType placeHolderType
456 (cmd_names `zip` cmd_names'),
457 fvCmd `plusFV` cmd_fvs) }
458
459 rnLCmd :: LHsCmd RdrName -> RnM (LHsCmd Name, FreeVars)
460 rnLCmd = wrapLocFstM rnCmd
461
462 rnCmd :: HsCmd RdrName -> RnM (HsCmd Name, FreeVars)
463
464 rnCmd (HsCmdArrApp arrow arg _ ho rtl)
465 = do { (arrow',fvArrow) <- select_arrow_scope (rnLExpr arrow)
466 ; (arg',fvArg) <- rnLExpr arg
467 ; return (HsCmdArrApp arrow' arg' placeHolderType ho rtl,
468 fvArrow `plusFV` fvArg) }
469 where
470 select_arrow_scope tc = case ho of
471 HsHigherOrderApp -> tc
472 HsFirstOrderApp -> escapeArrowScope tc
473 -- See Note [Escaping the arrow scope] in TcRnTypes
474 -- Before renaming 'arrow', use the environment of the enclosing
475 -- proc for the (-<) case.
476 -- Local bindings, inside the enclosing proc, are not in scope
477 -- inside 'arrow'. In the higher-order case (-<<), they are.
478
479 -- infix form
480 rnCmd (HsCmdArrForm op (Just _) [arg1, arg2])
481 = do { (op',fv_op) <- escapeArrowScope (rnLExpr op)
482 ; let L _ (HsVar op_name) = op'
483 ; (arg1',fv_arg1) <- rnCmdTop arg1
484 ; (arg2',fv_arg2) <- rnCmdTop arg2
485 -- Deal with fixity
486 ; fixity <- lookupFixityRn op_name
487 ; final_e <- mkOpFormRn arg1' op' fixity arg2'
488 ; return (final_e, fv_arg1 `plusFV` fv_op `plusFV` fv_arg2) }
489
490 rnCmd (HsCmdArrForm op fixity cmds)
491 = do { (op',fvOp) <- escapeArrowScope (rnLExpr op)
492 ; (cmds',fvCmds) <- rnCmdArgs cmds
493 ; return (HsCmdArrForm op' fixity cmds', fvOp `plusFV` fvCmds) }
494
495 rnCmd (HsCmdApp fun arg)
496 = do { (fun',fvFun) <- rnLCmd fun
497 ; (arg',fvArg) <- rnLExpr arg
498 ; return (HsCmdApp fun' arg', fvFun `plusFV` fvArg) }
499
500 rnCmd (HsCmdLam matches)
501 = do { (matches', fvMatch) <- rnMatchGroup LambdaExpr rnLCmd matches
502 ; return (HsCmdLam matches', fvMatch) }
503
504 rnCmd (HsCmdPar e)
505 = do { (e', fvs_e) <- rnLCmd e
506 ; return (HsCmdPar e', fvs_e) }
507
508 rnCmd (HsCmdCase expr matches)
509 = do { (new_expr, e_fvs) <- rnLExpr expr
510 ; (new_matches, ms_fvs) <- rnMatchGroup CaseAlt rnLCmd matches
511 ; return (HsCmdCase new_expr new_matches, e_fvs `plusFV` ms_fvs) }
512
513 rnCmd (HsCmdIf _ p b1 b2)
514 = do { (p', fvP) <- rnLExpr p
515 ; (b1', fvB1) <- rnLCmd b1
516 ; (b2', fvB2) <- rnLCmd b2
517 ; (mb_ite, fvITE) <- lookupIfThenElse
518 ; return (HsCmdIf mb_ite p' b1' b2', plusFVs [fvITE, fvP, fvB1, fvB2]) }
519
520 rnCmd (HsCmdLet binds cmd)
521 = rnLocalBindsAndThen binds $ \ binds' _ -> do
522 { (cmd',fvExpr) <- rnLCmd cmd
523 ; return (HsCmdLet binds' cmd', fvExpr) }
524
525 rnCmd (HsCmdDo stmts _)
526 = do { ((stmts', _), fvs) <-
527 rnStmts ArrowExpr rnLCmd stmts (\ _ -> return ((), emptyFVs))
528 ; return ( HsCmdDo stmts' placeHolderType, fvs ) }
529
530 rnCmd cmd@(HsCmdCast {}) = pprPanic "rnCmd" (ppr cmd)
531
532 ---------------------------------------------------
533 type CmdNeeds = FreeVars -- Only inhabitants are
534 -- appAName, choiceAName, loopAName
535
536 -- find what methods the Cmd needs (loop, choice, apply)
537 methodNamesLCmd :: LHsCmd Name -> CmdNeeds
538 methodNamesLCmd = methodNamesCmd . unLoc
539
540 methodNamesCmd :: HsCmd Name -> CmdNeeds
541
542 methodNamesCmd (HsCmdArrApp _arrow _arg _ HsFirstOrderApp _rtl)
543 = emptyFVs
544 methodNamesCmd (HsCmdArrApp _arrow _arg _ HsHigherOrderApp _rtl)
545 = unitFV appAName
546 methodNamesCmd (HsCmdArrForm {}) = emptyFVs
547 methodNamesCmd (HsCmdCast _ cmd) = methodNamesCmd cmd
548
549 methodNamesCmd (HsCmdPar c) = methodNamesLCmd c
550
551 methodNamesCmd (HsCmdIf _ _ c1 c2)
552 = methodNamesLCmd c1 `plusFV` methodNamesLCmd c2 `addOneFV` choiceAName
553
554 methodNamesCmd (HsCmdLet _ c) = methodNamesLCmd c
555 methodNamesCmd (HsCmdDo stmts _) = methodNamesStmts stmts
556 methodNamesCmd (HsCmdApp c _) = methodNamesLCmd c
557 methodNamesCmd (HsCmdLam match) = methodNamesMatch match
558
559 methodNamesCmd (HsCmdCase _ matches)
560 = methodNamesMatch matches `addOneFV` choiceAName
561
562 --methodNamesCmd _ = emptyFVs
563 -- Other forms can't occur in commands, but it's not convenient
564 -- to error here so we just do what's convenient.
565 -- The type checker will complain later
566
567 ---------------------------------------------------
568 methodNamesMatch :: MatchGroup Name (LHsCmd Name) -> FreeVars
569 methodNamesMatch (MG { mg_alts = ms })
570 = plusFVs (map do_one ms)
571 where
572 do_one (L _ (Match _ _ _ grhss)) = methodNamesGRHSs grhss
573
574 -------------------------------------------------
575 -- gaw 2004
576 methodNamesGRHSs :: GRHSs Name (LHsCmd Name) -> FreeVars
577 methodNamesGRHSs (GRHSs grhss _) = plusFVs (map methodNamesGRHS grhss)
578
579 -------------------------------------------------
580
581 methodNamesGRHS :: Located (GRHS Name (LHsCmd Name)) -> CmdNeeds
582 methodNamesGRHS (L _ (GRHS _ rhs)) = methodNamesLCmd rhs
583
584 ---------------------------------------------------
585 methodNamesStmts :: [Located (StmtLR Name Name (LHsCmd Name))] -> FreeVars
586 methodNamesStmts stmts = plusFVs (map methodNamesLStmt stmts)
587
588 ---------------------------------------------------
589 methodNamesLStmt :: Located (StmtLR Name Name (LHsCmd Name)) -> FreeVars
590 methodNamesLStmt = methodNamesStmt . unLoc
591
592 methodNamesStmt :: StmtLR Name Name (LHsCmd Name) -> FreeVars
593 methodNamesStmt (LastStmt cmd _ _) = methodNamesLCmd cmd
594 methodNamesStmt (BodyStmt cmd _ _ _) = methodNamesLCmd cmd
595 methodNamesStmt (BindStmt _ cmd _ _) = methodNamesLCmd cmd
596 methodNamesStmt (RecStmt { recS_stmts = stmts }) =
597 methodNamesStmts stmts `addOneFV` loopAName
598 methodNamesStmt (LetStmt {}) = emptyFVs
599 methodNamesStmt (ParStmt {}) = emptyFVs
600 methodNamesStmt (TransStmt {}) = emptyFVs
601 methodNamesStmt ApplicativeStmt{} = emptyFVs
602 -- ParStmt and TransStmt can't occur in commands, but it's not
603 -- convenient to error here so we just do what's convenient
604
605 {-
606 ************************************************************************
607 * *
608 Arithmetic sequences
609 * *
610 ************************************************************************
611 -}
612
613 rnArithSeq :: ArithSeqInfo RdrName -> RnM (ArithSeqInfo Name, FreeVars)
614 rnArithSeq (From expr)
615 = do { (expr', fvExpr) <- rnLExpr expr
616 ; return (From expr', fvExpr) }
617
618 rnArithSeq (FromThen expr1 expr2)
619 = do { (expr1', fvExpr1) <- rnLExpr expr1
620 ; (expr2', fvExpr2) <- rnLExpr expr2
621 ; return (FromThen expr1' expr2', fvExpr1 `plusFV` fvExpr2) }
622
623 rnArithSeq (FromTo expr1 expr2)
624 = do { (expr1', fvExpr1) <- rnLExpr expr1
625 ; (expr2', fvExpr2) <- rnLExpr expr2
626 ; return (FromTo expr1' expr2', fvExpr1 `plusFV` fvExpr2) }
627
628 rnArithSeq (FromThenTo expr1 expr2 expr3)
629 = do { (expr1', fvExpr1) <- rnLExpr expr1
630 ; (expr2', fvExpr2) <- rnLExpr expr2
631 ; (expr3', fvExpr3) <- rnLExpr expr3
632 ; return (FromThenTo expr1' expr2' expr3',
633 plusFVs [fvExpr1, fvExpr2, fvExpr3]) }
634
635 {-
636 ************************************************************************
637 * *
638 \subsubsection{@Stmt@s: in @do@ expressions}
639 * *
640 ************************************************************************
641 -}
642
643 -- | Rename some Stmts
644 rnStmts :: Outputable (body RdrName)
645 => HsStmtContext Name
646 -> (Located (body RdrName) -> RnM (Located (body Name), FreeVars))
647 -- ^ How to rename the body of each statement (e.g. rnLExpr)
648 -> [LStmt RdrName (Located (body RdrName))]
649 -- ^ Statements
650 -> ([Name] -> RnM (thing, FreeVars))
651 -- ^ if these statements scope over something, this renames it
652 -- and returns the result.
653 -> RnM (([LStmt Name (Located (body Name))], thing), FreeVars)
654 rnStmts ctxt rnBody = rnStmtsWithPostProcessing ctxt rnBody noPostProcessStmts
655
656 -- | like 'rnStmts' but applies a post-processing step to the renamed Stmts
657 rnStmtsWithPostProcessing
658 :: Outputable (body RdrName)
659 => HsStmtContext Name
660 -> (Located (body RdrName) -> RnM (Located (body Name), FreeVars))
661 -- ^ How to rename the body of each statement (e.g. rnLExpr)
662 -> (HsStmtContext Name
663 -> [(LStmt Name (Located (body Name)), FreeVars)]
664 -> RnM ([LStmt Name (Located (body Name))], FreeVars))
665 -- ^ postprocess the statements
666 -> [LStmt RdrName (Located (body RdrName))]
667 -- ^ Statements
668 -> ([Name] -> RnM (thing, FreeVars))
669 -- ^ if these statements scope over something, this renames it
670 -- and returns the result.
671 -> RnM (([LStmt Name (Located (body Name))], thing), FreeVars)
672 rnStmtsWithPostProcessing ctxt rnBody ppStmts stmts thing_inside
673 = do { ((stmts', thing), fvs) <-
674 rnStmtsWithFreeVars ctxt rnBody stmts thing_inside
675 ; (pp_stmts, fvs') <- ppStmts ctxt stmts'
676 ; return ((pp_stmts, thing), fvs `plusFV` fvs')
677 }
678
679 -- | maybe rearrange statements according to the ApplicativeDo transformation
680 postProcessStmtsForApplicativeDo
681 :: HsStmtContext Name
682 -> [(LStmt Name (LHsExpr Name), FreeVars)]
683 -> RnM ([LStmt Name (LHsExpr Name)], FreeVars)
684 postProcessStmtsForApplicativeDo ctxt stmts
685 = do {
686 -- rearrange the statements using ApplicativeStmt if
687 -- -XApplicativeDo is on. Also strip out the FreeVars attached
688 -- to each Stmt body.
689 ado_is_on <- xoptM Opt_ApplicativeDo
690 ; let is_do_expr | DoExpr <- ctxt = True
691 | otherwise = False
692 ; if ado_is_on && is_do_expr
693 then rearrangeForApplicativeDo ctxt stmts
694 else noPostProcessStmts ctxt stmts }
695
696 -- | strip the FreeVars annotations from statements
697 noPostProcessStmts
698 :: HsStmtContext Name
699 -> [(LStmt Name (Located (body Name)), FreeVars)]
700 -> RnM ([LStmt Name (Located (body Name))], FreeVars)
701 noPostProcessStmts _ stmts = return (map fst stmts, emptyNameSet)
702
703
704 rnStmtsWithFreeVars :: Outputable (body RdrName)
705 => HsStmtContext Name
706 -> (Located (body RdrName) -> RnM (Located (body Name), FreeVars))
707 -> [LStmt RdrName (Located (body RdrName))]
708 -> ([Name] -> RnM (thing, FreeVars))
709 -> RnM ( ([(LStmt Name (Located (body Name)), FreeVars)], thing)
710 , FreeVars)
711 -- Each Stmt body is annotated with its FreeVars, so that
712 -- we can rearrange statements for ApplicativeDo.
713 --
714 -- Variables bound by the Stmts, and mentioned in thing_inside,
715 -- do not appear in the result FreeVars
716
717 rnStmtsWithFreeVars ctxt _ [] thing_inside
718 = do { checkEmptyStmts ctxt
719 ; (thing, fvs) <- thing_inside []
720 ; return (([], thing), fvs) }
721
722 rnStmtsWithFreeVars MDoExpr rnBody stmts thing_inside -- Deal with mdo
723 = -- Behave like do { rec { ...all but last... }; last }
724 do { ((stmts1, (stmts2, thing)), fvs)
725 <- rnStmt MDoExpr rnBody (noLoc $ mkRecStmt all_but_last) $ \ _ ->
726 do { last_stmt' <- checkLastStmt MDoExpr last_stmt
727 ; rnStmt MDoExpr rnBody last_stmt' thing_inside }
728 ; return (((stmts1 ++ stmts2), thing), fvs) }
729 where
730 Just (all_but_last, last_stmt) = snocView stmts
731
732 rnStmtsWithFreeVars ctxt rnBody (lstmt@(L loc _) : lstmts) thing_inside
733 | null lstmts
734 = setSrcSpan loc $
735 do { lstmt' <- checkLastStmt ctxt lstmt
736 ; rnStmt ctxt rnBody lstmt' thing_inside }
737
738 | otherwise
739 = do { ((stmts1, (stmts2, thing)), fvs)
740 <- setSrcSpan loc $
741 do { checkStmt ctxt lstmt
742 ; rnStmt ctxt rnBody lstmt $ \ bndrs1 ->
743 rnStmtsWithFreeVars ctxt rnBody lstmts $ \ bndrs2 ->
744 thing_inside (bndrs1 ++ bndrs2) }
745 ; return (((stmts1 ++ stmts2), thing), fvs) }
746
747 ----------------------
748 rnStmt :: Outputable (body RdrName)
749 => HsStmtContext Name
750 -> (Located (body RdrName) -> RnM (Located (body Name), FreeVars))
751 -- ^ How to rename the body of the statement
752 -> LStmt RdrName (Located (body RdrName))
753 -- ^ The statement
754 -> ([Name] -> RnM (thing, FreeVars))
755 -- ^ Rename the stuff that this statement scopes over
756 -> RnM ( ([(LStmt Name (Located (body Name)), FreeVars)], thing)
757 , FreeVars)
758 -- Variables bound by the Stmt, and mentioned in thing_inside,
759 -- do not appear in the result FreeVars
760
761 rnStmt ctxt rnBody (L loc (LastStmt body noret _)) thing_inside
762 = do { (body', fv_expr) <- rnBody body
763 ; (ret_op, fvs1) <- lookupStmtName ctxt returnMName
764 ; (thing, fvs3) <- thing_inside []
765 ; return (([(L loc (LastStmt body' noret ret_op), fv_expr)], thing),
766 fv_expr `plusFV` fvs1 `plusFV` fvs3) }
767
768 rnStmt ctxt rnBody (L loc (BodyStmt body _ _ _)) thing_inside
769 = do { (body', fv_expr) <- rnBody body
770 ; (then_op, fvs1) <- lookupStmtName ctxt thenMName
771 ; (guard_op, fvs2) <- if isListCompExpr ctxt
772 then lookupStmtName ctxt guardMName
773 else return (noSyntaxExpr, emptyFVs)
774 -- Only list/parr/monad comprehensions use 'guard'
775 -- Also for sub-stmts of same eg [ e | x<-xs, gd | blah ]
776 -- Here "gd" is a guard
777 ; (thing, fvs3) <- thing_inside []
778 ; return (([(L loc (BodyStmt body'
779 then_op guard_op placeHolderType), fv_expr)], thing),
780 fv_expr `plusFV` fvs1 `plusFV` fvs2 `plusFV` fvs3) }
781
782 rnStmt ctxt rnBody (L loc (BindStmt pat body _ _)) thing_inside
783 = do { (body', fv_expr) <- rnBody body
784 -- The binders do not scope over the expression
785 ; (bind_op, fvs1) <- lookupStmtName ctxt bindMName
786 ; (fail_op, fvs2) <- lookupStmtName ctxt failMName
787 ; rnPat (StmtCtxt ctxt) pat $ \ pat' -> do
788 { (thing, fvs3) <- thing_inside (collectPatBinders pat')
789 ; return (( [(L loc (BindStmt pat' body' bind_op fail_op), fv_expr)]
790 , thing),
791 fv_expr `plusFV` fvs1 `plusFV` fvs2 `plusFV` fvs3) }}
792 -- fv_expr shouldn't really be filtered by the rnPatsAndThen
793 -- but it does not matter because the names are unique
794
795 rnStmt _ _ (L loc (LetStmt binds)) thing_inside
796 = do { rnLocalBindsAndThen binds $ \binds' bind_fvs -> do
797 { (thing, fvs) <- thing_inside (collectLocalBinders binds')
798 ; return (([(L loc (LetStmt binds'), bind_fvs)], thing), fvs) } }
799
800 rnStmt ctxt rnBody (L loc (RecStmt { recS_stmts = rec_stmts })) thing_inside
801 = do { (return_op, fvs1) <- lookupStmtName ctxt returnMName
802 ; (mfix_op, fvs2) <- lookupStmtName ctxt mfixName
803 ; (bind_op, fvs3) <- lookupStmtName ctxt bindMName
804 ; let empty_rec_stmt = emptyRecStmtName { recS_ret_fn = return_op
805 , recS_mfix_fn = mfix_op
806 , recS_bind_fn = bind_op }
807
808 -- Step1: Bring all the binders of the mdo into scope
809 -- (Remember that this also removes the binders from the
810 -- finally-returned free-vars.)
811 -- And rename each individual stmt, making a
812 -- singleton segment. At this stage the FwdRefs field
813 -- isn't finished: it's empty for all except a BindStmt
814 -- for which it's the fwd refs within the bind itself
815 -- (This set may not be empty, because we're in a recursive
816 -- context.)
817 ; rnRecStmtsAndThen rnBody rec_stmts $ \ segs -> do
818 { let bndrs = nameSetElems $ foldr (unionNameSet . (\(ds,_,_,_) -> ds))
819 emptyNameSet segs
820 ; (thing, fvs_later) <- thing_inside bndrs
821 ; let (rec_stmts', fvs) = segmentRecStmts loc ctxt empty_rec_stmt segs fvs_later
822 -- We aren't going to try to group RecStmts with
823 -- ApplicativeDo, so attaching empty FVs is fine.
824 ; return ( ((zip rec_stmts' (repeat emptyNameSet)), thing)
825 , fvs `plusFV` fvs1 `plusFV` fvs2 `plusFV` fvs3) } }
826
827 rnStmt ctxt _ (L loc (ParStmt segs _ _)) thing_inside
828 = do { (mzip_op, fvs1) <- lookupStmtName ctxt mzipName
829 ; (bind_op, fvs2) <- lookupStmtName ctxt bindMName
830 ; (return_op, fvs3) <- lookupStmtName ctxt returnMName
831 ; ((segs', thing), fvs4) <- rnParallelStmts (ParStmtCtxt ctxt) return_op segs thing_inside
832 ; return ( ([(L loc (ParStmt segs' mzip_op bind_op), fvs4)], thing)
833 , fvs1 `plusFV` fvs2 `plusFV` fvs3 `plusFV` fvs4) }
834
835 rnStmt ctxt _ (L loc (TransStmt { trS_stmts = stmts, trS_by = by, trS_form = form
836 , trS_using = using })) thing_inside
837 = do { -- Rename the 'using' expression in the context before the transform is begun
838 (using', fvs1) <- rnLExpr using
839
840 -- Rename the stmts and the 'by' expression
841 -- Keep track of the variables mentioned in the 'by' expression
842 ; ((stmts', (by', used_bndrs, thing)), fvs2)
843 <- rnStmts (TransStmtCtxt ctxt) rnLExpr stmts $ \ bndrs ->
844 do { (by', fvs_by) <- mapMaybeFvRn rnLExpr by
845 ; (thing, fvs_thing) <- thing_inside bndrs
846 ; let fvs = fvs_by `plusFV` fvs_thing
847 used_bndrs = filter (`elemNameSet` fvs) bndrs
848 -- The paper (Fig 5) has a bug here; we must treat any free variable
849 -- of the "thing inside", **or of the by-expression**, as used
850 ; return ((by', used_bndrs, thing), fvs) }
851
852 -- Lookup `return`, `(>>=)` and `liftM` for monad comprehensions
853 ; (return_op, fvs3) <- lookupStmtName ctxt returnMName
854 ; (bind_op, fvs4) <- lookupStmtName ctxt bindMName
855 ; (fmap_op, fvs5) <- case form of
856 ThenForm -> return (noSyntaxExpr, emptyFVs)
857 _ -> lookupStmtName ctxt fmapName
858
859 ; let all_fvs = fvs1 `plusFV` fvs2 `plusFV` fvs3
860 `plusFV` fvs4 `plusFV` fvs5
861 bndr_map = used_bndrs `zip` used_bndrs
862 -- See Note [TransStmt binder map] in HsExpr
863
864 ; traceRn (text "rnStmt: implicitly rebound these used binders:" <+> ppr bndr_map)
865 ; return (([(L loc (TransStmt { trS_stmts = stmts', trS_bndrs = bndr_map
866 , trS_by = by', trS_using = using', trS_form = form
867 , trS_ret = return_op, trS_bind = bind_op
868 , trS_fmap = fmap_op }), fvs2)], thing), all_fvs) }
869
870 rnStmt _ _ (L _ ApplicativeStmt{}) _ =
871 panic "rnStmt: ApplicativeStmt"
872
873 rnParallelStmts :: forall thing. HsStmtContext Name
874 -> SyntaxExpr Name
875 -> [ParStmtBlock RdrName RdrName]
876 -> ([Name] -> RnM (thing, FreeVars))
877 -> RnM (([ParStmtBlock Name Name], thing), FreeVars)
878 -- Note [Renaming parallel Stmts]
879 rnParallelStmts ctxt return_op segs thing_inside
880 = do { orig_lcl_env <- getLocalRdrEnv
881 ; rn_segs orig_lcl_env [] segs }
882 where
883 rn_segs :: LocalRdrEnv
884 -> [Name] -> [ParStmtBlock RdrName RdrName]
885 -> RnM (([ParStmtBlock Name Name], thing), FreeVars)
886 rn_segs _ bndrs_so_far []
887 = do { let (bndrs', dups) = removeDups cmpByOcc bndrs_so_far
888 ; mapM_ dupErr dups
889 ; (thing, fvs) <- bindLocalNames bndrs' (thing_inside bndrs')
890 ; return (([], thing), fvs) }
891
892 rn_segs env bndrs_so_far (ParStmtBlock stmts _ _ : segs)
893 = do { ((stmts', (used_bndrs, segs', thing)), fvs)
894 <- rnStmts ctxt rnLExpr stmts $ \ bndrs ->
895 setLocalRdrEnv env $ do
896 { ((segs', thing), fvs) <- rn_segs env (bndrs ++ bndrs_so_far) segs
897 ; let used_bndrs = filter (`elemNameSet` fvs) bndrs
898 ; return ((used_bndrs, segs', thing), fvs) }
899
900 ; let seg' = ParStmtBlock stmts' used_bndrs return_op
901 ; return ((seg':segs', thing), fvs) }
902
903 cmpByOcc n1 n2 = nameOccName n1 `compare` nameOccName n2
904 dupErr vs = addErr (ptext (sLit "Duplicate binding in parallel list comprehension for:")
905 <+> quotes (ppr (head vs)))
906
907 lookupStmtName :: HsStmtContext Name -> Name -> RnM (HsExpr Name, FreeVars)
908 -- Like lookupSyntaxName, but ListComp/PArrComp are never rebindable
909 -- Neither is ArrowExpr, which has its own desugarer in DsArrows
910 lookupStmtName ctxt n
911 = case ctxt of
912 ListComp -> not_rebindable
913 PArrComp -> not_rebindable
914 ArrowExpr -> not_rebindable
915 PatGuard {} -> not_rebindable
916
917 DoExpr -> rebindable
918 MDoExpr -> rebindable
919 MonadComp -> rebindable
920 GhciStmtCtxt -> rebindable -- I suppose?
921
922 ParStmtCtxt c -> lookupStmtName c n -- Look inside to
923 TransStmtCtxt c -> lookupStmtName c n -- the parent context
924 where
925 rebindable = lookupSyntaxName n
926 not_rebindable = return (HsVar n, emptyFVs)
927
928 {-
929 Note [Renaming parallel Stmts]
930 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
931 Renaming parallel statements is painful. Given, say
932 [ a+c | a <- as, bs <- bss
933 | c <- bs, a <- ds ]
934 Note that
935 (a) In order to report "Defined but not used" about 'bs', we must
936 rename each group of Stmts with a thing_inside whose FreeVars
937 include at least {a,c}
938
939 (b) We want to report that 'a' is illegally bound in both branches
940
941 (c) The 'bs' in the second group must obviously not be captured by
942 the binding in the first group
943
944 To satisfy (a) we nest the segements.
945 To satisfy (b) we check for duplicates just before thing_inside.
946 To satisfy (c) we reset the LocalRdrEnv each time.
947
948 ************************************************************************
949 * *
950 \subsubsection{mdo expressions}
951 * *
952 ************************************************************************
953 -}
954
955 type FwdRefs = NameSet
956 type Segment stmts = (Defs,
957 Uses, -- May include defs
958 FwdRefs, -- A subset of uses that are
959 -- (a) used before they are bound in this segment, or
960 -- (b) used here, and bound in subsequent segments
961 stmts) -- Either Stmt or [Stmt]
962
963
964 -- wrapper that does both the left- and right-hand sides
965 rnRecStmtsAndThen :: Outputable (body RdrName) =>
966 (Located (body RdrName)
967 -> RnM (Located (body Name), FreeVars))
968 -> [LStmt RdrName (Located (body RdrName))]
969 -- assumes that the FreeVars returned includes
970 -- the FreeVars of the Segments
971 -> ([Segment (LStmt Name (Located (body Name)))]
972 -> RnM (a, FreeVars))
973 -> RnM (a, FreeVars)
974 rnRecStmtsAndThen rnBody s cont
975 = do { -- (A) Make the mini fixity env for all of the stmts
976 fix_env <- makeMiniFixityEnv (collectRecStmtsFixities s)
977
978 -- (B) Do the LHSes
979 ; new_lhs_and_fv <- rn_rec_stmts_lhs fix_env s
980
981 -- ...bring them and their fixities into scope
982 ; let bound_names = collectLStmtsBinders (map fst new_lhs_and_fv)
983 -- Fake uses of variables introduced implicitly (warning suppression, see #4404)
984 implicit_uses = lStmtsImplicits (map fst new_lhs_and_fv)
985 ; bindLocalNamesFV bound_names $
986 addLocalFixities fix_env bound_names $ do
987
988 -- (C) do the right-hand-sides and thing-inside
989 { segs <- rn_rec_stmts rnBody bound_names new_lhs_and_fv
990 ; (res, fvs) <- cont segs
991 ; warnUnusedLocalBinds bound_names (fvs `unionNameSet` implicit_uses)
992 ; return (res, fvs) }}
993
994 -- get all the fixity decls in any Let stmt
995 collectRecStmtsFixities :: [LStmtLR RdrName RdrName body] -> [LFixitySig RdrName]
996 collectRecStmtsFixities l =
997 foldr (\ s -> \acc -> case s of
998 (L _ (LetStmt (HsValBinds (ValBindsIn _ sigs)))) ->
999 foldr (\ sig -> \ acc -> case sig of
1000 (L loc (FixSig s)) -> (L loc s) : acc
1001 _ -> acc) acc sigs
1002 _ -> acc) [] l
1003
1004 -- left-hand sides
1005
1006 rn_rec_stmt_lhs :: Outputable body => MiniFixityEnv
1007 -> LStmt RdrName body
1008 -- rename LHS, and return its FVs
1009 -- Warning: we will only need the FreeVars below in the case of a BindStmt,
1010 -- so we don't bother to compute it accurately in the other cases
1011 -> RnM [(LStmtLR Name RdrName body, FreeVars)]
1012
1013 rn_rec_stmt_lhs _ (L loc (BodyStmt body a b c))
1014 = return [(L loc (BodyStmt body a b c), emptyFVs)]
1015
1016 rn_rec_stmt_lhs _ (L loc (LastStmt body noret a))
1017 = return [(L loc (LastStmt body noret a), emptyFVs)]
1018
1019 rn_rec_stmt_lhs fix_env (L loc (BindStmt pat body a b))
1020 = do
1021 -- should the ctxt be MDo instead?
1022 (pat', fv_pat) <- rnBindPat (localRecNameMaker fix_env) pat
1023 return [(L loc (BindStmt pat' body a b),
1024 fv_pat)]
1025
1026 rn_rec_stmt_lhs _ (L _ (LetStmt binds@(HsIPBinds _)))
1027 = failWith (badIpBinds (ptext (sLit "an mdo expression")) binds)
1028
1029 rn_rec_stmt_lhs fix_env (L loc (LetStmt (HsValBinds binds)))
1030 = do (_bound_names, binds') <- rnLocalValBindsLHS fix_env binds
1031 return [(L loc (LetStmt (HsValBinds binds')),
1032 -- Warning: this is bogus; see function invariant
1033 emptyFVs
1034 )]
1035
1036 -- XXX Do we need to do something with the return and mfix names?
1037 rn_rec_stmt_lhs fix_env (L _ (RecStmt { recS_stmts = stmts })) -- Flatten Rec inside Rec
1038 = rn_rec_stmts_lhs fix_env stmts
1039
1040 rn_rec_stmt_lhs _ stmt@(L _ (ParStmt {})) -- Syntactically illegal in mdo
1041 = pprPanic "rn_rec_stmt" (ppr stmt)
1042
1043 rn_rec_stmt_lhs _ stmt@(L _ (TransStmt {})) -- Syntactically illegal in mdo
1044 = pprPanic "rn_rec_stmt" (ppr stmt)
1045
1046 rn_rec_stmt_lhs _ stmt@(L _ (ApplicativeStmt {})) -- Shouldn't appear yet
1047 = pprPanic "rn_rec_stmt" (ppr stmt)
1048
1049 rn_rec_stmt_lhs _ (L _ (LetStmt EmptyLocalBinds))
1050 = panic "rn_rec_stmt LetStmt EmptyLocalBinds"
1051
1052 rn_rec_stmts_lhs :: Outputable body => MiniFixityEnv
1053 -> [LStmt RdrName body]
1054 -> RnM [(LStmtLR Name RdrName body, FreeVars)]
1055 rn_rec_stmts_lhs fix_env stmts
1056 = do { ls <- concatMapM (rn_rec_stmt_lhs fix_env) stmts
1057 ; let boundNames = collectLStmtsBinders (map fst ls)
1058 -- First do error checking: we need to check for dups here because we
1059 -- don't bind all of the variables from the Stmt at once
1060 -- with bindLocatedLocals.
1061 ; checkDupNames boundNames
1062 ; return ls }
1063
1064
1065 -- right-hand-sides
1066
1067 rn_rec_stmt :: (Outputable (body RdrName)) =>
1068 (Located (body RdrName) -> RnM (Located (body Name), FreeVars))
1069 -> [Name]
1070 -> (LStmtLR Name RdrName (Located (body RdrName)), FreeVars)
1071 -> RnM [Segment (LStmt Name (Located (body Name)))]
1072 -- Rename a Stmt that is inside a RecStmt (or mdo)
1073 -- Assumes all binders are already in scope
1074 -- Turns each stmt into a singleton Stmt
1075 rn_rec_stmt rnBody _ (L loc (LastStmt body noret _), _)
1076 = do { (body', fv_expr) <- rnBody body
1077 ; (ret_op, fvs1) <- lookupSyntaxName returnMName
1078 ; return [(emptyNameSet, fv_expr `plusFV` fvs1, emptyNameSet,
1079 L loc (LastStmt body' noret ret_op))] }
1080
1081 rn_rec_stmt rnBody _ (L loc (BodyStmt body _ _ _), _)
1082 = do { (body', fvs) <- rnBody body
1083 ; (then_op, fvs1) <- lookupSyntaxName thenMName
1084 ; return [(emptyNameSet, fvs `plusFV` fvs1, emptyNameSet,
1085 L loc (BodyStmt body' then_op noSyntaxExpr placeHolderType))] }
1086
1087 rn_rec_stmt rnBody _ (L loc (BindStmt pat' body _ _), fv_pat)
1088 = do { (body', fv_expr) <- rnBody body
1089 ; (bind_op, fvs1) <- lookupSyntaxName bindMName
1090 ; (fail_op, fvs2) <- lookupSyntaxName failMName
1091 ; let bndrs = mkNameSet (collectPatBinders pat')
1092 fvs = fv_expr `plusFV` fv_pat `plusFV` fvs1 `plusFV` fvs2
1093 ; return [(bndrs, fvs, bndrs `intersectNameSet` fvs,
1094 L loc (BindStmt pat' body' bind_op fail_op))] }
1095
1096 rn_rec_stmt _ _ (L _ (LetStmt binds@(HsIPBinds _)), _)
1097 = failWith (badIpBinds (ptext (sLit "an mdo expression")) binds)
1098
1099 rn_rec_stmt _ all_bndrs (L loc (LetStmt (HsValBinds binds')), _)
1100 = do { (binds', du_binds) <- rnLocalValBindsRHS (mkNameSet all_bndrs) binds'
1101 -- fixities and unused are handled above in rnRecStmtsAndThen
1102 ; let fvs = allUses du_binds
1103 ; return [(duDefs du_binds, fvs, emptyNameSet,
1104 L loc (LetStmt (HsValBinds binds')))] }
1105
1106 -- no RecStmt case because they get flattened above when doing the LHSes
1107 rn_rec_stmt _ _ stmt@(L _ (RecStmt {}), _)
1108 = pprPanic "rn_rec_stmt: RecStmt" (ppr stmt)
1109
1110 rn_rec_stmt _ _ stmt@(L _ (ParStmt {}), _) -- Syntactically illegal in mdo
1111 = pprPanic "rn_rec_stmt: ParStmt" (ppr stmt)
1112
1113 rn_rec_stmt _ _ stmt@(L _ (TransStmt {}), _) -- Syntactically illegal in mdo
1114 = pprPanic "rn_rec_stmt: TransStmt" (ppr stmt)
1115
1116 rn_rec_stmt _ _ (L _ (LetStmt EmptyLocalBinds), _)
1117 = panic "rn_rec_stmt: LetStmt EmptyLocalBinds"
1118
1119 rn_rec_stmt _ _ stmt@(L _ (ApplicativeStmt {}), _)
1120 = pprPanic "rn_rec_stmt: ApplicativeStmt" (ppr stmt)
1121
1122 rn_rec_stmts :: Outputable (body RdrName) =>
1123 (Located (body RdrName) -> RnM (Located (body Name), FreeVars))
1124 -> [Name]
1125 -> [(LStmtLR Name RdrName (Located (body RdrName)), FreeVars)]
1126 -> RnM [Segment (LStmt Name (Located (body Name)))]
1127 rn_rec_stmts rnBody bndrs stmts
1128 = do { segs_s <- mapM (rn_rec_stmt rnBody bndrs) stmts
1129 ; return (concat segs_s) }
1130
1131 ---------------------------------------------
1132 segmentRecStmts :: SrcSpan -> HsStmtContext Name
1133 -> Stmt Name body
1134 -> [Segment (LStmt Name body)] -> FreeVars
1135 -> ([LStmt Name body], FreeVars)
1136
1137 segmentRecStmts loc ctxt empty_rec_stmt segs fvs_later
1138 | null segs
1139 = ([], fvs_later)
1140
1141 | MDoExpr <- ctxt
1142 = segsToStmts empty_rec_stmt grouped_segs fvs_later
1143 -- Step 4: Turn the segments into Stmts
1144 -- Use RecStmt when and only when there are fwd refs
1145 -- Also gather up the uses from the end towards the
1146 -- start, so we can tell the RecStmt which things are
1147 -- used 'after' the RecStmt
1148
1149 | otherwise
1150 = ([ L loc $
1151 empty_rec_stmt { recS_stmts = ss
1152 , recS_later_ids = nameSetElems (defs `intersectNameSet` fvs_later)
1153 , recS_rec_ids = nameSetElems (defs `intersectNameSet` uses) }]
1154 , uses `plusFV` fvs_later)
1155
1156 where
1157 (defs_s, uses_s, _, ss) = unzip4 segs
1158 defs = plusFVs defs_s
1159 uses = plusFVs uses_s
1160
1161 -- Step 2: Fill in the fwd refs.
1162 -- The segments are all singletons, but their fwd-ref
1163 -- field mentions all the things used by the segment
1164 -- that are bound after their use
1165 segs_w_fwd_refs = addFwdRefs segs
1166
1167 -- Step 3: Group together the segments to make bigger segments
1168 -- Invariant: in the result, no segment uses a variable
1169 -- bound in a later segment
1170 grouped_segs = glomSegments ctxt segs_w_fwd_refs
1171
1172 ----------------------------
1173 addFwdRefs :: [Segment a] -> [Segment a]
1174 -- So far the segments only have forward refs *within* the Stmt
1175 -- (which happens for bind: x <- ...x...)
1176 -- This function adds the cross-seg fwd ref info
1177
1178 addFwdRefs segs
1179 = fst (foldr mk_seg ([], emptyNameSet) segs)
1180 where
1181 mk_seg (defs, uses, fwds, stmts) (segs, later_defs)
1182 = (new_seg : segs, all_defs)
1183 where
1184 new_seg = (defs, uses, new_fwds, stmts)
1185 all_defs = later_defs `unionNameSet` defs
1186 new_fwds = fwds `unionNameSet` (uses `intersectNameSet` later_defs)
1187 -- Add the downstream fwd refs here
1188
1189 {-
1190 Note [Segmenting mdo]
1191 ~~~~~~~~~~~~~~~~~~~~~
1192 NB. June 7 2012: We only glom segments that appear in an explicit mdo;
1193 and leave those found in "do rec"'s intact. See
1194 http://ghc.haskell.org/trac/ghc/ticket/4148 for the discussion
1195 leading to this design choice. Hence the test in segmentRecStmts.
1196
1197 Note [Glomming segments]
1198 ~~~~~~~~~~~~~~~~~~~~~~~~
1199 Glomming the singleton segments of an mdo into minimal recursive groups.
1200
1201 At first I thought this was just strongly connected components, but
1202 there's an important constraint: the order of the stmts must not change.
1203
1204 Consider
1205 mdo { x <- ...y...
1206 p <- z
1207 y <- ...x...
1208 q <- x
1209 z <- y
1210 r <- x }
1211
1212 Here, the first stmt mention 'y', which is bound in the third.
1213 But that means that the innocent second stmt (p <- z) gets caught
1214 up in the recursion. And that in turn means that the binding for
1215 'z' has to be included... and so on.
1216
1217 Start at the tail { r <- x }
1218 Now add the next one { z <- y ; r <- x }
1219 Now add one more { q <- x ; z <- y ; r <- x }
1220 Now one more... but this time we have to group a bunch into rec
1221 { rec { y <- ...x... ; q <- x ; z <- y } ; r <- x }
1222 Now one more, which we can add on without a rec
1223 { p <- z ;
1224 rec { y <- ...x... ; q <- x ; z <- y } ;
1225 r <- x }
1226 Finally we add the last one; since it mentions y we have to
1227 glom it together with the first two groups
1228 { rec { x <- ...y...; p <- z ; y <- ...x... ;
1229 q <- x ; z <- y } ;
1230 r <- x }
1231 -}
1232
1233 glomSegments :: HsStmtContext Name
1234 -> [Segment (LStmt Name body)]
1235 -> [Segment [LStmt Name body]] -- Each segment has a non-empty list of Stmts
1236 -- See Note [Glomming segments]
1237
1238 glomSegments _ [] = []
1239 glomSegments ctxt ((defs,uses,fwds,stmt) : segs)
1240 -- Actually stmts will always be a singleton
1241 = (seg_defs, seg_uses, seg_fwds, seg_stmts) : others
1242 where
1243 segs' = glomSegments ctxt segs
1244 (extras, others) = grab uses segs'
1245 (ds, us, fs, ss) = unzip4 extras
1246
1247 seg_defs = plusFVs ds `plusFV` defs
1248 seg_uses = plusFVs us `plusFV` uses
1249 seg_fwds = plusFVs fs `plusFV` fwds
1250 seg_stmts = stmt : concat ss
1251
1252 grab :: NameSet -- The client
1253 -> [Segment a]
1254 -> ([Segment a], -- Needed by the 'client'
1255 [Segment a]) -- Not needed by the client
1256 -- The result is simply a split of the input
1257 grab uses dus
1258 = (reverse yeses, reverse noes)
1259 where
1260 (noes, yeses) = span not_needed (reverse dus)
1261 not_needed (defs,_,_,_) = not (intersectsNameSet defs uses)
1262
1263 ----------------------------------------------------
1264 segsToStmts :: Stmt Name body -- A RecStmt with the SyntaxOps filled in
1265 -> [Segment [LStmt Name body]] -- Each Segment has a non-empty list of Stmts
1266 -> FreeVars -- Free vars used 'later'
1267 -> ([LStmt Name body], FreeVars)
1268
1269 segsToStmts _ [] fvs_later = ([], fvs_later)
1270 segsToStmts empty_rec_stmt ((defs, uses, fwds, ss) : segs) fvs_later
1271 = ASSERT( not (null ss) )
1272 (new_stmt : later_stmts, later_uses `plusFV` uses)
1273 where
1274 (later_stmts, later_uses) = segsToStmts empty_rec_stmt segs fvs_later
1275 new_stmt | non_rec = head ss
1276 | otherwise = L (getLoc (head ss)) rec_stmt
1277 rec_stmt = empty_rec_stmt { recS_stmts = ss
1278 , recS_later_ids = nameSetElems used_later
1279 , recS_rec_ids = nameSetElems fwds }
1280 non_rec = isSingleton ss && isEmptyNameSet fwds
1281 used_later = defs `intersectNameSet` later_uses
1282 -- The ones needed after the RecStmt
1283
1284 {-
1285 ************************************************************************
1286 * *
1287 ApplicativeDo
1288 * *
1289 ************************************************************************
1290
1291 Note [ApplicativeDo]
1292
1293 = Example =
1294
1295 For a sequence of statements
1296
1297 do
1298 x <- A
1299 y <- B x
1300 z <- C
1301 return (f x y z)
1302
1303 We want to transform this to
1304
1305 (\(x,y) z -> f x y z) <$> (do x <- A; y <- B x; return (x,y)) <*> C
1306
1307 It would be easy to notice that "y <- B x" and "z <- C" are
1308 independent and do something like this:
1309
1310 do
1311 x <- A
1312 (y,z) <- (,) <$> B x <*> C
1313 return (f x y z)
1314
1315 But this isn't enough! A and C were also independent, and this
1316 transformation loses the ability to do A and C in parallel.
1317
1318 The algorithm works by first splitting the sequence of statements into
1319 independent "segments", and a separate "tail" (the final statement). In
1320 our example above, the segements would be
1321
1322 [ x <- A
1323 , y <- B x ]
1324
1325 [ z <- C ]
1326
1327 and the tail is:
1328
1329 return (f x y z)
1330
1331 Then we take these segments and make an Applicative expression from them:
1332
1333 (\(x,y) z -> return (f x y z))
1334 <$> do { x <- A; y <- B x; return (x,y) }
1335 <*> C
1336
1337 Finally, we recursively apply the transformation to each segment, to
1338 discover any nested parallelism.
1339
1340 = Syntax & spec =
1341
1342 expr ::= ... | do {stmt_1; ..; stmt_n} expr | ...
1343
1344 stmt ::= pat <- expr
1345 | (arg_1 | ... | arg_n) -- applicative composition, n>=1
1346 | ... -- other kinds of statement (e.g. let)
1347
1348 arg ::= pat <- expr
1349 | {stmt_1; ..; stmt_n} {var_1..var_n}
1350
1351 (note that in the actual implementation,the expr in a do statement is
1352 represented by a LastStmt as the final stmt, this is just a
1353 representational issue and may change later.)
1354
1355 == Transformation to introduce applicative stmts ==
1356
1357 ado {} tail = tail
1358 ado {pat <- expr} {return expr'} = (mkArg(pat <- expr)); return expr'
1359 ado {one} tail = one : tail
1360 ado stmts tail
1361 | n == 1 = ado before (ado after tail)
1362 where (before,after) = split(stmts_1)
1363 | n > 1 = (mkArg(stmts_1) | ... | mkArg(stmts_n)); tail
1364 where
1365 {stmts_1 .. stmts_n} = segments(stmts)
1366
1367 segments(stmts) =
1368 -- divide stmts into segments with no interdependencies
1369
1370 mkArg({pat <- expr}) = (pat <- expr)
1371 mkArg({stmt_1; ...; stmt_n}) =
1372 {stmt_1; ...; stmt_n} {vars(stmt_1) u .. u vars(stmt_n)}
1373
1374 split({stmt_1; ..; stmt_n) =
1375 ({stmt_1; ..; stmt_i}, {stmt_i+1; ..; stmt_n})
1376 -- 1 <= i <= n
1377 -- i is a good place to insert a bind
1378
1379 == Desugaring for do ==
1380
1381 dsDo {} expr = expr
1382
1383 dsDo {pat <- rhs; stmts} expr =
1384 rhs >>= \pat -> dsDo stmts expr
1385
1386 dsDo {(arg_1 | ... | arg_n)} (return expr) =
1387 (\argpat (arg_1) .. argpat(arg_n) -> expr)
1388 <$> argexpr(arg_1)
1389 <*> ...
1390 <*> argexpr(arg_n)
1391
1392 dsDo {(arg_1 | ... | arg_n); stmts} expr =
1393 join (\argpat (arg_1) .. argpat(arg_n) -> dsDo stmts expr)
1394 <$> argexpr(arg_1)
1395 <*> ...
1396 <*> argexpr(arg_n)
1397
1398 -}
1399
1400 -- | rearrange a list of statements using ApplicativeDoStmt. See
1401 -- Note [ApplicativeDo].
1402 rearrangeForApplicativeDo
1403 :: HsStmtContext Name
1404 -> [(LStmt Name (LHsExpr Name), FreeVars)]
1405 -> RnM ([LStmt Name (LHsExpr Name)], FreeVars)
1406
1407 rearrangeForApplicativeDo _ [] = return ([], emptyNameSet)
1408 rearrangeForApplicativeDo ctxt stmts0 = do
1409 (stmts', fvs) <- ado ctxt stmts [last] last_fvs
1410 return (stmts', fvs)
1411 where (stmts,(last,last_fvs)) = findLast stmts0
1412 findLast [] = error "findLast"
1413 findLast [last] = ([],last)
1414 findLast (x:xs) = (x:rest,last) where (rest,last) = findLast xs
1415
1416 -- | The ApplicativeDo transformation.
1417 ado
1418 :: HsStmtContext Name
1419 -> [(LStmt Name (LHsExpr Name), FreeVars)] -- ^ input statements
1420 -> [LStmt Name (LHsExpr Name)] -- ^ the "tail"
1421 -> FreeVars -- ^ free variables of the tail
1422 -> RnM ( [LStmt Name (LHsExpr Name)] -- ( output statements,
1423 , FreeVars ) -- , things we needed
1424 -- e.g. <$>, <*>, join )
1425
1426 ado _ctxt [] tail _ = return (tail, emptyNameSet)
1427
1428 -- If we have a single bind, and we can do it without a join, transform
1429 -- to an ApplicativeStmt. This corresponds to the rule
1430 -- dsBlock [pat <- rhs] (return expr) = expr <$> rhs
1431 -- In the spec, but we do it here rather than in the desugarer,
1432 -- because we need the typechecker to typecheck the <$> form rather than
1433 -- the bind form, which would give rise to a Monad constraint.
1434 ado ctxt [(L _ (BindStmt pat rhs _ _),_)] tail _
1435 | isIrrefutableHsPat pat, (False,tail') <- needJoin tail
1436 = mkApplicativeStmt ctxt [ApplicativeArgOne pat rhs] False tail'
1437
1438 ado _ctxt [(one,_)] tail _ = return (one:tail, emptyNameSet)
1439
1440 ado ctxt stmts tail tail_fvs =
1441 case segments stmts of -- chop into segments
1442 [] -> panic "ado"
1443 [one] ->
1444 -- one indivisible segment, divide it by adding a bind
1445 adoSegment ctxt one tail tail_fvs
1446 segs ->
1447 -- multiple segments; recursively transform the segments, and
1448 -- combine into an ApplicativeStmt
1449 do { pairs <- mapM (adoSegmentArg ctxt tail_fvs) segs
1450 ; let (stmts', fvss) = unzip pairs
1451 ; let (need_join, tail') = needJoin tail
1452 ; (stmts, fvs) <- mkApplicativeStmt ctxt stmts' need_join tail'
1453 ; return (stmts, unionNameSets (fvs:fvss)) }
1454
1455 -- | Deal with an indivisible segment. We pick a place to insert a
1456 -- bind (it will actually be a join), and recursively transform the
1457 -- two halves.
1458 adoSegment
1459 :: HsStmtContext Name
1460 -> [(LStmt Name (LHsExpr Name), FreeVars)]
1461 -> [LStmt Name (LHsExpr Name)]
1462 -> FreeVars
1463 -> RnM ( [LStmt Name (LHsExpr Name)], FreeVars )
1464 adoSegment ctxt stmts tail tail_fvs
1465 = do { -- choose somewhere to put a bind
1466 let (before,after) = splitSegment stmts
1467 ; (stmts1, fvs1) <- ado ctxt after tail tail_fvs
1468 ; let tail1_fvs = unionNameSets (tail_fvs : map snd after)
1469 ; (stmts2, fvs2) <- ado ctxt before stmts1 tail1_fvs
1470 ; return (stmts2, fvs1 `plusFV` fvs2) }
1471
1472 -- | Given a segment, make an ApplicativeArg. Here we recursively
1473 -- call adoSegment on the segment's contents to extract any further
1474 -- available parallelism.
1475 adoSegmentArg
1476 :: HsStmtContext Name
1477 -> FreeVars
1478 -> [(LStmt Name (LHsExpr Name), FreeVars)]
1479 -> RnM (ApplicativeArg Name Name, FreeVars)
1480 adoSegmentArg _ _ [(L _ (BindStmt pat exp _ _),_)] =
1481 return (ApplicativeArgOne pat exp, emptyFVs)
1482 adoSegmentArg ctxt tail_fvs stmts =
1483 do { let pvarset = mkNameSet (concatMap (collectStmtBinders.unLoc.fst) stmts)
1484 `intersectNameSet` tail_fvs
1485 pvars = nameSetElems pvarset
1486 pat = mkBigLHsVarPatTup pvars
1487 tup = mkBigLHsVarTup pvars
1488 ; (stmts',fvs2) <- adoSegment ctxt stmts [] pvarset
1489 ; (mb_ret, fvs1) <- case () of
1490 _ | L _ ApplicativeStmt{} <- last stmts' ->
1491 return (unLoc tup, emptyNameSet)
1492 | otherwise -> do
1493 (ret,fvs) <- lookupStmtName ctxt returnMName
1494 return (HsApp (noLoc ret) tup, fvs)
1495 ; return ( ApplicativeArgMany stmts' mb_ret pat
1496 , fvs1 `plusFV` fvs2) }
1497
1498 -- | Divide a sequence of statements into segments, where no segment
1499 -- depends on any variables defined by a statement in another segment.
1500 segments
1501 :: [(LStmt Name (LHsExpr Name), FreeVars)]
1502 -> [[(LStmt Name (LHsExpr Name), FreeVars)]]
1503 segments stmts = map fst $ merge $ reverse $ map reverse $ walk (reverse stmts)
1504 where
1505 allvars = mkNameSet (concatMap (collectStmtBinders.unLoc.fst) stmts)
1506
1507 -- We would rather not have a segment that just has LetStmts in
1508 -- it, so combine those with an adjacent segment where possible.
1509 merge [] = []
1510 merge (seg : segs)
1511 = case rest of
1512 [] -> [(seg,all_lets)]
1513 ((s,s_lets):ss) | all_lets || s_lets
1514 -> (seg ++ s, all_lets && s_lets) : ss
1515 _otherwise -> (seg,all_lets) : rest
1516 where
1517 rest = merge segs
1518 all_lets = all (not . isBindStmt . fst) seg
1519
1520 walk [] = []
1521 walk ((stmt,fvs) : stmts) = ((stmt,fvs) : seg) : walk rest
1522 where (seg,rest) = chunter (fvs `intersectNameSet` allvars) stmts
1523
1524 chunter _ [] = ([], [])
1525 chunter vars ((stmt,fvs) : rest)
1526 | not (isEmptyNameSet vars)
1527 = ((stmt,fvs) : chunk, rest')
1528 where (chunk,rest') = chunter vars' rest
1529 evars = fvs `intersectNameSet` allvars
1530 pvars = mkNameSet (collectStmtBinders (unLoc stmt))
1531 vars' = (vars `minusNameSet` pvars) `unionNameSet` evars
1532 chunter _ rest = ([], rest)
1533
1534 isBindStmt (L _ BindStmt{}) = True
1535 isBindStmt _ = False
1536
1537 -- | Find a "good" place to insert a bind in an indivisible segment.
1538 -- This is the only place where we use heuristics. The current
1539 -- heuristic is to peel off the first group of independent statements
1540 -- and put the bind after those.
1541 splitSegment
1542 :: [(LStmt Name (LHsExpr Name), FreeVars)]
1543 -> ( [(LStmt Name (LHsExpr Name), FreeVars)]
1544 , [(LStmt Name (LHsExpr Name), FreeVars)] )
1545 splitSegment stmts
1546 | Just (lets,binds,rest) <- slurpIndependentStmts stmts
1547 = if not (null lets)
1548 then (lets, binds++rest)
1549 else (lets++binds, rest)
1550 | otherwise
1551 = case stmts of
1552 (x:xs) -> ([x],xs)
1553 _other -> (stmts,[])
1554
1555 slurpIndependentStmts
1556 :: [(LStmt Name (Located (body Name)), FreeVars)]
1557 -> Maybe ( [(LStmt Name (Located (body Name)), FreeVars)] -- LetStmts
1558 , [(LStmt Name (Located (body Name)), FreeVars)] -- BindStmts
1559 , [(LStmt Name (Located (body Name)), FreeVars)] )
1560 slurpIndependentStmts stmts = go [] [] emptyNameSet stmts
1561 where
1562 -- If we encounter a BindStmt that doesn't depend on a previous BindStmt
1563 -- in this group, then add it to the group.
1564 go lets indep bndrs ((L loc (BindStmt pat body bind_op fail_op), fvs) : rest)
1565 | isEmptyNameSet (bndrs `intersectNameSet` fvs)
1566 = go lets ((L loc (BindStmt pat body bind_op fail_op), fvs) : indep)
1567 bndrs' rest
1568 where bndrs' = bndrs `unionNameSet` mkNameSet (collectPatBinders pat)
1569 -- If we encounter a LetStmt that doesn't depend on a BindStmt in this
1570 -- group, then move it to the beginning, so that it doesn't interfere with
1571 -- grouping more BindStmts.
1572 -- TODO: perhaps we shouldn't do this if there are any strict bindings,
1573 -- because we might be moving evaluation earlier.
1574 go lets indep bndrs ((L loc (LetStmt binds), fvs) : rest)
1575 | isEmptyNameSet (bndrs `intersectNameSet` fvs)
1576 = go ((L loc (LetStmt binds), fvs) : lets) indep bndrs rest
1577 go _ [] _ _ = Nothing
1578 go _ [_] _ _ = Nothing
1579 go lets indep _ stmts = Just (reverse lets, reverse indep, stmts)
1580
1581 -- | Build an ApplicativeStmt, and strip the "return" from the tail
1582 -- if necessary.
1583 --
1584 -- For example, if we start with
1585 -- do x <- E1; y <- E2; return (f x y)
1586 -- then we get
1587 -- do (E1[x] | E2[y]); f x y
1588 --
1589 -- the LastStmt in this case has the return removed, but we set the
1590 -- flag on the LastStmt to indicate this, so that we can print out the
1591 -- original statement correctly in error messages. It is easier to do
1592 -- it this way rather than try to ignore the return later in both the
1593 -- typechecker and the desugarer (I tried it that way first!).
1594 mkApplicativeStmt
1595 :: HsStmtContext Name
1596 -> [ApplicativeArg Name Name] -- ^ The args
1597 -> Bool -- ^ True <=> need a join
1598 -> [LStmt Name (LHsExpr Name)] -- ^ The body statements
1599 -> RnM ([LStmt Name (LHsExpr Name)], FreeVars)
1600 mkApplicativeStmt ctxt args need_join body_stmts
1601 = do { (fmap_op, fvs1) <- lookupStmtName ctxt fmapName
1602 ; (ap_op, fvs2) <- lookupStmtName ctxt apAName
1603 ; (mb_join, fvs3) <-
1604 if need_join then
1605 do { (join_op, fvs) <- lookupStmtName ctxt joinMName
1606 ; return (Just join_op, fvs) }
1607 else
1608 return (Nothing, emptyNameSet)
1609 ; let applicative_stmt = noLoc $ ApplicativeStmt
1610 (zip (fmap_op : repeat ap_op) args)
1611 mb_join
1612 placeHolderType
1613 ; return ( applicative_stmt : body_stmts
1614 , fvs1 `plusFV` fvs2 `plusFV` fvs3) }
1615
1616 -- | Given the statements following an ApplicativeStmt, determine whether
1617 -- we need a @join@ or not, and remove the @return@ if necessary.
1618 needJoin :: [LStmt Name (LHsExpr Name)] -> (Bool, [LStmt Name (LHsExpr Name)])
1619 needJoin [] = (False, []) -- we're in an ApplicativeArg
1620 needJoin [L loc (LastStmt e _ t)]
1621 | Just arg <- isReturnApp e = (False, [L loc (LastStmt arg True t)])
1622 needJoin stmts = (True, stmts)
1623
1624 -- | @Just e@, if the expression is @return e@, otherwise @Nothing@
1625 isReturnApp :: LHsExpr Name -> Maybe (LHsExpr Name)
1626 isReturnApp (L _ (HsPar expr)) = isReturnApp expr
1627 isReturnApp (L _ (HsApp f arg))
1628 | is_return f = Just arg
1629 | otherwise = Nothing
1630 where
1631 is_return (L _ (HsPar e)) = is_return e
1632 is_return (L _ (HsVar r)) = r == returnMName
1633 -- TODO: I don't know how to get this right for rebindable syntax
1634 is_return _ = False
1635 isReturnApp _ = Nothing
1636
1637
1638 {-
1639 ************************************************************************
1640 * *
1641 \subsubsection{Errors}
1642 * *
1643 ************************************************************************
1644 -}
1645
1646 checkEmptyStmts :: HsStmtContext Name -> RnM ()
1647 -- We've seen an empty sequence of Stmts... is that ok?
1648 checkEmptyStmts ctxt
1649 = unless (okEmpty ctxt) (addErr (emptyErr ctxt))
1650
1651 okEmpty :: HsStmtContext a -> Bool
1652 okEmpty (PatGuard {}) = True
1653 okEmpty _ = False
1654
1655 emptyErr :: HsStmtContext Name -> SDoc
1656 emptyErr (ParStmtCtxt {}) = ptext (sLit "Empty statement group in parallel comprehension")
1657 emptyErr (TransStmtCtxt {}) = ptext (sLit "Empty statement group preceding 'group' or 'then'")
1658 emptyErr ctxt = ptext (sLit "Empty") <+> pprStmtContext ctxt
1659
1660 ----------------------
1661 checkLastStmt :: Outputable (body RdrName) => HsStmtContext Name
1662 -> LStmt RdrName (Located (body RdrName))
1663 -> RnM (LStmt RdrName (Located (body RdrName)))
1664 checkLastStmt ctxt lstmt@(L loc stmt)
1665 = case ctxt of
1666 ListComp -> check_comp
1667 MonadComp -> check_comp
1668 PArrComp -> check_comp
1669 ArrowExpr -> check_do
1670 DoExpr -> check_do
1671 MDoExpr -> check_do
1672 _ -> check_other
1673 where
1674 check_do -- Expect BodyStmt, and change it to LastStmt
1675 = case stmt of
1676 BodyStmt e _ _ _ -> return (L loc (mkLastStmt e))
1677 LastStmt {} -> return lstmt -- "Deriving" clauses may generate a
1678 -- LastStmt directly (unlike the parser)
1679 _ -> do { addErr (hang last_error 2 (ppr stmt)); return lstmt }
1680 last_error = (ptext (sLit "The last statement in") <+> pprAStmtContext ctxt
1681 <+> ptext (sLit "must be an expression"))
1682
1683 check_comp -- Expect LastStmt; this should be enforced by the parser!
1684 = case stmt of
1685 LastStmt {} -> return lstmt
1686 _ -> pprPanic "checkLastStmt" (ppr lstmt)
1687
1688 check_other -- Behave just as if this wasn't the last stmt
1689 = do { checkStmt ctxt lstmt; return lstmt }
1690
1691 -- Checking when a particular Stmt is ok
1692 checkStmt :: HsStmtContext Name
1693 -> LStmt RdrName (Located (body RdrName))
1694 -> RnM ()
1695 checkStmt ctxt (L _ stmt)
1696 = do { dflags <- getDynFlags
1697 ; case okStmt dflags ctxt stmt of
1698 IsValid -> return ()
1699 NotValid extra -> addErr (msg $$ extra) }
1700 where
1701 msg = sep [ ptext (sLit "Unexpected") <+> pprStmtCat stmt <+> ptext (sLit "statement")
1702 , ptext (sLit "in") <+> pprAStmtContext ctxt ]
1703
1704 pprStmtCat :: Stmt a body -> SDoc
1705 pprStmtCat (TransStmt {}) = ptext (sLit "transform")
1706 pprStmtCat (LastStmt {}) = ptext (sLit "return expression")
1707 pprStmtCat (BodyStmt {}) = ptext (sLit "body")
1708 pprStmtCat (BindStmt {}) = ptext (sLit "binding")
1709 pprStmtCat (LetStmt {}) = ptext (sLit "let")
1710 pprStmtCat (RecStmt {}) = ptext (sLit "rec")
1711 pprStmtCat (ParStmt {}) = ptext (sLit "parallel")
1712 pprStmtCat (ApplicativeStmt {}) = panic "pprStmtCat: ApplicativeStmt"
1713
1714 ------------
1715 emptyInvalid :: Validity -- Payload is the empty document
1716 emptyInvalid = NotValid Outputable.empty
1717
1718 okStmt, okDoStmt, okCompStmt, okParStmt, okPArrStmt
1719 :: DynFlags -> HsStmtContext Name
1720 -> Stmt RdrName (Located (body RdrName)) -> Validity
1721 -- Return Nothing if OK, (Just extra) if not ok
1722 -- The "extra" is an SDoc that is appended to an generic error message
1723
1724 okStmt dflags ctxt stmt
1725 = case ctxt of
1726 PatGuard {} -> okPatGuardStmt stmt
1727 ParStmtCtxt ctxt -> okParStmt dflags ctxt stmt
1728 DoExpr -> okDoStmt dflags ctxt stmt
1729 MDoExpr -> okDoStmt dflags ctxt stmt
1730 ArrowExpr -> okDoStmt dflags ctxt stmt
1731 GhciStmtCtxt -> okDoStmt dflags ctxt stmt
1732 ListComp -> okCompStmt dflags ctxt stmt
1733 MonadComp -> okCompStmt dflags ctxt stmt
1734 PArrComp -> okPArrStmt dflags ctxt stmt
1735 TransStmtCtxt ctxt -> okStmt dflags ctxt stmt
1736
1737 -------------
1738 okPatGuardStmt :: Stmt RdrName (Located (body RdrName)) -> Validity
1739 okPatGuardStmt stmt
1740 = case stmt of
1741 BodyStmt {} -> IsValid
1742 BindStmt {} -> IsValid
1743 LetStmt {} -> IsValid
1744 _ -> emptyInvalid
1745
1746 -------------
1747 okParStmt dflags ctxt stmt
1748 = case stmt of
1749 LetStmt (HsIPBinds {}) -> emptyInvalid
1750 _ -> okStmt dflags ctxt stmt
1751
1752 ----------------
1753 okDoStmt dflags ctxt stmt
1754 = case stmt of
1755 RecStmt {}
1756 | Opt_RecursiveDo `xopt` dflags -> IsValid
1757 | ArrowExpr <- ctxt -> IsValid -- Arrows allows 'rec'
1758 | otherwise -> NotValid (ptext (sLit "Use RecursiveDo"))
1759 BindStmt {} -> IsValid
1760 LetStmt {} -> IsValid
1761 BodyStmt {} -> IsValid
1762 _ -> emptyInvalid
1763
1764 ----------------
1765 okCompStmt dflags _ stmt
1766 = case stmt of
1767 BindStmt {} -> IsValid
1768 LetStmt {} -> IsValid
1769 BodyStmt {} -> IsValid
1770 ParStmt {}
1771 | Opt_ParallelListComp `xopt` dflags -> IsValid
1772 | otherwise -> NotValid (ptext (sLit "Use ParallelListComp"))
1773 TransStmt {}
1774 | Opt_TransformListComp `xopt` dflags -> IsValid
1775 | otherwise -> NotValid (ptext (sLit "Use TransformListComp"))
1776 RecStmt {} -> emptyInvalid
1777 LastStmt {} -> emptyInvalid -- Should not happen (dealt with by checkLastStmt)
1778 ApplicativeStmt {} -> emptyInvalid
1779
1780 ----------------
1781 okPArrStmt dflags _ stmt
1782 = case stmt of
1783 BindStmt {} -> IsValid
1784 LetStmt {} -> IsValid
1785 BodyStmt {} -> IsValid
1786 ParStmt {}
1787 | Opt_ParallelListComp `xopt` dflags -> IsValid
1788 | otherwise -> NotValid (ptext (sLit "Use ParallelListComp"))
1789 TransStmt {} -> emptyInvalid
1790 RecStmt {} -> emptyInvalid
1791 LastStmt {} -> emptyInvalid -- Should not happen (dealt with by checkLastStmt)
1792 ApplicativeStmt {} -> emptyInvalid
1793
1794 ---------
1795 checkTupleSection :: [LHsTupArg RdrName] -> RnM ()
1796 checkTupleSection args
1797 = do { tuple_section <- xoptM Opt_TupleSections
1798 ; checkErr (all tupArgPresent args || tuple_section) msg }
1799 where
1800 msg = ptext (sLit "Illegal tuple section: use TupleSections")
1801
1802 ---------
1803 sectionErr :: HsExpr RdrName -> SDoc
1804 sectionErr expr
1805 = hang (ptext (sLit "A section must be enclosed in parentheses"))
1806 2 (ptext (sLit "thus:") <+> (parens (ppr expr)))
1807
1808 patSynErr :: HsExpr RdrName -> RnM (HsExpr Name, FreeVars)
1809 patSynErr e = do { addErr (sep [ptext (sLit "Pattern syntax in expression context:"),
1810 nest 4 (ppr e)])
1811 ; return (EWildPat, emptyFVs) }
1812
1813 badIpBinds :: Outputable a => SDoc -> a -> SDoc
1814 badIpBinds what binds
1815 = hang (ptext (sLit "Implicit-parameter bindings illegal in") <+> what)
1816 2 (ppr binds)