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