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