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