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