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