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