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