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