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