ApplicativeDo: allow "return $ e"
[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 nameSetElemsStable (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 {-
637 Note [Deterministic ApplicativeDo and RecursiveDo desugaring]
638 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
639 Both ApplicativeDo and RecursiveDo need to create tuples not
640 present in the source text.
641
642 For ApplicativeDo we create:
643
644 (a,b,c) <- (\c b a -> (a,b,c)) <$>
645
646 For RecursiveDo we create:
647
648 mfix (\ ~(a,b,c) -> do ...; return (a',b',c'))
649
650 The order of the components in those tuples needs to be stable
651 across recompilations, otherwise they can get optimized differently
652 and we end up with incompatible binaries.
653 To get a stable order we use nameSetElemsStable.
654 See Note [Deterministic UniqFM] to learn more about nondeterminism.
655 -}
656
657 -- | Rename some Stmts
658 rnStmts :: 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 -> [LStmt RdrName (Located (body RdrName))]
663 -- ^ Statements
664 -> ([Name] -> RnM (thing, FreeVars))
665 -- ^ if these statements scope over something, this renames it
666 -- and returns the result.
667 -> RnM (([LStmt Name (Located (body Name))], thing), FreeVars)
668 rnStmts ctxt rnBody = rnStmtsWithPostProcessing ctxt rnBody noPostProcessStmts
669
670 -- | like 'rnStmts' but applies a post-processing step to the renamed Stmts
671 rnStmtsWithPostProcessing
672 :: Outputable (body RdrName)
673 => HsStmtContext Name
674 -> (Located (body RdrName) -> RnM (Located (body Name), FreeVars))
675 -- ^ How to rename the body of each statement (e.g. rnLExpr)
676 -> (HsStmtContext Name
677 -> [(LStmt Name (Located (body Name)), FreeVars)]
678 -> RnM ([LStmt Name (Located (body Name))], FreeVars))
679 -- ^ postprocess the statements
680 -> [LStmt RdrName (Located (body RdrName))]
681 -- ^ Statements
682 -> ([Name] -> RnM (thing, FreeVars))
683 -- ^ if these statements scope over something, this renames it
684 -- and returns the result.
685 -> RnM (([LStmt Name (Located (body Name))], thing), FreeVars)
686 rnStmtsWithPostProcessing ctxt rnBody ppStmts stmts thing_inside
687 = do { ((stmts', thing), fvs) <-
688 rnStmtsWithFreeVars ctxt rnBody stmts thing_inside
689 ; (pp_stmts, fvs') <- ppStmts ctxt stmts'
690 ; return ((pp_stmts, thing), fvs `plusFV` fvs')
691 }
692
693 -- | maybe rearrange statements according to the ApplicativeDo transformation
694 postProcessStmtsForApplicativeDo
695 :: HsStmtContext Name
696 -> [(ExprLStmt Name, FreeVars)]
697 -> RnM ([ExprLStmt Name], FreeVars)
698 postProcessStmtsForApplicativeDo ctxt stmts
699 = do {
700 -- rearrange the statements using ApplicativeStmt if
701 -- -XApplicativeDo is on. Also strip out the FreeVars attached
702 -- to each Stmt body.
703 ado_is_on <- xoptM LangExt.ApplicativeDo
704 ; let is_do_expr | DoExpr <- ctxt = True
705 | otherwise = False
706 ; if ado_is_on && is_do_expr
707 then rearrangeForApplicativeDo ctxt stmts
708 else noPostProcessStmts ctxt stmts }
709
710 -- | strip the FreeVars annotations from statements
711 noPostProcessStmts
712 :: HsStmtContext Name
713 -> [(LStmt Name (Located (body Name)), FreeVars)]
714 -> RnM ([LStmt Name (Located (body Name))], FreeVars)
715 noPostProcessStmts _ stmts = return (map fst stmts, emptyNameSet)
716
717
718 rnStmtsWithFreeVars :: Outputable (body RdrName)
719 => HsStmtContext Name
720 -> (Located (body RdrName) -> RnM (Located (body Name), FreeVars))
721 -> [LStmt RdrName (Located (body RdrName))]
722 -> ([Name] -> RnM (thing, FreeVars))
723 -> RnM ( ([(LStmt Name (Located (body Name)), FreeVars)], thing)
724 , FreeVars)
725 -- Each Stmt body is annotated with its FreeVars, so that
726 -- we can rearrange statements for ApplicativeDo.
727 --
728 -- Variables bound by the Stmts, and mentioned in thing_inside,
729 -- do not appear in the result FreeVars
730
731 rnStmtsWithFreeVars ctxt _ [] thing_inside
732 = do { checkEmptyStmts ctxt
733 ; (thing, fvs) <- thing_inside []
734 ; return (([], thing), fvs) }
735
736 rnStmtsWithFreeVars MDoExpr rnBody stmts thing_inside -- Deal with mdo
737 = -- Behave like do { rec { ...all but last... }; last }
738 do { ((stmts1, (stmts2, thing)), fvs)
739 <- rnStmt MDoExpr rnBody (noLoc $ mkRecStmt all_but_last) $ \ _ ->
740 do { last_stmt' <- checkLastStmt MDoExpr last_stmt
741 ; rnStmt MDoExpr rnBody last_stmt' thing_inside }
742 ; return (((stmts1 ++ stmts2), thing), fvs) }
743 where
744 Just (all_but_last, last_stmt) = snocView stmts
745
746 rnStmtsWithFreeVars ctxt rnBody (lstmt@(L loc _) : lstmts) thing_inside
747 | null lstmts
748 = setSrcSpan loc $
749 do { lstmt' <- checkLastStmt ctxt lstmt
750 ; rnStmt ctxt rnBody lstmt' thing_inside }
751
752 | otherwise
753 = do { ((stmts1, (stmts2, thing)), fvs)
754 <- setSrcSpan loc $
755 do { checkStmt ctxt lstmt
756 ; rnStmt ctxt rnBody lstmt $ \ bndrs1 ->
757 rnStmtsWithFreeVars ctxt rnBody lstmts $ \ bndrs2 ->
758 thing_inside (bndrs1 ++ bndrs2) }
759 ; return (((stmts1 ++ stmts2), thing), fvs) }
760
761 ----------------------
762 rnStmt :: Outputable (body RdrName)
763 => HsStmtContext Name
764 -> (Located (body RdrName) -> RnM (Located (body Name), FreeVars))
765 -- ^ How to rename the body of the statement
766 -> LStmt RdrName (Located (body RdrName))
767 -- ^ The statement
768 -> ([Name] -> RnM (thing, FreeVars))
769 -- ^ Rename the stuff that this statement scopes over
770 -> RnM ( ([(LStmt Name (Located (body Name)), FreeVars)], thing)
771 , FreeVars)
772 -- Variables bound by the Stmt, and mentioned in thing_inside,
773 -- do not appear in the result FreeVars
774
775 rnStmt ctxt rnBody (L loc (LastStmt body noret _)) thing_inside
776 = do { (body', fv_expr) <- rnBody body
777 ; (ret_op, fvs1) <- lookupStmtName ctxt returnMName
778 ; (thing, fvs3) <- thing_inside []
779 ; return (([(L loc (LastStmt body' noret ret_op), fv_expr)], thing),
780 fv_expr `plusFV` fvs1 `plusFV` fvs3) }
781
782 rnStmt ctxt rnBody (L loc (BodyStmt body _ _ _)) thing_inside
783 = do { (body', fv_expr) <- rnBody body
784 ; (then_op, fvs1) <- lookupStmtName ctxt thenMName
785 ; (guard_op, fvs2) <- if isListCompExpr ctxt
786 then lookupStmtName ctxt guardMName
787 else return (noSyntaxExpr, emptyFVs)
788 -- Only list/parr/monad comprehensions use 'guard'
789 -- Also for sub-stmts of same eg [ e | x<-xs, gd | blah ]
790 -- Here "gd" is a guard
791 ; (thing, fvs3) <- thing_inside []
792 ; return (([(L loc (BodyStmt body'
793 then_op guard_op placeHolderType), fv_expr)], thing),
794 fv_expr `plusFV` fvs1 `plusFV` fvs2 `plusFV` fvs3) }
795
796 rnStmt ctxt rnBody (L loc (BindStmt pat body _ _ _)) thing_inside
797 = do { (body', fv_expr) <- rnBody body
798 -- The binders do not scope over the expression
799 ; (bind_op, fvs1) <- lookupStmtName ctxt bindMName
800
801 ; xMonadFailEnabled <- fmap (xopt LangExt.MonadFailDesugaring) getDynFlags
802 ; let failFunction | xMonadFailEnabled = failMName
803 | otherwise = failMName_preMFP
804 ; (fail_op, fvs2) <- lookupSyntaxName failFunction
805
806 ; rnPat (StmtCtxt ctxt) pat $ \ pat' -> do
807 { (thing, fvs3) <- thing_inside (collectPatBinders pat')
808 ; return (( [( L loc (BindStmt pat' body' bind_op fail_op PlaceHolder)
809 , fv_expr )]
810 , thing),
811 fv_expr `plusFV` fvs1 `plusFV` fvs2 `plusFV` fvs3) }}
812 -- fv_expr shouldn't really be filtered by the rnPatsAndThen
813 -- but it does not matter because the names are unique
814
815 rnStmt _ _ (L loc (LetStmt (L l binds))) thing_inside
816 = do { rnLocalBindsAndThen binds $ \binds' bind_fvs -> do
817 { (thing, fvs) <- thing_inside (collectLocalBinders binds')
818 ; return (([(L loc (LetStmt (L l binds')), bind_fvs)], thing), fvs) } }
819
820 rnStmt ctxt rnBody (L loc (RecStmt { recS_stmts = rec_stmts })) thing_inside
821 = do { (return_op, fvs1) <- lookupStmtName ctxt returnMName
822 ; (mfix_op, fvs2) <- lookupStmtName ctxt mfixName
823 ; (bind_op, fvs3) <- lookupStmtName ctxt bindMName
824 ; let empty_rec_stmt = emptyRecStmtName { recS_ret_fn = return_op
825 , recS_mfix_fn = mfix_op
826 , recS_bind_fn = bind_op }
827
828 -- Step1: Bring all the binders of the mdo into scope
829 -- (Remember that this also removes the binders from the
830 -- finally-returned free-vars.)
831 -- And rename each individual stmt, making a
832 -- singleton segment. At this stage the FwdRefs field
833 -- isn't finished: it's empty for all except a BindStmt
834 -- for which it's the fwd refs within the bind itself
835 -- (This set may not be empty, because we're in a recursive
836 -- context.)
837 ; rnRecStmtsAndThen rnBody rec_stmts $ \ segs -> do
838 { let bndrs = nameSetElemsStable $
839 foldr (unionNameSet . (\(ds,_,_,_) -> ds))
840 emptyNameSet
841 segs
842 -- See Note [Deterministic ApplicativeDo and RecursiveDo desugaring]
843 ; (thing, fvs_later) <- thing_inside bndrs
844 ; let (rec_stmts', fvs) = segmentRecStmts loc ctxt empty_rec_stmt segs fvs_later
845 -- We aren't going to try to group RecStmts with
846 -- ApplicativeDo, so attaching empty FVs is fine.
847 ; return ( ((zip rec_stmts' (repeat emptyNameSet)), thing)
848 , fvs `plusFV` fvs1 `plusFV` fvs2 `plusFV` fvs3) } }
849
850 rnStmt ctxt _ (L loc (ParStmt segs _ _ _)) thing_inside
851 = do { (mzip_op, fvs1) <- lookupStmtNamePoly ctxt mzipName
852 ; (bind_op, fvs2) <- lookupStmtName ctxt bindMName
853 ; (return_op, fvs3) <- lookupStmtName ctxt returnMName
854 ; ((segs', thing), fvs4) <- rnParallelStmts (ParStmtCtxt ctxt) return_op segs thing_inside
855 ; return ( ([(L loc (ParStmt segs' mzip_op bind_op placeHolderType), fvs4)], thing)
856 , fvs1 `plusFV` fvs2 `plusFV` fvs3 `plusFV` fvs4) }
857
858 rnStmt ctxt _ (L loc (TransStmt { trS_stmts = stmts, trS_by = by, trS_form = form
859 , trS_using = using })) thing_inside
860 = do { -- Rename the 'using' expression in the context before the transform is begun
861 (using', fvs1) <- rnLExpr using
862
863 -- Rename the stmts and the 'by' expression
864 -- Keep track of the variables mentioned in the 'by' expression
865 ; ((stmts', (by', used_bndrs, thing)), fvs2)
866 <- rnStmts (TransStmtCtxt ctxt) rnLExpr stmts $ \ bndrs ->
867 do { (by', fvs_by) <- mapMaybeFvRn rnLExpr by
868 ; (thing, fvs_thing) <- thing_inside bndrs
869 ; let fvs = fvs_by `plusFV` fvs_thing
870 used_bndrs = filter (`elemNameSet` fvs) bndrs
871 -- The paper (Fig 5) has a bug here; we must treat any free variable
872 -- of the "thing inside", **or of the by-expression**, as used
873 ; return ((by', used_bndrs, thing), fvs) }
874
875 -- Lookup `return`, `(>>=)` and `liftM` for monad comprehensions
876 ; (return_op, fvs3) <- lookupStmtName ctxt returnMName
877 ; (bind_op, fvs4) <- lookupStmtName ctxt bindMName
878 ; (fmap_op, fvs5) <- case form of
879 ThenForm -> return (noExpr, emptyFVs)
880 _ -> lookupStmtNamePoly ctxt fmapName
881
882 ; let all_fvs = fvs1 `plusFV` fvs2 `plusFV` fvs3
883 `plusFV` fvs4 `plusFV` fvs5
884 bndr_map = used_bndrs `zip` used_bndrs
885 -- See Note [TransStmt binder map] in HsExpr
886
887 ; traceRn (text "rnStmt: implicitly rebound these used binders:" <+> ppr bndr_map)
888 ; return (([(L loc (TransStmt { trS_stmts = stmts', trS_bndrs = bndr_map
889 , trS_by = by', trS_using = using', trS_form = form
890 , trS_ret = return_op, trS_bind = bind_op
891 , trS_bind_arg_ty = PlaceHolder
892 , trS_fmap = fmap_op }), fvs2)], thing), all_fvs) }
893
894 rnStmt _ _ (L _ ApplicativeStmt{}) _ =
895 panic "rnStmt: ApplicativeStmt"
896
897 rnParallelStmts :: forall thing. HsStmtContext Name
898 -> SyntaxExpr Name
899 -> [ParStmtBlock RdrName RdrName]
900 -> ([Name] -> RnM (thing, FreeVars))
901 -> RnM (([ParStmtBlock Name Name], thing), FreeVars)
902 -- Note [Renaming parallel Stmts]
903 rnParallelStmts ctxt return_op segs thing_inside
904 = do { orig_lcl_env <- getLocalRdrEnv
905 ; rn_segs orig_lcl_env [] segs }
906 where
907 rn_segs :: LocalRdrEnv
908 -> [Name] -> [ParStmtBlock RdrName RdrName]
909 -> RnM (([ParStmtBlock Name Name], thing), FreeVars)
910 rn_segs _ bndrs_so_far []
911 = do { let (bndrs', dups) = removeDups cmpByOcc bndrs_so_far
912 ; mapM_ dupErr dups
913 ; (thing, fvs) <- bindLocalNames bndrs' (thing_inside bndrs')
914 ; return (([], thing), fvs) }
915
916 rn_segs env bndrs_so_far (ParStmtBlock stmts _ _ : segs)
917 = do { ((stmts', (used_bndrs, segs', thing)), fvs)
918 <- rnStmts ctxt rnLExpr stmts $ \ bndrs ->
919 setLocalRdrEnv env $ do
920 { ((segs', thing), fvs) <- rn_segs env (bndrs ++ bndrs_so_far) segs
921 ; let used_bndrs = filter (`elemNameSet` fvs) bndrs
922 ; return ((used_bndrs, segs', thing), fvs) }
923
924 ; let seg' = ParStmtBlock stmts' used_bndrs return_op
925 ; return ((seg':segs', thing), fvs) }
926
927 cmpByOcc n1 n2 = nameOccName n1 `compare` nameOccName n2
928 dupErr vs = addErr (text "Duplicate binding in parallel list comprehension for:"
929 <+> quotes (ppr (head vs)))
930
931 lookupStmtName :: HsStmtContext Name -> Name -> RnM (SyntaxExpr Name, FreeVars)
932 -- Like lookupSyntaxName, but respects contexts
933 lookupStmtName ctxt n
934 | rebindableContext ctxt
935 = lookupSyntaxName n
936 | otherwise
937 = return (mkRnSyntaxExpr n, emptyFVs)
938
939 lookupStmtNamePoly :: HsStmtContext Name -> Name -> RnM (HsExpr Name, FreeVars)
940 lookupStmtNamePoly ctxt name
941 | rebindableContext ctxt
942 = do { rebindable_on <- xoptM LangExt.RebindableSyntax
943 ; if rebindable_on
944 then do { fm <- lookupOccRn (nameRdrName name)
945 ; return (HsVar (noLoc fm), unitFV fm) }
946 else not_rebindable }
947 | otherwise
948 = not_rebindable
949 where
950 not_rebindable = return (HsVar (noLoc name), emptyFVs)
951
952 -- | Is this a context where we respect RebindableSyntax?
953 -- but ListComp/PArrComp are never rebindable
954 -- Neither is ArrowExpr, which has its own desugarer in DsArrows
955 rebindableContext :: HsStmtContext Name -> Bool
956 rebindableContext ctxt = case ctxt of
957 ListComp -> False
958 PArrComp -> False
959 ArrowExpr -> False
960 PatGuard {} -> False
961
962 DoExpr -> True
963 MDoExpr -> True
964 MonadComp -> True
965 GhciStmtCtxt -> True -- I suppose?
966
967 ParStmtCtxt c -> rebindableContext c -- Look inside to
968 TransStmtCtxt c -> rebindableContext c -- the parent context
969
970 {-
971 Note [Renaming parallel Stmts]
972 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
973 Renaming parallel statements is painful. Given, say
974 [ a+c | a <- as, bs <- bss
975 | c <- bs, a <- ds ]
976 Note that
977 (a) In order to report "Defined but not used" about 'bs', we must
978 rename each group of Stmts with a thing_inside whose FreeVars
979 include at least {a,c}
980
981 (b) We want to report that 'a' is illegally bound in both branches
982
983 (c) The 'bs' in the second group must obviously not be captured by
984 the binding in the first group
985
986 To satisfy (a) we nest the segements.
987 To satisfy (b) we check for duplicates just before thing_inside.
988 To satisfy (c) we reset the LocalRdrEnv each time.
989
990 ************************************************************************
991 * *
992 \subsubsection{mdo expressions}
993 * *
994 ************************************************************************
995 -}
996
997 type FwdRefs = NameSet
998 type Segment stmts = (Defs,
999 Uses, -- May include defs
1000 FwdRefs, -- A subset of uses that are
1001 -- (a) used before they are bound in this segment, or
1002 -- (b) used here, and bound in subsequent segments
1003 stmts) -- Either Stmt or [Stmt]
1004
1005
1006 -- wrapper that does both the left- and right-hand sides
1007 rnRecStmtsAndThen :: Outputable (body RdrName) =>
1008 (Located (body RdrName)
1009 -> RnM (Located (body Name), FreeVars))
1010 -> [LStmt RdrName (Located (body RdrName))]
1011 -- assumes that the FreeVars returned includes
1012 -- the FreeVars of the Segments
1013 -> ([Segment (LStmt Name (Located (body Name)))]
1014 -> RnM (a, FreeVars))
1015 -> RnM (a, FreeVars)
1016 rnRecStmtsAndThen rnBody s cont
1017 = do { -- (A) Make the mini fixity env for all of the stmts
1018 fix_env <- makeMiniFixityEnv (collectRecStmtsFixities s)
1019
1020 -- (B) Do the LHSes
1021 ; new_lhs_and_fv <- rn_rec_stmts_lhs fix_env s
1022
1023 -- ...bring them and their fixities into scope
1024 ; let bound_names = collectLStmtsBinders (map fst new_lhs_and_fv)
1025 -- Fake uses of variables introduced implicitly (warning suppression, see #4404)
1026 implicit_uses = lStmtsImplicits (map fst new_lhs_and_fv)
1027 ; bindLocalNamesFV bound_names $
1028 addLocalFixities fix_env bound_names $ do
1029
1030 -- (C) do the right-hand-sides and thing-inside
1031 { segs <- rn_rec_stmts rnBody bound_names new_lhs_and_fv
1032 ; (res, fvs) <- cont segs
1033 ; warnUnusedLocalBinds bound_names (fvs `unionNameSet` implicit_uses)
1034 ; return (res, fvs) }}
1035
1036 -- get all the fixity decls in any Let stmt
1037 collectRecStmtsFixities :: [LStmtLR RdrName RdrName body] -> [LFixitySig RdrName]
1038 collectRecStmtsFixities l =
1039 foldr (\ s -> \acc -> case s of
1040 (L _ (LetStmt (L _ (HsValBinds (ValBindsIn _ sigs))))) ->
1041 foldr (\ sig -> \ acc -> case sig of
1042 (L loc (FixSig s)) -> (L loc s) : acc
1043 _ -> acc) acc sigs
1044 _ -> acc) [] l
1045
1046 -- left-hand sides
1047
1048 rn_rec_stmt_lhs :: Outputable body => MiniFixityEnv
1049 -> LStmt RdrName body
1050 -- rename LHS, and return its FVs
1051 -- Warning: we will only need the FreeVars below in the case of a BindStmt,
1052 -- so we don't bother to compute it accurately in the other cases
1053 -> RnM [(LStmtLR Name RdrName body, FreeVars)]
1054
1055 rn_rec_stmt_lhs _ (L loc (BodyStmt body a b c))
1056 = return [(L loc (BodyStmt body a b c), emptyFVs)]
1057
1058 rn_rec_stmt_lhs _ (L loc (LastStmt body noret a))
1059 = return [(L loc (LastStmt body noret a), emptyFVs)]
1060
1061 rn_rec_stmt_lhs fix_env (L loc (BindStmt pat body a b t))
1062 = do
1063 -- should the ctxt be MDo instead?
1064 (pat', fv_pat) <- rnBindPat (localRecNameMaker fix_env) pat
1065 return [(L loc (BindStmt pat' body a b t),
1066 fv_pat)]
1067
1068 rn_rec_stmt_lhs _ (L _ (LetStmt (L _ binds@(HsIPBinds _))))
1069 = failWith (badIpBinds (text "an mdo expression") binds)
1070
1071 rn_rec_stmt_lhs fix_env (L loc (LetStmt (L l(HsValBinds binds))))
1072 = do (_bound_names, binds') <- rnLocalValBindsLHS fix_env binds
1073 return [(L loc (LetStmt (L l (HsValBinds binds'))),
1074 -- Warning: this is bogus; see function invariant
1075 emptyFVs
1076 )]
1077
1078 -- XXX Do we need to do something with the return and mfix names?
1079 rn_rec_stmt_lhs fix_env (L _ (RecStmt { recS_stmts = stmts })) -- Flatten Rec inside Rec
1080 = rn_rec_stmts_lhs fix_env stmts
1081
1082 rn_rec_stmt_lhs _ stmt@(L _ (ParStmt {})) -- Syntactically illegal in mdo
1083 = pprPanic "rn_rec_stmt" (ppr stmt)
1084
1085 rn_rec_stmt_lhs _ stmt@(L _ (TransStmt {})) -- Syntactically illegal in mdo
1086 = pprPanic "rn_rec_stmt" (ppr stmt)
1087
1088 rn_rec_stmt_lhs _ stmt@(L _ (ApplicativeStmt {})) -- Shouldn't appear yet
1089 = pprPanic "rn_rec_stmt" (ppr stmt)
1090
1091 rn_rec_stmt_lhs _ (L _ (LetStmt (L _ EmptyLocalBinds)))
1092 = panic "rn_rec_stmt LetStmt EmptyLocalBinds"
1093
1094 rn_rec_stmts_lhs :: Outputable body => MiniFixityEnv
1095 -> [LStmt RdrName body]
1096 -> RnM [(LStmtLR Name RdrName body, FreeVars)]
1097 rn_rec_stmts_lhs fix_env stmts
1098 = do { ls <- concatMapM (rn_rec_stmt_lhs fix_env) stmts
1099 ; let boundNames = collectLStmtsBinders (map fst ls)
1100 -- First do error checking: we need to check for dups here because we
1101 -- don't bind all of the variables from the Stmt at once
1102 -- with bindLocatedLocals.
1103 ; checkDupNames boundNames
1104 ; return ls }
1105
1106
1107 -- right-hand-sides
1108
1109 rn_rec_stmt :: (Outputable (body RdrName)) =>
1110 (Located (body RdrName) -> RnM (Located (body Name), FreeVars))
1111 -> [Name]
1112 -> (LStmtLR Name RdrName (Located (body RdrName)), FreeVars)
1113 -> RnM [Segment (LStmt Name (Located (body Name)))]
1114 -- Rename a Stmt that is inside a RecStmt (or mdo)
1115 -- Assumes all binders are already in scope
1116 -- Turns each stmt into a singleton Stmt
1117 rn_rec_stmt rnBody _ (L loc (LastStmt body noret _), _)
1118 = do { (body', fv_expr) <- rnBody body
1119 ; (ret_op, fvs1) <- lookupSyntaxName returnMName
1120 ; return [(emptyNameSet, fv_expr `plusFV` fvs1, emptyNameSet,
1121 L loc (LastStmt body' noret ret_op))] }
1122
1123 rn_rec_stmt rnBody _ (L loc (BodyStmt body _ _ _), _)
1124 = do { (body', fvs) <- rnBody body
1125 ; (then_op, fvs1) <- lookupSyntaxName thenMName
1126 ; return [(emptyNameSet, fvs `plusFV` fvs1, emptyNameSet,
1127 L loc (BodyStmt body' then_op noSyntaxExpr placeHolderType))] }
1128
1129 rn_rec_stmt rnBody _ (L loc (BindStmt pat' body _ _ _), fv_pat)
1130 = do { (body', fv_expr) <- rnBody body
1131 ; (bind_op, fvs1) <- lookupSyntaxName bindMName
1132
1133 ; xMonadFailEnabled <- fmap (xopt LangExt.MonadFailDesugaring) getDynFlags
1134 ; let failFunction | xMonadFailEnabled = failMName
1135 | otherwise = failMName_preMFP
1136 ; (fail_op, fvs2) <- lookupSyntaxName failFunction
1137
1138 ; let bndrs = mkNameSet (collectPatBinders pat')
1139 fvs = fv_expr `plusFV` fv_pat `plusFV` fvs1 `plusFV` fvs2
1140 ; return [(bndrs, fvs, bndrs `intersectNameSet` fvs,
1141 L loc (BindStmt pat' body' bind_op fail_op PlaceHolder))] }
1142
1143 rn_rec_stmt _ _ (L _ (LetStmt (L _ binds@(HsIPBinds _))), _)
1144 = failWith (badIpBinds (text "an mdo expression") binds)
1145
1146 rn_rec_stmt _ all_bndrs (L loc (LetStmt (L l (HsValBinds binds'))), _)
1147 = do { (binds', du_binds) <- rnLocalValBindsRHS (mkNameSet all_bndrs) binds'
1148 -- fixities and unused are handled above in rnRecStmtsAndThen
1149 ; let fvs = allUses du_binds
1150 ; return [(duDefs du_binds, fvs, emptyNameSet,
1151 L loc (LetStmt (L l (HsValBinds binds'))))] }
1152
1153 -- no RecStmt case because they get flattened above when doing the LHSes
1154 rn_rec_stmt _ _ stmt@(L _ (RecStmt {}), _)
1155 = pprPanic "rn_rec_stmt: RecStmt" (ppr stmt)
1156
1157 rn_rec_stmt _ _ stmt@(L _ (ParStmt {}), _) -- Syntactically illegal in mdo
1158 = pprPanic "rn_rec_stmt: ParStmt" (ppr stmt)
1159
1160 rn_rec_stmt _ _ stmt@(L _ (TransStmt {}), _) -- Syntactically illegal in mdo
1161 = pprPanic "rn_rec_stmt: TransStmt" (ppr stmt)
1162
1163 rn_rec_stmt _ _ (L _ (LetStmt (L _ EmptyLocalBinds)), _)
1164 = panic "rn_rec_stmt: LetStmt EmptyLocalBinds"
1165
1166 rn_rec_stmt _ _ stmt@(L _ (ApplicativeStmt {}), _)
1167 = pprPanic "rn_rec_stmt: ApplicativeStmt" (ppr stmt)
1168
1169 rn_rec_stmts :: Outputable (body RdrName) =>
1170 (Located (body RdrName) -> RnM (Located (body Name), FreeVars))
1171 -> [Name]
1172 -> [(LStmtLR Name RdrName (Located (body RdrName)), FreeVars)]
1173 -> RnM [Segment (LStmt Name (Located (body Name)))]
1174 rn_rec_stmts rnBody bndrs stmts
1175 = do { segs_s <- mapM (rn_rec_stmt rnBody bndrs) stmts
1176 ; return (concat segs_s) }
1177
1178 ---------------------------------------------
1179 segmentRecStmts :: SrcSpan -> HsStmtContext Name
1180 -> Stmt Name body
1181 -> [Segment (LStmt Name body)] -> FreeVars
1182 -> ([LStmt Name body], FreeVars)
1183
1184 segmentRecStmts loc ctxt empty_rec_stmt segs fvs_later
1185 | null segs
1186 = ([], fvs_later)
1187
1188 | MDoExpr <- ctxt
1189 = segsToStmts empty_rec_stmt grouped_segs fvs_later
1190 -- Step 4: Turn the segments into Stmts
1191 -- Use RecStmt when and only when there are fwd refs
1192 -- Also gather up the uses from the end towards the
1193 -- start, so we can tell the RecStmt which things are
1194 -- used 'after' the RecStmt
1195
1196 | otherwise
1197 = ([ L loc $
1198 empty_rec_stmt { recS_stmts = ss
1199 , recS_later_ids = nameSetElemsStable
1200 (defs `intersectNameSet` fvs_later)
1201 , recS_rec_ids = nameSetElemsStable
1202 (defs `intersectNameSet` uses) }]
1203 -- See Note [Deterministic ApplicativeDo and RecursiveDo desugaring]
1204 , uses `plusFV` fvs_later)
1205
1206 where
1207 (defs_s, uses_s, _, ss) = unzip4 segs
1208 defs = plusFVs defs_s
1209 uses = plusFVs uses_s
1210
1211 -- Step 2: Fill in the fwd refs.
1212 -- The segments are all singletons, but their fwd-ref
1213 -- field mentions all the things used by the segment
1214 -- that are bound after their use
1215 segs_w_fwd_refs = addFwdRefs segs
1216
1217 -- Step 3: Group together the segments to make bigger segments
1218 -- Invariant: in the result, no segment uses a variable
1219 -- bound in a later segment
1220 grouped_segs = glomSegments ctxt segs_w_fwd_refs
1221
1222 ----------------------------
1223 addFwdRefs :: [Segment a] -> [Segment a]
1224 -- So far the segments only have forward refs *within* the Stmt
1225 -- (which happens for bind: x <- ...x...)
1226 -- This function adds the cross-seg fwd ref info
1227
1228 addFwdRefs segs
1229 = fst (foldr mk_seg ([], emptyNameSet) segs)
1230 where
1231 mk_seg (defs, uses, fwds, stmts) (segs, later_defs)
1232 = (new_seg : segs, all_defs)
1233 where
1234 new_seg = (defs, uses, new_fwds, stmts)
1235 all_defs = later_defs `unionNameSet` defs
1236 new_fwds = fwds `unionNameSet` (uses `intersectNameSet` later_defs)
1237 -- Add the downstream fwd refs here
1238
1239 {-
1240 Note [Segmenting mdo]
1241 ~~~~~~~~~~~~~~~~~~~~~
1242 NB. June 7 2012: We only glom segments that appear in an explicit mdo;
1243 and leave those found in "do rec"'s intact. See
1244 http://ghc.haskell.org/trac/ghc/ticket/4148 for the discussion
1245 leading to this design choice. Hence the test in segmentRecStmts.
1246
1247 Note [Glomming segments]
1248 ~~~~~~~~~~~~~~~~~~~~~~~~
1249 Glomming the singleton segments of an mdo into minimal recursive groups.
1250
1251 At first I thought this was just strongly connected components, but
1252 there's an important constraint: the order of the stmts must not change.
1253
1254 Consider
1255 mdo { x <- ...y...
1256 p <- z
1257 y <- ...x...
1258 q <- x
1259 z <- y
1260 r <- x }
1261
1262 Here, the first stmt mention 'y', which is bound in the third.
1263 But that means that the innocent second stmt (p <- z) gets caught
1264 up in the recursion. And that in turn means that the binding for
1265 'z' has to be included... and so on.
1266
1267 Start at the tail { r <- x }
1268 Now add the next one { z <- y ; r <- x }
1269 Now add one more { q <- x ; z <- y ; r <- x }
1270 Now one more... but this time we have to group a bunch into rec
1271 { rec { y <- ...x... ; q <- x ; z <- y } ; r <- x }
1272 Now one more, which we can add on without a rec
1273 { p <- z ;
1274 rec { y <- ...x... ; q <- x ; z <- y } ;
1275 r <- x }
1276 Finally we add the last one; since it mentions y we have to
1277 glom it together with the first two groups
1278 { rec { x <- ...y...; p <- z ; y <- ...x... ;
1279 q <- x ; z <- y } ;
1280 r <- x }
1281 -}
1282
1283 glomSegments :: HsStmtContext Name
1284 -> [Segment (LStmt Name body)]
1285 -> [Segment [LStmt Name body]] -- Each segment has a non-empty list of Stmts
1286 -- See Note [Glomming segments]
1287
1288 glomSegments _ [] = []
1289 glomSegments ctxt ((defs,uses,fwds,stmt) : segs)
1290 -- Actually stmts will always be a singleton
1291 = (seg_defs, seg_uses, seg_fwds, seg_stmts) : others
1292 where
1293 segs' = glomSegments ctxt segs
1294 (extras, others) = grab uses segs'
1295 (ds, us, fs, ss) = unzip4 extras
1296
1297 seg_defs = plusFVs ds `plusFV` defs
1298 seg_uses = plusFVs us `plusFV` uses
1299 seg_fwds = plusFVs fs `plusFV` fwds
1300 seg_stmts = stmt : concat ss
1301
1302 grab :: NameSet -- The client
1303 -> [Segment a]
1304 -> ([Segment a], -- Needed by the 'client'
1305 [Segment a]) -- Not needed by the client
1306 -- The result is simply a split of the input
1307 grab uses dus
1308 = (reverse yeses, reverse noes)
1309 where
1310 (noes, yeses) = span not_needed (reverse dus)
1311 not_needed (defs,_,_,_) = not (intersectsNameSet defs uses)
1312
1313 ----------------------------------------------------
1314 segsToStmts :: Stmt Name body -- A RecStmt with the SyntaxOps filled in
1315 -> [Segment [LStmt Name body]] -- Each Segment has a non-empty list of Stmts
1316 -> FreeVars -- Free vars used 'later'
1317 -> ([LStmt Name body], FreeVars)
1318
1319 segsToStmts _ [] fvs_later = ([], fvs_later)
1320 segsToStmts empty_rec_stmt ((defs, uses, fwds, ss) : segs) fvs_later
1321 = ASSERT( not (null ss) )
1322 (new_stmt : later_stmts, later_uses `plusFV` uses)
1323 where
1324 (later_stmts, later_uses) = segsToStmts empty_rec_stmt segs fvs_later
1325 new_stmt | non_rec = head ss
1326 | otherwise = L (getLoc (head ss)) rec_stmt
1327 rec_stmt = empty_rec_stmt { recS_stmts = ss
1328 , recS_later_ids = nameSetElemsStable used_later
1329 , recS_rec_ids = nameSetElemsStable fwds }
1330 -- See Note [Deterministic ApplicativeDo and RecursiveDo desugaring]
1331 non_rec = isSingleton ss && isEmptyNameSet fwds
1332 used_later = defs `intersectNameSet` later_uses
1333 -- The ones needed after the RecStmt
1334
1335 {-
1336 ************************************************************************
1337 * *
1338 ApplicativeDo
1339 * *
1340 ************************************************************************
1341
1342 Note [ApplicativeDo]
1343
1344 = Example =
1345
1346 For a sequence of statements
1347
1348 do
1349 x <- A
1350 y <- B x
1351 z <- C
1352 return (f x y z)
1353
1354 We want to transform this to
1355
1356 (\(x,y) z -> f x y z) <$> (do x <- A; y <- B x; return (x,y)) <*> C
1357
1358 It would be easy to notice that "y <- B x" and "z <- C" are
1359 independent and do something like this:
1360
1361 do
1362 x <- A
1363 (y,z) <- (,) <$> B x <*> C
1364 return (f x y z)
1365
1366 But this isn't enough! A and C were also independent, and this
1367 transformation loses the ability to do A and C in parallel.
1368
1369 The algorithm works by first splitting the sequence of statements into
1370 independent "segments", and a separate "tail" (the final statement). In
1371 our example above, the segements would be
1372
1373 [ x <- A
1374 , y <- B x ]
1375
1376 [ z <- C ]
1377
1378 and the tail is:
1379
1380 return (f x y z)
1381
1382 Then we take these segments and make an Applicative expression from them:
1383
1384 (\(x,y) z -> return (f x y z))
1385 <$> do { x <- A; y <- B x; return (x,y) }
1386 <*> C
1387
1388 Finally, we recursively apply the transformation to each segment, to
1389 discover any nested parallelism.
1390
1391 = Syntax & spec =
1392
1393 expr ::= ... | do {stmt_1; ..; stmt_n} expr | ...
1394
1395 stmt ::= pat <- expr
1396 | (arg_1 | ... | arg_n) -- applicative composition, n>=1
1397 | ... -- other kinds of statement (e.g. let)
1398
1399 arg ::= pat <- expr
1400 | {stmt_1; ..; stmt_n} {var_1..var_n}
1401
1402 (note that in the actual implementation,the expr in a do statement is
1403 represented by a LastStmt as the final stmt, this is just a
1404 representational issue and may change later.)
1405
1406 == Transformation to introduce applicative stmts ==
1407
1408 ado {} tail = tail
1409 ado {pat <- expr} {return expr'} = (mkArg(pat <- expr)); return expr'
1410 ado {one} tail = one : tail
1411 ado stmts tail
1412 | n == 1 = ado before (ado after tail)
1413 where (before,after) = split(stmts_1)
1414 | n > 1 = (mkArg(stmts_1) | ... | mkArg(stmts_n)); tail
1415 where
1416 {stmts_1 .. stmts_n} = segments(stmts)
1417
1418 segments(stmts) =
1419 -- divide stmts into segments with no interdependencies
1420
1421 mkArg({pat <- expr}) = (pat <- expr)
1422 mkArg({stmt_1; ...; stmt_n}) =
1423 {stmt_1; ...; stmt_n} {vars(stmt_1) u .. u vars(stmt_n)}
1424
1425 split({stmt_1; ..; stmt_n) =
1426 ({stmt_1; ..; stmt_i}, {stmt_i+1; ..; stmt_n})
1427 -- 1 <= i <= n
1428 -- i is a good place to insert a bind
1429
1430 == Desugaring for do ==
1431
1432 dsDo {} expr = expr
1433
1434 dsDo {pat <- rhs; stmts} expr =
1435 rhs >>= \pat -> dsDo stmts expr
1436
1437 dsDo {(arg_1 | ... | arg_n)} (return expr) =
1438 (\argpat (arg_1) .. argpat(arg_n) -> expr)
1439 <$> argexpr(arg_1)
1440 <*> ...
1441 <*> argexpr(arg_n)
1442
1443 dsDo {(arg_1 | ... | arg_n); stmts} expr =
1444 join (\argpat (arg_1) .. argpat(arg_n) -> dsDo stmts expr)
1445 <$> argexpr(arg_1)
1446 <*> ...
1447 <*> argexpr(arg_n)
1448
1449 -}
1450
1451 -- | rearrange a list of statements using ApplicativeDoStmt. See
1452 -- Note [ApplicativeDo].
1453 rearrangeForApplicativeDo
1454 :: HsStmtContext Name
1455 -> [(ExprLStmt Name, FreeVars)]
1456 -> RnM ([ExprLStmt Name], FreeVars)
1457
1458 rearrangeForApplicativeDo _ [] = return ([], emptyNameSet)
1459 rearrangeForApplicativeDo _ [(one,_)] = return ([one], emptyNameSet)
1460 rearrangeForApplicativeDo ctxt stmts0 = do
1461 optimal_ado <- goptM Opt_OptimalApplicativeDo
1462 let stmt_tree | optimal_ado = mkStmtTreeOptimal stmts
1463 | otherwise = mkStmtTreeHeuristic stmts
1464 stmtTreeToStmts ctxt stmt_tree [last] last_fvs
1465 where
1466 (stmts,(last,last_fvs)) = findLast stmts0
1467 findLast [] = error "findLast"
1468 findLast [last] = ([],last)
1469 findLast (x:xs) = (x:rest,last) where (rest,last) = findLast xs
1470
1471 -- | A tree of statements using a mixture of applicative and bind constructs.
1472 data StmtTree a
1473 = StmtTreeOne a
1474 | StmtTreeBind (StmtTree a) (StmtTree a)
1475 | StmtTreeApplicative [StmtTree a]
1476
1477 flattenStmtTree :: StmtTree a -> [a]
1478 flattenStmtTree t = go t []
1479 where
1480 go (StmtTreeOne a) as = a : as
1481 go (StmtTreeBind l r) as = go l (go r as)
1482 go (StmtTreeApplicative ts) as = foldr go as ts
1483
1484 type ExprStmtTree = StmtTree (ExprLStmt Name, FreeVars)
1485 type Cost = Int
1486
1487 -- | Turn a sequence of statements into an ExprStmtTree using a
1488 -- heuristic algorithm. /O(n^2)/
1489 mkStmtTreeHeuristic :: [(ExprLStmt Name, FreeVars)] -> ExprStmtTree
1490 mkStmtTreeHeuristic [one] = StmtTreeOne one
1491 mkStmtTreeHeuristic stmts =
1492 case segments stmts of
1493 [one] -> split one
1494 segs -> StmtTreeApplicative (map split segs)
1495 where
1496 split [one] = StmtTreeOne one
1497 split stmts =
1498 StmtTreeBind (mkStmtTreeHeuristic before) (mkStmtTreeHeuristic after)
1499 where (before, after) = splitSegment stmts
1500
1501 -- | Turn a sequence of statements into an ExprStmtTree optimally,
1502 -- using dynamic programming. /O(n^3)/
1503 mkStmtTreeOptimal :: [(ExprLStmt Name, FreeVars)] -> ExprStmtTree
1504 mkStmtTreeOptimal stmts =
1505 ASSERT(not (null stmts)) -- the empty case is handled by the caller;
1506 -- we don't support empty StmtTrees.
1507 fst (arr ! (0,n))
1508 where
1509 n = length stmts - 1
1510 stmt_arr = listArray (0,n) stmts
1511
1512 -- lazy cache of optimal trees for subsequences of the input
1513 arr :: Array (Int,Int) (ExprStmtTree, Cost)
1514 arr = array ((0,0),(n,n))
1515 [ ((lo,hi), tree lo hi)
1516 | lo <- [0..n]
1517 , hi <- [lo..n] ]
1518
1519 -- compute the optimal tree for the sequence [lo..hi]
1520 tree lo hi
1521 | hi == lo = (StmtTreeOne (stmt_arr ! lo), 1)
1522 | otherwise =
1523 case segments [ stmt_arr ! i | i <- [lo..hi] ] of
1524 [] -> panic "mkStmtTree"
1525 [_one] -> split lo hi
1526 segs -> (StmtTreeApplicative trees, maximum costs)
1527 where
1528 bounds = scanl (\(_,hi) a -> (hi+1, hi + length a)) (0,lo-1) segs
1529 (trees,costs) = unzip (map (uncurry split) (tail bounds))
1530
1531 -- find the best place to split the segment [lo..hi]
1532 split :: Int -> Int -> (ExprStmtTree, Cost)
1533 split lo hi
1534 | hi == lo = (StmtTreeOne (stmt_arr ! lo), 1)
1535 | otherwise = (StmtTreeBind before after, c1+c2)
1536 where
1537 -- As per the paper, for a sequence s1...sn, we want to find
1538 -- the split with the minimum cost, where the cost is the
1539 -- sum of the cost of the left and right subsequences.
1540 --
1541 -- As an optimisation (also in the paper) if the cost of
1542 -- s1..s(n-1) is different from the cost of s2..sn, we know
1543 -- that the optimal solution is the lower of the two. Only
1544 -- in the case that these two have the same cost do we need
1545 -- to do the exhaustive search.
1546 --
1547 ((before,c1),(after,c2))
1548 | hi - lo == 1
1549 = ((StmtTreeOne (stmt_arr ! lo), 1),
1550 (StmtTreeOne (stmt_arr ! hi), 1))
1551 | left_cost < right_cost
1552 = ((left,left_cost), (StmtTreeOne (stmt_arr ! hi), 1))
1553 | otherwise -- left_cost > right_cost
1554 = ((StmtTreeOne (stmt_arr ! lo), 1), (right,right_cost))
1555 | otherwise = minimumBy (comparing cost) alternatives
1556 where
1557 (left, left_cost) = arr ! (lo,hi-1)
1558 (right, right_cost) = arr ! (lo+1,hi)
1559 cost ((_,c1),(_,c2)) = c1 + c2
1560 alternatives = [ (arr ! (lo,k), arr ! (k+1,hi))
1561 | k <- [lo .. hi-1] ]
1562
1563
1564 -- | Turn the ExprStmtTree back into a sequence of statements, using
1565 -- ApplicativeStmt where necessary.
1566 stmtTreeToStmts
1567 :: HsStmtContext Name
1568 -> ExprStmtTree
1569 -> [ExprLStmt Name] -- ^ the "tail"
1570 -> FreeVars -- ^ free variables of the tail
1571 -> RnM ( [ExprLStmt Name] -- ( output statements,
1572 , FreeVars ) -- , things we needed
1573
1574 -- If we have a single bind, and we can do it without a join, transform
1575 -- to an ApplicativeStmt. This corresponds to the rule
1576 -- dsBlock [pat <- rhs] (return expr) = expr <$> rhs
1577 -- In the spec, but we do it here rather than in the desugarer,
1578 -- because we need the typechecker to typecheck the <$> form rather than
1579 -- the bind form, which would give rise to a Monad constraint.
1580 stmtTreeToStmts ctxt (StmtTreeOne (L _ (BindStmt pat rhs _ _ _),_))
1581 tail _tail_fvs
1582 | isIrrefutableHsPat pat, (False,tail') <- needJoin tail
1583 -- WARNING: isIrrefutableHsPat on (HsPat Name) doesn't have enough info
1584 -- to know which types have only one constructor. So only
1585 -- tuples come out as irrefutable; other single-constructor
1586 -- types, and newtypes, will not. See the code for
1587 -- isIrrefuatableHsPat
1588 = mkApplicativeStmt ctxt [ApplicativeArgOne pat rhs] False tail'
1589
1590 stmtTreeToStmts _ctxt (StmtTreeOne (s,_)) tail _tail_fvs =
1591 return (s : tail, emptyNameSet)
1592
1593 stmtTreeToStmts ctxt (StmtTreeBind before after) tail tail_fvs = do
1594 (stmts1, fvs1) <- stmtTreeToStmts ctxt after tail tail_fvs
1595 let tail1_fvs = unionNameSets (tail_fvs : map snd (flattenStmtTree after))
1596 (stmts2, fvs2) <- stmtTreeToStmts ctxt before stmts1 tail1_fvs
1597 return (stmts2, fvs1 `plusFV` fvs2)
1598
1599 stmtTreeToStmts ctxt (StmtTreeApplicative trees) tail tail_fvs = do
1600 pairs <- mapM (stmtTreeArg ctxt tail_fvs) trees
1601 let (stmts', fvss) = unzip pairs
1602 let (need_join, tail') = needJoin tail
1603 (stmts, fvs) <- mkApplicativeStmt ctxt stmts' need_join tail'
1604 return (stmts, unionNameSets (fvs:fvss))
1605 where
1606 stmtTreeArg _ctxt _tail_fvs (StmtTreeOne (L _ (BindStmt pat exp _ _ _), _)) =
1607 return (ApplicativeArgOne pat exp, emptyFVs)
1608 stmtTreeArg ctxt tail_fvs tree = do
1609 let stmts = flattenStmtTree tree
1610 pvarset = mkNameSet (concatMap (collectStmtBinders.unLoc.fst) stmts)
1611 `intersectNameSet` tail_fvs
1612 pvars = nameSetElemsStable pvarset
1613 -- See Note [Deterministic ApplicativeDo and RecursiveDo desugaring]
1614 pat = mkBigLHsVarPatTup pvars
1615 tup = mkBigLHsVarTup pvars
1616 (stmts',fvs2) <- stmtTreeToStmts ctxt tree [] pvarset
1617 (mb_ret, fvs1) <-
1618 if | L _ ApplicativeStmt{} <- last stmts' ->
1619 return (unLoc tup, emptyNameSet)
1620 | otherwise -> do
1621 (ret,fvs) <- lookupStmtNamePoly ctxt returnMName
1622 return (HsApp (noLoc ret) tup, fvs)
1623 return ( ApplicativeArgMany stmts' mb_ret pat
1624 , fvs1 `plusFV` fvs2)
1625
1626
1627 -- | Divide a sequence of statements into segments, where no segment
1628 -- depends on any variables defined by a statement in another segment.
1629 segments
1630 :: [(ExprLStmt Name, FreeVars)]
1631 -> [[(ExprLStmt Name, FreeVars)]]
1632 segments stmts = map fst $ merge $ reverse $ map reverse $ walk (reverse stmts)
1633 where
1634 allvars = mkNameSet (concatMap (collectStmtBinders.unLoc.fst) stmts)
1635
1636 -- We would rather not have a segment that just has LetStmts in
1637 -- it, so combine those with an adjacent segment where possible.
1638 merge [] = []
1639 merge (seg : segs)
1640 = case rest of
1641 [] -> [(seg,all_lets)]
1642 ((s,s_lets):ss) | all_lets || s_lets
1643 -> (seg ++ s, all_lets && s_lets) : ss
1644 _otherwise -> (seg,all_lets) : rest
1645 where
1646 rest = merge segs
1647 all_lets = all (isLetStmt . fst) seg
1648
1649 -- walk splits the statement sequence into segments, traversing
1650 -- the sequence from the back to the front, and keeping track of
1651 -- the set of free variables of the current segment. Whenever
1652 -- this set of free variables is empty, we have a complete segment.
1653 walk :: [(ExprLStmt Name, FreeVars)] -> [[(ExprLStmt Name, FreeVars)]]
1654 walk [] = []
1655 walk ((stmt,fvs) : stmts) = ((stmt,fvs) : seg) : walk rest
1656 where (seg,rest) = chunter fvs' stmts
1657 (_, fvs') = stmtRefs stmt fvs
1658
1659 chunter _ [] = ([], [])
1660 chunter vars ((stmt,fvs) : rest)
1661 | not (isEmptyNameSet vars)
1662 = ((stmt,fvs) : chunk, rest')
1663 where (chunk,rest') = chunter vars' rest
1664 (pvars, evars) = stmtRefs stmt fvs
1665 vars' = (vars `minusNameSet` pvars) `unionNameSet` evars
1666 chunter _ rest = ([], rest)
1667
1668 stmtRefs stmt fvs
1669 | isLetStmt stmt = (pvars, fvs' `minusNameSet` pvars)
1670 | otherwise = (pvars, fvs')
1671 where fvs' = fvs `intersectNameSet` allvars
1672 pvars = mkNameSet (collectStmtBinders (unLoc stmt))
1673
1674 isLetStmt :: LStmt a b -> Bool
1675 isLetStmt (L _ LetStmt{}) = True
1676 isLetStmt _ = False
1677
1678 -- | Find a "good" place to insert a bind in an indivisible segment.
1679 -- This is the only place where we use heuristics. The current
1680 -- heuristic is to peel off the first group of independent statements
1681 -- and put the bind after those.
1682 splitSegment
1683 :: [(ExprLStmt Name, FreeVars)]
1684 -> ( [(ExprLStmt Name, FreeVars)]
1685 , [(ExprLStmt Name, FreeVars)] )
1686 splitSegment [one,two] = ([one],[two])
1687 -- there is no choice when there are only two statements; this just saves
1688 -- some work in a common case.
1689 splitSegment stmts
1690 | Just (lets,binds,rest) <- slurpIndependentStmts stmts
1691 = if not (null lets)
1692 then (lets, binds++rest)
1693 else (lets++binds, rest)
1694 | otherwise
1695 = case stmts of
1696 (x:xs) -> ([x],xs)
1697 _other -> (stmts,[])
1698
1699 slurpIndependentStmts
1700 :: [(LStmt Name (Located (body Name)), FreeVars)]
1701 -> Maybe ( [(LStmt Name (Located (body Name)), FreeVars)] -- LetStmts
1702 , [(LStmt Name (Located (body Name)), FreeVars)] -- BindStmts
1703 , [(LStmt Name (Located (body Name)), FreeVars)] )
1704 slurpIndependentStmts stmts = go [] [] emptyNameSet stmts
1705 where
1706 -- If we encounter a BindStmt that doesn't depend on a previous BindStmt
1707 -- in this group, then add it to the group.
1708 go lets indep bndrs ((L loc (BindStmt pat body bind_op fail_op ty), fvs) : rest)
1709 | isEmptyNameSet (bndrs `intersectNameSet` fvs)
1710 = go lets ((L loc (BindStmt pat body bind_op fail_op ty), fvs) : indep)
1711 bndrs' rest
1712 where bndrs' = bndrs `unionNameSet` mkNameSet (collectPatBinders pat)
1713 -- If we encounter a LetStmt that doesn't depend on a BindStmt in this
1714 -- group, then move it to the beginning, so that it doesn't interfere with
1715 -- grouping more BindStmts.
1716 -- TODO: perhaps we shouldn't do this if there are any strict bindings,
1717 -- because we might be moving evaluation earlier.
1718 go lets indep bndrs ((L loc (LetStmt binds), fvs) : rest)
1719 | isEmptyNameSet (bndrs `intersectNameSet` fvs)
1720 = go ((L loc (LetStmt binds), fvs) : lets) indep bndrs rest
1721 go _ [] _ _ = Nothing
1722 go _ [_] _ _ = Nothing
1723 go lets indep _ stmts = Just (reverse lets, reverse indep, stmts)
1724
1725 -- | Build an ApplicativeStmt, and strip the "return" from the tail
1726 -- if necessary.
1727 --
1728 -- For example, if we start with
1729 -- do x <- E1; y <- E2; return (f x y)
1730 -- then we get
1731 -- do (E1[x] | E2[y]); f x y
1732 --
1733 -- the LastStmt in this case has the return removed, but we set the
1734 -- flag on the LastStmt to indicate this, so that we can print out the
1735 -- original statement correctly in error messages. It is easier to do
1736 -- it this way rather than try to ignore the return later in both the
1737 -- typechecker and the desugarer (I tried it that way first!).
1738 mkApplicativeStmt
1739 :: HsStmtContext Name
1740 -> [ApplicativeArg Name Name] -- ^ The args
1741 -> Bool -- ^ True <=> need a join
1742 -> [ExprLStmt Name] -- ^ The body statements
1743 -> RnM ([ExprLStmt Name], FreeVars)
1744 mkApplicativeStmt ctxt args need_join body_stmts
1745 = do { (fmap_op, fvs1) <- lookupStmtName ctxt fmapName
1746 ; (ap_op, fvs2) <- lookupStmtName ctxt apAName
1747 ; (mb_join, fvs3) <-
1748 if need_join then
1749 do { (join_op, fvs) <- lookupStmtName ctxt joinMName
1750 ; return (Just join_op, fvs) }
1751 else
1752 return (Nothing, emptyNameSet)
1753 ; let applicative_stmt = noLoc $ ApplicativeStmt
1754 (zip (fmap_op : repeat ap_op) args)
1755 mb_join
1756 placeHolderType
1757 ; return ( applicative_stmt : body_stmts
1758 , fvs1 `plusFV` fvs2 `plusFV` fvs3) }
1759
1760 -- | Given the statements following an ApplicativeStmt, determine whether
1761 -- we need a @join@ or not, and remove the @return@ if necessary.
1762 needJoin :: [ExprLStmt Name] -> (Bool, [ExprLStmt Name])
1763 needJoin [] = (False, []) -- we're in an ApplicativeArg
1764 needJoin [L loc (LastStmt e _ t)]
1765 | Just arg <- isReturnApp e = (False, [L loc (LastStmt arg True t)])
1766 needJoin stmts = (True, stmts)
1767
1768 -- | @Just e@, if the expression is @return e@ or @return $ e@,
1769 -- otherwise @Nothing@
1770 isReturnApp :: LHsExpr Name -> Maybe (LHsExpr Name)
1771 isReturnApp (L _ (HsPar expr)) = isReturnApp expr
1772 isReturnApp (L _ e) = case e of
1773 OpApp l op _ r | is_return l, is_dollar op -> Just r
1774 HsApp f arg | is_return f -> Just arg
1775 _otherwise -> Nothing
1776 where
1777 is_var f (L _ (HsPar e)) = is_var f e
1778 is_var f (L _ (HsAppType e _)) = is_var f e
1779 is_var f (L _ (HsVar (L _ r))) = f r
1780 -- TODO: I don't know how to get this right for rebindable syntax
1781 is_var _ _ = False
1782
1783 is_return = is_var (\n -> n == returnMName || n == pureAName)
1784 is_dollar = is_var (`hasKey` dollarIdKey)
1785
1786 {-
1787 ************************************************************************
1788 * *
1789 \subsubsection{Errors}
1790 * *
1791 ************************************************************************
1792 -}
1793
1794 checkEmptyStmts :: HsStmtContext Name -> RnM ()
1795 -- We've seen an empty sequence of Stmts... is that ok?
1796 checkEmptyStmts ctxt
1797 = unless (okEmpty ctxt) (addErr (emptyErr ctxt))
1798
1799 okEmpty :: HsStmtContext a -> Bool
1800 okEmpty (PatGuard {}) = True
1801 okEmpty _ = False
1802
1803 emptyErr :: HsStmtContext Name -> SDoc
1804 emptyErr (ParStmtCtxt {}) = text "Empty statement group in parallel comprehension"
1805 emptyErr (TransStmtCtxt {}) = text "Empty statement group preceding 'group' or 'then'"
1806 emptyErr ctxt = text "Empty" <+> pprStmtContext ctxt
1807
1808 ----------------------
1809 checkLastStmt :: Outputable (body RdrName) => HsStmtContext Name
1810 -> LStmt RdrName (Located (body RdrName))
1811 -> RnM (LStmt RdrName (Located (body RdrName)))
1812 checkLastStmt ctxt lstmt@(L loc stmt)
1813 = case ctxt of
1814 ListComp -> check_comp
1815 MonadComp -> check_comp
1816 PArrComp -> check_comp
1817 ArrowExpr -> check_do
1818 DoExpr -> check_do
1819 MDoExpr -> check_do
1820 _ -> check_other
1821 where
1822 check_do -- Expect BodyStmt, and change it to LastStmt
1823 = case stmt of
1824 BodyStmt e _ _ _ -> return (L loc (mkLastStmt e))
1825 LastStmt {} -> return lstmt -- "Deriving" clauses may generate a
1826 -- LastStmt directly (unlike the parser)
1827 _ -> do { addErr (hang last_error 2 (ppr stmt)); return lstmt }
1828 last_error = (text "The last statement in" <+> pprAStmtContext ctxt
1829 <+> text "must be an expression")
1830
1831 check_comp -- Expect LastStmt; this should be enforced by the parser!
1832 = case stmt of
1833 LastStmt {} -> return lstmt
1834 _ -> pprPanic "checkLastStmt" (ppr lstmt)
1835
1836 check_other -- Behave just as if this wasn't the last stmt
1837 = do { checkStmt ctxt lstmt; return lstmt }
1838
1839 -- Checking when a particular Stmt is ok
1840 checkStmt :: HsStmtContext Name
1841 -> LStmt RdrName (Located (body RdrName))
1842 -> RnM ()
1843 checkStmt ctxt (L _ stmt)
1844 = do { dflags <- getDynFlags
1845 ; case okStmt dflags ctxt stmt of
1846 IsValid -> return ()
1847 NotValid extra -> addErr (msg $$ extra) }
1848 where
1849 msg = sep [ text "Unexpected" <+> pprStmtCat stmt <+> ptext (sLit "statement")
1850 , text "in" <+> pprAStmtContext ctxt ]
1851
1852 pprStmtCat :: Stmt a body -> SDoc
1853 pprStmtCat (TransStmt {}) = text "transform"
1854 pprStmtCat (LastStmt {}) = text "return expression"
1855 pprStmtCat (BodyStmt {}) = text "body"
1856 pprStmtCat (BindStmt {}) = text "binding"
1857 pprStmtCat (LetStmt {}) = text "let"
1858 pprStmtCat (RecStmt {}) = text "rec"
1859 pprStmtCat (ParStmt {}) = text "parallel"
1860 pprStmtCat (ApplicativeStmt {}) = panic "pprStmtCat: ApplicativeStmt"
1861
1862 ------------
1863 emptyInvalid :: Validity -- Payload is the empty document
1864 emptyInvalid = NotValid Outputable.empty
1865
1866 okStmt, okDoStmt, okCompStmt, okParStmt, okPArrStmt
1867 :: DynFlags -> HsStmtContext Name
1868 -> Stmt RdrName (Located (body RdrName)) -> Validity
1869 -- Return Nothing if OK, (Just extra) if not ok
1870 -- The "extra" is an SDoc that is appended to an generic error message
1871
1872 okStmt dflags ctxt stmt
1873 = case ctxt of
1874 PatGuard {} -> okPatGuardStmt stmt
1875 ParStmtCtxt ctxt -> okParStmt dflags ctxt stmt
1876 DoExpr -> okDoStmt dflags ctxt stmt
1877 MDoExpr -> okDoStmt dflags ctxt stmt
1878 ArrowExpr -> okDoStmt dflags ctxt stmt
1879 GhciStmtCtxt -> okDoStmt dflags ctxt stmt
1880 ListComp -> okCompStmt dflags ctxt stmt
1881 MonadComp -> okCompStmt dflags ctxt stmt
1882 PArrComp -> okPArrStmt dflags ctxt stmt
1883 TransStmtCtxt ctxt -> okStmt dflags ctxt stmt
1884
1885 -------------
1886 okPatGuardStmt :: Stmt RdrName (Located (body RdrName)) -> Validity
1887 okPatGuardStmt stmt
1888 = case stmt of
1889 BodyStmt {} -> IsValid
1890 BindStmt {} -> IsValid
1891 LetStmt {} -> IsValid
1892 _ -> emptyInvalid
1893
1894 -------------
1895 okParStmt dflags ctxt stmt
1896 = case stmt of
1897 LetStmt (L _ (HsIPBinds {})) -> emptyInvalid
1898 _ -> okStmt dflags ctxt stmt
1899
1900 ----------------
1901 okDoStmt dflags ctxt stmt
1902 = case stmt of
1903 RecStmt {}
1904 | LangExt.RecursiveDo `xopt` dflags -> IsValid
1905 | ArrowExpr <- ctxt -> IsValid -- Arrows allows 'rec'
1906 | otherwise -> NotValid (text "Use RecursiveDo")
1907 BindStmt {} -> IsValid
1908 LetStmt {} -> IsValid
1909 BodyStmt {} -> IsValid
1910 _ -> emptyInvalid
1911
1912 ----------------
1913 okCompStmt dflags _ stmt
1914 = case stmt of
1915 BindStmt {} -> IsValid
1916 LetStmt {} -> IsValid
1917 BodyStmt {} -> IsValid
1918 ParStmt {}
1919 | LangExt.ParallelListComp `xopt` dflags -> IsValid
1920 | otherwise -> NotValid (text "Use ParallelListComp")
1921 TransStmt {}
1922 | LangExt.TransformListComp `xopt` dflags -> IsValid
1923 | otherwise -> NotValid (text "Use TransformListComp")
1924 RecStmt {} -> emptyInvalid
1925 LastStmt {} -> emptyInvalid -- Should not happen (dealt with by checkLastStmt)
1926 ApplicativeStmt {} -> emptyInvalid
1927
1928 ----------------
1929 okPArrStmt dflags _ stmt
1930 = case stmt of
1931 BindStmt {} -> IsValid
1932 LetStmt {} -> IsValid
1933 BodyStmt {} -> IsValid
1934 ParStmt {}
1935 | LangExt.ParallelListComp `xopt` dflags -> IsValid
1936 | otherwise -> NotValid (text "Use ParallelListComp")
1937 TransStmt {} -> emptyInvalid
1938 RecStmt {} -> emptyInvalid
1939 LastStmt {} -> emptyInvalid -- Should not happen (dealt with by checkLastStmt)
1940 ApplicativeStmt {} -> emptyInvalid
1941
1942 ---------
1943 checkTupleSection :: [LHsTupArg RdrName] -> RnM ()
1944 checkTupleSection args
1945 = do { tuple_section <- xoptM LangExt.TupleSections
1946 ; checkErr (all tupArgPresent args || tuple_section) msg }
1947 where
1948 msg = text "Illegal tuple section: use TupleSections"
1949
1950 ---------
1951 sectionErr :: HsExpr RdrName -> SDoc
1952 sectionErr expr
1953 = hang (text "A section must be enclosed in parentheses")
1954 2 (text "thus:" <+> (parens (ppr expr)))
1955
1956 patSynErr :: HsExpr RdrName -> SDoc -> RnM (HsExpr Name, FreeVars)
1957 patSynErr e explanation = do { addErr (sep [text "Pattern syntax in expression context:",
1958 nest 4 (ppr e)] $$
1959 explanation)
1960 ; return (EWildPat, emptyFVs) }
1961
1962 badIpBinds :: Outputable a => SDoc -> a -> SDoc
1963 badIpBinds what binds
1964 = hang (text "Implicit-parameter bindings illegal in" <+> what)
1965 2 (ppr binds)