e1a314f0292191be35894d963bad25b8ee760324
[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 | otherwise -- 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 | isIrrefutableHsPat pat, (False,tail') <- needJoin monad_names tail
1639 -- WARNING: isIrrefutableHsPat on (HsPat Name) doesn't have enough info
1640 -- to know which types have only one constructor. So only
1641 -- tuples come out as irrefutable; other single-constructor
1642 -- types, and newtypes, will not. See the code for
1643 -- isIrrefuatableHsPat
1644 = mkApplicativeStmt ctxt [ApplicativeArgOne pat rhs] False tail'
1645
1646 stmtTreeToStmts _monad_names _ctxt (StmtTreeOne (s,_)) tail _tail_fvs =
1647 return (s : tail, emptyNameSet)
1648
1649 stmtTreeToStmts monad_names ctxt (StmtTreeBind before after) tail tail_fvs = do
1650 (stmts1, fvs1) <- stmtTreeToStmts monad_names ctxt after tail tail_fvs
1651 let tail1_fvs = unionNameSets (tail_fvs : map snd (flattenStmtTree after))
1652 (stmts2, fvs2) <- stmtTreeToStmts monad_names ctxt before stmts1 tail1_fvs
1653 return (stmts2, fvs1 `plusFV` fvs2)
1654
1655 stmtTreeToStmts monad_names ctxt (StmtTreeApplicative trees) tail tail_fvs = do
1656 pairs <- mapM (stmtTreeArg ctxt tail_fvs) trees
1657 let (stmts', fvss) = unzip pairs
1658 let (need_join, tail') = needJoin monad_names tail
1659 (stmts, fvs) <- mkApplicativeStmt ctxt stmts' need_join tail'
1660 return (stmts, unionNameSets (fvs:fvss))
1661 where
1662 stmtTreeArg _ctxt _tail_fvs (StmtTreeOne (L _ (BindStmt pat exp _ _ _), _)) =
1663 return (ApplicativeArgOne pat exp, emptyFVs)
1664 stmtTreeArg ctxt tail_fvs tree = do
1665 let stmts = flattenStmtTree tree
1666 pvarset = mkNameSet (concatMap (collectStmtBinders.unLoc.fst) stmts)
1667 `intersectNameSet` tail_fvs
1668 pvars = nameSetElemsStable pvarset
1669 -- See Note [Deterministic ApplicativeDo and RecursiveDo desugaring]
1670 pat = mkBigLHsVarPatTup pvars
1671 tup = mkBigLHsVarTup pvars
1672 (stmts',fvs2) <- stmtTreeToStmts monad_names ctxt tree [] pvarset
1673 (mb_ret, fvs1) <-
1674 if | L _ ApplicativeStmt{} <- last stmts' ->
1675 return (unLoc tup, emptyNameSet)
1676 | otherwise -> do
1677 (ret,fvs) <- lookupStmtNamePoly ctxt returnMName
1678 return (HsApp (noLoc ret) tup, fvs)
1679 return ( ApplicativeArgMany stmts' mb_ret pat
1680 , fvs1 `plusFV` fvs2)
1681
1682
1683 -- | Divide a sequence of statements into segments, where no segment
1684 -- depends on any variables defined by a statement in another segment.
1685 segments
1686 :: [(ExprLStmt GhcRn, FreeVars)]
1687 -> [[(ExprLStmt GhcRn, FreeVars)]]
1688 segments stmts = map fst $ merge $ reverse $ map reverse $ walk (reverse stmts)
1689 where
1690 allvars = mkNameSet (concatMap (collectStmtBinders.unLoc.fst) stmts)
1691
1692 -- We would rather not have a segment that just has LetStmts in
1693 -- it, so combine those with an adjacent segment where possible.
1694 merge [] = []
1695 merge (seg : segs)
1696 = case rest of
1697 [] -> [(seg,all_lets)]
1698 ((s,s_lets):ss) | all_lets || s_lets
1699 -> (seg ++ s, all_lets && s_lets) : ss
1700 _otherwise -> (seg,all_lets) : rest
1701 where
1702 rest = merge segs
1703 all_lets = all (isLetStmt . fst) seg
1704
1705 -- walk splits the statement sequence into segments, traversing
1706 -- the sequence from the back to the front, and keeping track of
1707 -- the set of free variables of the current segment. Whenever
1708 -- this set of free variables is empty, we have a complete segment.
1709 walk :: [(ExprLStmt GhcRn, FreeVars)] -> [[(ExprLStmt GhcRn, FreeVars)]]
1710 walk [] = []
1711 walk ((stmt,fvs) : stmts) = ((stmt,fvs) : seg) : walk rest
1712 where (seg,rest) = chunter fvs' stmts
1713 (_, fvs') = stmtRefs stmt fvs
1714
1715 chunter _ [] = ([], [])
1716 chunter vars ((stmt,fvs) : rest)
1717 | not (isEmptyNameSet vars)
1718 = ((stmt,fvs) : chunk, rest')
1719 where (chunk,rest') = chunter vars' rest
1720 (pvars, evars) = stmtRefs stmt fvs
1721 vars' = (vars `minusNameSet` pvars) `unionNameSet` evars
1722 chunter _ rest = ([], rest)
1723
1724 stmtRefs stmt fvs
1725 | isLetStmt stmt = (pvars, fvs' `minusNameSet` pvars)
1726 | otherwise = (pvars, fvs')
1727 where fvs' = fvs `intersectNameSet` allvars
1728 pvars = mkNameSet (collectStmtBinders (unLoc stmt))
1729
1730 isLetStmt :: LStmt a b -> Bool
1731 isLetStmt (L _ LetStmt{}) = True
1732 isLetStmt _ = False
1733
1734 -- | Find a "good" place to insert a bind in an indivisible segment.
1735 -- This is the only place where we use heuristics. The current
1736 -- heuristic is to peel off the first group of independent statements
1737 -- and put the bind after those.
1738 splitSegment
1739 :: [(ExprLStmt GhcRn, FreeVars)]
1740 -> ( [(ExprLStmt GhcRn, FreeVars)]
1741 , [(ExprLStmt GhcRn, FreeVars)] )
1742 splitSegment [one,two] = ([one],[two])
1743 -- there is no choice when there are only two statements; this just saves
1744 -- some work in a common case.
1745 splitSegment stmts
1746 | Just (lets,binds,rest) <- slurpIndependentStmts stmts
1747 = if not (null lets)
1748 then (lets, binds++rest)
1749 else (lets++binds, rest)
1750 | otherwise
1751 = case stmts of
1752 (x:xs) -> ([x],xs)
1753 _other -> (stmts,[])
1754
1755 slurpIndependentStmts
1756 :: [(LStmt GhcRn (Located (body GhcRn)), FreeVars)]
1757 -> Maybe ( [(LStmt GhcRn (Located (body GhcRn)), FreeVars)] -- LetStmts
1758 , [(LStmt GhcRn (Located (body GhcRn)), FreeVars)] -- BindStmts
1759 , [(LStmt GhcRn (Located (body GhcRn)), FreeVars)] )
1760 slurpIndependentStmts stmts = go [] [] emptyNameSet stmts
1761 where
1762 -- If we encounter a BindStmt that doesn't depend on a previous BindStmt
1763 -- in this group, then add it to the group.
1764 go lets indep bndrs ((L loc (BindStmt pat body bind_op fail_op ty), fvs) : rest)
1765 | isEmptyNameSet (bndrs `intersectNameSet` fvs)
1766 = go lets ((L loc (BindStmt pat body bind_op fail_op ty), fvs) : indep)
1767 bndrs' rest
1768 where bndrs' = bndrs `unionNameSet` mkNameSet (collectPatBinders pat)
1769 -- If we encounter a LetStmt that doesn't depend on a BindStmt in this
1770 -- group, then move it to the beginning, so that it doesn't interfere with
1771 -- grouping more BindStmts.
1772 -- TODO: perhaps we shouldn't do this if there are any strict bindings,
1773 -- because we might be moving evaluation earlier.
1774 go lets indep bndrs ((L loc (LetStmt binds), fvs) : rest)
1775 | isEmptyNameSet (bndrs `intersectNameSet` fvs)
1776 = go ((L loc (LetStmt binds), fvs) : lets) indep bndrs rest
1777 go _ [] _ _ = Nothing
1778 go _ [_] _ _ = Nothing
1779 go lets indep _ stmts = Just (reverse lets, reverse indep, stmts)
1780
1781 -- | Build an ApplicativeStmt, and strip the "return" from the tail
1782 -- if necessary.
1783 --
1784 -- For example, if we start with
1785 -- do x <- E1; y <- E2; return (f x y)
1786 -- then we get
1787 -- do (E1[x] | E2[y]); f x y
1788 --
1789 -- the LastStmt in this case has the return removed, but we set the
1790 -- flag on the LastStmt to indicate this, so that we can print out the
1791 -- original statement correctly in error messages. It is easier to do
1792 -- it this way rather than try to ignore the return later in both the
1793 -- typechecker and the desugarer (I tried it that way first!).
1794 mkApplicativeStmt
1795 :: HsStmtContext Name
1796 -> [ApplicativeArg GhcRn GhcRn] -- ^ The args
1797 -> Bool -- ^ True <=> need a join
1798 -> [ExprLStmt GhcRn] -- ^ The body statements
1799 -> RnM ([ExprLStmt GhcRn], FreeVars)
1800 mkApplicativeStmt ctxt args need_join body_stmts
1801 = do { (fmap_op, fvs1) <- lookupStmtName ctxt fmapName
1802 ; (ap_op, fvs2) <- lookupStmtName ctxt apAName
1803 ; (mb_join, fvs3) <-
1804 if need_join then
1805 do { (join_op, fvs) <- lookupStmtName ctxt joinMName
1806 ; return (Just join_op, fvs) }
1807 else
1808 return (Nothing, emptyNameSet)
1809 ; let applicative_stmt = noLoc $ ApplicativeStmt
1810 (zip (fmap_op : repeat ap_op) args)
1811 mb_join
1812 placeHolderType
1813 ; return ( applicative_stmt : body_stmts
1814 , fvs1 `plusFV` fvs2 `plusFV` fvs3) }
1815
1816 -- | Given the statements following an ApplicativeStmt, determine whether
1817 -- we need a @join@ or not, and remove the @return@ if necessary.
1818 needJoin :: MonadNames
1819 -> [ExprLStmt GhcRn]
1820 -> (Bool, [ExprLStmt GhcRn])
1821 needJoin _monad_names [] = (False, []) -- we're in an ApplicativeArg
1822 needJoin monad_names [L loc (LastStmt e _ t)]
1823 | Just arg <- isReturnApp monad_names e =
1824 (False, [L loc (LastStmt arg True t)])
1825 needJoin _monad_names stmts = (True, stmts)
1826
1827 -- | @Just e@, if the expression is @return e@ or @return $ e@,
1828 -- otherwise @Nothing@
1829 isReturnApp :: MonadNames
1830 -> LHsExpr GhcRn
1831 -> Maybe (LHsExpr GhcRn)
1832 isReturnApp monad_names (L _ (HsPar expr)) = isReturnApp monad_names expr
1833 isReturnApp monad_names (L _ e) = case e of
1834 OpApp l op _ r | is_return l, is_dollar op -> Just r
1835 HsApp f arg | is_return f -> Just arg
1836 _otherwise -> Nothing
1837 where
1838 is_var f (L _ (HsPar e)) = is_var f e
1839 is_var f (L _ (HsAppType e _)) = is_var f e
1840 is_var f (L _ (HsVar (L _ r))) = f r
1841 -- TODO: I don't know how to get this right for rebindable syntax
1842 is_var _ _ = False
1843
1844 is_return = is_var (\n -> n == return_name monad_names
1845 || n == pure_name monad_names)
1846 is_dollar = is_var (`hasKey` dollarIdKey)
1847
1848 {-
1849 ************************************************************************
1850 * *
1851 \subsubsection{Errors}
1852 * *
1853 ************************************************************************
1854 -}
1855
1856 checkEmptyStmts :: HsStmtContext Name -> RnM ()
1857 -- We've seen an empty sequence of Stmts... is that ok?
1858 checkEmptyStmts ctxt
1859 = unless (okEmpty ctxt) (addErr (emptyErr ctxt))
1860
1861 okEmpty :: HsStmtContext a -> Bool
1862 okEmpty (PatGuard {}) = True
1863 okEmpty _ = False
1864
1865 emptyErr :: HsStmtContext Name -> SDoc
1866 emptyErr (ParStmtCtxt {}) = text "Empty statement group in parallel comprehension"
1867 emptyErr (TransStmtCtxt {}) = text "Empty statement group preceding 'group' or 'then'"
1868 emptyErr ctxt = text "Empty" <+> pprStmtContext ctxt
1869
1870 ----------------------
1871 checkLastStmt :: Outputable (body GhcPs) => HsStmtContext Name
1872 -> LStmt GhcPs (Located (body GhcPs))
1873 -> RnM (LStmt GhcPs (Located (body GhcPs)))
1874 checkLastStmt ctxt lstmt@(L loc stmt)
1875 = case ctxt of
1876 ListComp -> check_comp
1877 MonadComp -> check_comp
1878 PArrComp -> check_comp
1879 ArrowExpr -> check_do
1880 DoExpr -> check_do
1881 MDoExpr -> check_do
1882 _ -> check_other
1883 where
1884 check_do -- Expect BodyStmt, and change it to LastStmt
1885 = case stmt of
1886 BodyStmt e _ _ _ -> return (L loc (mkLastStmt e))
1887 LastStmt {} -> return lstmt -- "Deriving" clauses may generate a
1888 -- LastStmt directly (unlike the parser)
1889 _ -> do { addErr (hang last_error 2 (ppr stmt)); return lstmt }
1890 last_error = (text "The last statement in" <+> pprAStmtContext ctxt
1891 <+> text "must be an expression")
1892
1893 check_comp -- Expect LastStmt; this should be enforced by the parser!
1894 = case stmt of
1895 LastStmt {} -> return lstmt
1896 _ -> pprPanic "checkLastStmt" (ppr lstmt)
1897
1898 check_other -- Behave just as if this wasn't the last stmt
1899 = do { checkStmt ctxt lstmt; return lstmt }
1900
1901 -- Checking when a particular Stmt is ok
1902 checkStmt :: HsStmtContext Name
1903 -> LStmt GhcPs (Located (body GhcPs))
1904 -> RnM ()
1905 checkStmt ctxt (L _ stmt)
1906 = do { dflags <- getDynFlags
1907 ; case okStmt dflags ctxt stmt of
1908 IsValid -> return ()
1909 NotValid extra -> addErr (msg $$ extra) }
1910 where
1911 msg = sep [ text "Unexpected" <+> pprStmtCat stmt <+> ptext (sLit "statement")
1912 , text "in" <+> pprAStmtContext ctxt ]
1913
1914 pprStmtCat :: Stmt a body -> SDoc
1915 pprStmtCat (TransStmt {}) = text "transform"
1916 pprStmtCat (LastStmt {}) = text "return expression"
1917 pprStmtCat (BodyStmt {}) = text "body"
1918 pprStmtCat (BindStmt {}) = text "binding"
1919 pprStmtCat (LetStmt {}) = text "let"
1920 pprStmtCat (RecStmt {}) = text "rec"
1921 pprStmtCat (ParStmt {}) = text "parallel"
1922 pprStmtCat (ApplicativeStmt {}) = panic "pprStmtCat: ApplicativeStmt"
1923
1924 ------------
1925 emptyInvalid :: Validity -- Payload is the empty document
1926 emptyInvalid = NotValid Outputable.empty
1927
1928 okStmt, okDoStmt, okCompStmt, okParStmt, okPArrStmt
1929 :: DynFlags -> HsStmtContext Name
1930 -> Stmt GhcPs (Located (body GhcPs)) -> Validity
1931 -- Return Nothing if OK, (Just extra) if not ok
1932 -- The "extra" is an SDoc that is appended to an generic error message
1933
1934 okStmt dflags ctxt stmt
1935 = case ctxt of
1936 PatGuard {} -> okPatGuardStmt stmt
1937 ParStmtCtxt ctxt -> okParStmt dflags ctxt stmt
1938 DoExpr -> okDoStmt dflags ctxt stmt
1939 MDoExpr -> okDoStmt dflags ctxt stmt
1940 ArrowExpr -> okDoStmt dflags ctxt stmt
1941 GhciStmtCtxt -> okDoStmt dflags ctxt stmt
1942 ListComp -> okCompStmt dflags ctxt stmt
1943 MonadComp -> okCompStmt dflags ctxt stmt
1944 PArrComp -> okPArrStmt dflags ctxt stmt
1945 TransStmtCtxt ctxt -> okStmt dflags ctxt stmt
1946
1947 -------------
1948 okPatGuardStmt :: Stmt GhcPs (Located (body GhcPs)) -> Validity
1949 okPatGuardStmt stmt
1950 = case stmt of
1951 BodyStmt {} -> IsValid
1952 BindStmt {} -> IsValid
1953 LetStmt {} -> IsValid
1954 _ -> emptyInvalid
1955
1956 -------------
1957 okParStmt dflags ctxt stmt
1958 = case stmt of
1959 LetStmt (L _ (HsIPBinds {})) -> emptyInvalid
1960 _ -> okStmt dflags ctxt stmt
1961
1962 ----------------
1963 okDoStmt dflags ctxt stmt
1964 = case stmt of
1965 RecStmt {}
1966 | LangExt.RecursiveDo `xopt` dflags -> IsValid
1967 | ArrowExpr <- ctxt -> IsValid -- Arrows allows 'rec'
1968 | otherwise -> NotValid (text "Use RecursiveDo")
1969 BindStmt {} -> IsValid
1970 LetStmt {} -> IsValid
1971 BodyStmt {} -> IsValid
1972 _ -> emptyInvalid
1973
1974 ----------------
1975 okCompStmt dflags _ stmt
1976 = case stmt of
1977 BindStmt {} -> IsValid
1978 LetStmt {} -> IsValid
1979 BodyStmt {} -> IsValid
1980 ParStmt {}
1981 | LangExt.ParallelListComp `xopt` dflags -> IsValid
1982 | otherwise -> NotValid (text "Use ParallelListComp")
1983 TransStmt {}
1984 | LangExt.TransformListComp `xopt` dflags -> IsValid
1985 | otherwise -> NotValid (text "Use TransformListComp")
1986 RecStmt {} -> emptyInvalid
1987 LastStmt {} -> emptyInvalid -- Should not happen (dealt with by checkLastStmt)
1988 ApplicativeStmt {} -> emptyInvalid
1989
1990 ----------------
1991 okPArrStmt dflags _ stmt
1992 = case stmt of
1993 BindStmt {} -> IsValid
1994 LetStmt {} -> IsValid
1995 BodyStmt {} -> IsValid
1996 ParStmt {}
1997 | LangExt.ParallelListComp `xopt` dflags -> IsValid
1998 | otherwise -> NotValid (text "Use ParallelListComp")
1999 TransStmt {} -> emptyInvalid
2000 RecStmt {} -> emptyInvalid
2001 LastStmt {} -> emptyInvalid -- Should not happen (dealt with by checkLastStmt)
2002 ApplicativeStmt {} -> emptyInvalid
2003
2004 ---------
2005 checkTupleSection :: [LHsTupArg GhcPs] -> RnM ()
2006 checkTupleSection args
2007 = do { tuple_section <- xoptM LangExt.TupleSections
2008 ; checkErr (all tupArgPresent args || tuple_section) msg }
2009 where
2010 msg = text "Illegal tuple section: use TupleSections"
2011
2012 ---------
2013 sectionErr :: HsExpr GhcPs -> SDoc
2014 sectionErr expr
2015 = hang (text "A section must be enclosed in parentheses")
2016 2 (text "thus:" <+> (parens (ppr expr)))
2017
2018 patSynErr :: HsExpr GhcPs -> SDoc -> RnM (HsExpr GhcRn, FreeVars)
2019 patSynErr e explanation = do { addErr (sep [text "Pattern syntax in expression context:",
2020 nest 4 (ppr e)] $$
2021 explanation)
2022 ; return (EWildPat, emptyFVs) }
2023
2024 badIpBinds :: Outputable a => SDoc -> a -> SDoc
2025 badIpBinds what binds
2026 = hang (text "Implicit-parameter bindings illegal in" <+> what)
2027 2 (ppr binds)