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