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