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