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