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