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