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