Refactor treatment of wildcards
[ghc.git] / compiler / rename / RnExpr.hs
1 {-
2 (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
3
4 \section[RnExpr]{Renaming of expressions}
5
6 Basically dependency analysis.
7
8 Handles @Match@, @GRHSs@, @HsExpr@, and @Qualifier@ datatypes. In
9 general, all of these functions return a renamed thing, and a set of
10 free variables.
11 -}
12
13 {-# LANGUAGE CPP #-}
14 {-# LANGUAGE ScopedTypeVariables #-}
15
16 module RnExpr (
17 rnLExpr, rnExpr, rnStmts
18 ) where
19
20 #include "HsVersions.h"
21
22 import RnBinds ( rnLocalBindsAndThen, rnLocalValBindsLHS, rnLocalValBindsRHS,
23 rnMatchGroup, rnGRHS, makeMiniFixityEnv)
24 import HsSyn
25 import TcRnMonad
26 import Module ( getModule )
27 import RnEnv
28 import RnSplice ( rnBracket, rnSpliceExpr, checkThLocalName )
29 import RnTypes
30 import RnPat
31 import DynFlags
32 import PrelNames
33
34 import BasicTypes
35 import Name
36 import NameSet
37 import RdrName
38 import UniqSet
39 import Data.List
40 import Util
41 import ListSetOps ( removeDups )
42 import ErrUtils
43 import Outputable
44 import SrcLoc
45 import FastString
46 import Control.Monad
47 import TysWiredIn ( nilDataConName )
48
49 {-
50 ************************************************************************
51 * *
52 \subsubsection{Expressions}
53 * *
54 ************************************************************************
55 -}
56
57 rnExprs :: [LHsExpr RdrName] -> RnM ([LHsExpr Name], FreeVars)
58 rnExprs ls = rnExprs' ls emptyUniqSet
59 where
60 rnExprs' [] acc = return ([], acc)
61 rnExprs' (expr:exprs) acc =
62 do { (expr', fvExpr) <- rnLExpr expr
63 -- Now we do a "seq" on the free vars because typically it's small
64 -- or empty, especially in very long lists of constants
65 ; let acc' = acc `plusFV` fvExpr
66 ; (exprs', fvExprs) <- acc' `seq` rnExprs' exprs acc'
67 ; return (expr':exprs', fvExprs) }
68
69 -- Variables. We look up the variable and return the resulting name.
70
71 rnLExpr :: LHsExpr RdrName -> RnM (LHsExpr Name, FreeVars)
72 rnLExpr = wrapLocFstM rnExpr
73
74 rnExpr :: HsExpr RdrName -> RnM (HsExpr Name, FreeVars)
75
76 finishHsVar :: Located Name -> RnM (HsExpr Name, FreeVars)
77 -- Separated from rnExpr because it's also used
78 -- when renaming infix expressions
79 finishHsVar (L l name)
80 = do { this_mod <- getModule
81 ; when (nameIsLocalOrFrom this_mod name) $
82 checkThLocalName name
83 ; return (HsVar (L l name), unitFV name) }
84
85 rnUnboundVar :: RdrName -> RnM (HsExpr Name, FreeVars)
86 rnUnboundVar v
87 = do { if isUnqual v
88 then -- Treat this as a "hole"
89 -- Do not fail right now; instead, return HsUnboundVar
90 -- and let the type checker report the error
91 return (HsUnboundVar (rdrNameOcc v), emptyFVs)
92
93 else -- Fail immediately (qualified name)
94 do { n <- reportUnboundName v
95 ; return (HsVar (noLoc n), emptyFVs) } }
96
97 rnExpr (HsVar (L l v))
98 = do { opt_DuplicateRecordFields <- xoptM Opt_DuplicateRecordFields
99 ; mb_name <- lookupOccRn_overloaded opt_DuplicateRecordFields v
100 ; case mb_name of {
101 Nothing -> rnUnboundVar v ;
102 Just (Left name)
103 | name == nilDataConName -- Treat [] as an ExplicitList, so that
104 -- OverloadedLists works correctly
105 -> rnExpr (ExplicitList placeHolderType Nothing [])
106
107 | otherwise
108 -> finishHsVar (L l name) ;
109 Just (Right [f]) -> return (HsRecFld (ambiguousFieldOcc f)
110 , unitFV (selectorFieldOcc f)) ;
111 Just (Right fs@(_:_:_)) -> return (HsRecFld (Ambiguous v PlaceHolder)
112 , mkFVs (map selectorFieldOcc fs));
113 Just (Right []) -> error "runExpr/HsVar" } }
114
115 rnExpr (HsIPVar v)
116 = return (HsIPVar v, emptyFVs)
117
118 rnExpr (HsOverLabel v)
119 = return (HsOverLabel v, emptyFVs)
120
121 rnExpr (HsLit lit@(HsString src s))
122 = do { opt_OverloadedStrings <- xoptM Opt_OverloadedStrings
123 ; if opt_OverloadedStrings then
124 rnExpr (HsOverLit (mkHsIsString src s placeHolderType))
125 else do {
126 ; rnLit lit
127 ; return (HsLit lit, emptyFVs) } }
128
129 rnExpr (HsLit lit)
130 = do { rnLit lit
131 ; return (HsLit lit, emptyFVs) }
132
133 rnExpr (HsOverLit lit)
134 = do { (lit', fvs) <- rnOverLit lit
135 ; return (HsOverLit lit', fvs) }
136
137 rnExpr (HsApp fun arg)
138 = do { (fun',fvFun) <- rnLExpr fun
139 ; (arg',fvArg) <- rnLExpr arg
140 ; return (HsApp fun' arg', fvFun `plusFV` fvArg) }
141
142 rnExpr (OpApp e1 op _ e2)
143 = do { (e1', fv_e1) <- rnLExpr e1
144 ; (e2', fv_e2) <- rnLExpr e2
145 ; (op', fv_op) <- rnLExpr op
146
147 -- Deal with fixity
148 -- When renaming code synthesised from "deriving" declarations
149 -- we used to avoid fixity stuff, but we can't easily tell any
150 -- more, so I've removed the test. Adding HsPars in TcGenDeriv
151 -- should prevent bad things happening.
152 ; fixity <- case op' of
153 L _ (HsVar (L _ n)) -> lookupFixityRn n
154 _ -> return (Fixity minPrecedence InfixL)
155 -- c.f. lookupFixity for unbound
156
157 ; final_e <- mkOpAppRn e1' op' fixity e2'
158 ; return (final_e, fv_e1 `plusFV` fv_op `plusFV` fv_e2) }
159
160 rnExpr (NegApp e _)
161 = do { (e', fv_e) <- rnLExpr e
162 ; (neg_name, fv_neg) <- lookupSyntaxName negateName
163 ; final_e <- mkNegAppRn e' neg_name
164 ; return (final_e, fv_e `plusFV` fv_neg) }
165
166 ------------------------------------------
167 -- Template Haskell extensions
168 -- Don't ifdef-GHCI them because we want to fail gracefully
169 -- (not with an rnExpr crash) in a stage-1 compiler.
170 rnExpr e@(HsBracket br_body) = rnBracket e br_body
171
172 rnExpr (HsSpliceE splice) = rnSpliceExpr splice
173
174 ---------------------------------------------
175 -- Sections
176 -- See Note [Parsing sections] in Parser.y
177 rnExpr (HsPar (L loc (section@(SectionL {}))))
178 = do { (section', fvs) <- rnSection section
179 ; return (HsPar (L loc section'), fvs) }
180
181 rnExpr (HsPar (L loc (section@(SectionR {}))))
182 = do { (section', fvs) <- rnSection section
183 ; return (HsPar (L loc section'), fvs) }
184
185 rnExpr (HsPar e)
186 = do { (e', fvs_e) <- rnLExpr e
187 ; return (HsPar e', fvs_e) }
188
189 rnExpr expr@(SectionL {})
190 = do { addErr (sectionErr expr); rnSection expr }
191 rnExpr expr@(SectionR {})
192 = do { addErr (sectionErr expr); rnSection expr }
193
194 ---------------------------------------------
195 rnExpr (HsCoreAnn src ann expr)
196 = do { (expr', fvs_expr) <- rnLExpr expr
197 ; return (HsCoreAnn src ann expr', fvs_expr) }
198
199 rnExpr (HsSCC src lbl expr)
200 = do { (expr', fvs_expr) <- rnLExpr expr
201 ; return (HsSCC src lbl expr', fvs_expr) }
202 rnExpr (HsTickPragma src info expr)
203 = do { (expr', fvs_expr) <- rnLExpr expr
204 ; return (HsTickPragma src info expr', fvs_expr) }
205
206 rnExpr (HsLam matches)
207 = do { (matches', fvMatch) <- rnMatchGroup LambdaExpr rnLExpr matches
208 ; return (HsLam matches', fvMatch) }
209
210 rnExpr (HsLamCase _arg matches)
211 = do { (matches', fvs_ms) <- rnMatchGroup CaseAlt rnLExpr matches
212 -- ; return (HsLamCase arg matches', fvs_ms) }
213 ; return (HsLamCase placeHolderType matches', fvs_ms) }
214
215 rnExpr (HsCase expr matches)
216 = do { (new_expr, e_fvs) <- rnLExpr expr
217 ; (new_matches, ms_fvs) <- rnMatchGroup CaseAlt rnLExpr matches
218 ; return (HsCase new_expr new_matches, e_fvs `plusFV` ms_fvs) }
219
220 rnExpr (HsLet (L l binds) expr)
221 = rnLocalBindsAndThen binds $ \binds' _ -> do
222 { (expr',fvExpr) <- rnLExpr expr
223 ; return (HsLet (L l binds') expr', fvExpr) }
224
225 rnExpr (HsDo do_or_lc (L l stmts) _)
226 = do { ((stmts', _), fvs) <-
227 rnStmtsWithPostProcessing do_or_lc rnLExpr
228 postProcessStmtsForApplicativeDo stmts
229 (\ _ -> return ((), emptyFVs))
230 ; return ( HsDo do_or_lc (L l stmts') placeHolderType, fvs ) }
231
232 rnExpr (ExplicitList _ _ exps)
233 = do { opt_OverloadedLists <- xoptM Opt_OverloadedLists
234 ; (exps', fvs) <- rnExprs exps
235 ; if opt_OverloadedLists
236 then do {
237 ; (from_list_n_name, fvs') <- lookupSyntaxName fromListNName
238 ; return (ExplicitList placeHolderType (Just from_list_n_name) exps'
239 , fvs `plusFV` fvs') }
240 else
241 return (ExplicitList placeHolderType Nothing exps', fvs) }
242
243 rnExpr (ExplicitPArr _ exps)
244 = do { (exps', fvs) <- rnExprs exps
245 ; return (ExplicitPArr placeHolderType exps', fvs) }
246
247 rnExpr (ExplicitTuple tup_args boxity)
248 = do { checkTupleSection tup_args
249 ; checkTupSize (length tup_args)
250 ; (tup_args', fvs) <- mapAndUnzipM rnTupArg tup_args
251 ; return (ExplicitTuple tup_args' boxity, plusFVs fvs) }
252 where
253 rnTupArg (L l (Present e)) = do { (e',fvs) <- rnLExpr e
254 ; return (L l (Present e'), fvs) }
255 rnTupArg (L l (Missing _)) = return (L l (Missing placeHolderType)
256 , emptyFVs)
257
258 rnExpr (RecordCon { rcon_con_name = con_id
259 , rcon_flds = rec_binds@(HsRecFields { rec_dotdot = dd }) })
260 = do { con_lname@(L _ con_name) <- lookupLocatedOccRn con_id
261 ; (flds, fvs) <- rnHsRecFields (HsRecFieldCon con_name) mk_hs_var rec_binds
262 ; (flds', fvss) <- mapAndUnzipM rn_field flds
263 ; let rec_binds' = HsRecFields { rec_flds = flds', rec_dotdot = dd }
264 ; return (RecordCon { rcon_con_name = con_lname, rcon_flds = rec_binds'
265 , rcon_con_expr = noPostTcExpr, rcon_con_like = PlaceHolder }
266 , fvs `plusFV` plusFVs fvss `addOneFV` con_name) }
267 where
268 mk_hs_var l n = HsVar (L l n)
269 rn_field (L l fld) = do { (arg', fvs) <- rnLExpr (hsRecFieldArg fld)
270 ; return (L l (fld { hsRecFieldArg = arg' }), fvs) }
271
272 rnExpr (RecordUpd { rupd_expr = expr, rupd_flds = rbinds })
273 = do { (expr', fvExpr) <- rnLExpr expr
274 ; (rbinds', fvRbinds) <- rnHsRecUpdFields rbinds
275 ; return (RecordUpd { rupd_expr = expr', rupd_flds = rbinds'
276 , rupd_cons = PlaceHolder, rupd_in_tys = PlaceHolder
277 , rupd_out_tys = PlaceHolder, rupd_wrap = PlaceHolder }
278 , fvExpr `plusFV` fvRbinds) }
279
280 rnExpr (ExprWithTySig expr pty)
281 = do { (pty', fvTy) <- rnHsSigWcType ExprWithTySigCtx pty
282 ; (expr', fvExpr) <- bindSigTyVarsFV (hsWcScopedTvs pty') $
283 rnLExpr expr
284 ; return (ExprWithTySig expr' pty', fvExpr `plusFV` fvTy) }
285
286 rnExpr (HsIf _ p b1 b2)
287 = do { (p', fvP) <- rnLExpr p
288 ; (b1', fvB1) <- rnLExpr b1
289 ; (b2', fvB2) <- rnLExpr b2
290 ; (mb_ite, fvITE) <- lookupIfThenElse
291 ; return (HsIf mb_ite p' b1' b2', plusFVs [fvITE, fvP, fvB1, fvB2]) }
292
293 rnExpr (HsMultiIf _ty alts)
294 = do { (alts', fvs) <- mapFvRn (rnGRHS IfAlt rnLExpr) alts
295 -- ; return (HsMultiIf ty alts', fvs) }
296 ; return (HsMultiIf placeHolderType alts', fvs) }
297
298 rnExpr (HsType a)
299 = do { (t, fvT) <- rnLHsType HsTypeCtx a
300 ; return (HsType t, fvT) }
301
302 rnExpr (ArithSeq _ _ seq)
303 = do { opt_OverloadedLists <- xoptM Opt_OverloadedLists
304 ; (new_seq, fvs) <- rnArithSeq seq
305 ; if opt_OverloadedLists
306 then do {
307 ; (from_list_name, fvs') <- lookupSyntaxName fromListName
308 ; return (ArithSeq noPostTcExpr (Just from_list_name) new_seq, fvs `plusFV` fvs') }
309 else
310 return (ArithSeq noPostTcExpr Nothing new_seq, fvs) }
311
312 rnExpr (PArrSeq _ seq)
313 = do { (new_seq, fvs) <- rnArithSeq seq
314 ; return (PArrSeq noPostTcExpr new_seq, fvs) }
315
316 {-
317 These three are pattern syntax appearing in expressions.
318 Since all the symbols are reservedops we can simply reject them.
319 We return a (bogus) EWildPat in each case.
320 -}
321
322 rnExpr EWildPat = return (hsHoleExpr, emptyFVs) -- "_" is just a hole
323 rnExpr e@(EAsPat {}) = patSynErr e
324 rnExpr e@(EViewPat {}) = patSynErr e
325 rnExpr e@(ELazyPat {}) = patSynErr e
326
327 {-
328 ************************************************************************
329 * *
330 Static values
331 * *
332 ************************************************************************
333
334 For the static form we check that the free variables are all top-level
335 value bindings. This is done by checking that the name is external or
336 wired-in. See the Notes about the NameSorts in Name.hs.
337 -}
338
339 rnExpr e@(HsStatic expr) = do
340 target <- fmap hscTarget getDynFlags
341 case target of
342 -- SPT entries are expected to exist in object code so far, and this is
343 -- not the case in interpreted mode. See bug #9878.
344 HscInterpreted -> addErr $ sep
345 [ text "The static form is not supported in interpreted mode."
346 , text "Please use -fobject-code."
347 ]
348 _ -> return ()
349 (expr',fvExpr) <- rnLExpr expr
350 stage <- getStage
351 case stage of
352 Brack _ _ -> return () -- Don't check names if we are inside brackets.
353 -- We don't want to reject cases like:
354 -- \e -> [| static $(e) |]
355 -- if $(e) turns out to produce a legal expression.
356 Splice _ -> addErr $ sep
357 [ text "static forms cannot be used in splices:"
358 , nest 2 $ ppr e
359 ]
360 _ -> do
361 let isTopLevelName n = isExternalName n || isWiredInName n
362 case nameSetElems $ filterNameSet
363 (\n -> not (isTopLevelName n || isUnboundName n))
364 fvExpr of
365 [] -> return ()
366 fvNonGlobal -> addErr $ cat
367 [ text $ "Only identifiers of top-level bindings can "
368 ++ "appear in the body of the static form:"
369 , nest 2 $ ppr e
370 , text "but the following identifiers were found instead:"
371 , nest 2 $ vcat $ map ppr fvNonGlobal
372 ]
373 return (HsStatic expr', fvExpr)
374
375 {-
376 ************************************************************************
377 * *
378 Arrow notation
379 * *
380 ************************************************************************
381 -}
382
383 rnExpr (HsProc pat body)
384 = newArrowScope $
385 rnPat ProcExpr pat $ \ pat' -> do
386 { (body',fvBody) <- rnCmdTop body
387 ; return (HsProc pat' body', fvBody) }
388
389 -- Ideally, these would be done in parsing, but to keep parsing simple, we do it here.
390 rnExpr e@(HsArrApp {}) = arrowFail e
391 rnExpr e@(HsArrForm {}) = arrowFail e
392
393 rnExpr other = pprPanic "rnExpr: unexpected expression" (ppr other)
394 -- HsWrap
395
396 hsHoleExpr :: HsExpr id
397 hsHoleExpr = HsUnboundVar (mkVarOcc "_")
398
399 arrowFail :: HsExpr RdrName -> RnM (HsExpr Name, FreeVars)
400 arrowFail e
401 = do { addErr (vcat [ ptext (sLit "Arrow command found where an expression was expected:")
402 , nest 2 (ppr e) ])
403 -- Return a place-holder hole, so that we can carry on
404 -- to report other errors
405 ; return (hsHoleExpr, emptyFVs) }
406
407 ----------------------
408 -- See Note [Parsing sections] in Parser.y
409 rnSection :: HsExpr RdrName -> RnM (HsExpr Name, FreeVars)
410 rnSection section@(SectionR op expr)
411 = do { (op', fvs_op) <- rnLExpr op
412 ; (expr', fvs_expr) <- rnLExpr expr
413 ; checkSectionPrec InfixR section op' expr'
414 ; return (SectionR op' expr', fvs_op `plusFV` fvs_expr) }
415
416 rnSection section@(SectionL expr op)
417 = do { (expr', fvs_expr) <- rnLExpr expr
418 ; (op', fvs_op) <- rnLExpr op
419 ; checkSectionPrec InfixL section op' expr'
420 ; return (SectionL expr' op', fvs_op `plusFV` fvs_expr) }
421
422 rnSection other = pprPanic "rnSection" (ppr other)
423
424 {-
425 ************************************************************************
426 * *
427 Arrow commands
428 * *
429 ************************************************************************
430 -}
431
432 rnCmdArgs :: [LHsCmdTop RdrName] -> RnM ([LHsCmdTop Name], FreeVars)
433 rnCmdArgs [] = return ([], emptyFVs)
434 rnCmdArgs (arg:args)
435 = do { (arg',fvArg) <- rnCmdTop arg
436 ; (args',fvArgs) <- rnCmdArgs args
437 ; return (arg':args', fvArg `plusFV` fvArgs) }
438
439 rnCmdTop :: LHsCmdTop RdrName -> RnM (LHsCmdTop Name, FreeVars)
440 rnCmdTop = wrapLocFstM rnCmdTop'
441 where
442 rnCmdTop' (HsCmdTop cmd _ _ _)
443 = do { (cmd', fvCmd) <- rnLCmd cmd
444 ; let cmd_names = [arrAName, composeAName, firstAName] ++
445 nameSetElems (methodNamesCmd (unLoc cmd'))
446 -- Generate the rebindable syntax for the monad
447 ; (cmd_names', cmd_fvs) <- lookupSyntaxNames cmd_names
448
449 ; return (HsCmdTop cmd' placeHolderType placeHolderType
450 (cmd_names `zip` cmd_names'),
451 fvCmd `plusFV` cmd_fvs) }
452
453 rnLCmd :: LHsCmd RdrName -> RnM (LHsCmd Name, FreeVars)
454 rnLCmd = wrapLocFstM rnCmd
455
456 rnCmd :: HsCmd RdrName -> RnM (HsCmd Name, FreeVars)
457
458 rnCmd (HsCmdArrApp arrow arg _ ho rtl)
459 = do { (arrow',fvArrow) <- select_arrow_scope (rnLExpr arrow)
460 ; (arg',fvArg) <- rnLExpr arg
461 ; return (HsCmdArrApp arrow' arg' placeHolderType ho rtl,
462 fvArrow `plusFV` fvArg) }
463 where
464 select_arrow_scope tc = case ho of
465 HsHigherOrderApp -> tc
466 HsFirstOrderApp -> escapeArrowScope tc
467 -- See Note [Escaping the arrow scope] in TcRnTypes
468 -- Before renaming 'arrow', use the environment of the enclosing
469 -- proc for the (-<) case.
470 -- Local bindings, inside the enclosing proc, are not in scope
471 -- inside 'arrow'. In the higher-order case (-<<), they are.
472
473 -- infix form
474 rnCmd (HsCmdArrForm op (Just _) [arg1, arg2])
475 = do { (op',fv_op) <- escapeArrowScope (rnLExpr op)
476 ; let L _ (HsVar (L _ op_name)) = op'
477 ; (arg1',fv_arg1) <- rnCmdTop arg1
478 ; (arg2',fv_arg2) <- rnCmdTop arg2
479 -- Deal with fixity
480 ; fixity <- lookupFixityRn op_name
481 ; final_e <- mkOpFormRn arg1' op' fixity arg2'
482 ; return (final_e, fv_arg1 `plusFV` fv_op `plusFV` fv_arg2) }
483
484 rnCmd (HsCmdArrForm op fixity cmds)
485 = do { (op',fvOp) <- escapeArrowScope (rnLExpr op)
486 ; (cmds',fvCmds) <- rnCmdArgs cmds
487 ; return (HsCmdArrForm op' fixity cmds', fvOp `plusFV` fvCmds) }
488
489 rnCmd (HsCmdApp fun arg)
490 = do { (fun',fvFun) <- rnLCmd fun
491 ; (arg',fvArg) <- rnLExpr arg
492 ; return (HsCmdApp fun' arg', fvFun `plusFV` fvArg) }
493
494 rnCmd (HsCmdLam matches)
495 = do { (matches', fvMatch) <- rnMatchGroup LambdaExpr rnLCmd matches
496 ; return (HsCmdLam matches', fvMatch) }
497
498 rnCmd (HsCmdPar e)
499 = do { (e', fvs_e) <- rnLCmd e
500 ; return (HsCmdPar e', fvs_e) }
501
502 rnCmd (HsCmdCase expr matches)
503 = do { (new_expr, e_fvs) <- rnLExpr expr
504 ; (new_matches, ms_fvs) <- rnMatchGroup CaseAlt rnLCmd matches
505 ; return (HsCmdCase new_expr new_matches, e_fvs `plusFV` ms_fvs) }
506
507 rnCmd (HsCmdIf _ p b1 b2)
508 = do { (p', fvP) <- rnLExpr p
509 ; (b1', fvB1) <- rnLCmd b1
510 ; (b2', fvB2) <- rnLCmd b2
511 ; (mb_ite, fvITE) <- lookupIfThenElse
512 ; return (HsCmdIf mb_ite p' b1' b2', plusFVs [fvITE, fvP, fvB1, fvB2]) }
513
514 rnCmd (HsCmdLet (L l binds) cmd)
515 = rnLocalBindsAndThen binds $ \ binds' _ -> do
516 { (cmd',fvExpr) <- rnLCmd cmd
517 ; return (HsCmdLet (L l binds') cmd', fvExpr) }
518
519 rnCmd (HsCmdDo (L l stmts) _)
520 = do { ((stmts', _), fvs) <-
521 rnStmts ArrowExpr rnLCmd stmts (\ _ -> return ((), emptyFVs))
522 ; return ( HsCmdDo (L l stmts') placeHolderType, fvs ) }
523
524 rnCmd cmd@(HsCmdCast {}) = pprPanic "rnCmd" (ppr cmd)
525
526 ---------------------------------------------------
527 type CmdNeeds = FreeVars -- Only inhabitants are
528 -- appAName, choiceAName, loopAName
529
530 -- find what methods the Cmd needs (loop, choice, apply)
531 methodNamesLCmd :: LHsCmd Name -> CmdNeeds
532 methodNamesLCmd = methodNamesCmd . unLoc
533
534 methodNamesCmd :: HsCmd Name -> CmdNeeds
535
536 methodNamesCmd (HsCmdArrApp _arrow _arg _ HsFirstOrderApp _rtl)
537 = emptyFVs
538 methodNamesCmd (HsCmdArrApp _arrow _arg _ HsHigherOrderApp _rtl)
539 = unitFV appAName
540 methodNamesCmd (HsCmdArrForm {}) = emptyFVs
541 methodNamesCmd (HsCmdCast _ cmd) = methodNamesCmd cmd
542
543 methodNamesCmd (HsCmdPar c) = methodNamesLCmd c
544
545 methodNamesCmd (HsCmdIf _ _ c1 c2)
546 = methodNamesLCmd c1 `plusFV` methodNamesLCmd c2 `addOneFV` choiceAName
547
548 methodNamesCmd (HsCmdLet _ c) = methodNamesLCmd c
549 methodNamesCmd (HsCmdDo (L _ stmts) _) = methodNamesStmts stmts
550 methodNamesCmd (HsCmdApp c _) = methodNamesLCmd c
551 methodNamesCmd (HsCmdLam match) = methodNamesMatch match
552
553 methodNamesCmd (HsCmdCase _ matches)
554 = methodNamesMatch matches `addOneFV` choiceAName
555
556 --methodNamesCmd _ = emptyFVs
557 -- Other forms can't occur in commands, but it's not convenient
558 -- to error here so we just do what's convenient.
559 -- The type checker will complain later
560
561 ---------------------------------------------------
562 methodNamesMatch :: MatchGroup Name (LHsCmd Name) -> FreeVars
563 methodNamesMatch (MG { mg_alts = L _ ms })
564 = plusFVs (map do_one ms)
565 where
566 do_one (L _ (Match _ _ _ grhss)) = methodNamesGRHSs grhss
567
568 -------------------------------------------------
569 -- gaw 2004
570 methodNamesGRHSs :: GRHSs Name (LHsCmd Name) -> FreeVars
571 methodNamesGRHSs (GRHSs grhss _) = plusFVs (map methodNamesGRHS grhss)
572
573 -------------------------------------------------
574
575 methodNamesGRHS :: Located (GRHS Name (LHsCmd Name)) -> CmdNeeds
576 methodNamesGRHS (L _ (GRHS _ rhs)) = methodNamesLCmd rhs
577
578 ---------------------------------------------------
579 methodNamesStmts :: [Located (StmtLR Name Name (LHsCmd Name))] -> FreeVars
580 methodNamesStmts stmts = plusFVs (map methodNamesLStmt stmts)
581
582 ---------------------------------------------------
583 methodNamesLStmt :: Located (StmtLR Name Name (LHsCmd Name)) -> FreeVars
584 methodNamesLStmt = methodNamesStmt . unLoc
585
586 methodNamesStmt :: StmtLR Name Name (LHsCmd Name) -> FreeVars
587 methodNamesStmt (LastStmt cmd _ _) = methodNamesLCmd cmd
588 methodNamesStmt (BodyStmt cmd _ _ _) = methodNamesLCmd cmd
589 methodNamesStmt (BindStmt _ cmd _ _) = methodNamesLCmd cmd
590 methodNamesStmt (RecStmt { recS_stmts = stmts }) =
591 methodNamesStmts stmts `addOneFV` loopAName
592 methodNamesStmt (LetStmt {}) = emptyFVs
593 methodNamesStmt (ParStmt {}) = emptyFVs
594 methodNamesStmt (TransStmt {}) = emptyFVs
595 methodNamesStmt ApplicativeStmt{} = emptyFVs
596 -- ParStmt and TransStmt can't occur in commands, but it's not
597 -- convenient to error here so we just do what's convenient
598
599 {-
600 ************************************************************************
601 * *
602 Arithmetic sequences
603 * *
604 ************************************************************************
605 -}
606
607 rnArithSeq :: ArithSeqInfo RdrName -> RnM (ArithSeqInfo Name, FreeVars)
608 rnArithSeq (From expr)
609 = do { (expr', fvExpr) <- rnLExpr expr
610 ; return (From expr', fvExpr) }
611
612 rnArithSeq (FromThen expr1 expr2)
613 = do { (expr1', fvExpr1) <- rnLExpr expr1
614 ; (expr2', fvExpr2) <- rnLExpr expr2
615 ; return (FromThen expr1' expr2', fvExpr1 `plusFV` fvExpr2) }
616
617 rnArithSeq (FromTo expr1 expr2)
618 = do { (expr1', fvExpr1) <- rnLExpr expr1
619 ; (expr2', fvExpr2) <- rnLExpr expr2
620 ; return (FromTo expr1' expr2', fvExpr1 `plusFV` fvExpr2) }
621
622 rnArithSeq (FromThenTo expr1 expr2 expr3)
623 = do { (expr1', fvExpr1) <- rnLExpr expr1
624 ; (expr2', fvExpr2) <- rnLExpr expr2
625 ; (expr3', fvExpr3) <- rnLExpr expr3
626 ; return (FromThenTo expr1' expr2' expr3',
627 plusFVs [fvExpr1, fvExpr2, fvExpr3]) }
628
629 {-
630 ************************************************************************
631 * *
632 \subsubsection{@Stmt@s: in @do@ expressions}
633 * *
634 ************************************************************************
635 -}
636
637 -- | Rename some Stmts
638 rnStmts :: Outputable (body RdrName)
639 => HsStmtContext Name
640 -> (Located (body RdrName) -> RnM (Located (body Name), FreeVars))
641 -- ^ How to rename the body of each statement (e.g. rnLExpr)
642 -> [LStmt RdrName (Located (body RdrName))]
643 -- ^ Statements
644 -> ([Name] -> RnM (thing, FreeVars))
645 -- ^ if these statements scope over something, this renames it
646 -- and returns the result.
647 -> RnM (([LStmt Name (Located (body Name))], thing), FreeVars)
648 rnStmts ctxt rnBody = rnStmtsWithPostProcessing ctxt rnBody noPostProcessStmts
649
650 -- | like 'rnStmts' but applies a post-processing step to the renamed Stmts
651 rnStmtsWithPostProcessing
652 :: Outputable (body RdrName)
653 => HsStmtContext Name
654 -> (Located (body RdrName) -> RnM (Located (body Name), FreeVars))
655 -- ^ How to rename the body of each statement (e.g. rnLExpr)
656 -> (HsStmtContext Name
657 -> [(LStmt Name (Located (body Name)), FreeVars)]
658 -> RnM ([LStmt Name (Located (body Name))], FreeVars))
659 -- ^ postprocess the statements
660 -> [LStmt RdrName (Located (body RdrName))]
661 -- ^ Statements
662 -> ([Name] -> RnM (thing, FreeVars))
663 -- ^ if these statements scope over something, this renames it
664 -- and returns the result.
665 -> RnM (([LStmt Name (Located (body Name))], thing), FreeVars)
666 rnStmtsWithPostProcessing ctxt rnBody ppStmts stmts thing_inside
667 = do { ((stmts', thing), fvs) <-
668 rnStmtsWithFreeVars ctxt rnBody stmts thing_inside
669 ; (pp_stmts, fvs') <- ppStmts ctxt stmts'
670 ; return ((pp_stmts, thing), fvs `plusFV` fvs')
671 }
672
673 -- | maybe rearrange statements according to the ApplicativeDo transformation
674 postProcessStmtsForApplicativeDo
675 :: HsStmtContext Name
676 -> [(LStmt Name (LHsExpr Name), FreeVars)]
677 -> RnM ([LStmt Name (LHsExpr Name)], FreeVars)
678 postProcessStmtsForApplicativeDo ctxt stmts
679 = do {
680 -- rearrange the statements using ApplicativeStmt if
681 -- -XApplicativeDo is on. Also strip out the FreeVars attached
682 -- to each Stmt body.
683 ado_is_on <- xoptM Opt_ApplicativeDo
684 ; let is_do_expr | DoExpr <- ctxt = True
685 | otherwise = False
686 ; if ado_is_on && is_do_expr
687 then rearrangeForApplicativeDo ctxt stmts
688 else noPostProcessStmts ctxt stmts }
689
690 -- | strip the FreeVars annotations from statements
691 noPostProcessStmts
692 :: HsStmtContext Name
693 -> [(LStmt Name (Located (body Name)), FreeVars)]
694 -> RnM ([LStmt Name (Located (body Name))], FreeVars)
695 noPostProcessStmts _ stmts = return (map fst stmts, emptyNameSet)
696
697
698 rnStmtsWithFreeVars :: Outputable (body RdrName)
699 => HsStmtContext Name
700 -> (Located (body RdrName) -> RnM (Located (body Name), FreeVars))
701 -> [LStmt RdrName (Located (body RdrName))]
702 -> ([Name] -> RnM (thing, FreeVars))
703 -> RnM ( ([(LStmt Name (Located (body Name)), FreeVars)], thing)
704 , FreeVars)
705 -- Each Stmt body is annotated with its FreeVars, so that
706 -- we can rearrange statements for ApplicativeDo.
707 --
708 -- Variables bound by the Stmts, and mentioned in thing_inside,
709 -- do not appear in the result FreeVars
710
711 rnStmtsWithFreeVars ctxt _ [] thing_inside
712 = do { checkEmptyStmts ctxt
713 ; (thing, fvs) <- thing_inside []
714 ; return (([], thing), fvs) }
715
716 rnStmtsWithFreeVars MDoExpr rnBody stmts thing_inside -- Deal with mdo
717 = -- Behave like do { rec { ...all but last... }; last }
718 do { ((stmts1, (stmts2, thing)), fvs)
719 <- rnStmt MDoExpr rnBody (noLoc $ mkRecStmt all_but_last) $ \ _ ->
720 do { last_stmt' <- checkLastStmt MDoExpr last_stmt
721 ; rnStmt MDoExpr rnBody last_stmt' thing_inside }
722 ; return (((stmts1 ++ stmts2), thing), fvs) }
723 where
724 Just (all_but_last, last_stmt) = snocView stmts
725
726 rnStmtsWithFreeVars ctxt rnBody (lstmt@(L loc _) : lstmts) thing_inside
727 | null lstmts
728 = setSrcSpan loc $
729 do { lstmt' <- checkLastStmt ctxt lstmt
730 ; rnStmt ctxt rnBody lstmt' thing_inside }
731
732 | otherwise
733 = do { ((stmts1, (stmts2, thing)), fvs)
734 <- setSrcSpan loc $
735 do { checkStmt ctxt lstmt
736 ; rnStmt ctxt rnBody lstmt $ \ bndrs1 ->
737 rnStmtsWithFreeVars ctxt rnBody lstmts $ \ bndrs2 ->
738 thing_inside (bndrs1 ++ bndrs2) }
739 ; return (((stmts1 ++ stmts2), thing), fvs) }
740
741 ----------------------
742 rnStmt :: Outputable (body RdrName)
743 => HsStmtContext Name
744 -> (Located (body RdrName) -> RnM (Located (body Name), FreeVars))
745 -- ^ How to rename the body of the statement
746 -> LStmt RdrName (Located (body RdrName))
747 -- ^ The statement
748 -> ([Name] -> RnM (thing, FreeVars))
749 -- ^ Rename the stuff that this statement scopes over
750 -> RnM ( ([(LStmt Name (Located (body Name)), FreeVars)], thing)
751 , FreeVars)
752 -- Variables bound by the Stmt, and mentioned in thing_inside,
753 -- do not appear in the result FreeVars
754
755 rnStmt ctxt rnBody (L loc (LastStmt body noret _)) thing_inside
756 = do { (body', fv_expr) <- rnBody body
757 ; (ret_op, fvs1) <- lookupStmtName ctxt returnMName
758 ; (thing, fvs3) <- thing_inside []
759 ; return (([(L loc (LastStmt body' noret ret_op), fv_expr)], thing),
760 fv_expr `plusFV` fvs1 `plusFV` fvs3) }
761
762 rnStmt ctxt rnBody (L loc (BodyStmt body _ _ _)) thing_inside
763 = do { (body', fv_expr) <- rnBody body
764 ; (then_op, fvs1) <- lookupStmtName ctxt thenMName
765 ; (guard_op, fvs2) <- if isListCompExpr ctxt
766 then lookupStmtName ctxt guardMName
767 else return (noSyntaxExpr, emptyFVs)
768 -- Only list/parr/monad comprehensions use 'guard'
769 -- Also for sub-stmts of same eg [ e | x<-xs, gd | blah ]
770 -- Here "gd" is a guard
771 ; (thing, fvs3) <- thing_inside []
772 ; return (([(L loc (BodyStmt body'
773 then_op guard_op placeHolderType), fv_expr)], thing),
774 fv_expr `plusFV` fvs1 `plusFV` fvs2 `plusFV` fvs3) }
775
776 rnStmt ctxt rnBody (L loc (BindStmt pat body _ _)) thing_inside
777 = do { (body', fv_expr) <- rnBody body
778 -- The binders do not scope over the expression
779 ; (bind_op, fvs1) <- lookupStmtName ctxt bindMName
780
781 ; xMonadFailEnabled <- fmap (xopt Opt_MonadFailDesugaring) getDynFlags
782 ; let failFunction | xMonadFailEnabled = failMName
783 | otherwise = failMName_preMFP
784 ; (fail_op, fvs2) <- lookupSyntaxName failFunction
785
786 ; rnPat (StmtCtxt ctxt) pat $ \ pat' -> do
787 { (thing, fvs3) <- thing_inside (collectPatBinders pat')
788 ; return (( [(L loc (BindStmt pat' body' bind_op fail_op), fv_expr)]
789 , thing),
790 fv_expr `plusFV` fvs1 `plusFV` fvs2 `plusFV` fvs3) }}
791 -- fv_expr shouldn't really be filtered by the rnPatsAndThen
792 -- but it does not matter because the names are unique
793
794 rnStmt _ _ (L loc (LetStmt (L l binds))) thing_inside
795 = do { rnLocalBindsAndThen binds $ \binds' bind_fvs -> do
796 { (thing, fvs) <- thing_inside (collectLocalBinders binds')
797 ; return (([(L loc (LetStmt (L l binds')), bind_fvs)], thing), fvs) } }
798
799 rnStmt ctxt rnBody (L loc (RecStmt { recS_stmts = rec_stmts })) thing_inside
800 = do { (return_op, fvs1) <- lookupStmtName ctxt returnMName
801 ; (mfix_op, fvs2) <- lookupStmtName ctxt mfixName
802 ; (bind_op, fvs3) <- lookupStmtName ctxt bindMName
803 ; let empty_rec_stmt = emptyRecStmtName { recS_ret_fn = return_op
804 , recS_mfix_fn = mfix_op
805 , recS_bind_fn = bind_op }
806
807 -- Step1: Bring all the binders of the mdo into scope
808 -- (Remember that this also removes the binders from the
809 -- finally-returned free-vars.)
810 -- And rename each individual stmt, making a
811 -- singleton segment. At this stage the FwdRefs field
812 -- isn't finished: it's empty for all except a BindStmt
813 -- for which it's the fwd refs within the bind itself
814 -- (This set may not be empty, because we're in a recursive
815 -- context.)
816 ; rnRecStmtsAndThen rnBody rec_stmts $ \ segs -> do
817 { let bndrs = nameSetElems $ foldr (unionNameSet . (\(ds,_,_,_) -> ds))
818 emptyNameSet segs
819 ; (thing, fvs_later) <- thing_inside bndrs
820 ; let (rec_stmts', fvs) = segmentRecStmts loc ctxt empty_rec_stmt segs fvs_later
821 -- We aren't going to try to group RecStmts with
822 -- ApplicativeDo, so attaching empty FVs is fine.
823 ; return ( ((zip rec_stmts' (repeat emptyNameSet)), thing)
824 , fvs `plusFV` fvs1 `plusFV` fvs2 `plusFV` fvs3) } }
825
826 rnStmt ctxt _ (L loc (ParStmt segs _ _)) thing_inside
827 = do { (mzip_op, fvs1) <- lookupStmtName ctxt mzipName
828 ; (bind_op, fvs2) <- lookupStmtName ctxt bindMName
829 ; (return_op, fvs3) <- lookupStmtName ctxt returnMName
830 ; ((segs', thing), fvs4) <- rnParallelStmts (ParStmtCtxt ctxt) return_op segs thing_inside
831 ; return ( ([(L loc (ParStmt segs' mzip_op bind_op), fvs4)], thing)
832 , fvs1 `plusFV` fvs2 `plusFV` fvs3 `plusFV` fvs4) }
833
834 rnStmt ctxt _ (L loc (TransStmt { trS_stmts = stmts, trS_by = by, trS_form = form
835 , trS_using = using })) thing_inside
836 = do { -- Rename the 'using' expression in the context before the transform is begun
837 (using', fvs1) <- rnLExpr using
838
839 -- Rename the stmts and the 'by' expression
840 -- Keep track of the variables mentioned in the 'by' expression
841 ; ((stmts', (by', used_bndrs, thing)), fvs2)
842 <- rnStmts (TransStmtCtxt ctxt) rnLExpr stmts $ \ bndrs ->
843 do { (by', fvs_by) <- mapMaybeFvRn rnLExpr by
844 ; (thing, fvs_thing) <- thing_inside bndrs
845 ; let fvs = fvs_by `plusFV` fvs_thing
846 used_bndrs = filter (`elemNameSet` fvs) bndrs
847 -- The paper (Fig 5) has a bug here; we must treat any free variable
848 -- of the "thing inside", **or of the by-expression**, as used
849 ; return ((by', used_bndrs, thing), fvs) }
850
851 -- Lookup `return`, `(>>=)` and `liftM` for monad comprehensions
852 ; (return_op, fvs3) <- lookupStmtName ctxt returnMName
853 ; (bind_op, fvs4) <- lookupStmtName ctxt bindMName
854 ; (fmap_op, fvs5) <- case form of
855 ThenForm -> return (noSyntaxExpr, emptyFVs)
856 _ -> lookupStmtName ctxt fmapName
857
858 ; let all_fvs = fvs1 `plusFV` fvs2 `plusFV` fvs3
859 `plusFV` fvs4 `plusFV` fvs5
860 bndr_map = used_bndrs `zip` used_bndrs
861 -- See Note [TransStmt binder map] in HsExpr
862
863 ; traceRn (text "rnStmt: implicitly rebound these used binders:" <+> ppr bndr_map)
864 ; return (([(L loc (TransStmt { trS_stmts = stmts', trS_bndrs = bndr_map
865 , trS_by = by', trS_using = using', trS_form = form
866 , trS_ret = return_op, trS_bind = bind_op
867 , trS_fmap = fmap_op }), fvs2)], thing), all_fvs) }
868
869 rnStmt _ _ (L _ ApplicativeStmt{}) _ =
870 panic "rnStmt: ApplicativeStmt"
871
872 rnParallelStmts :: forall thing. HsStmtContext Name
873 -> SyntaxExpr Name
874 -> [ParStmtBlock RdrName RdrName]
875 -> ([Name] -> RnM (thing, FreeVars))
876 -> RnM (([ParStmtBlock Name Name], thing), FreeVars)
877 -- Note [Renaming parallel Stmts]
878 rnParallelStmts ctxt return_op segs thing_inside
879 = do { orig_lcl_env <- getLocalRdrEnv
880 ; rn_segs orig_lcl_env [] segs }
881 where
882 rn_segs :: LocalRdrEnv
883 -> [Name] -> [ParStmtBlock RdrName RdrName]
884 -> RnM (([ParStmtBlock Name Name], thing), FreeVars)
885 rn_segs _ bndrs_so_far []
886 = do { let (bndrs', dups) = removeDups cmpByOcc bndrs_so_far
887 ; mapM_ dupErr dups
888 ; (thing, fvs) <- bindLocalNames bndrs' (thing_inside bndrs')
889 ; return (([], thing), fvs) }
890
891 rn_segs env bndrs_so_far (ParStmtBlock stmts _ _ : segs)
892 = do { ((stmts', (used_bndrs, segs', thing)), fvs)
893 <- rnStmts ctxt rnLExpr stmts $ \ bndrs ->
894 setLocalRdrEnv env $ do
895 { ((segs', thing), fvs) <- rn_segs env (bndrs ++ bndrs_so_far) segs
896 ; let used_bndrs = filter (`elemNameSet` fvs) bndrs
897 ; return ((used_bndrs, segs', thing), fvs) }
898
899 ; let seg' = ParStmtBlock stmts' used_bndrs return_op
900 ; return ((seg':segs', thing), fvs) }
901
902 cmpByOcc n1 n2 = nameOccName n1 `compare` nameOccName n2
903 dupErr vs = addErr (ptext (sLit "Duplicate binding in parallel list comprehension for:")
904 <+> quotes (ppr (head vs)))
905
906 lookupStmtName :: HsStmtContext Name -> Name -> RnM (HsExpr Name, FreeVars)
907 -- Like lookupSyntaxName, but ListComp/PArrComp are never rebindable
908 -- Neither is ArrowExpr, which has its own desugarer in DsArrows
909 lookupStmtName ctxt n
910 = case ctxt of
911 ListComp -> not_rebindable
912 PArrComp -> not_rebindable
913 ArrowExpr -> not_rebindable
914 PatGuard {} -> not_rebindable
915
916 DoExpr -> rebindable
917 MDoExpr -> rebindable
918 MonadComp -> rebindable
919 GhciStmtCtxt -> rebindable -- I suppose?
920
921 ParStmtCtxt c -> lookupStmtName c n -- Look inside to
922 TransStmtCtxt c -> lookupStmtName c n -- the parent context
923 where
924 rebindable = lookupSyntaxName n
925 not_rebindable = return (HsVar (noLoc n), emptyFVs)
926
927 {-
928 Note [Renaming parallel Stmts]
929 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
930 Renaming parallel statements is painful. Given, say
931 [ a+c | a <- as, bs <- bss
932 | c <- bs, a <- ds ]
933 Note that
934 (a) In order to report "Defined but not used" about 'bs', we must
935 rename each group of Stmts with a thing_inside whose FreeVars
936 include at least {a,c}
937
938 (b) We want to report that 'a' is illegally bound in both branches
939
940 (c) The 'bs' in the second group must obviously not be captured by
941 the binding in the first group
942
943 To satisfy (a) we nest the segements.
944 To satisfy (b) we check for duplicates just before thing_inside.
945 To satisfy (c) we reset the LocalRdrEnv each time.
946
947 ************************************************************************
948 * *
949 \subsubsection{mdo expressions}
950 * *
951 ************************************************************************
952 -}
953
954 type FwdRefs = NameSet
955 type Segment stmts = (Defs,
956 Uses, -- May include defs
957 FwdRefs, -- A subset of uses that are
958 -- (a) used before they are bound in this segment, or
959 -- (b) used here, and bound in subsequent segments
960 stmts) -- Either Stmt or [Stmt]
961
962
963 -- wrapper that does both the left- and right-hand sides
964 rnRecStmtsAndThen :: Outputable (body RdrName) =>
965 (Located (body RdrName)
966 -> RnM (Located (body Name), FreeVars))
967 -> [LStmt RdrName (Located (body RdrName))]
968 -- assumes that the FreeVars returned includes
969 -- the FreeVars of the Segments
970 -> ([Segment (LStmt Name (Located (body Name)))]
971 -> RnM (a, FreeVars))
972 -> RnM (a, FreeVars)
973 rnRecStmtsAndThen rnBody s cont
974 = do { -- (A) Make the mini fixity env for all of the stmts
975 fix_env <- makeMiniFixityEnv (collectRecStmtsFixities s)
976
977 -- (B) Do the LHSes
978 ; new_lhs_and_fv <- rn_rec_stmts_lhs fix_env s
979
980 -- ...bring them and their fixities into scope
981 ; let bound_names = collectLStmtsBinders (map fst new_lhs_and_fv)
982 -- Fake uses of variables introduced implicitly (warning suppression, see #4404)
983 implicit_uses = lStmtsImplicits (map fst new_lhs_and_fv)
984 ; bindLocalNamesFV bound_names $
985 addLocalFixities fix_env bound_names $ do
986
987 -- (C) do the right-hand-sides and thing-inside
988 { segs <- rn_rec_stmts rnBody bound_names new_lhs_and_fv
989 ; (res, fvs) <- cont segs
990 ; warnUnusedLocalBinds bound_names (fvs `unionNameSet` implicit_uses)
991 ; return (res, fvs) }}
992
993 -- get all the fixity decls in any Let stmt
994 collectRecStmtsFixities :: [LStmtLR RdrName RdrName body] -> [LFixitySig RdrName]
995 collectRecStmtsFixities l =
996 foldr (\ s -> \acc -> case s of
997 (L _ (LetStmt (L _ (HsValBinds (ValBindsIn _ sigs))))) ->
998 foldr (\ sig -> \ acc -> case sig of
999 (L loc (FixSig s)) -> (L loc s) : acc
1000 _ -> acc) acc sigs
1001 _ -> acc) [] l
1002
1003 -- left-hand sides
1004
1005 rn_rec_stmt_lhs :: Outputable body => MiniFixityEnv
1006 -> LStmt RdrName body
1007 -- rename LHS, and return its FVs
1008 -- Warning: we will only need the FreeVars below in the case of a BindStmt,
1009 -- so we don't bother to compute it accurately in the other cases
1010 -> RnM [(LStmtLR Name RdrName body, FreeVars)]
1011
1012 rn_rec_stmt_lhs _ (L loc (BodyStmt body a b c))
1013 = return [(L loc (BodyStmt body a b c), emptyFVs)]
1014
1015 rn_rec_stmt_lhs _ (L loc (LastStmt body noret a))
1016 = return [(L loc (LastStmt body noret a), emptyFVs)]
1017
1018 rn_rec_stmt_lhs fix_env (L loc (BindStmt pat body a b))
1019 = do
1020 -- should the ctxt be MDo instead?
1021 (pat', fv_pat) <- rnBindPat (localRecNameMaker fix_env) pat
1022 return [(L loc (BindStmt pat' body a b),
1023 fv_pat)]
1024
1025 rn_rec_stmt_lhs _ (L _ (LetStmt (L _ binds@(HsIPBinds _))))
1026 = failWith (badIpBinds (ptext (sLit "an mdo expression")) binds)
1027
1028 rn_rec_stmt_lhs fix_env (L loc (LetStmt (L l(HsValBinds binds))))
1029 = do (_bound_names, binds') <- rnLocalValBindsLHS fix_env binds
1030 return [(L loc (LetStmt (L l (HsValBinds binds'))),
1031 -- Warning: this is bogus; see function invariant
1032 emptyFVs
1033 )]
1034
1035 -- XXX Do we need to do something with the return and mfix names?
1036 rn_rec_stmt_lhs fix_env (L _ (RecStmt { recS_stmts = stmts })) -- Flatten Rec inside Rec
1037 = rn_rec_stmts_lhs fix_env stmts
1038
1039 rn_rec_stmt_lhs _ stmt@(L _ (ParStmt {})) -- Syntactically illegal in mdo
1040 = pprPanic "rn_rec_stmt" (ppr stmt)
1041
1042 rn_rec_stmt_lhs _ stmt@(L _ (TransStmt {})) -- Syntactically illegal in mdo
1043 = pprPanic "rn_rec_stmt" (ppr stmt)
1044
1045 rn_rec_stmt_lhs _ stmt@(L _ (ApplicativeStmt {})) -- Shouldn't appear yet
1046 = pprPanic "rn_rec_stmt" (ppr stmt)
1047
1048 rn_rec_stmt_lhs _ (L _ (LetStmt (L _ EmptyLocalBinds)))
1049 = panic "rn_rec_stmt LetStmt EmptyLocalBinds"
1050
1051 rn_rec_stmts_lhs :: Outputable body => MiniFixityEnv
1052 -> [LStmt RdrName body]
1053 -> RnM [(LStmtLR Name RdrName body, FreeVars)]
1054 rn_rec_stmts_lhs fix_env stmts
1055 = do { ls <- concatMapM (rn_rec_stmt_lhs fix_env) stmts
1056 ; let boundNames = collectLStmtsBinders (map fst ls)
1057 -- First do error checking: we need to check for dups here because we
1058 -- don't bind all of the variables from the Stmt at once
1059 -- with bindLocatedLocals.
1060 ; checkDupNames boundNames
1061 ; return ls }
1062
1063
1064 -- right-hand-sides
1065
1066 rn_rec_stmt :: (Outputable (body RdrName)) =>
1067 (Located (body RdrName) -> RnM (Located (body Name), FreeVars))
1068 -> [Name]
1069 -> (LStmtLR Name RdrName (Located (body RdrName)), FreeVars)
1070 -> RnM [Segment (LStmt Name (Located (body Name)))]
1071 -- Rename a Stmt that is inside a RecStmt (or mdo)
1072 -- Assumes all binders are already in scope
1073 -- Turns each stmt into a singleton Stmt
1074 rn_rec_stmt rnBody _ (L loc (LastStmt body noret _), _)
1075 = do { (body', fv_expr) <- rnBody body
1076 ; (ret_op, fvs1) <- lookupSyntaxName returnMName
1077 ; return [(emptyNameSet, fv_expr `plusFV` fvs1, emptyNameSet,
1078 L loc (LastStmt body' noret ret_op))] }
1079
1080 rn_rec_stmt rnBody _ (L loc (BodyStmt body _ _ _), _)
1081 = do { (body', fvs) <- rnBody body
1082 ; (then_op, fvs1) <- lookupSyntaxName thenMName
1083 ; return [(emptyNameSet, fvs `plusFV` fvs1, emptyNameSet,
1084 L loc (BodyStmt body' then_op noSyntaxExpr placeHolderType))] }
1085
1086 rn_rec_stmt rnBody _ (L loc (BindStmt pat' body _ _), fv_pat)
1087 = do { (body', fv_expr) <- rnBody body
1088 ; (bind_op, fvs1) <- lookupSyntaxName bindMName
1089
1090 ; xMonadFailEnabled <- fmap (xopt Opt_MonadFailDesugaring) getDynFlags
1091 ; let failFunction | xMonadFailEnabled = failMName
1092 | otherwise = failMName_preMFP
1093 ; (fail_op, fvs2) <- lookupSyntaxName failFunction
1094
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 (L _ 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)