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