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