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