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