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