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