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