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