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