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