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