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