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