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