never executed always true always false
1
2 {-# LANGUAGE ConstraintKinds #-}
3 {-# LANGUAGE CPP #-}
4 {-# LANGUAGE FlexibleContexts #-}
5 {-# LANGUAGE MultiWayIf #-}
6 {-# LANGUAGE ScopedTypeVariables #-}
7 {-# LANGUAGE TypeApplications #-}
8 {-# LANGUAGE TypeFamilies #-}
9
10 {-# OPTIONS_GHC -Wno-incomplete-record-updates #-}
11 {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
12
13 {-
14 (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
15
16 Renaming of expressions
17
18 Basically dependency analysis.
19
20 Handles @Match@, @GRHSs@, @HsExpr@, and @Qualifier@ datatypes. In
21 general, all of these functions return a renamed thing, and a set of
22 free variables.
23 -}
24
25 module GHC.Rename.Expr (
26 rnLExpr, rnExpr, rnStmts,
27 AnnoBody
28 ) where
29
30 import GHC.Prelude
31
32 import GHC.Rename.Bind ( rnLocalBindsAndThen, rnLocalValBindsLHS, rnLocalValBindsRHS
33 , rnMatchGroup, rnGRHS, makeMiniFixityEnv)
34 import GHC.Hs
35 import GHC.Tc.Errors.Types
36 import GHC.Tc.Utils.Env ( isBrackStage )
37 import GHC.Tc.Utils.Monad
38 import GHC.Unit.Module ( getModule, isInteractiveModule )
39 import GHC.Rename.Env
40 import GHC.Rename.Fixity
41 import GHC.Rename.Utils ( HsDocContext(..), bindLocalNamesFV, checkDupNames
42 , bindLocalNames
43 , mapMaybeFvRn, mapFvRn
44 , warnUnusedLocalBinds, typeAppErr
45 , checkUnusedRecordWildcard
46 , wrapGenSpan, genHsIntegralLit, genHsTyLit
47 , genHsVar, genLHsVar, genHsApp, genHsApps
48 , genAppType )
49 import GHC.Rename.Unbound ( reportUnboundName )
50 import GHC.Rename.Splice ( rnBracket, rnSpliceExpr, checkThLocalName )
51 import GHC.Rename.HsType
52 import GHC.Rename.Pat
53 import GHC.Driver.Session
54 import GHC.Builtin.Names
55
56 import GHC.Types.FieldLabel
57 import GHC.Types.Fixity
58 import GHC.Types.Hint (suggestExtension)
59 import GHC.Types.Id.Make
60 import GHC.Types.Name
61 import GHC.Types.Name.Set
62 import GHC.Types.Name.Reader
63 import GHC.Types.Unique.Set
64 import GHC.Types.SourceText
65 import GHC.Utils.Misc
66 import GHC.Data.List.SetOps ( removeDups )
67 import GHC.Utils.Error
68 import GHC.Utils.Panic
69 import GHC.Utils.Panic.Plain
70 import GHC.Utils.Outputable as Outputable
71 import GHC.Types.SrcLoc
72 import Control.Monad
73 import GHC.Builtin.Types ( nilDataConName )
74 import qualified GHC.LanguageExtensions as LangExt
75
76 import Data.List (unzip4, minimumBy)
77 import Data.Maybe (isJust, isNothing)
78 import Control.Arrow (first)
79 import Data.Ord
80 import Data.Array
81 import qualified Data.List.NonEmpty as NE
82
83 {- Note [Handling overloaded and rebindable constructs]
84 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
85 For overloaded constructs (overloaded literals, lists, strings), and
86 rebindable constructs (e.g. if-then-else), our general plan is this,
87 using overloaded labels #foo as an example:
88
89 * In the RENAMER: transform
90 HsOverLabel "foo"
91 ==> XExpr (HsExpansion (HsOverLabel #foo)
92 (fromLabel `HsAppType` "foo"))
93 We write this more compactly in concrete-syntax form like this
94 #foo ==> fromLabel @"foo"
95
96 Recall that in (HsExpansion orig expanded), 'orig' is the original term
97 the user wrote, and 'expanded' is the expanded or desugared version
98 to be typechecked.
99
100 * In the TYPECHECKER: typecheck the expansion, in this case
101 fromLabel @"foo"
102 The typechecker (and desugarer) will never see HsOverLabel
103
104 In effect, the renamer does a bit of desugaring. Recall GHC.Hs.Expr
105 Note [Rebindable syntax and HsExpansion], which describes the use of HsExpansion.
106
107 RebindableSyntax:
108 If RebindableSyntax is off we use the built-in 'fromLabel', defined in
109 GHC.Builtin.Names.fromLabelClassOpName
110 If RebindableSyntax if ON, we look up "fromLabel" in the environment
111 to get whichever one is in scope.
112 This is accomplished by lookupSyntaxName, and it applies to all the
113 constructs below.
114
115 See also Note [Handling overloaded and rebindable patterns] in GHC.Rename.Pat
116 for the story with patterns.
117
118 Here are the expressions that we transform in this way. Some are uniform,
119 but several have a little bit of special treatment:
120
121 * HsIf (if-the-else)
122 if b then e1 else e2 ==> ifThenElse b e1 e2
123 We do this /only/ if rebindable syntax is on, because the coverage
124 checker looks for HsIf (see GHC.HsToCore.Coverage.addTickHsExpr)
125 That means the typechecker and desugarer need to understand HsIf
126 for the non-rebindable-syntax case.
127
128 * OverLabel (overloaded labels, #lbl)
129 #lbl ==> fromLabel @"lbl"
130 As ever, we use lookupSyntaxName to look up 'fromLabel'
131 See Note [Overloaded labels]
132
133 * ExplicitList (explicit lists [a,b,c])
134 When (and only when) OverloadedLists is on
135 [e1,e2] ==> fromListN 2 [e1,e2]
136 NB: the type checker and desugarer still see ExplicitList,
137 but to them it always means the built-in lists.
138
139 * SectionL and SectionR (left and right sections)
140 (`op` e) ==> rightSection op e
141 (e `op`) ==> leftSection (op e)
142 where `leftSection` and `rightSection` are representation-polymorphic
143 wired-in Ids. See Note [Left and right sections]
144
145 * It's a bit painful to transform `OpApp e1 op e2` to a `HsExpansion`
146 form, because the renamer does precedence rearrangement after name
147 resolution. So the renamer leaves an OpApp as an OpApp.
148
149 The typechecker turns `OpApp` into a use of `HsExpansion`
150 on the fly, in GHC.Tc.Gen.Head.splitHsApps. RebindableSyntax
151 does not affect this.
152
153 Note [Overloaded labels]
154 ~~~~~~~~~~~~~~~~~~~~~~~~
155 For overloaded labels, note that we /only/ apply `fromLabel` to the
156 Symbol argument, so the resulting expression has type
157 fromLabel @"foo" :: forall a. IsLabel "foo" a => a
158 Now ordinary Visible Type Application can be used to instantiate the 'a':
159 the user may have written (#foo @Int).
160
161 Notice that this all works fine in a kind-polymorphic setting (#19154).
162 Suppose we have
163 fromLabel :: forall {k1} {k2} (a:k1). blah
164
165 Then we want to instantiate those inferred quantifiers k1,k2, before
166 type-applying to "foo", so we get
167 fromLabel @Symbol @blah @"foo" ...
168
169 And those inferred kind quantifiers will indeed be instantiated when we
170 typecheck the renamed-syntax call (fromLabel @"foo").
171 -}
172
173 {-
174 ************************************************************************
175 * *
176 \subsubsection{Expressions}
177 * *
178 ************************************************************************
179 -}
180
181 rnExprs :: [LHsExpr GhcPs] -> RnM ([LHsExpr GhcRn], FreeVars)
182 rnExprs ls = rnExprs' ls emptyUniqSet
183 where
184 rnExprs' [] acc = return ([], acc)
185 rnExprs' (expr:exprs) acc =
186 do { (expr', fvExpr) <- rnLExpr expr
187 -- Now we do a "seq" on the free vars because typically it's small
188 -- or empty, especially in very long lists of constants
189 ; let acc' = acc `plusFV` fvExpr
190 ; (exprs', fvExprs) <- acc' `seq` rnExprs' exprs acc'
191 ; return (expr':exprs', fvExprs) }
192
193 -- Variables. We look up the variable and return the resulting name.
194
195 rnLExpr :: LHsExpr GhcPs -> RnM (LHsExpr GhcRn, FreeVars)
196 rnLExpr = wrapLocFstMA rnExpr
197
198 rnExpr :: HsExpr GhcPs -> RnM (HsExpr GhcRn, FreeVars)
199
200 finishHsVar :: LocatedA Name -> RnM (HsExpr GhcRn, FreeVars)
201 -- Separated from rnExpr because it's also used
202 -- when renaming infix expressions
203 finishHsVar (L l name)
204 = do { this_mod <- getModule
205 ; when (nameIsLocalOrFrom this_mod name) $
206 checkThLocalName name
207 ; return (HsVar noExtField (L (la2na l) name), unitFV name) }
208
209 rnUnboundVar :: RdrName -> RnM (HsExpr GhcRn, FreeVars)
210 rnUnboundVar v =
211 if isUnqual v
212 then -- Treat this as a "hole"
213 -- Do not fail right now; instead, return HsUnboundVar
214 -- and let the type checker report the error
215 return (HsUnboundVar noExtField (rdrNameOcc v), emptyFVs)
216
217 else -- Fail immediately (qualified name)
218 do { n <- reportUnboundName v
219 ; return (HsVar noExtField (noLocA n), emptyFVs) }
220
221 rnExpr (HsVar _ (L l v))
222 = do { dflags <- getDynFlags
223 ; mb_name <- lookupExprOccRn v
224
225 ; case mb_name of {
226 Nothing -> rnUnboundVar v ;
227 Just (NormalGreName name)
228 | name == nilDataConName -- Treat [] as an ExplicitList, so that
229 -- OverloadedLists works correctly
230 -- Note [Empty lists] in GHC.Hs.Expr
231 , xopt LangExt.OverloadedLists dflags
232 -> rnExpr (ExplicitList noAnn [])
233
234 | otherwise
235 -> finishHsVar (L (na2la l) name) ;
236 Just (FieldGreName fl)
237 -> do { let sel_name = flSelector fl
238 ; this_mod <- getModule
239 ; when (nameIsLocalOrFrom this_mod sel_name) $
240 checkThLocalName sel_name
241 ; return ( HsRecSel noExtField (FieldOcc sel_name (L l v) ), unitFV sel_name)
242 }
243 }
244 }
245
246 rnExpr (HsIPVar x v)
247 = return (HsIPVar x v, emptyFVs)
248
249 rnExpr (HsUnboundVar _ v)
250 = return (HsUnboundVar noExtField v, emptyFVs)
251
252 -- HsOverLabel: see Note [Handling overloaded and rebindable constructs]
253 rnExpr (HsOverLabel _ v)
254 = do { (from_label, fvs) <- lookupSyntaxName fromLabelClassOpName
255 ; return ( mkExpandedExpr (HsOverLabel noAnn v) $
256 HsAppType noExtField (genLHsVar from_label) hs_ty_arg
257 , fvs ) }
258 where
259 hs_ty_arg = mkEmptyWildCardBndrs $ wrapGenSpan $
260 HsTyLit noExtField (HsStrTy NoSourceText v)
261
262 rnExpr (HsLit x lit@(HsString src s))
263 = do { opt_OverloadedStrings <- xoptM LangExt.OverloadedStrings
264 ; if opt_OverloadedStrings then
265 rnExpr (HsOverLit x (mkHsIsString src s))
266 else do {
267 ; rnLit lit
268 ; return (HsLit x (convertLit lit), emptyFVs) } }
269
270 rnExpr (HsLit x lit)
271 = do { rnLit lit
272 ; return (HsLit x(convertLit lit), emptyFVs) }
273
274 rnExpr (HsOverLit x lit)
275 = do { ((lit', mb_neg), fvs) <- rnOverLit lit -- See Note [Negative zero]
276 ; case mb_neg of
277 Nothing -> return (HsOverLit x lit', fvs)
278 Just neg ->
279 return (HsApp noComments (noLocA neg) (noLocA (HsOverLit x lit'))
280 , fvs ) }
281
282 rnExpr (HsApp x fun arg)
283 = do { (fun',fvFun) <- rnLExpr fun
284 ; (arg',fvArg) <- rnLExpr arg
285 ; return (HsApp x fun' arg', fvFun `plusFV` fvArg) }
286
287 rnExpr (HsAppType _ fun arg)
288 = do { type_app <- xoptM LangExt.TypeApplications
289 ; unless type_app $ addErr $ typeAppErr "type" $ hswc_body arg
290 ; (fun',fvFun) <- rnLExpr fun
291 ; (arg',fvArg) <- rnHsWcType HsTypeCtx arg
292 ; return (HsAppType NoExtField fun' arg', fvFun `plusFV` fvArg) }
293
294 rnExpr (OpApp _ e1 op e2)
295 = do { (e1', fv_e1) <- rnLExpr e1
296 ; (e2', fv_e2) <- rnLExpr e2
297 ; (op', fv_op) <- rnLExpr op
298
299 -- Deal with fixity
300 -- When renaming code synthesised from "deriving" declarations
301 -- we used to avoid fixity stuff, but we can't easily tell any
302 -- more, so I've removed the test. Adding HsPars in GHC.Tc.Deriv.Generate
303 -- should prevent bad things happening.
304 ; fixity <- case op' of
305 L _ (HsVar _ (L _ n)) -> lookupFixityRn n
306 L _ (HsRecSel _ f) -> lookupFieldFixityRn f
307 _ -> return (Fixity NoSourceText minPrecedence InfixL)
308 -- c.f. lookupFixity for unbound
309
310 ; lexical_negation <- xoptM LangExt.LexicalNegation
311 ; let negation_handling | lexical_negation = KeepNegationIntact
312 | otherwise = ReassociateNegation
313 ; final_e <- mkOpAppRn negation_handling e1' op' fixity e2'
314 ; return (final_e, fv_e1 `plusFV` fv_op `plusFV` fv_e2) }
315
316 rnExpr (NegApp _ e _)
317 = do { (e', fv_e) <- rnLExpr e
318 ; (neg_name, fv_neg) <- lookupSyntax negateName
319 ; final_e <- mkNegAppRn e' neg_name
320 ; return (final_e, fv_e `plusFV` fv_neg) }
321
322 ------------------------------------------
323 -- Record dot syntax
324
325 rnExpr (HsGetField _ e f)
326 = do { (getField, fv_getField) <- lookupSyntaxName getFieldName
327 ; (e, fv_e) <- rnLExpr e
328 ; let f' = rnDotFieldOcc f
329 ; return ( mkExpandedExpr
330 (HsGetField noExtField e f')
331 (mkGetField getField e (fmap (unLoc . dfoLabel) f'))
332 , fv_e `plusFV` fv_getField ) }
333
334 rnExpr (HsProjection _ fs)
335 = do { (getField, fv_getField) <- lookupSyntaxName getFieldName
336 ; circ <- lookupOccRn compose_RDR
337 ; let fs' = fmap rnDotFieldOcc fs
338 ; return ( mkExpandedExpr
339 (HsProjection noExtField fs')
340 (mkProjection getField circ (map (fmap (unLoc . dfoLabel)) fs'))
341 , unitFV circ `plusFV` fv_getField) }
342
343 ------------------------------------------
344 -- Template Haskell extensions
345 rnExpr e@(HsBracket _ br_body) = rnBracket e br_body
346
347 rnExpr (HsSpliceE _ splice) = rnSpliceExpr splice
348
349 ---------------------------------------------
350 -- Sections
351 -- See Note [Parsing sections] in GHC.Parser
352 rnExpr (HsPar x lpar (L loc (section@(SectionL {}))) rpar)
353 = do { (section', fvs) <- rnSection section
354 ; return (HsPar x lpar (L loc section') rpar, fvs) }
355
356 rnExpr (HsPar x lpar (L loc (section@(SectionR {}))) rpar)
357 = do { (section', fvs) <- rnSection section
358 ; return (HsPar x lpar (L loc section') rpar, fvs) }
359
360 rnExpr (HsPar x lpar e rpar)
361 = do { (e', fvs_e) <- rnLExpr e
362 ; return (HsPar x lpar e' rpar, fvs_e) }
363
364 rnExpr expr@(SectionL {})
365 = do { addErr (sectionErr expr); rnSection expr }
366 rnExpr expr@(SectionR {})
367 = do { addErr (sectionErr expr); rnSection expr }
368
369 ---------------------------------------------
370 rnExpr (HsPragE x prag expr)
371 = do { (expr', fvs_expr) <- rnLExpr expr
372 ; return (HsPragE x (rn_prag prag) expr', fvs_expr) }
373 where
374 rn_prag :: HsPragE GhcPs -> HsPragE GhcRn
375 rn_prag (HsPragSCC x1 src ann) = HsPragSCC x1 src ann
376
377 rnExpr (HsLam x matches)
378 = do { (matches', fvMatch) <- rnMatchGroup LambdaExpr rnLExpr matches
379 ; return (HsLam x matches', fvMatch) }
380
381 rnExpr (HsLamCase x matches)
382 = do { (matches', fvs_ms) <- rnMatchGroup CaseAlt rnLExpr matches
383 ; return (HsLamCase x matches', fvs_ms) }
384
385 rnExpr (HsCase _ expr matches)
386 = do { (new_expr, e_fvs) <- rnLExpr expr
387 ; (new_matches, ms_fvs) <- rnMatchGroup CaseAlt rnLExpr matches
388 ; return (HsCase noExtField new_expr new_matches, e_fvs `plusFV` ms_fvs) }
389
390 rnExpr (HsLet _ tkLet binds tkIn expr)
391 = rnLocalBindsAndThen binds $ \binds' _ -> do
392 { (expr',fvExpr) <- rnLExpr expr
393 ; return (HsLet noExtField tkLet binds' tkIn expr', fvExpr) }
394
395 rnExpr (HsDo _ do_or_lc (L l stmts))
396 = do { ((stmts1, _), fvs1) <-
397 rnStmtsWithFreeVars (HsDoStmt do_or_lc) rnExpr stmts
398 (\ _ -> return ((), emptyFVs))
399 ; (pp_stmts, fvs2) <- postProcessStmtsForApplicativeDo do_or_lc stmts1
400 ; return ( HsDo noExtField do_or_lc (L l pp_stmts), fvs1 `plusFV` fvs2 ) }
401
402 -- ExplicitList: see Note [Handling overloaded and rebindable constructs]
403 rnExpr (ExplicitList _ exps)
404 = do { (exps', fvs) <- rnExprs exps
405 ; opt_OverloadedLists <- xoptM LangExt.OverloadedLists
406 ; if not opt_OverloadedLists
407 then return (ExplicitList noExtField exps', fvs)
408 else
409 do { (from_list_n_name, fvs') <- lookupSyntaxName fromListNName
410 ; let rn_list = ExplicitList noExtField exps'
411 lit_n = mkIntegralLit (length exps)
412 hs_lit = genHsIntegralLit lit_n
413 exp_list = genHsApps from_list_n_name [hs_lit, wrapGenSpan rn_list]
414 ; return ( mkExpandedExpr rn_list exp_list
415 , fvs `plusFV` fvs') } }
416
417 rnExpr (ExplicitTuple _ tup_args boxity)
418 = do { checkTupleSection tup_args
419 ; (tup_args', fvs) <- mapAndUnzipM rnTupArg tup_args
420 ; return (ExplicitTuple noExtField tup_args' boxity, plusFVs fvs) }
421 where
422 rnTupArg (Present x e) = do { (e',fvs) <- rnLExpr e
423 ; return (Present x e', fvs) }
424 rnTupArg (Missing _) = return (Missing noExtField, emptyFVs)
425
426 rnExpr (ExplicitSum _ alt arity expr)
427 = do { (expr', fvs) <- rnLExpr expr
428 ; return (ExplicitSum noExtField alt arity expr', fvs) }
429
430 rnExpr (RecordCon { rcon_con = con_id
431 , rcon_flds = rec_binds@(HsRecFields { rec_dotdot = dd }) })
432 = do { con_lname@(L _ con_name) <- lookupLocatedOccRnConstr con_id
433 ; (flds, fvs) <- rnHsRecFields (HsRecFieldCon con_name) mk_hs_var rec_binds
434 ; (flds', fvss) <- mapAndUnzipM rn_field flds
435 ; let rec_binds' = HsRecFields { rec_flds = flds', rec_dotdot = dd }
436 ; return (RecordCon { rcon_ext = noExtField
437 , rcon_con = con_lname, rcon_flds = rec_binds' }
438 , fvs `plusFV` plusFVs fvss `addOneFV` con_name) }
439 where
440 mk_hs_var l n = HsVar noExtField (L (noAnnSrcSpan l) n)
441 rn_field (L l fld) = do { (arg', fvs) <- rnLExpr (hfbRHS fld)
442 ; return (L l (fld { hfbRHS = arg' }), fvs) }
443
444 rnExpr (RecordUpd { rupd_expr = expr, rupd_flds = rbinds })
445 = case rbinds of
446 Left flds -> -- 'OverloadedRecordUpdate' is not in effect. Regular record update.
447 do { ; (e, fv_e) <- rnLExpr expr
448 ; (rs, fv_rs) <- rnHsRecUpdFields flds
449 ; return ( RecordUpd noExtField e (Left rs), fv_e `plusFV` fv_rs )
450 }
451 Right flds -> -- 'OverloadedRecordUpdate' is in effect. Record dot update desugaring.
452 do { ; unlessXOptM LangExt.RebindableSyntax $
453 addErr $ TcRnUnknownMessage $ mkPlainError noHints $
454 text "RebindableSyntax is required if OverloadedRecordUpdate is enabled."
455 ; let punnedFields = [fld | (L _ fld) <- flds, hfbPun fld]
456 ; punsEnabled <-xoptM LangExt.NamedFieldPuns
457 ; unless (null punnedFields || punsEnabled) $
458 addErr $ TcRnUnknownMessage $ mkPlainError noHints $
459 text "For this to work enable NamedFieldPuns."
460 ; (getField, fv_getField) <- lookupSyntaxName getFieldName
461 ; (setField, fv_setField) <- lookupSyntaxName setFieldName
462 ; (e, fv_e) <- rnLExpr expr
463 ; (us, fv_us) <- rnHsUpdProjs flds
464 ; return ( mkExpandedExpr
465 (RecordUpd noExtField e (Right us))
466 (mkRecordDotUpd getField setField e us)
467 , plusFVs [fv_getField, fv_setField, fv_e, fv_us] )
468 }
469
470 rnExpr (ExprWithTySig _ expr pty)
471 = do { (pty', fvTy) <- rnHsSigWcType ExprWithTySigCtx pty
472 ; (expr', fvExpr) <- bindSigTyVarsFV (hsWcScopedTvs pty') $
473 rnLExpr expr
474 ; return (ExprWithTySig noExtField expr' pty', fvExpr `plusFV` fvTy) }
475
476 -- HsIf: see Note [Handling overloaded and rebindable constructs]
477 -- Because of the coverage checker it is most convenient /not/ to
478 -- expand HsIf; unless we are in rebindable syntax.
479 rnExpr (HsIf _ p b1 b2)
480 = do { (p', fvP) <- rnLExpr p
481 ; (b1', fvB1) <- rnLExpr b1
482 ; (b2', fvB2) <- rnLExpr b2
483 ; let fvs_if = plusFVs [fvP, fvB1, fvB2]
484 rn_if = HsIf noExtField p' b1' b2'
485
486 -- Deal with rebindable syntax
487 -- See Note [Handling overloaded and rebindable constructs]
488 ; mb_ite <- lookupIfThenElse
489 ; case mb_ite of
490 Nothing -- Non rebindable-syntax case
491 -> return (rn_if, fvs_if)
492
493 Just ite_name -- Rebindable-syntax case
494 -> do { let ds_if = genHsApps ite_name [p', b1', b2']
495 fvs = plusFVs [fvs_if, unitFV ite_name]
496 ; return (mkExpandedExpr rn_if ds_if, fvs) } }
497
498 rnExpr (HsMultiIf _ alts)
499 = do { (alts', fvs) <- mapFvRn (rnGRHS IfAlt rnLExpr) alts
500 ; return (HsMultiIf noExtField alts', fvs) }
501
502 rnExpr (ArithSeq _ _ seq)
503 = do { opt_OverloadedLists <- xoptM LangExt.OverloadedLists
504 ; (new_seq, fvs) <- rnArithSeq seq
505 ; if opt_OverloadedLists
506 then do {
507 ; (from_list_name, fvs') <- lookupSyntax fromListName
508 ; return (ArithSeq noExtField (Just from_list_name) new_seq
509 , fvs `plusFV` fvs') }
510 else
511 return (ArithSeq noExtField Nothing new_seq, fvs) }
512
513 {-
514 ************************************************************************
515 * *
516 Static values
517 * *
518 ************************************************************************
519
520 For the static form we check that it is not used in splices.
521 We also collect the free variables of the term which come from
522 this module. See Note [Grand plan for static forms] in GHC.Iface.Tidy.StaticPtrTable.
523 -}
524
525 rnExpr e@(HsStatic _ expr) = do
526 -- Normally, you wouldn't be able to construct a static expression without
527 -- first enabling -XStaticPointers in the first place, since that extension
528 -- is what makes the parser treat `static` as a keyword. But this is not a
529 -- sufficient safeguard, as one can construct static expressions by another
530 -- mechanism: Template Haskell (see #14204). To ensure that GHC is
531 -- absolutely prepared to cope with static forms, we check for
532 -- -XStaticPointers here as well.
533 unlessXOptM LangExt.StaticPointers $
534 addErr $ TcRnUnknownMessage $ mkPlainError noHints $
535 hang (text "Illegal static expression:" <+> ppr e)
536 2 (text "Use StaticPointers to enable this extension")
537 (expr',fvExpr) <- rnLExpr expr
538 stage <- getStage
539 case stage of
540 Splice _ -> addErr $ TcRnUnknownMessage $ mkPlainError noHints $ sep
541 [ text "static forms cannot be used in splices:"
542 , nest 2 $ ppr e
543 ]
544 _ -> return ()
545 mod <- getModule
546 let fvExpr' = filterNameSet (nameIsLocalOrFrom mod) fvExpr
547 return (HsStatic fvExpr' expr', fvExpr)
548
549 {- *********************************************************************
550 * *
551 Arrow notation
552 * *
553 ********************************************************************* -}
554
555 rnExpr (HsProc x pat body)
556 = newArrowScope $
557 rnPat (ArrowMatchCtxt ProcExpr) pat $ \ pat' -> do
558 { (body',fvBody) <- rnCmdTop body
559 ; return (HsProc x pat' body', fvBody) }
560
561 rnExpr other = pprPanic "rnExpr: unexpected expression" (ppr other)
562 -- HsWrap
563
564 {- *********************************************************************
565 * *
566 Operator sections
567 * *
568 ********************************************************************* -}
569
570
571 rnSection :: HsExpr GhcPs -> RnM (HsExpr GhcRn, FreeVars)
572 -- See Note [Parsing sections] in GHC.Parser
573 -- Also see Note [Handling overloaded and rebindable constructs]
574
575 rnSection section@(SectionR x op expr)
576 -- See Note [Left and right sections]
577 = do { (op', fvs_op) <- rnLExpr op
578 ; (expr', fvs_expr) <- rnLExpr expr
579 ; checkSectionPrec InfixR section op' expr'
580 ; let rn_section = SectionR x op' expr'
581 ds_section = genHsApps rightSectionName [op',expr']
582 ; return ( mkExpandedExpr rn_section ds_section
583 , fvs_op `plusFV` fvs_expr) }
584
585 rnSection section@(SectionL x expr op)
586 -- See Note [Left and right sections]
587 = do { (expr', fvs_expr) <- rnLExpr expr
588 ; (op', fvs_op) <- rnLExpr op
589 ; checkSectionPrec InfixL section op' expr'
590 ; postfix_ops <- xoptM LangExt.PostfixOperators
591 -- Note [Left and right sections]
592 ; let rn_section = SectionL x expr' op'
593 ds_section
594 | postfix_ops = HsApp noAnn op' expr'
595 | otherwise = genHsApps leftSectionName
596 [wrapGenSpan $ HsApp noAnn op' expr']
597 ; return ( mkExpandedExpr rn_section ds_section
598 , fvs_op `plusFV` fvs_expr) }
599
600 rnSection other = pprPanic "rnSection" (ppr other)
601
602 {- Note [Left and right sections]
603 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
604 Dealing with left sections (x *) and right sections (* x) is
605 surprisingly fiddly. We expand like this
606 (`op` e) ==> rightSection op e
607 (e `op`) ==> leftSection (op e)
608
609 Using an auxiliary function in this way avoids the awkwardness of
610 generating a lambda, esp if `e` is a redex, so we *don't* want
611 to generate `(\x -> op x e)`. See Historical
612 Note [Desugaring operator sections]
613
614 Here are their definitions:
615 leftSection :: forall r1 r2 n (a:TYPE r1) (b:TYPE r2).
616 (a %n-> b) -> a %n-> b
617 leftSection f x = f x
618
619 rightSection :: forall r1 r2 r3 (a:TYPE r1) (b:TYPE r2) (c:TYPE r3).
620 (a %n1 -> b %n2-> c) -> b %n2-> a %n1-> c
621 rightSection f y x = f x y
622
623 Note the wrinkles:
624
625 * We do /not/ use lookupSyntaxName, which would make left and right
626 section fall under RebindableSyntax. Reason: it would be a user-
627 facing change, and there are some tricky design choices (#19354).
628 Plus, infix operator applications would be trickier to make
629 rebindable, so it'd be inconsistent to do so for sections.
630
631 TL;DR: we still us the renamer-expansion mechanism for operator
632 sections , but only to eliminate special-purpose code paths in the
633 renamer and desugarer.
634
635 * leftSection and rightSection must be representation-polymorphic, to allow
636 (+# 4#) and (4# +#) to work. See GHC.Types.Id.Make.
637 Note [Wired-in Ids for rebindable syntax] in
638
639 * leftSection and rightSection must be multiplicity-polymorphic.
640 (Test linear/should_compile/OldList showed this up.)
641
642 * Because they are representation-polymorphic, we have to define them
643 as wired-in Ids, with compulsory inlining. See
644 GHC.Types.Id.Make.leftSectionId, rightSectionId.
645
646 * leftSection is just ($) really; but unlike ($) it is
647 representation-polymorphic in the result type, so we can write
648 `(x +#)`, say.
649
650 * The type of leftSection must have an arrow in its first argument,
651 because (x `ord`) should be rejected, because ord does not take two
652 arguments
653
654 * It's important that we define leftSection in an eta-expanded way,
655 (i.e. not leftSection f = f), so that
656 (True `undefined`) `seq` ()
657 = (leftSection (undefined True) `seq` ())
658 evaluates to () and not undefined
659
660 * If PostfixOperators is ON, then we expand a left section like this:
661 (e `op`) ==> op e
662 with no auxiliary function at all. Simple!
663
664
665 Historical Note [Desugaring operator sections]
666 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
667 This Note explains some historical trickiness in desugaring left and
668 right sections. That trickiness has completely disappeared now that
669 we desugar to calls to 'leftSection` and `rightSection`, but I'm
670 leaving it here to remind us how nice the new story is.
671
672 Desugaring left sections with -XPostfixOperators is straightforward: convert
673 (expr `op`) to (op expr).
674
675 Without -XPostfixOperators it's a bit more tricky. At first it looks as if we
676 can convert
677
678 (expr `op`)
679
680 naively to
681
682 \x -> op expr x
683
684 But no! expr might be a redex, and we can lose laziness badly this
685 way. Consider
686
687 map (expr `op`) xs
688
689 for example. If expr were a redex then eta-expanding naively would
690 result in multiple evaluations where the user might only have expected one.
691
692 So we convert instead to
693
694 let y = expr in \x -> op y x
695
696 Also, note that we must do this for both right and (perhaps surprisingly) left
697 sections. Why are left sections necessary? Consider the program (found in #18151),
698
699 seq (True `undefined`) ()
700
701 according to the Haskell Report this should reduce to () (as it specifies
702 desugaring via eta expansion). However, if we fail to eta expand we will rather
703 bottom. Consequently, we must eta expand even in the case of a left section.
704
705 If `expr` is actually just a variable, say, then the simplifier
706 will inline `y`, eliminating the redundant `let`.
707
708 Note that this works even in the case that `expr` is unlifted. In this case
709 bindNonRec will automatically do the right thing, giving us:
710
711 case expr of y -> (\x -> op y x)
712
713 See #18151.
714 -}
715
716 {-
717 ************************************************************************
718 * *
719 Field Labels
720 * *
721 ************************************************************************
722 -}
723
724 rnDotFieldOcc :: LocatedAn NoEpAnns (DotFieldOcc GhcPs) -> LocatedAn NoEpAnns (DotFieldOcc GhcRn)
725 rnDotFieldOcc (L l (DotFieldOcc x label)) = L l (DotFieldOcc x label)
726
727 rnFieldLabelStrings :: FieldLabelStrings GhcPs -> FieldLabelStrings GhcRn
728 rnFieldLabelStrings (FieldLabelStrings fls) = FieldLabelStrings (map rnDotFieldOcc fls)
729
730 {-
731 ************************************************************************
732 * *
733 Arrow commands
734 * *
735 ************************************************************************
736 -}
737
738 rnCmdArgs :: [LHsCmdTop GhcPs] -> RnM ([LHsCmdTop GhcRn], FreeVars)
739 rnCmdArgs [] = return ([], emptyFVs)
740 rnCmdArgs (arg:args)
741 = do { (arg',fvArg) <- rnCmdTop arg
742 ; (args',fvArgs) <- rnCmdArgs args
743 ; return (arg':args', fvArg `plusFV` fvArgs) }
744
745 rnCmdTop :: LHsCmdTop GhcPs -> RnM (LHsCmdTop GhcRn, FreeVars)
746 rnCmdTop = wrapLocFstMA rnCmdTop'
747 where
748 rnCmdTop' :: HsCmdTop GhcPs -> RnM (HsCmdTop GhcRn, FreeVars)
749 rnCmdTop' (HsCmdTop _ cmd)
750 = do { (cmd', fvCmd) <- rnLCmd cmd
751 ; let cmd_names = [arrAName, composeAName, firstAName] ++
752 nameSetElemsStable (methodNamesCmd (unLoc cmd'))
753 -- Generate the rebindable syntax for the monad
754 ; (cmd_names', cmd_fvs) <- lookupSyntaxNames cmd_names
755
756 ; return (HsCmdTop (cmd_names `zip` cmd_names') cmd',
757 fvCmd `plusFV` cmd_fvs) }
758
759 rnLCmd :: LHsCmd GhcPs -> RnM (LHsCmd GhcRn, FreeVars)
760 rnLCmd = wrapLocFstMA rnCmd
761
762 rnCmd :: HsCmd GhcPs -> RnM (HsCmd GhcRn, FreeVars)
763
764 rnCmd (HsCmdArrApp _ arrow arg ho rtl)
765 = do { (arrow',fvArrow) <- select_arrow_scope (rnLExpr arrow)
766 ; (arg',fvArg) <- rnLExpr arg
767 ; return (HsCmdArrApp noExtField arrow' arg' ho rtl,
768 fvArrow `plusFV` fvArg) }
769 where
770 select_arrow_scope tc = case ho of
771 HsHigherOrderApp -> tc
772 HsFirstOrderApp -> escapeArrowScope tc
773 -- See Note [Escaping the arrow scope] in GHC.Tc.Types
774 -- Before renaming 'arrow', use the environment of the enclosing
775 -- proc for the (-<) case.
776 -- Local bindings, inside the enclosing proc, are not in scope
777 -- inside 'arrow'. In the higher-order case (-<<), they are.
778
779 -- infix form
780 rnCmd (HsCmdArrForm _ op _ (Just _) [arg1, arg2])
781 = do { (op',fv_op) <- escapeArrowScope (rnLExpr op)
782 ; let L _ (HsVar _ (L _ op_name)) = op'
783 ; (arg1',fv_arg1) <- rnCmdTop arg1
784 ; (arg2',fv_arg2) <- rnCmdTop arg2
785 -- Deal with fixity
786 ; fixity <- lookupFixityRn op_name
787 ; final_e <- mkOpFormRn arg1' op' fixity arg2'
788 ; return (final_e, fv_arg1 `plusFV` fv_op `plusFV` fv_arg2) }
789
790 rnCmd (HsCmdArrForm _ op f fixity cmds)
791 = do { (op',fvOp) <- escapeArrowScope (rnLExpr op)
792 ; (cmds',fvCmds) <- rnCmdArgs cmds
793 ; return ( HsCmdArrForm noExtField op' f fixity cmds'
794 , fvOp `plusFV` fvCmds) }
795
796 rnCmd (HsCmdApp x fun arg)
797 = do { (fun',fvFun) <- rnLCmd fun
798 ; (arg',fvArg) <- rnLExpr arg
799 ; return (HsCmdApp x fun' arg', fvFun `plusFV` fvArg) }
800
801 rnCmd (HsCmdLam _ matches)
802 = do { (matches', fvMatch) <- rnMatchGroup (ArrowMatchCtxt KappaExpr) rnLCmd matches
803 ; return (HsCmdLam noExtField matches', fvMatch) }
804
805 rnCmd (HsCmdPar x lpar e rpar)
806 = do { (e', fvs_e) <- rnLCmd e
807 ; return (HsCmdPar x lpar e' rpar, fvs_e) }
808
809 rnCmd (HsCmdCase _ expr matches)
810 = do { (new_expr, e_fvs) <- rnLExpr expr
811 ; (new_matches, ms_fvs) <- rnMatchGroup (ArrowMatchCtxt ArrowCaseAlt) rnLCmd matches
812 ; return (HsCmdCase noExtField new_expr new_matches
813 , e_fvs `plusFV` ms_fvs) }
814
815 rnCmd (HsCmdLamCase x matches)
816 = do { (new_matches, ms_fvs) <- rnMatchGroup (ArrowMatchCtxt ArrowCaseAlt) rnLCmd matches
817 ; return (HsCmdLamCase x new_matches, ms_fvs) }
818
819 rnCmd (HsCmdIf _ _ p b1 b2)
820 = do { (p', fvP) <- rnLExpr p
821 ; (b1', fvB1) <- rnLCmd b1
822 ; (b2', fvB2) <- rnLCmd b2
823
824 ; mb_ite <- lookupIfThenElse
825 ; let (ite, fvITE) = case mb_ite of
826 Just ite_name -> (mkRnSyntaxExpr ite_name, unitFV ite_name)
827 Nothing -> (NoSyntaxExprRn, emptyFVs)
828
829 ; return (HsCmdIf noExtField ite p' b1' b2', plusFVs [fvITE, fvP, fvB1, fvB2])}
830
831 rnCmd (HsCmdLet _ tkLet binds tkIn cmd)
832 = rnLocalBindsAndThen binds $ \ binds' _ -> do
833 { (cmd',fvExpr) <- rnLCmd cmd
834 ; return (HsCmdLet noExtField tkLet binds' tkIn cmd', fvExpr) }
835
836 rnCmd (HsCmdDo _ (L l stmts))
837 = do { ((stmts', _), fvs) <-
838 rnStmts ArrowExpr rnCmd stmts (\ _ -> return ((), emptyFVs))
839 ; return ( HsCmdDo noExtField (L l stmts'), fvs ) }
840
841 ---------------------------------------------------
842 type CmdNeeds = FreeVars -- Only inhabitants are
843 -- appAName, choiceAName, loopAName
844
845 -- find what methods the Cmd needs (loop, choice, apply)
846 methodNamesLCmd :: LHsCmd GhcRn -> CmdNeeds
847 methodNamesLCmd = methodNamesCmd . unLoc
848
849 methodNamesCmd :: HsCmd GhcRn -> CmdNeeds
850
851 methodNamesCmd (HsCmdArrApp _ _arrow _arg HsFirstOrderApp _rtl)
852 = emptyFVs
853 methodNamesCmd (HsCmdArrApp _ _arrow _arg HsHigherOrderApp _rtl)
854 = unitFV appAName
855 methodNamesCmd (HsCmdArrForm {}) = emptyFVs
856
857 methodNamesCmd (HsCmdPar _ _ c _) = methodNamesLCmd c
858
859 methodNamesCmd (HsCmdIf _ _ _ c1 c2)
860 = methodNamesLCmd c1 `plusFV` methodNamesLCmd c2 `addOneFV` choiceAName
861
862 methodNamesCmd (HsCmdLet _ _ _ _ c) = methodNamesLCmd c
863 methodNamesCmd (HsCmdDo _ (L _ stmts)) = methodNamesStmts stmts
864 methodNamesCmd (HsCmdApp _ c _) = methodNamesLCmd c
865 methodNamesCmd (HsCmdLam _ match) = methodNamesMatch match
866
867 methodNamesCmd (HsCmdCase _ _ matches)
868 = methodNamesMatch matches `addOneFV` choiceAName
869 methodNamesCmd (HsCmdLamCase _ matches)
870 = methodNamesMatch matches `addOneFV` choiceAName
871
872 --methodNamesCmd _ = emptyFVs
873 -- Other forms can't occur in commands, but it's not convenient
874 -- to error here so we just do what's convenient.
875 -- The type checker will complain later
876
877 ---------------------------------------------------
878 methodNamesMatch :: MatchGroup GhcRn (LHsCmd GhcRn) -> FreeVars
879 methodNamesMatch (MG { mg_alts = L _ ms })
880 = plusFVs (map do_one ms)
881 where
882 do_one (L _ (Match { m_grhss = grhss })) = methodNamesGRHSs grhss
883
884 -------------------------------------------------
885 -- gaw 2004
886 methodNamesGRHSs :: GRHSs GhcRn (LHsCmd GhcRn) -> FreeVars
887 methodNamesGRHSs (GRHSs _ grhss _) = plusFVs (map methodNamesGRHS grhss)
888
889 -------------------------------------------------
890
891 methodNamesGRHS :: LocatedAn NoEpAnns (GRHS GhcRn (LHsCmd GhcRn)) -> CmdNeeds
892 methodNamesGRHS (L _ (GRHS _ _ rhs)) = methodNamesLCmd rhs
893
894 ---------------------------------------------------
895 methodNamesStmts :: [LStmtLR GhcRn GhcRn (LHsCmd GhcRn)] -> FreeVars
896 methodNamesStmts stmts = plusFVs (map methodNamesLStmt stmts)
897
898 ---------------------------------------------------
899 methodNamesLStmt :: LStmtLR GhcRn GhcRn (LHsCmd GhcRn) -> FreeVars
900 methodNamesLStmt = methodNamesStmt . unLoc
901
902 methodNamesStmt :: StmtLR GhcRn GhcRn (LHsCmd GhcRn) -> FreeVars
903 methodNamesStmt (LastStmt _ cmd _ _) = methodNamesLCmd cmd
904 methodNamesStmt (BodyStmt _ cmd _ _) = methodNamesLCmd cmd
905 methodNamesStmt (BindStmt _ _ cmd) = methodNamesLCmd cmd
906 methodNamesStmt (RecStmt { recS_stmts = L _ stmts }) =
907 methodNamesStmts stmts `addOneFV` loopAName
908 methodNamesStmt (LetStmt {}) = emptyFVs
909 methodNamesStmt (ParStmt {}) = emptyFVs
910 methodNamesStmt (TransStmt {}) = emptyFVs
911 methodNamesStmt ApplicativeStmt{} = emptyFVs
912 -- ParStmt and TransStmt can't occur in commands, but it's not
913 -- convenient to error here so we just do what's convenient
914
915 {-
916 ************************************************************************
917 * *
918 Arithmetic sequences
919 * *
920 ************************************************************************
921 -}
922
923 rnArithSeq :: ArithSeqInfo GhcPs -> RnM (ArithSeqInfo GhcRn, FreeVars)
924 rnArithSeq (From expr)
925 = do { (expr', fvExpr) <- rnLExpr expr
926 ; return (From expr', fvExpr) }
927
928 rnArithSeq (FromThen expr1 expr2)
929 = do { (expr1', fvExpr1) <- rnLExpr expr1
930 ; (expr2', fvExpr2) <- rnLExpr expr2
931 ; return (FromThen expr1' expr2', fvExpr1 `plusFV` fvExpr2) }
932
933 rnArithSeq (FromTo expr1 expr2)
934 = do { (expr1', fvExpr1) <- rnLExpr expr1
935 ; (expr2', fvExpr2) <- rnLExpr expr2
936 ; return (FromTo expr1' expr2', fvExpr1 `plusFV` fvExpr2) }
937
938 rnArithSeq (FromThenTo expr1 expr2 expr3)
939 = do { (expr1', fvExpr1) <- rnLExpr expr1
940 ; (expr2', fvExpr2) <- rnLExpr expr2
941 ; (expr3', fvExpr3) <- rnLExpr expr3
942 ; return (FromThenTo expr1' expr2' expr3',
943 plusFVs [fvExpr1, fvExpr2, fvExpr3]) }
944
945 {-
946 ************************************************************************
947 * *
948 \subsubsection{@Stmt@s: in @do@ expressions}
949 * *
950 ************************************************************************
951 -}
952
953 {-
954 Note [Deterministic ApplicativeDo and RecursiveDo desugaring]
955 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
956 Both ApplicativeDo and RecursiveDo need to create tuples not
957 present in the source text.
958
959 For ApplicativeDo we create:
960
961 (a,b,c) <- (\c b a -> (a,b,c)) <$>
962
963 For RecursiveDo we create:
964
965 mfix (\ ~(a,b,c) -> do ...; return (a',b',c'))
966
967 The order of the components in those tuples needs to be stable
968 across recompilations, otherwise they can get optimized differently
969 and we end up with incompatible binaries.
970 To get a stable order we use nameSetElemsStable.
971 See Note [Deterministic UniqFM] to learn more about nondeterminism.
972 -}
973
974 type AnnoBody body
975 = ( Outputable (body GhcPs)
976 , Anno (StmtLR GhcPs GhcPs (LocatedA (body GhcPs))) ~ SrcSpanAnnA
977 , Anno (StmtLR GhcRn GhcPs (LocatedA (body GhcPs))) ~ SrcSpanAnnA
978 , Anno (StmtLR GhcRn GhcRn (LocatedA (body GhcRn))) ~ SrcSpanAnnA
979 )
980
981 -- | Rename some Stmts
982 rnStmts :: AnnoBody body
983 => HsStmtContext GhcRn
984 -> (body GhcPs -> RnM (body GhcRn, FreeVars))
985 -- ^ How to rename the body of each statement (e.g. rnLExpr)
986 -> [LStmt GhcPs (LocatedA (body GhcPs))]
987 -- ^ Statements
988 -> ([Name] -> RnM (thing, FreeVars))
989 -- ^ if these statements scope over something, this renames it
990 -- and returns the result.
991 -> RnM (([LStmt GhcRn (LocatedA (body GhcRn))], thing), FreeVars)
992 rnStmts ctxt rnBody stmts thing_inside
993 = do { ((stmts', thing), fvs) <- rnStmtsWithFreeVars ctxt rnBody stmts thing_inside
994 ; return ((map fst stmts', thing), fvs) }
995
996 -- | maybe rearrange statements according to the ApplicativeDo transformation
997 postProcessStmtsForApplicativeDo
998 :: HsDoFlavour
999 -> [(ExprLStmt GhcRn, FreeVars)]
1000 -> RnM ([ExprLStmt GhcRn], FreeVars)
1001 postProcessStmtsForApplicativeDo ctxt stmts
1002 = do {
1003 -- rearrange the statements using ApplicativeStmt if
1004 -- -XApplicativeDo is on. Also strip out the FreeVars attached
1005 -- to each Stmt body.
1006 ado_is_on <- xoptM LangExt.ApplicativeDo
1007 ; let is_do_expr | DoExpr{} <- ctxt = True
1008 | otherwise = False
1009 -- don't apply the transformation inside TH brackets, because
1010 -- GHC.HsToCore.Quote does not handle ApplicativeDo.
1011 ; in_th_bracket <- isBrackStage <$> getStage
1012 ; if ado_is_on && is_do_expr && not in_th_bracket
1013 then do { traceRn "ppsfa" (ppr stmts)
1014 ; rearrangeForApplicativeDo ctxt stmts }
1015 else noPostProcessStmts (HsDoStmt ctxt) stmts }
1016
1017 -- | strip the FreeVars annotations from statements
1018 noPostProcessStmts
1019 :: HsStmtContext GhcRn
1020 -> [(LStmt GhcRn (LocatedA (body GhcRn)), FreeVars)]
1021 -> RnM ([LStmt GhcRn (LocatedA (body GhcRn))], FreeVars)
1022 noPostProcessStmts _ stmts = return (map fst stmts, emptyNameSet)
1023
1024
1025 rnStmtsWithFreeVars :: AnnoBody body
1026 => HsStmtContext GhcRn
1027 -> ((body GhcPs) -> RnM ((body GhcRn), FreeVars))
1028 -> [LStmt GhcPs (LocatedA (body GhcPs))]
1029 -> ([Name] -> RnM (thing, FreeVars))
1030 -> RnM ( ([(LStmt GhcRn (LocatedA (body GhcRn)), FreeVars)], thing)
1031 , FreeVars)
1032 -- Each Stmt body is annotated with its FreeVars, so that
1033 -- we can rearrange statements for ApplicativeDo.
1034 --
1035 -- Variables bound by the Stmts, and mentioned in thing_inside,
1036 -- do not appear in the result FreeVars
1037
1038 rnStmtsWithFreeVars ctxt _ [] thing_inside
1039 = do { checkEmptyStmts ctxt
1040 ; (thing, fvs) <- thing_inside []
1041 ; return (([], thing), fvs) }
1042
1043 rnStmtsWithFreeVars mDoExpr@(HsDoStmt MDoExpr{}) rnBody stmts thing_inside -- Deal with mdo
1044 = -- Behave like do { rec { ...all but last... }; last }
1045 do { ((stmts1, (stmts2, thing)), fvs)
1046 <- rnStmt mDoExpr rnBody (noLocA $ mkRecStmt noAnn (noLocA all_but_last)) $ \ _ ->
1047 do { last_stmt' <- checkLastStmt mDoExpr last_stmt
1048 ; rnStmt mDoExpr rnBody last_stmt' thing_inside }
1049 ; return (((stmts1 ++ stmts2), thing), fvs) }
1050 where
1051 Just (all_but_last, last_stmt) = snocView stmts
1052
1053 rnStmtsWithFreeVars ctxt rnBody (lstmt@(L loc _) : lstmts) thing_inside
1054 | null lstmts
1055 = setSrcSpanA loc $
1056 do { lstmt' <- checkLastStmt ctxt lstmt
1057 ; rnStmt ctxt rnBody lstmt' thing_inside }
1058
1059 | otherwise
1060 = do { ((stmts1, (stmts2, thing)), fvs)
1061 <- setSrcSpanA loc $
1062 do { checkStmt ctxt lstmt
1063 ; rnStmt ctxt rnBody lstmt $ \ bndrs1 ->
1064 rnStmtsWithFreeVars ctxt rnBody lstmts $ \ bndrs2 ->
1065 thing_inside (bndrs1 ++ bndrs2) }
1066 ; return (((stmts1 ++ stmts2), thing), fvs) }
1067
1068 ----------------------
1069
1070 {-
1071 Note [Failing pattern matches in Stmts]
1072 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1073
1074 Many things desugar to HsStmts including monadic things like `do` and `mdo`
1075 statements, pattern guards, and list comprehensions (see 'HsStmtContext' for an
1076 exhaustive list). How we deal with pattern match failure is context-dependent.
1077
1078 * In the case of list comprehensions and pattern guards we don't need any
1079 'fail' function; the desugarer ignores the fail function of 'BindStmt'
1080 entirely. So, for list comprehensions, the fail function is set to 'Nothing'
1081 for clarity.
1082
1083 * In the case of monadic contexts (e.g. monad comprehensions, do, and mdo
1084 expressions) we want pattern match failure to be desugared to the
1085 'fail' function (from MonadFail type class).
1086
1087 At one point we failed to make this distinction, leading to #11216.
1088 -}
1089
1090 rnStmt :: AnnoBody body
1091 => HsStmtContext GhcRn
1092 -> (body GhcPs -> RnM (body GhcRn, FreeVars))
1093 -- ^ How to rename the body of the statement
1094 -> LStmt GhcPs (LocatedA (body GhcPs))
1095 -- ^ The statement
1096 -> ([Name] -> RnM (thing, FreeVars))
1097 -- ^ Rename the stuff that this statement scopes over
1098 -> RnM ( ([(LStmt GhcRn (LocatedA (body GhcRn)), FreeVars)], thing)
1099 , FreeVars)
1100 -- Variables bound by the Stmt, and mentioned in thing_inside,
1101 -- do not appear in the result FreeVars
1102
1103 rnStmt ctxt rnBody (L loc (LastStmt _ (L lb body) noret _)) thing_inside
1104 = do { (body', fv_expr) <- rnBody body
1105 ; (ret_op, fvs1) <- if isMonadCompContext ctxt
1106 then lookupStmtName ctxt returnMName
1107 else return (noSyntaxExpr, emptyFVs)
1108 -- The 'return' in a LastStmt is used only
1109 -- for MonadComp; and we don't want to report
1110 -- "non in scope: return" in other cases
1111 -- #15607
1112
1113 ; (thing, fvs3) <- thing_inside []
1114 ; return (([(L loc (LastStmt noExtField (L lb body') noret ret_op), fv_expr)]
1115 , thing), fv_expr `plusFV` fvs1 `plusFV` fvs3) }
1116
1117 rnStmt ctxt rnBody (L loc (BodyStmt _ (L lb body) _ _)) thing_inside
1118 = do { (body', fv_expr) <- rnBody body
1119 ; (then_op, fvs1) <- lookupQualifiedDoStmtName ctxt thenMName
1120
1121 ; (guard_op, fvs2) <- if isComprehensionContext ctxt
1122 then lookupStmtName ctxt guardMName
1123 else return (noSyntaxExpr, emptyFVs)
1124 -- Only list/monad comprehensions use 'guard'
1125 -- Also for sub-stmts of same eg [ e | x<-xs, gd | blah ]
1126 -- Here "gd" is a guard
1127
1128 ; (thing, fvs3) <- thing_inside []
1129 ; return ( ([(L loc (BodyStmt noExtField (L lb body') then_op guard_op), fv_expr)]
1130 , thing), fv_expr `plusFV` fvs1 `plusFV` fvs2 `plusFV` fvs3) }
1131
1132 rnStmt ctxt rnBody (L loc (BindStmt _ pat (L lb body))) thing_inside
1133 = do { (body', fv_expr) <- rnBody body
1134 -- The binders do not scope over the expression
1135 ; (bind_op, fvs1) <- lookupQualifiedDoStmtName ctxt bindMName
1136
1137 ; (fail_op, fvs2) <- monadFailOp pat ctxt
1138
1139 ; rnPat (StmtCtxt ctxt) pat $ \ pat' -> do
1140 { (thing, fvs3) <- thing_inside (collectPatBinders CollNoDictBinders pat')
1141 ; let xbsrn = XBindStmtRn { xbsrn_bindOp = bind_op, xbsrn_failOp = fail_op }
1142 ; return (( [( L loc (BindStmt xbsrn pat' (L lb body')), fv_expr )]
1143 , thing),
1144 fv_expr `plusFV` fvs1 `plusFV` fvs2 `plusFV` fvs3) }}
1145 -- fv_expr shouldn't really be filtered by the rnPatsAndThen
1146 -- but it does not matter because the names are unique
1147
1148 rnStmt _ _ (L loc (LetStmt _ binds)) thing_inside
1149 = rnLocalBindsAndThen binds $ \binds' bind_fvs -> do
1150 { (thing, fvs) <- thing_inside (collectLocalBinders CollNoDictBinders binds')
1151 ; return ( ([(L loc (LetStmt noAnn binds'), bind_fvs)], thing)
1152 , fvs) }
1153
1154 rnStmt ctxt rnBody (L loc (RecStmt { recS_stmts = L _ rec_stmts })) thing_inside
1155 = do { (return_op, fvs1) <- lookupQualifiedDoStmtName ctxt returnMName
1156 ; (mfix_op, fvs2) <- lookupQualifiedDoStmtName ctxt mfixName
1157 ; (bind_op, fvs3) <- lookupQualifiedDoStmtName ctxt bindMName
1158 ; let empty_rec_stmt = emptyRecStmtName { recS_ret_fn = return_op
1159 , recS_mfix_fn = mfix_op
1160 , recS_bind_fn = bind_op }
1161
1162 -- Step1: Bring all the binders of the mdo into scope
1163 -- (Remember that this also removes the binders from the
1164 -- finally-returned free-vars.)
1165 -- And rename each individual stmt, making a
1166 -- singleton segment. At this stage the FwdRefs field
1167 -- isn't finished: it's empty for all except a BindStmt
1168 -- for which it's the fwd refs within the bind itself
1169 -- (This set may not be empty, because we're in a recursive
1170 -- context.)
1171 ; rnRecStmtsAndThen ctxt rnBody rec_stmts $ \ segs -> do
1172 { let bndrs = nameSetElemsStable $
1173 foldr (unionNameSet . (\(ds,_,_,_) -> ds))
1174 emptyNameSet
1175 segs
1176 -- See Note [Deterministic ApplicativeDo and RecursiveDo desugaring]
1177 ; (thing, fvs_later) <- thing_inside bndrs
1178 -- In interactive mode, assume that all variables are used later
1179 ; is_interactive <- isInteractiveModule . tcg_mod <$> getGblEnv
1180 ; let
1181 final_fvs_later = if is_interactive then Nothing else Just fvs_later
1182 (rec_stmts', fvs) = segmentRecStmts (locA loc) ctxt empty_rec_stmt segs final_fvs_later
1183 -- We aren't going to try to group RecStmts with
1184 -- ApplicativeDo, so attaching empty FVs is fine.
1185 ; return ( ((zip rec_stmts' (repeat emptyNameSet)), thing)
1186 , fvs `plusFV` fvs1 `plusFV` fvs2 `plusFV` fvs3) } }
1187
1188 rnStmt ctxt _ (L loc (ParStmt _ segs _ _)) thing_inside
1189 = do { (mzip_op, fvs1) <- lookupStmtNamePoly ctxt mzipName
1190 ; (bind_op, fvs2) <- lookupStmtName ctxt bindMName
1191 ; (return_op, fvs3) <- lookupStmtName ctxt returnMName
1192 ; ((segs', thing), fvs4) <- rnParallelStmts (ParStmtCtxt ctxt) return_op segs thing_inside
1193 ; return (([(L loc (ParStmt noExtField segs' mzip_op bind_op), fvs4)], thing)
1194 , fvs1 `plusFV` fvs2 `plusFV` fvs3 `plusFV` fvs4) }
1195
1196 rnStmt ctxt _ (L loc (TransStmt { trS_stmts = stmts, trS_by = by, trS_form = form
1197 , trS_using = using })) thing_inside
1198 = do { -- Rename the 'using' expression in the context before the transform is begun
1199 (using', fvs1) <- rnLExpr using
1200
1201 -- Rename the stmts and the 'by' expression
1202 -- Keep track of the variables mentioned in the 'by' expression
1203 ; ((stmts', (by', used_bndrs, thing)), fvs2)
1204 <- rnStmts (TransStmtCtxt ctxt) rnExpr stmts $ \ bndrs ->
1205 do { (by', fvs_by) <- mapMaybeFvRn rnLExpr by
1206 ; (thing, fvs_thing) <- thing_inside bndrs
1207 ; let fvs = fvs_by `plusFV` fvs_thing
1208 used_bndrs = filter (`elemNameSet` fvs) bndrs
1209 -- The paper (Fig 5) has a bug here; we must treat any free variable
1210 -- of the "thing inside", **or of the by-expression**, as used
1211 ; return ((by', used_bndrs, thing), fvs) }
1212
1213 -- Lookup `return`, `(>>=)` and `liftM` for monad comprehensions
1214 ; (return_op, fvs3) <- lookupStmtName ctxt returnMName
1215 ; (bind_op, fvs4) <- lookupStmtName ctxt bindMName
1216 ; (fmap_op, fvs5) <- case form of
1217 ThenForm -> return (noExpr, emptyFVs)
1218 _ -> lookupStmtNamePoly ctxt fmapName
1219
1220 ; let all_fvs = fvs1 `plusFV` fvs2 `plusFV` fvs3
1221 `plusFV` fvs4 `plusFV` fvs5
1222 bndr_map = used_bndrs `zip` used_bndrs
1223 -- See Note [TransStmt binder map] in GHC.Hs.Expr
1224
1225 ; traceRn "rnStmt: implicitly rebound these used binders:" (ppr bndr_map)
1226 ; return (([(L loc (TransStmt { trS_ext = noExtField
1227 , trS_stmts = stmts', trS_bndrs = bndr_map
1228 , trS_by = by', trS_using = using', trS_form = form
1229 , trS_ret = return_op, trS_bind = bind_op
1230 , trS_fmap = fmap_op }), fvs2)], thing), all_fvs) }
1231
1232 rnStmt _ _ (L _ ApplicativeStmt{}) _ =
1233 panic "rnStmt: ApplicativeStmt"
1234
1235 rnParallelStmts :: forall thing. HsStmtContext GhcRn
1236 -> SyntaxExpr GhcRn
1237 -> [ParStmtBlock GhcPs GhcPs]
1238 -> ([Name] -> RnM (thing, FreeVars))
1239 -> RnM (([ParStmtBlock GhcRn GhcRn], thing), FreeVars)
1240 -- Note [Renaming parallel Stmts]
1241 rnParallelStmts ctxt return_op segs thing_inside
1242 = do { orig_lcl_env <- getLocalRdrEnv
1243 ; rn_segs orig_lcl_env [] segs }
1244 where
1245 rn_segs :: LocalRdrEnv
1246 -> [Name] -> [ParStmtBlock GhcPs GhcPs]
1247 -> RnM (([ParStmtBlock GhcRn GhcRn], thing), FreeVars)
1248 rn_segs _ bndrs_so_far []
1249 = do { let (bndrs', dups) = removeDups cmpByOcc bndrs_so_far
1250 ; mapM_ dupErr dups
1251 ; (thing, fvs) <- bindLocalNames bndrs' (thing_inside bndrs')
1252 ; return (([], thing), fvs) }
1253
1254 rn_segs env bndrs_so_far (ParStmtBlock x stmts _ _ : segs)
1255 = do { ((stmts', (used_bndrs, segs', thing)), fvs)
1256 <- rnStmts ctxt rnExpr stmts $ \ bndrs ->
1257 setLocalRdrEnv env $ do
1258 { ((segs', thing), fvs) <- rn_segs env (bndrs ++ bndrs_so_far) segs
1259 ; let used_bndrs = filter (`elemNameSet` fvs) bndrs
1260 ; return ((used_bndrs, segs', thing), fvs) }
1261
1262 ; let seg' = ParStmtBlock x stmts' used_bndrs return_op
1263 ; return ((seg':segs', thing), fvs) }
1264
1265 cmpByOcc n1 n2 = nameOccName n1 `compare` nameOccName n2
1266 dupErr vs = addErr $ TcRnUnknownMessage $ mkPlainError noHints $
1267 (text "Duplicate binding in parallel list comprehension for:"
1268 <+> quotes (ppr (NE.head vs)))
1269
1270 lookupQualifiedDoStmtName :: HsStmtContext GhcRn -> Name -> RnM (SyntaxExpr GhcRn, FreeVars)
1271 -- Like lookupStmtName, but respects QualifiedDo
1272 lookupQualifiedDoStmtName ctxt n
1273 = case qualifiedDoModuleName_maybe ctxt of
1274 Nothing -> lookupStmtName ctxt n
1275 Just modName ->
1276 first (mkSyntaxExpr . nl_HsVar) <$> lookupNameWithQualifier n modName
1277
1278 lookupStmtName :: HsStmtContext GhcRn -> Name -> RnM (SyntaxExpr GhcRn, FreeVars)
1279 -- Like lookupSyntax, but respects contexts
1280 lookupStmtName ctxt n
1281 | rebindableContext ctxt
1282 = lookupSyntax n
1283 | otherwise
1284 = return (mkRnSyntaxExpr n, emptyFVs)
1285
1286 lookupStmtNamePoly :: HsStmtContext GhcRn -> Name -> RnM (HsExpr GhcRn, FreeVars)
1287 lookupStmtNamePoly ctxt name
1288 | rebindableContext ctxt
1289 = do { rebindable_on <- xoptM LangExt.RebindableSyntax
1290 ; if rebindable_on
1291 then do { fm <- lookupOccRn (nameRdrName name)
1292 ; return (HsVar noExtField (noLocA fm), unitFV fm) }
1293 else not_rebindable }
1294 | otherwise
1295 = not_rebindable
1296 where
1297 not_rebindable = return (HsVar noExtField (noLocA name), emptyFVs)
1298
1299 -- | Is this a context where we respect RebindableSyntax?
1300 -- but ListComp are never rebindable
1301 -- Neither is ArrowExpr, which has its own desugarer in GHC.HsToCore.Arrows
1302 rebindableContext :: HsStmtContext GhcRn -> Bool
1303 rebindableContext ctxt = case ctxt of
1304 HsDoStmt flavour -> rebindableDoStmtContext flavour
1305 ArrowExpr -> False
1306 PatGuard {} -> False
1307
1308
1309 ParStmtCtxt c -> rebindableContext c -- Look inside to
1310 TransStmtCtxt c -> rebindableContext c -- the parent context
1311
1312 rebindableDoStmtContext :: HsDoFlavour -> Bool
1313 rebindableDoStmtContext flavour = case flavour of
1314 ListComp -> False
1315 DoExpr m -> isNothing m
1316 MDoExpr m -> isNothing m
1317 MonadComp -> True
1318 GhciStmtCtxt -> True -- I suppose?
1319
1320 {-
1321 Note [Renaming parallel Stmts]
1322 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1323 Renaming parallel statements is painful. Given, say
1324 [ a+c | a <- as, bs <- bss
1325 | c <- bs, a <- ds ]
1326 Note that
1327 (a) In order to report "Defined but not used" about 'bs', we must
1328 rename each group of Stmts with a thing_inside whose FreeVars
1329 include at least {a,c}
1330
1331 (b) We want to report that 'a' is illegally bound in both branches
1332
1333 (c) The 'bs' in the second group must obviously not be captured by
1334 the binding in the first group
1335
1336 To satisfy (a) we nest the segements.
1337 To satisfy (b) we check for duplicates just before thing_inside.
1338 To satisfy (c) we reset the LocalRdrEnv each time.
1339
1340 ************************************************************************
1341 * *
1342 \subsubsection{mdo expressions}
1343 * *
1344 ************************************************************************
1345 -}
1346
1347 type FwdRefs = NameSet
1348 type Segment stmts = (Defs,
1349 Uses, -- May include defs
1350 FwdRefs, -- A subset of uses that are
1351 -- (a) used before they are bound in this segment, or
1352 -- (b) used here, and bound in subsequent segments
1353 stmts) -- Either Stmt or [Stmt]
1354
1355
1356 -- wrapper that does both the left- and right-hand sides
1357 rnRecStmtsAndThen :: AnnoBody body =>
1358 HsStmtContext GhcRn
1359 -> (body GhcPs -> RnM (body GhcRn, FreeVars))
1360 -> [LStmt GhcPs (LocatedA (body GhcPs))]
1361 -- assumes that the FreeVars returned includes
1362 -- the FreeVars of the Segments
1363 -> ([Segment (LStmt GhcRn (LocatedA (body GhcRn)))]
1364 -> RnM (a, FreeVars))
1365 -> RnM (a, FreeVars)
1366 rnRecStmtsAndThen ctxt rnBody s cont
1367 = do { -- (A) Make the mini fixity env for all of the stmts
1368 fix_env <- makeMiniFixityEnv (collectRecStmtsFixities s)
1369
1370 -- (B) Do the LHSes
1371 ; new_lhs_and_fv <- rn_rec_stmts_lhs fix_env s
1372
1373 -- ...bring them and their fixities into scope
1374 ; let bound_names = collectLStmtsBinders CollNoDictBinders (map fst new_lhs_and_fv)
1375 -- Fake uses of variables introduced implicitly (warning suppression, see #4404)
1376 rec_uses = lStmtsImplicits (map fst new_lhs_and_fv)
1377 implicit_uses = mkNameSet $ concatMap snd $ rec_uses
1378 ; bindLocalNamesFV bound_names $
1379 addLocalFixities fix_env bound_names $ do
1380
1381 -- (C) do the right-hand-sides and thing-inside
1382 { segs <- rn_rec_stmts ctxt rnBody bound_names new_lhs_and_fv
1383 ; (res, fvs) <- cont segs
1384 ; mapM_ (\(loc, ns) -> checkUnusedRecordWildcard loc fvs (Just ns))
1385 rec_uses
1386 ; warnUnusedLocalBinds bound_names (fvs `unionNameSet` implicit_uses)
1387 ; return (res, fvs) }}
1388
1389 -- get all the fixity decls in any Let stmt
1390 collectRecStmtsFixities :: [LStmtLR GhcPs GhcPs body] -> [LFixitySig GhcPs]
1391 collectRecStmtsFixities l =
1392 foldr (\ s -> \acc -> case s of
1393 (L _ (LetStmt _ (HsValBinds _ (ValBinds _ _ sigs)))) ->
1394 foldr (\ sig -> \ acc -> case sig of
1395 (L loc (FixSig _ s)) -> (L loc s) : acc
1396 _ -> acc) acc sigs
1397 _ -> acc) [] l
1398
1399 -- left-hand sides
1400
1401 rn_rec_stmt_lhs :: AnnoBody body => MiniFixityEnv
1402 -> LStmt GhcPs (LocatedA (body GhcPs))
1403 -- rename LHS, and return its FVs
1404 -- Warning: we will only need the FreeVars below in the case of a BindStmt,
1405 -- so we don't bother to compute it accurately in the other cases
1406 -> RnM [(LStmtLR GhcRn GhcPs (LocatedA (body GhcPs)), FreeVars)]
1407
1408 rn_rec_stmt_lhs _ (L loc (BodyStmt _ body a b))
1409 = return [(L loc (BodyStmt noExtField body a b), emptyFVs)]
1410
1411 rn_rec_stmt_lhs _ (L loc (LastStmt _ body noret a))
1412 = return [(L loc (LastStmt noExtField body noret a), emptyFVs)]
1413
1414 rn_rec_stmt_lhs fix_env (L loc (BindStmt _ pat body))
1415 = do
1416 -- should the ctxt be MDo instead?
1417 (pat', fv_pat) <- rnBindPat (localRecNameMaker fix_env) pat
1418 return [(L loc (BindStmt noAnn pat' body), fv_pat)]
1419
1420 rn_rec_stmt_lhs _ (L _ (LetStmt _ binds@(HsIPBinds {})))
1421 = failWith (badIpBinds (text "an mdo expression") binds)
1422
1423 rn_rec_stmt_lhs fix_env (L loc (LetStmt _ (HsValBinds x binds)))
1424 = do (_bound_names, binds') <- rnLocalValBindsLHS fix_env binds
1425 return [(L loc (LetStmt noAnn (HsValBinds x binds')),
1426 -- Warning: this is bogus; see function invariant
1427 emptyFVs
1428 )]
1429
1430 -- XXX Do we need to do something with the return and mfix names?
1431 rn_rec_stmt_lhs fix_env (L _ (RecStmt { recS_stmts = L _ stmts })) -- Flatten Rec inside Rec
1432 = rn_rec_stmts_lhs fix_env stmts
1433
1434 rn_rec_stmt_lhs _ stmt@(L _ (ParStmt {})) -- Syntactically illegal in mdo
1435 = pprPanic "rn_rec_stmt" (ppr stmt)
1436
1437 rn_rec_stmt_lhs _ stmt@(L _ (TransStmt {})) -- Syntactically illegal in mdo
1438 = pprPanic "rn_rec_stmt" (ppr stmt)
1439
1440 rn_rec_stmt_lhs _ stmt@(L _ (ApplicativeStmt {})) -- Shouldn't appear yet
1441 = pprPanic "rn_rec_stmt" (ppr stmt)
1442
1443 rn_rec_stmt_lhs _ (L _ (LetStmt _ (EmptyLocalBinds _)))
1444 = panic "rn_rec_stmt LetStmt EmptyLocalBinds"
1445
1446 rn_rec_stmts_lhs :: AnnoBody body => MiniFixityEnv
1447 -> [LStmt GhcPs (LocatedA (body GhcPs))]
1448 -> RnM [(LStmtLR GhcRn GhcPs (LocatedA (body GhcPs)), FreeVars)]
1449 rn_rec_stmts_lhs fix_env stmts
1450 = do { ls <- concatMapM (rn_rec_stmt_lhs fix_env) stmts
1451 ; let boundNames = collectLStmtsBinders CollNoDictBinders (map fst ls)
1452 -- First do error checking: we need to check for dups here because we
1453 -- don't bind all of the variables from the Stmt at once
1454 -- with bindLocatedLocals.
1455 ; checkDupNames boundNames
1456 ; return ls }
1457
1458
1459 -- right-hand-sides
1460
1461 rn_rec_stmt :: AnnoBody body =>
1462 HsStmtContext GhcRn
1463 -> (body GhcPs -> RnM (body GhcRn, FreeVars))
1464 -> [Name]
1465 -> (LStmtLR GhcRn GhcPs (LocatedA (body GhcPs)), FreeVars)
1466 -> RnM [Segment (LStmt GhcRn (LocatedA (body GhcRn)))]
1467 -- Rename a Stmt that is inside a RecStmt (or mdo)
1468 -- Assumes all binders are already in scope
1469 -- Turns each stmt into a singleton Stmt
1470 rn_rec_stmt ctxt rnBody _ (L loc (LastStmt _ (L lb body) noret _), _)
1471 = do { (body', fv_expr) <- rnBody body
1472 ; (ret_op, fvs1) <- lookupQualifiedDo ctxt returnMName
1473 ; return [(emptyNameSet, fv_expr `plusFV` fvs1, emptyNameSet,
1474 L loc (LastStmt noExtField (L lb body') noret ret_op))] }
1475
1476 rn_rec_stmt ctxt rnBody _ (L loc (BodyStmt _ (L lb body) _ _), _)
1477 = do { (body', fvs) <- rnBody body
1478 ; (then_op, fvs1) <- lookupQualifiedDo ctxt thenMName
1479 ; return [(emptyNameSet, fvs `plusFV` fvs1, emptyNameSet,
1480 L loc (BodyStmt noExtField (L lb body') then_op noSyntaxExpr))] }
1481
1482 rn_rec_stmt ctxt rnBody _ (L loc (BindStmt _ pat' (L lb body)), fv_pat)
1483 = do { (body', fv_expr) <- rnBody body
1484 ; (bind_op, fvs1) <- lookupQualifiedDo ctxt bindMName
1485
1486 ; (fail_op, fvs2) <- getMonadFailOp ctxt
1487
1488 ; let bndrs = mkNameSet (collectPatBinders CollNoDictBinders pat')
1489 fvs = fv_expr `plusFV` fv_pat `plusFV` fvs1 `plusFV` fvs2
1490 ; let xbsrn = XBindStmtRn { xbsrn_bindOp = bind_op, xbsrn_failOp = fail_op }
1491 ; return [(bndrs, fvs, bndrs `intersectNameSet` fvs,
1492 L loc (BindStmt xbsrn pat' (L lb body')))] }
1493
1494 rn_rec_stmt _ _ _ (L _ (LetStmt _ binds@(HsIPBinds {})), _)
1495 = failWith (badIpBinds (text "an mdo expression") binds)
1496
1497 rn_rec_stmt _ _ all_bndrs (L loc (LetStmt _ (HsValBinds x binds')), _)
1498 = do { (binds', du_binds) <- rnLocalValBindsRHS (mkNameSet all_bndrs) binds'
1499 -- fixities and unused are handled above in rnRecStmtsAndThen
1500 ; let fvs = allUses du_binds
1501 ; return [(duDefs du_binds, fvs, emptyNameSet,
1502 L loc (LetStmt noAnn (HsValBinds x binds')))] }
1503
1504 -- no RecStmt case because they get flattened above when doing the LHSes
1505 rn_rec_stmt _ _ _ stmt@(L _ (RecStmt {}), _)
1506 = pprPanic "rn_rec_stmt: RecStmt" (ppr stmt)
1507
1508 rn_rec_stmt _ _ _ stmt@(L _ (ParStmt {}), _) -- Syntactically illegal in mdo
1509 = pprPanic "rn_rec_stmt: ParStmt" (ppr stmt)
1510
1511 rn_rec_stmt _ _ _ stmt@(L _ (TransStmt {}), _) -- Syntactically illegal in mdo
1512 = pprPanic "rn_rec_stmt: TransStmt" (ppr stmt)
1513
1514 rn_rec_stmt _ _ _ (L _ (LetStmt _ (EmptyLocalBinds _)), _)
1515 = panic "rn_rec_stmt: LetStmt EmptyLocalBinds"
1516
1517 rn_rec_stmt _ _ _ stmt@(L _ (ApplicativeStmt {}), _)
1518 = pprPanic "rn_rec_stmt: ApplicativeStmt" (ppr stmt)
1519
1520 rn_rec_stmts :: AnnoBody body =>
1521 HsStmtContext GhcRn
1522 -> (body GhcPs -> RnM (body GhcRn, FreeVars))
1523 -> [Name]
1524 -> [(LStmtLR GhcRn GhcPs (LocatedA (body GhcPs)), FreeVars)]
1525 -> RnM [Segment (LStmt GhcRn (LocatedA (body GhcRn)))]
1526 rn_rec_stmts ctxt rnBody bndrs stmts
1527 = do { segs_s <- mapM (rn_rec_stmt ctxt rnBody bndrs) stmts
1528 ; return (concat segs_s) }
1529
1530 ---------------------------------------------
1531 segmentRecStmts :: AnnoBody body
1532 => SrcSpan -> HsStmtContext GhcRn
1533 -> Stmt GhcRn (LocatedA (body GhcRn))
1534 -> [Segment (LStmt GhcRn (LocatedA (body GhcRn)))]
1535 -> Maybe FreeVars -- Nothing when in interactive mode, everything can be used later
1536 -- Note [What is "used later" in a rec stmt]
1537 -> ([LStmt GhcRn (LocatedA (body GhcRn))], FreeVars)
1538
1539 segmentRecStmts loc ctxt empty_rec_stmt segs mfvs_later
1540 | null segs
1541 = ([], final_fv_uses)
1542
1543 | HsDoStmt (MDoExpr _) <- ctxt
1544 = segsToStmts empty_rec_stmt grouped_segs later_ids
1545 -- Step 4: Turn the segments into Stmts
1546 -- Use RecStmt when and only when there are fwd refs
1547 -- Also gather up the uses from the end towards the
1548 -- start, so we can tell the RecStmt which things are
1549 -- used 'after' the RecStmt
1550
1551 | otherwise
1552 = ([ L (noAnnSrcSpan loc) $
1553 empty_rec_stmt { recS_stmts = noLocA ss
1554 , recS_later_ids = nameSetElemsStable later_ids
1555 , recS_rec_ids = nameSetElemsStable
1556 (defs `intersectNameSet` uses) }]
1557 -- See Note [Deterministic ApplicativeDo and RecursiveDo desugaring]
1558 , uses `plusFV` final_fv_uses)
1559
1560 where
1561 final_fv_uses = case mfvs_later of
1562 Nothing -> defs
1563 Just later -> uses `plusFV` later
1564 later_ids = case mfvs_later of
1565 Nothing -> defs
1566 Just fvs_later -> defs `intersectNameSet` fvs_later
1567
1568 (defs_s, uses_s, _, ss) = unzip4 segs
1569 defs = plusFVs defs_s
1570 uses = plusFVs uses_s
1571
1572 -- Step 2: Fill in the fwd refs.
1573 -- The segments are all singletons, but their fwd-ref
1574 -- field mentions all the things used by the segment
1575 -- that are bound after their use
1576 segs_w_fwd_refs = addFwdRefs segs
1577
1578 -- Step 3: Group together the segments to make bigger segments
1579 -- Invariant: in the result, no segment uses a variable
1580 -- bound in a later segment
1581 grouped_segs = glomSegments ctxt segs_w_fwd_refs
1582
1583 ----------------------------
1584 addFwdRefs :: [Segment a] -> [Segment a]
1585 -- So far the segments only have forward refs *within* the Stmt
1586 -- (which happens for bind: x <- ...x...)
1587 -- This function adds the cross-seg fwd ref info
1588
1589 addFwdRefs segs
1590 = fst (foldr mk_seg ([], emptyNameSet) segs)
1591 where
1592 mk_seg (defs, uses, fwds, stmts) (segs, later_defs)
1593 = (new_seg : segs, all_defs)
1594 where
1595 new_seg = (defs, uses, new_fwds, stmts)
1596 all_defs = later_defs `unionNameSet` defs
1597 new_fwds = fwds `unionNameSet` (uses `intersectNameSet` later_defs)
1598 -- Add the downstream fwd refs here
1599
1600 {-
1601 Note [Segmenting mdo]
1602 ~~~~~~~~~~~~~~~~~~~~~
1603 NB. June 7 2012: We only glom segments that appear in an explicit mdo;
1604 and leave those found in "do rec"'s intact. See
1605 https://gitlab.haskell.org/ghc/ghc/issues/4148 for the discussion
1606 leading to this design choice. Hence the test in segmentRecStmts.
1607
1608 Note [Glomming segments]
1609 ~~~~~~~~~~~~~~~~~~~~~~~~
1610 Glomming the singleton segments of an mdo into minimal recursive groups.
1611
1612 At first I thought this was just strongly connected components, but
1613 there's an important constraint: the order of the stmts must not change.
1614
1615 Consider
1616 mdo { x <- ...y...
1617 p <- z
1618 y <- ...x...
1619 q <- x
1620 z <- y
1621 r <- x }
1622
1623 Here, the first stmt mention 'y', which is bound in the third.
1624 But that means that the innocent second stmt (p <- z) gets caught
1625 up in the recursion. And that in turn means that the binding for
1626 'z' has to be included... and so on.
1627
1628 Start at the tail { r <- x }
1629 Now add the next one { z <- y ; r <- x }
1630 Now add one more { q <- x ; z <- y ; r <- x }
1631 Now one more... but this time we have to group a bunch into rec
1632 { rec { y <- ...x... ; q <- x ; z <- y } ; r <- x }
1633 Now one more, which we can add on without a rec
1634 { p <- z ;
1635 rec { y <- ...x... ; q <- x ; z <- y } ;
1636 r <- x }
1637 Finally we add the last one; since it mentions y we have to
1638 glom it together with the first two groups
1639 { rec { x <- ...y...; p <- z ; y <- ...x... ;
1640 q <- x ; z <- y } ;
1641 r <- x }
1642
1643 Note [What is "used later" in a rec stmt]
1644 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1645 We desugar a recursive Stmt to somethign like
1646
1647 (a,_,c) <- mfix (\(a,b,_) -> do { ... ; return (a,b,c) })
1648 ...stuff after the rec...
1649
1650 The knot-tied tuple must contain
1651 * All the variables that are used before they are bound in the `rec` block
1652 * All the variables that are used after the entire `rec` block
1653
1654 In the case of GHCi, however, we don't know what variables will be used
1655 after the `rec` (#20206). For example, we might have
1656 ghci> rec { x <- e1; y <- e2 }
1657 ghci> print x
1658 ghci> print y
1659
1660 So we have to assume that *all* the variables bound in the `rec` are used
1661 afterwards. We use `Nothing` in the argument to segmentRecStmts to signal
1662 that all the variables are used.
1663 -}
1664
1665 glomSegments :: HsStmtContext GhcRn
1666 -> [Segment (LStmt GhcRn body)]
1667 -> [Segment [LStmt GhcRn body]]
1668 -- Each segment has a non-empty list of Stmts
1669 -- See Note [Glomming segments]
1670
1671 glomSegments _ [] = []
1672 glomSegments ctxt ((defs,uses,fwds,stmt) : segs)
1673 -- Actually stmts will always be a singleton
1674 = (seg_defs, seg_uses, seg_fwds, seg_stmts) : others
1675 where
1676 segs' = glomSegments ctxt segs
1677 (extras, others) = grab uses segs'
1678 (ds, us, fs, ss) = unzip4 extras
1679
1680 seg_defs = plusFVs ds `plusFV` defs
1681 seg_uses = plusFVs us `plusFV` uses
1682 seg_fwds = plusFVs fs `plusFV` fwds
1683 seg_stmts = stmt : concat ss
1684
1685 grab :: NameSet -- The client
1686 -> [Segment a]
1687 -> ([Segment a], -- Needed by the 'client'
1688 [Segment a]) -- Not needed by the client
1689 -- The result is simply a split of the input
1690 grab uses dus
1691 = (reverse yeses, reverse noes)
1692 where
1693 (noes, yeses) = span not_needed (reverse dus)
1694 not_needed (defs,_,_,_) = disjointNameSet defs uses
1695
1696 ----------------------------------------------------
1697 segsToStmts :: Stmt GhcRn (LocatedA (body GhcRn))
1698 -- A RecStmt with the SyntaxOps filled in
1699 -> [Segment [LStmt GhcRn (LocatedA (body GhcRn))]]
1700 -- Each Segment has a non-empty list of Stmts
1701 -> FreeVars -- Free vars used 'later'
1702 -> ([LStmt GhcRn (LocatedA (body GhcRn))], FreeVars)
1703
1704 segsToStmts _ [] fvs_later = ([], fvs_later)
1705 segsToStmts empty_rec_stmt ((defs, uses, fwds, ss) : segs) fvs_later
1706 = assert (not (null ss))
1707 (new_stmt : later_stmts, later_uses `plusFV` uses)
1708 where
1709 (later_stmts, later_uses) = segsToStmts empty_rec_stmt segs fvs_later
1710 new_stmt | non_rec = head ss
1711 | otherwise = L (getLoc (head ss)) rec_stmt
1712 rec_stmt = empty_rec_stmt { recS_stmts = noLocA ss
1713 , recS_later_ids = nameSetElemsStable used_later
1714 , recS_rec_ids = nameSetElemsStable fwds }
1715 -- See Note [Deterministic ApplicativeDo and RecursiveDo desugaring]
1716 non_rec = isSingleton ss && isEmptyNameSet fwds
1717 used_later = defs `intersectNameSet` later_uses
1718 -- The ones needed after the RecStmt
1719
1720 {-
1721 ************************************************************************
1722 * *
1723 ApplicativeDo
1724 * *
1725 ************************************************************************
1726
1727 Note [ApplicativeDo]
1728
1729 = Example =
1730
1731 For a sequence of statements
1732
1733 do
1734 x <- A
1735 y <- B x
1736 z <- C
1737 return (f x y z)
1738
1739 We want to transform this to
1740
1741 (\(x,y) z -> f x y z) <$> (do x <- A; y <- B x; return (x,y)) <*> C
1742
1743 It would be easy to notice that "y <- B x" and "z <- C" are
1744 independent and do something like this:
1745
1746 do
1747 x <- A
1748 (y,z) <- (,) <$> B x <*> C
1749 return (f x y z)
1750
1751 But this isn't enough! A and C were also independent, and this
1752 transformation loses the ability to do A and C in parallel.
1753
1754 The algorithm works by first splitting the sequence of statements into
1755 independent "segments", and a separate "tail" (the final statement). In
1756 our example above, the segements would be
1757
1758 [ x <- A
1759 , y <- B x ]
1760
1761 [ z <- C ]
1762
1763 and the tail is:
1764
1765 return (f x y z)
1766
1767 Then we take these segments and make an Applicative expression from them:
1768
1769 (\(x,y) z -> return (f x y z))
1770 <$> do { x <- A; y <- B x; return (x,y) }
1771 <*> C
1772
1773 Finally, we recursively apply the transformation to each segment, to
1774 discover any nested parallelism.
1775
1776 = Syntax & spec =
1777
1778 expr ::= ... | do {stmt_1; ..; stmt_n} expr | ...
1779
1780 stmt ::= pat <- expr
1781 | (arg_1 | ... | arg_n) -- applicative composition, n>=1
1782 | ... -- other kinds of statement (e.g. let)
1783
1784 arg ::= pat <- expr
1785 | {stmt_1; ..; stmt_n} {var_1..var_n}
1786
1787 (note that in the actual implementation,the expr in a do statement is
1788 represented by a LastStmt as the final stmt, this is just a
1789 representational issue and may change later.)
1790
1791 == Transformation to introduce applicative stmts ==
1792
1793 ado {} tail = tail
1794 ado {pat <- expr} {return expr'} = (mkArg(pat <- expr)); return expr'
1795 ado {one} tail = one : tail
1796 ado stmts tail
1797 | n == 1 = ado before (ado after tail)
1798 where (before,after) = split(stmts_1)
1799 | n > 1 = (mkArg(stmts_1) | ... | mkArg(stmts_n)); tail
1800 where
1801 {stmts_1 .. stmts_n} = segments(stmts)
1802
1803 segments(stmts) =
1804 -- divide stmts into segments with no interdependencies
1805
1806 mkArg({pat <- expr}) = (pat <- expr)
1807 mkArg({stmt_1; ...; stmt_n}) =
1808 {stmt_1; ...; stmt_n} {vars(stmt_1) u .. u vars(stmt_n)}
1809
1810 split({stmt_1; ..; stmt_n) =
1811 ({stmt_1; ..; stmt_i}, {stmt_i+1; ..; stmt_n})
1812 -- 1 <= i <= n
1813 -- i is a good place to insert a bind
1814
1815 == Desugaring for do ==
1816
1817 dsDo {} expr = expr
1818
1819 dsDo {pat <- rhs; stmts} expr =
1820 rhs >>= \pat -> dsDo stmts expr
1821
1822 dsDo {(arg_1 | ... | arg_n)} (return expr) =
1823 (\argpat (arg_1) .. argpat(arg_n) -> expr)
1824 <$> argexpr(arg_1)
1825 <*> ...
1826 <*> argexpr(arg_n)
1827
1828 dsDo {(arg_1 | ... | arg_n); stmts} expr =
1829 join (\argpat (arg_1) .. argpat(arg_n) -> dsDo stmts expr)
1830 <$> argexpr(arg_1)
1831 <*> ...
1832 <*> argexpr(arg_n)
1833
1834 = Relevant modules in the rest of the compiler =
1835
1836 ApplicativeDo touches a few phases in the compiler:
1837
1838 * Renamer: The journey begins here in the renamer, where do-blocks are
1839 scheduled as outlined above and transformed into applicative
1840 combinators. However, the code is still represented as a do-block
1841 with special forms of applicative statements. This allows us to
1842 recover the original do-block when e.g. printing type errors, where
1843 we don't want to show any of the applicative combinators since they
1844 don't exist in the source code.
1845 See ApplicativeStmt and ApplicativeArg in HsExpr.
1846
1847 * Typechecker: ApplicativeDo passes through the typechecker much like any
1848 other form of expression. The only crux is that the typechecker has to
1849 be aware of the special ApplicativeDo statements in the do-notation, and
1850 typecheck them appropriately.
1851 Relevant module: GHC.Tc.Gen.Match
1852
1853 * Desugarer: Any do-block which contains applicative statements is desugared
1854 as outlined above, to use the Applicative combinators.
1855 Relevant module: GHC.HsToCore.Expr
1856
1857 -}
1858
1859 -- | The 'Name's of @return@ and @pure@. These may not be 'returnName' and
1860 -- 'pureName' due to @QualifiedDo@ or @RebindableSyntax@.
1861 data MonadNames = MonadNames { return_name, pure_name :: Name }
1862
1863 instance Outputable MonadNames where
1864 ppr (MonadNames {return_name=return_name,pure_name=pure_name}) =
1865 hcat
1866 [text "MonadNames { return_name = "
1867 ,ppr return_name
1868 ,text ", pure_name = "
1869 ,ppr pure_name
1870 ,text "}"
1871 ]
1872
1873 -- | rearrange a list of statements using ApplicativeDoStmt. See
1874 -- Note [ApplicativeDo].
1875 rearrangeForApplicativeDo
1876 :: HsDoFlavour
1877 -> [(ExprLStmt GhcRn, FreeVars)]
1878 -> RnM ([ExprLStmt GhcRn], FreeVars)
1879
1880 rearrangeForApplicativeDo _ [] = return ([], emptyNameSet)
1881 rearrangeForApplicativeDo _ [(one,_)] = return ([one], emptyNameSet)
1882 rearrangeForApplicativeDo ctxt stmts0 = do
1883 optimal_ado <- goptM Opt_OptimalApplicativeDo
1884 let stmt_tree | optimal_ado = mkStmtTreeOptimal stmts
1885 | otherwise = mkStmtTreeHeuristic stmts
1886 traceRn "rearrangeForADo" (ppr stmt_tree)
1887 (return_name, _) <- lookupQualifiedDoName (HsDoStmt ctxt) returnMName
1888 (pure_name, _) <- lookupQualifiedDoName (HsDoStmt ctxt) pureAName
1889 let monad_names = MonadNames { return_name = return_name
1890 , pure_name = pure_name }
1891 stmtTreeToStmts monad_names ctxt stmt_tree [last] last_fvs
1892 where
1893 (stmts,(last,last_fvs)) = findLast stmts0
1894 findLast [] = error "findLast"
1895 findLast [last] = ([],last)
1896 findLast (x:xs) = (x:rest,last) where (rest,last) = findLast xs
1897
1898 -- | A tree of statements using a mixture of applicative and bind constructs.
1899 data StmtTree a
1900 = StmtTreeOne a
1901 | StmtTreeBind (StmtTree a) (StmtTree a)
1902 | StmtTreeApplicative [StmtTree a]
1903
1904 instance Outputable a => Outputable (StmtTree a) where
1905 ppr (StmtTreeOne x) = parens (text "StmtTreeOne" <+> ppr x)
1906 ppr (StmtTreeBind x y) = parens (hang (text "StmtTreeBind")
1907 2 (sep [ppr x, ppr y]))
1908 ppr (StmtTreeApplicative xs) = parens (hang (text "StmtTreeApplicative")
1909 2 (vcat (map ppr xs)))
1910
1911 flattenStmtTree :: StmtTree a -> [a]
1912 flattenStmtTree t = go t []
1913 where
1914 go (StmtTreeOne a) as = a : as
1915 go (StmtTreeBind l r) as = go l (go r as)
1916 go (StmtTreeApplicative ts) as = foldr go as ts
1917
1918 type ExprStmtTree = StmtTree (ExprLStmt GhcRn, FreeVars)
1919 type Cost = Int
1920
1921 -- | Turn a sequence of statements into an ExprStmtTree using a
1922 -- heuristic algorithm. /O(n^2)/
1923 mkStmtTreeHeuristic :: [(ExprLStmt GhcRn, FreeVars)] -> ExprStmtTree
1924 mkStmtTreeHeuristic [one] = StmtTreeOne one
1925 mkStmtTreeHeuristic stmts =
1926 case segments stmts of
1927 [one] -> split one
1928 segs -> StmtTreeApplicative (map split segs)
1929 where
1930 split [one] = StmtTreeOne one
1931 split stmts =
1932 StmtTreeBind (mkStmtTreeHeuristic before) (mkStmtTreeHeuristic after)
1933 where (before, after) = splitSegment stmts
1934
1935 -- | Turn a sequence of statements into an ExprStmtTree optimally,
1936 -- using dynamic programming. /O(n^3)/
1937 mkStmtTreeOptimal :: [(ExprLStmt GhcRn, FreeVars)] -> ExprStmtTree
1938 mkStmtTreeOptimal stmts =
1939 assert (not (null stmts)) $ -- the empty case is handled by the caller;
1940 -- we don't support empty StmtTrees.
1941 fst (arr ! (0,n))
1942 where
1943 n = length stmts - 1
1944 stmt_arr = listArray (0,n) stmts
1945
1946 -- lazy cache of optimal trees for subsequences of the input
1947 arr :: Array (Int,Int) (ExprStmtTree, Cost)
1948 arr = array ((0,0),(n,n))
1949 [ ((lo,hi), tree lo hi)
1950 | lo <- [0..n]
1951 , hi <- [lo..n] ]
1952
1953 -- compute the optimal tree for the sequence [lo..hi]
1954 tree lo hi
1955 | hi == lo = (StmtTreeOne (stmt_arr ! lo), 1)
1956 | otherwise =
1957 case segments [ stmt_arr ! i | i <- [lo..hi] ] of
1958 [] -> panic "mkStmtTree"
1959 [_one] -> split lo hi
1960 segs -> (StmtTreeApplicative trees, maximum costs)
1961 where
1962 bounds = scanl (\(_,hi) a -> (hi+1, hi + length a)) (0,lo-1) segs
1963 (trees,costs) = unzip (map (uncurry split) (tail bounds))
1964
1965 -- find the best place to split the segment [lo..hi]
1966 split :: Int -> Int -> (ExprStmtTree, Cost)
1967 split lo hi
1968 | hi == lo = (StmtTreeOne (stmt_arr ! lo), 1)
1969 | otherwise = (StmtTreeBind before after, c1+c2)
1970 where
1971 -- As per the paper, for a sequence s1...sn, we want to find
1972 -- the split with the minimum cost, where the cost is the
1973 -- sum of the cost of the left and right subsequences.
1974 --
1975 -- As an optimisation (also in the paper) if the cost of
1976 -- s1..s(n-1) is different from the cost of s2..sn, we know
1977 -- that the optimal solution is the lower of the two. Only
1978 -- in the case that these two have the same cost do we need
1979 -- to do the exhaustive search.
1980 --
1981 ((before,c1),(after,c2))
1982 | hi - lo == 1
1983 = ((StmtTreeOne (stmt_arr ! lo), 1),
1984 (StmtTreeOne (stmt_arr ! hi), 1))
1985 | left_cost < right_cost
1986 = ((left,left_cost), (StmtTreeOne (stmt_arr ! hi), 1))
1987 | left_cost > right_cost
1988 = ((StmtTreeOne (stmt_arr ! lo), 1), (right,right_cost))
1989 | otherwise = minimumBy (comparing cost) alternatives
1990 where
1991 (left, left_cost) = arr ! (lo,hi-1)
1992 (right, right_cost) = arr ! (lo+1,hi)
1993 cost ((_,c1),(_,c2)) = c1 + c2
1994 alternatives = [ (arr ! (lo,k), arr ! (k+1,hi))
1995 | k <- [lo .. hi-1] ]
1996
1997
1998 -- | Turn the ExprStmtTree back into a sequence of statements, using
1999 -- ApplicativeStmt where necessary.
2000 stmtTreeToStmts
2001 :: MonadNames
2002 -> HsDoFlavour
2003 -> ExprStmtTree
2004 -> [ExprLStmt GhcRn] -- ^ the "tail"
2005 -> FreeVars -- ^ free variables of the tail
2006 -> RnM ( [ExprLStmt GhcRn] -- ( output statements,
2007 , FreeVars ) -- , things we needed
2008
2009 -- If we have a single bind, and we can do it without a join, transform
2010 -- to an ApplicativeStmt. This corresponds to the rule
2011 -- dsBlock [pat <- rhs] (return expr) = expr <$> rhs
2012 -- In the spec, but we do it here rather than in the desugarer,
2013 -- because we need the typechecker to typecheck the <$> form rather than
2014 -- the bind form, which would give rise to a Monad constraint.
2015 stmtTreeToStmts monad_names ctxt (StmtTreeOne (L _ (BindStmt xbs pat rhs), _))
2016 tail _tail_fvs
2017 | not (isStrictPattern pat), (False,tail') <- needJoin monad_names tail
2018 -- See Note [ApplicativeDo and strict patterns]
2019 = mkApplicativeStmt ctxt [ApplicativeArgOne
2020 { xarg_app_arg_one = xbsrn_failOp xbs
2021 , app_arg_pattern = pat
2022 , arg_expr = rhs
2023 , is_body_stmt = False
2024 }]
2025 False tail'
2026 stmtTreeToStmts monad_names ctxt (StmtTreeOne (L _ (BodyStmt _ rhs _ _),_))
2027 tail _tail_fvs
2028 | (False,tail') <- needJoin monad_names tail
2029 = mkApplicativeStmt ctxt
2030 [ApplicativeArgOne
2031 { xarg_app_arg_one = Nothing
2032 , app_arg_pattern = nlWildPatName
2033 , arg_expr = rhs
2034 , is_body_stmt = True
2035 }] False tail'
2036
2037 stmtTreeToStmts _monad_names _ctxt (StmtTreeOne (s,_)) tail _tail_fvs =
2038 return (s : tail, emptyNameSet)
2039
2040 stmtTreeToStmts monad_names ctxt (StmtTreeBind before after) tail tail_fvs = do
2041 (stmts1, fvs1) <- stmtTreeToStmts monad_names ctxt after tail tail_fvs
2042 let tail1_fvs = unionNameSets (tail_fvs : map snd (flattenStmtTree after))
2043 (stmts2, fvs2) <- stmtTreeToStmts monad_names ctxt before stmts1 tail1_fvs
2044 return (stmts2, fvs1 `plusFV` fvs2)
2045
2046 stmtTreeToStmts monad_names ctxt (StmtTreeApplicative trees) tail tail_fvs = do
2047 pairs <- mapM (stmtTreeArg ctxt tail_fvs) trees
2048 dflags <- getDynFlags
2049 let (stmts', fvss) = unzip pairs
2050 let (need_join, tail') =
2051 -- See Note [ApplicativeDo and refutable patterns]
2052 if any (hasRefutablePattern dflags) stmts'
2053 then (True, tail)
2054 else needJoin monad_names tail
2055
2056 (stmts, fvs) <- mkApplicativeStmt ctxt stmts' need_join tail'
2057 return (stmts, unionNameSets (fvs:fvss))
2058 where
2059 stmtTreeArg _ctxt _tail_fvs (StmtTreeOne (L _ (BindStmt xbs pat exp), _))
2060 = return (ApplicativeArgOne
2061 { xarg_app_arg_one = xbsrn_failOp xbs
2062 , app_arg_pattern = pat
2063 , arg_expr = exp
2064 , is_body_stmt = False
2065 }, emptyFVs)
2066 stmtTreeArg _ctxt _tail_fvs (StmtTreeOne (L _ (BodyStmt _ exp _ _), _)) =
2067 return (ApplicativeArgOne
2068 { xarg_app_arg_one = Nothing
2069 , app_arg_pattern = nlWildPatName
2070 , arg_expr = exp
2071 , is_body_stmt = True
2072 }, emptyFVs)
2073 stmtTreeArg ctxt tail_fvs tree = do
2074 let stmts = flattenStmtTree tree
2075 pvarset = mkNameSet (concatMap (collectStmtBinders CollNoDictBinders . unLoc . fst) stmts)
2076 `intersectNameSet` tail_fvs
2077 pvars = nameSetElemsStable pvarset
2078 -- See Note [Deterministic ApplicativeDo and RecursiveDo desugaring]
2079 pat = mkBigLHsVarPatTup pvars
2080 tup = mkBigLHsVarTup pvars noExtField
2081 (stmts',fvs2) <- stmtTreeToStmts monad_names ctxt tree [] pvarset
2082 (mb_ret, fvs1) <-
2083 if | L _ ApplicativeStmt{} <- last stmts' ->
2084 return (unLoc tup, emptyNameSet)
2085 | otherwise -> do
2086 (ret, _) <- lookupQualifiedDoExpr (HsDoStmt ctxt) returnMName
2087 let expr = HsApp noComments (noLocA ret) tup
2088 return (expr, emptyFVs)
2089 return ( ApplicativeArgMany
2090 { xarg_app_arg_many = noExtField
2091 , app_stmts = stmts'
2092 , final_expr = mb_ret
2093 , bv_pattern = pat
2094 , stmt_context = ctxt
2095 }
2096 , fvs1 `plusFV` fvs2)
2097
2098
2099 -- | Divide a sequence of statements into segments, where no segment
2100 -- depends on any variables defined by a statement in another segment.
2101 segments
2102 :: [(ExprLStmt GhcRn, FreeVars)]
2103 -> [[(ExprLStmt GhcRn, FreeVars)]]
2104 segments stmts = map fst $ merge $ reverse $ map reverse $ walk (reverse stmts)
2105 where
2106 allvars = mkNameSet (concatMap (collectStmtBinders CollNoDictBinders . unLoc . fst) stmts)
2107
2108 -- We would rather not have a segment that just has LetStmts in
2109 -- it, so combine those with an adjacent segment where possible.
2110 merge [] = []
2111 merge (seg : segs)
2112 = case rest of
2113 [] -> [(seg,all_lets)]
2114 ((s,s_lets):ss) | all_lets || s_lets
2115 -> (seg ++ s, all_lets && s_lets) : ss
2116 _otherwise -> (seg,all_lets) : rest
2117 where
2118 rest = merge segs
2119 all_lets = all (isLetStmt . fst) seg
2120
2121 -- walk splits the statement sequence into segments, traversing
2122 -- the sequence from the back to the front, and keeping track of
2123 -- the set of free variables of the current segment. Whenever
2124 -- this set of free variables is empty, we have a complete segment.
2125 walk :: [(ExprLStmt GhcRn, FreeVars)] -> [[(ExprLStmt GhcRn, FreeVars)]]
2126 walk [] = []
2127 walk ((stmt,fvs) : stmts) = ((stmt,fvs) : seg) : walk rest
2128 where (seg,rest) = chunter fvs' stmts
2129 (_, fvs') = stmtRefs stmt fvs
2130
2131 chunter _ [] = ([], [])
2132 chunter vars ((stmt,fvs) : rest)
2133 | not (isEmptyNameSet vars)
2134 || isStrictPatternBind stmt
2135 -- See Note [ApplicativeDo and strict patterns]
2136 = ((stmt,fvs) : chunk, rest')
2137 where (chunk,rest') = chunter vars' rest
2138 (pvars, evars) = stmtRefs stmt fvs
2139 vars' = (vars `minusNameSet` pvars) `unionNameSet` evars
2140 chunter _ rest = ([], rest)
2141
2142 stmtRefs stmt fvs
2143 | isLetStmt stmt = (pvars, fvs' `minusNameSet` pvars)
2144 | otherwise = (pvars, fvs')
2145 where fvs' = fvs `intersectNameSet` allvars
2146 pvars = mkNameSet (collectStmtBinders CollNoDictBinders (unLoc stmt))
2147
2148 isStrictPatternBind :: ExprLStmt GhcRn -> Bool
2149 isStrictPatternBind (L _ (BindStmt _ pat _)) = isStrictPattern pat
2150 isStrictPatternBind _ = False
2151
2152 {-
2153 Note [ApplicativeDo and strict patterns]
2154
2155 A strict pattern match is really a dependency. For example,
2156
2157 do
2158 (x,y) <- A
2159 z <- B
2160 return C
2161
2162 The pattern (_,_) must be matched strictly before we do B. If we
2163 allowed this to be transformed into
2164
2165 (\(x,y) -> \z -> C) <$> A <*> B
2166
2167 then it could be lazier than the standard desuraging using >>=. See #13875
2168 for more examples.
2169
2170 Thus, whenever we have a strict pattern match, we treat it as a
2171 dependency between that statement and the following one. The
2172 dependency prevents those two statements from being performed "in
2173 parallel" in an ApplicativeStmt, but doesn't otherwise affect what we
2174 can do with the rest of the statements in the same "do" expression.
2175 -}
2176
2177 isStrictPattern :: forall p. IsPass p => LPat (GhcPass p) -> Bool
2178 isStrictPattern (L loc pat) =
2179 case pat of
2180 WildPat{} -> False
2181 VarPat{} -> False
2182 LazyPat{} -> False
2183 AsPat _ _ p -> isStrictPattern p
2184 ParPat _ _ p _ -> isStrictPattern p
2185 ViewPat _ _ p -> isStrictPattern p
2186 SigPat _ p _ -> isStrictPattern p
2187 BangPat{} -> True
2188 ListPat{} -> True
2189 TuplePat{} -> True
2190 SumPat{} -> True
2191 ConPat{} -> True
2192 LitPat{} -> True
2193 NPat{} -> True
2194 NPlusKPat{} -> True
2195 SplicePat{} -> True
2196 XPat ext -> case ghcPass @p of
2197 #if __GLASGOW_HASKELL__ < 811
2198 GhcPs -> noExtCon ext
2199 #endif
2200 GhcRn
2201 | HsPatExpanded _ p <- ext
2202 -> isStrictPattern (L loc p)
2203 GhcTc -> case ext of
2204 ExpansionPat _ p -> isStrictPattern (L loc p)
2205 CoPat {} -> panic "isStrictPattern: CoPat"
2206
2207 {-
2208 Note [ApplicativeDo and refutable patterns]
2209
2210 Refutable patterns in do blocks are desugared to use the monadic 'fail' operation.
2211 This means that sometimes an applicative block needs to be wrapped in 'join' simply because
2212 of a refutable pattern, in order for the types to work out.
2213
2214 -}
2215
2216 hasRefutablePattern :: DynFlags -> ApplicativeArg GhcRn -> Bool
2217 hasRefutablePattern dflags (ApplicativeArgOne { app_arg_pattern = pat
2218 , is_body_stmt = False}) =
2219 not (isIrrefutableHsPat dflags pat)
2220 hasRefutablePattern _ _ = False
2221
2222 isLetStmt :: LStmt (GhcPass a) b -> Bool
2223 isLetStmt (L _ LetStmt{}) = True
2224 isLetStmt _ = False
2225
2226 -- | Find a "good" place to insert a bind in an indivisible segment.
2227 -- This is the only place where we use heuristics. The current
2228 -- heuristic is to peel off the first group of independent statements
2229 -- and put the bind after those.
2230 splitSegment
2231 :: [(ExprLStmt GhcRn, FreeVars)]
2232 -> ( [(ExprLStmt GhcRn, FreeVars)]
2233 , [(ExprLStmt GhcRn, FreeVars)] )
2234 splitSegment [one,two] = ([one],[two])
2235 -- there is no choice when there are only two statements; this just saves
2236 -- some work in a common case.
2237 splitSegment stmts
2238 | Just (lets,binds,rest) <- slurpIndependentStmts stmts
2239 = if not (null lets)
2240 then (lets, binds++rest)
2241 else (lets++binds, rest)
2242 | otherwise
2243 = case stmts of
2244 (x:xs) -> ([x],xs)
2245 _other -> (stmts,[])
2246
2247 slurpIndependentStmts
2248 :: [(LStmt GhcRn (LocatedA (body GhcRn)), FreeVars)]
2249 -> Maybe ( [(LStmt GhcRn (LocatedA (body GhcRn)), FreeVars)] -- LetStmts
2250 , [(LStmt GhcRn (LocatedA (body GhcRn)), FreeVars)] -- BindStmts
2251 , [(LStmt GhcRn (LocatedA (body GhcRn)), FreeVars)] )
2252 slurpIndependentStmts stmts = go [] [] emptyNameSet stmts
2253 where
2254 -- If we encounter a BindStmt that doesn't depend on a previous BindStmt
2255 -- in this group, then add it to the group. We have to be careful about
2256 -- strict patterns though; splitSegments expects that if we return Just
2257 -- then we have actually done some splitting. Otherwise it will go into
2258 -- an infinite loop (#14163).
2259 go lets indep bndrs ((L loc (BindStmt xbs pat body), fvs): rest)
2260 | disjointNameSet bndrs fvs && not (isStrictPattern pat)
2261 = go lets ((L loc (BindStmt xbs pat body), fvs) : indep)
2262 bndrs' rest
2263 where bndrs' = bndrs `unionNameSet` mkNameSet (collectPatBinders CollNoDictBinders pat)
2264 -- If we encounter a LetStmt that doesn't depend on a BindStmt in this
2265 -- group, then move it to the beginning, so that it doesn't interfere with
2266 -- grouping more BindStmts.
2267 -- TODO: perhaps we shouldn't do this if there are any strict bindings,
2268 -- because we might be moving evaluation earlier.
2269 go lets indep bndrs ((L loc (LetStmt noExtField binds), fvs) : rest)
2270 | disjointNameSet bndrs fvs
2271 = go ((L loc (LetStmt noExtField binds), fvs) : lets) indep bndrs rest
2272 go _ [] _ _ = Nothing
2273 go _ [_] _ _ = Nothing
2274 go lets indep _ stmts = Just (reverse lets, reverse indep, stmts)
2275
2276 -- | Build an ApplicativeStmt, and strip the "return" from the tail
2277 -- if necessary.
2278 --
2279 -- For example, if we start with
2280 -- do x <- E1; y <- E2; return (f x y)
2281 -- then we get
2282 -- do (E1[x] | E2[y]); f x y
2283 --
2284 -- the LastStmt in this case has the return removed, but we set the
2285 -- flag on the LastStmt to indicate this, so that we can print out the
2286 -- original statement correctly in error messages. It is easier to do
2287 -- it this way rather than try to ignore the return later in both the
2288 -- typechecker and the desugarer (I tried it that way first!).
2289 mkApplicativeStmt
2290 :: HsDoFlavour
2291 -> [ApplicativeArg GhcRn] -- ^ The args
2292 -> Bool -- ^ True <=> need a join
2293 -> [ExprLStmt GhcRn] -- ^ The body statements
2294 -> RnM ([ExprLStmt GhcRn], FreeVars)
2295 mkApplicativeStmt ctxt args need_join body_stmts
2296 = do { (fmap_op, fvs1) <- lookupQualifiedDoStmtName (HsDoStmt ctxt) fmapName
2297 ; (ap_op, fvs2) <- lookupQualifiedDoStmtName (HsDoStmt ctxt) apAName
2298 ; (mb_join, fvs3) <-
2299 if need_join then
2300 do { (join_op, fvs) <- lookupQualifiedDoStmtName (HsDoStmt ctxt) joinMName
2301 ; return (Just join_op, fvs) }
2302 else
2303 return (Nothing, emptyNameSet)
2304 ; let applicative_stmt = noLocA $ ApplicativeStmt noExtField
2305 (zip (fmap_op : repeat ap_op) args)
2306 mb_join
2307 ; return ( applicative_stmt : body_stmts
2308 , fvs1 `plusFV` fvs2 `plusFV` fvs3) }
2309
2310 -- | Given the statements following an ApplicativeStmt, determine whether
2311 -- we need a @join@ or not, and remove the @return@ if necessary.
2312 needJoin :: MonadNames
2313 -> [ExprLStmt GhcRn]
2314 -> (Bool, [ExprLStmt GhcRn])
2315 needJoin _monad_names [] = (False, []) -- we're in an ApplicativeArg
2316 needJoin monad_names [L loc (LastStmt _ e _ t)]
2317 | Just (arg, wasDollar) <- isReturnApp monad_names e =
2318 (False, [L loc (LastStmt noExtField arg (Just wasDollar) t)])
2319 needJoin _monad_names stmts = (True, stmts)
2320
2321 -- | @(Just e, False)@, if the expression is @return e@
2322 -- @(Just e, True)@ if the expression is @return $ e@,
2323 -- otherwise @Nothing@.
2324 isReturnApp :: MonadNames
2325 -> LHsExpr GhcRn
2326 -> Maybe (LHsExpr GhcRn, Bool)
2327 isReturnApp monad_names (L _ (HsPar _ _ expr _)) = isReturnApp monad_names expr
2328 isReturnApp monad_names (L _ e) = case e of
2329 OpApp _ l op r | is_return l, is_dollar op -> Just (r, True)
2330 HsApp _ f arg | is_return f -> Just (arg, False)
2331 _otherwise -> Nothing
2332 where
2333 is_var f (L _ (HsPar _ _ e _)) = is_var f e
2334 is_var f (L _ (HsAppType _ e _)) = is_var f e
2335 is_var f (L _ (HsVar _ (L _ r))) = f r
2336 -- TODO: I don't know how to get this right for rebindable syntax
2337 is_var _ _ = False
2338
2339 is_return = is_var (\n -> n == return_name monad_names
2340 || n == pure_name monad_names)
2341 is_dollar = is_var (`hasKey` dollarIdKey)
2342
2343 {-
2344 ************************************************************************
2345 * *
2346 \subsubsection{Errors}
2347 * *
2348 ************************************************************************
2349 -}
2350
2351 checkEmptyStmts :: HsStmtContext GhcRn -> RnM ()
2352 -- We've seen an empty sequence of Stmts... is that ok?
2353 checkEmptyStmts ctxt
2354 = unless (okEmpty ctxt) (addErr (emptyErr ctxt))
2355
2356 okEmpty :: HsStmtContext a -> Bool
2357 okEmpty (PatGuard {}) = True
2358 okEmpty _ = False
2359
2360 emptyErr :: HsStmtContext GhcRn -> TcRnMessage
2361 emptyErr (ParStmtCtxt {}) = TcRnUnknownMessage $ mkPlainError noHints $
2362 text "Empty statement group in parallel comprehension"
2363 emptyErr (TransStmtCtxt {}) = TcRnUnknownMessage $ mkPlainError noHints $
2364 text "Empty statement group preceding 'group' or 'then'"
2365 emptyErr ctxt@(HsDoStmt _) = TcRnUnknownMessage $ mkPlainError [suggestExtension LangExt.NondecreasingIndentation] $
2366 text "Empty" <+> pprStmtContext ctxt
2367 emptyErr ctxt = TcRnUnknownMessage $ mkPlainError noHints $
2368 text "Empty" <+> pprStmtContext ctxt
2369
2370 ----------------------
2371 checkLastStmt :: AnnoBody body => HsStmtContext GhcRn
2372 -> LStmt GhcPs (LocatedA (body GhcPs))
2373 -> RnM (LStmt GhcPs (LocatedA (body GhcPs)))
2374 checkLastStmt ctxt lstmt@(L loc stmt)
2375 = case ctxt of
2376 HsDoStmt ListComp -> check_comp
2377 HsDoStmt MonadComp -> check_comp
2378 HsDoStmt DoExpr{} -> check_do
2379 HsDoStmt MDoExpr{} -> check_do
2380 ArrowExpr -> check_do
2381 _ -> check_other
2382 where
2383 check_do -- Expect BodyStmt, and change it to LastStmt
2384 = case stmt of
2385 BodyStmt _ e _ _ -> return (L loc (mkLastStmt e))
2386 LastStmt {} -> return lstmt -- "Deriving" clauses may generate a
2387 -- LastStmt directly (unlike the parser)
2388 _ -> do { addErr $ TcRnUnknownMessage $ mkPlainError noHints $
2389 (hang last_error 2 (ppr stmt))
2390 ; return lstmt }
2391 last_error = (text "The last statement in" <+> pprAStmtContext ctxt
2392 <+> text "must be an expression")
2393
2394 check_comp -- Expect LastStmt; this should be enforced by the parser!
2395 = case stmt of
2396 LastStmt {} -> return lstmt
2397 _ -> pprPanic "checkLastStmt" (ppr lstmt)
2398
2399 check_other -- Behave just as if this wasn't the last stmt
2400 = do { checkStmt ctxt lstmt; return lstmt }
2401
2402 -- Checking when a particular Stmt is ok
2403 checkStmt :: HsStmtContext GhcRn
2404 -> LStmt GhcPs (LocatedA (body GhcPs))
2405 -> RnM ()
2406 checkStmt ctxt (L _ stmt)
2407 = do { dflags <- getDynFlags
2408 ; case okStmt dflags ctxt stmt of
2409 IsValid -> return ()
2410 NotValid extra -> addErr $ TcRnUnknownMessage $ mkPlainError noHints (msg $$ extra) }
2411 where
2412 msg = sep [ text "Unexpected" <+> pprStmtCat stmt <+> text "statement"
2413 , text "in" <+> pprAStmtContext ctxt ]
2414
2415 pprStmtCat :: Stmt (GhcPass a) body -> SDoc
2416 pprStmtCat (TransStmt {}) = text "transform"
2417 pprStmtCat (LastStmt {}) = text "return expression"
2418 pprStmtCat (BodyStmt {}) = text "body"
2419 pprStmtCat (BindStmt {}) = text "binding"
2420 pprStmtCat (LetStmt {}) = text "let"
2421 pprStmtCat (RecStmt {}) = text "rec"
2422 pprStmtCat (ParStmt {}) = text "parallel"
2423 pprStmtCat (ApplicativeStmt {}) = panic "pprStmtCat: ApplicativeStmt"
2424
2425 ------------
2426 emptyInvalid :: Validity -- Payload is the empty document
2427 emptyInvalid = NotValid Outputable.empty
2428
2429 okStmt, okDoStmt, okCompStmt, okParStmt
2430 :: DynFlags -> HsStmtContext GhcRn
2431 -> Stmt GhcPs (LocatedA (body GhcPs)) -> Validity
2432 -- Return Nothing if OK, (Just extra) if not ok
2433 -- The "extra" is an SDoc that is appended to a generic error message
2434
2435 okStmt dflags ctxt stmt
2436 = case ctxt of
2437 PatGuard {} -> okPatGuardStmt stmt
2438 ParStmtCtxt ctxt -> okParStmt dflags ctxt stmt
2439 HsDoStmt flavour -> okDoFlavourStmt dflags flavour ctxt stmt
2440 ArrowExpr -> okDoStmt dflags ctxt stmt
2441 TransStmtCtxt ctxt -> okStmt dflags ctxt stmt
2442
2443 okDoFlavourStmt
2444 :: DynFlags -> HsDoFlavour -> HsStmtContext GhcRn
2445 -> Stmt GhcPs (LocatedA (body GhcPs)) -> Validity
2446 okDoFlavourStmt dflags flavour ctxt stmt = case flavour of
2447 DoExpr{} -> okDoStmt dflags ctxt stmt
2448 MDoExpr{} -> okDoStmt dflags ctxt stmt
2449 GhciStmtCtxt -> okDoStmt dflags ctxt stmt
2450 ListComp -> okCompStmt dflags ctxt stmt
2451 MonadComp -> okCompStmt dflags ctxt stmt
2452
2453 -------------
2454 okPatGuardStmt :: Stmt GhcPs (LocatedA (body GhcPs)) -> Validity
2455 okPatGuardStmt stmt
2456 = case stmt of
2457 BodyStmt {} -> IsValid
2458 BindStmt {} -> IsValid
2459 LetStmt {} -> IsValid
2460 _ -> emptyInvalid
2461
2462 -------------
2463 okParStmt dflags ctxt stmt
2464 = case stmt of
2465 LetStmt _ (HsIPBinds {}) -> emptyInvalid
2466 _ -> okStmt dflags ctxt stmt
2467
2468 ----------------
2469 okDoStmt dflags ctxt stmt
2470 = case stmt of
2471 RecStmt {}
2472 | LangExt.RecursiveDo `xopt` dflags -> IsValid
2473 | ArrowExpr <- ctxt -> IsValid -- Arrows allows 'rec'
2474 | otherwise -> NotValid (text "Use RecursiveDo")
2475 BindStmt {} -> IsValid
2476 LetStmt {} -> IsValid
2477 BodyStmt {} -> IsValid
2478 _ -> emptyInvalid
2479
2480 ----------------
2481 okCompStmt dflags _ stmt
2482 = case stmt of
2483 BindStmt {} -> IsValid
2484 LetStmt {} -> IsValid
2485 BodyStmt {} -> IsValid
2486 ParStmt {}
2487 | LangExt.ParallelListComp `xopt` dflags -> IsValid
2488 | otherwise -> NotValid (text "Use ParallelListComp")
2489 TransStmt {}
2490 | LangExt.TransformListComp `xopt` dflags -> IsValid
2491 | otherwise -> NotValid (text "Use TransformListComp")
2492 RecStmt {} -> emptyInvalid
2493 LastStmt {} -> emptyInvalid -- Should not happen (dealt with by checkLastStmt)
2494 ApplicativeStmt {} -> emptyInvalid
2495
2496 ---------
2497 checkTupleSection :: [HsTupArg GhcPs] -> RnM ()
2498 checkTupleSection args
2499 = do { tuple_section <- xoptM LangExt.TupleSections
2500 ; checkErr (all tupArgPresent args || tuple_section) msg }
2501 where
2502 msg :: TcRnMessage
2503 msg = TcRnUnknownMessage $ mkPlainError noHints $
2504 text "Illegal tuple section: use TupleSections"
2505
2506 ---------
2507 sectionErr :: HsExpr GhcPs -> TcRnMessage
2508 sectionErr expr
2509 = TcRnUnknownMessage $ mkPlainError noHints $
2510 hang (text "A section must be enclosed in parentheses")
2511 2 (text "thus:" <+> (parens (ppr expr)))
2512
2513 badIpBinds :: Outputable a => SDoc -> a -> TcRnMessage
2514 badIpBinds what binds
2515 = TcRnUnknownMessage $ mkPlainError noHints $
2516 hang (text "Implicit-parameter bindings illegal in" <+> what)
2517 2 (ppr binds)
2518
2519 ---------
2520
2521 monadFailOp :: LPat GhcPs
2522 -> HsStmtContext GhcRn
2523 -> RnM (FailOperator GhcRn, FreeVars)
2524 monadFailOp pat ctxt = do
2525 dflags <- getDynFlags
2526 -- If the pattern is irrefutable (e.g.: wildcard, tuple, ~pat, etc.)
2527 -- we should not need to fail.
2528 if | isIrrefutableHsPat dflags pat -> return (Nothing, emptyFVs)
2529
2530 -- For non-monadic contexts (e.g. guard patterns, list
2531 -- comprehensions, etc.) we should not need to fail, or failure is handled in
2532 -- a different way. See Note [Failing pattern matches in Stmts].
2533 | not (isMonadStmtContext ctxt) -> return (Nothing, emptyFVs)
2534
2535 | otherwise -> getMonadFailOp ctxt
2536
2537 {-
2538 Note [Monad fail : Rebindable syntax, overloaded strings]
2539 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
2540
2541 Given the code
2542 foo x = do { Just y <- x; return y }
2543
2544 we expect it to desugar as
2545 foo x = x >>= \r -> case r of
2546 Just y -> return y
2547 Nothing -> fail "Pattern match error"
2548
2549 But with RebindableSyntax and OverloadedStrings, we really want
2550 it to desugar thus:
2551 foo x = x >>= \r -> case r of
2552 Just y -> return y
2553 Nothing -> fail (fromString "Patterm match error")
2554
2555 So, in this case, we synthesize the function
2556 \x -> fail (fromString x)
2557
2558 (rather than plain 'fail') for the 'fail' operation. This is done in
2559 'getMonadFailOp'.
2560
2561 Similarly with QualifiedDo and OverloadedStrings, we also want to desugar
2562 using fromString:
2563
2564 foo x = M.do { Just y <- x; return y }
2565
2566 ===>
2567
2568 foo x = x M.>>= \r -> case r of
2569 Just y -> return y
2570 Nothing -> M.fail (fromString "Pattern match error")
2571
2572 -}
2573 getMonadFailOp :: HsStmtContext p -> RnM (FailOperator GhcRn, FreeVars) -- Syntax expr fail op
2574 getMonadFailOp ctxt
2575 = do { xOverloadedStrings <- fmap (xopt LangExt.OverloadedStrings) getDynFlags
2576 ; xRebindableSyntax <- fmap (xopt LangExt.RebindableSyntax) getDynFlags
2577 ; (fail, fvs) <- reallyGetMonadFailOp xRebindableSyntax xOverloadedStrings
2578 ; return (Just fail, fvs)
2579 }
2580 where
2581 isQualifiedDo = isJust (qualifiedDoModuleName_maybe ctxt)
2582
2583 reallyGetMonadFailOp rebindableSyntax overloadedStrings
2584 | (isQualifiedDo || rebindableSyntax) && overloadedStrings = do
2585 (failExpr, failFvs) <- lookupQualifiedDoExpr ctxt failMName
2586 (fromStringExpr, fromStringFvs) <- lookupSyntaxExpr fromStringName
2587 let arg_lit = mkVarOcc "arg"
2588 arg_name <- newSysName arg_lit
2589 let arg_syn_expr = nlHsVar arg_name
2590 body :: LHsExpr GhcRn =
2591 nlHsApp (noLocA failExpr)
2592 (nlHsApp (noLocA $ fromStringExpr) arg_syn_expr)
2593 let failAfterFromStringExpr :: HsExpr GhcRn =
2594 unLoc $ mkHsLam [noLocA $ VarPat noExtField $ noLocA arg_name] body
2595 let failAfterFromStringSynExpr :: SyntaxExpr GhcRn =
2596 mkSyntaxExpr failAfterFromStringExpr
2597 return (failAfterFromStringSynExpr, failFvs `plusFV` fromStringFvs)
2598 | otherwise = lookupQualifiedDo ctxt failMName
2599
2600
2601 {- *********************************************************************
2602 * *
2603 Generating code for HsExpanded
2604 See Note [Handling overloaded and rebindable constructs]
2605 * *
2606 ********************************************************************* -}
2607
2608 -- | Build a 'HsExpansion' out of an extension constructor,
2609 -- and the two components of the expansion: original and
2610 -- desugared expressions.
2611 mkExpandedExpr
2612 :: HsExpr GhcRn -- ^ source expression
2613 -> HsExpr GhcRn -- ^ expanded expression
2614 -> HsExpr GhcRn -- ^ suitably wrapped 'HsExpansion'
2615 mkExpandedExpr a b = XExpr (HsExpanded a b)
2616
2617 -----------------------------------------
2618 -- Bits and pieces for RecordDotSyntax.
2619 --
2620 -- See Note [Overview of record dot syntax] in GHC.Hs.Expr.
2621
2622 -- mkGetField arg field calcuates a get_field @field arg expression.
2623 -- e.g. z.x = mkGetField z x = get_field @x z
2624 mkGetField :: Name -> LHsExpr GhcRn -> LocatedAn NoEpAnns FieldLabelString -> HsExpr GhcRn
2625 mkGetField get_field arg field = unLoc (head $ mkGet get_field [arg] field)
2626
2627 -- mkSetField a field b calculates a set_field @field expression.
2628 -- e.g mkSetSetField a field b = set_field @"field" a b (read as "set field 'field' on a to b").
2629 mkSetField :: Name -> LHsExpr GhcRn -> LocatedAn NoEpAnns FieldLabelString -> LHsExpr GhcRn -> HsExpr GhcRn
2630 mkSetField set_field a (L _ field) b =
2631 genHsApp (genHsApp (genHsVar set_field `genAppType` genHsTyLit field) a) b
2632
2633 mkGet :: Name -> [LHsExpr GhcRn] -> LocatedAn NoEpAnns FieldLabelString -> [LHsExpr GhcRn]
2634 mkGet get_field l@(r : _) (L _ field) =
2635 wrapGenSpan (genHsApp (genHsVar get_field `genAppType` genHsTyLit field) r) : l
2636 mkGet _ [] _ = panic "mkGet : The impossible has happened!"
2637
2638 mkSet :: Name -> LHsExpr GhcRn -> (LocatedAn NoEpAnns FieldLabelString, LHsExpr GhcRn) -> LHsExpr GhcRn
2639 mkSet set_field acc (field, g) = wrapGenSpan (mkSetField set_field g field acc)
2640
2641 -- mkProjection fields calculates a projection.
2642 -- e.g. .x = mkProjection [x] = getField @"x"
2643 -- .x.y = mkProjection [.x, .y] = (.y) . (.x) = getField @"y" . getField @"x"
2644 mkProjection :: Name -> Name -> [LocatedAn NoEpAnns FieldLabelString] -> HsExpr GhcRn
2645 mkProjection getFieldName circName (field : fields) = foldl' f (proj field) fields
2646 where
2647 f :: HsExpr GhcRn -> LocatedAn NoEpAnns FieldLabelString -> HsExpr GhcRn
2648 f acc field = genHsApps circName $ map wrapGenSpan [proj field, acc]
2649
2650 proj :: LocatedAn NoEpAnns FieldLabelString -> HsExpr GhcRn
2651 proj (L _ f) = genHsVar getFieldName `genAppType` genHsTyLit f
2652 mkProjection _ _ [] = panic "mkProjection: The impossible happened"
2653
2654 -- mkProjUpdateSetField calculates functions representing dot notation record updates.
2655 -- e.g. Suppose an update like foo.bar = 1.
2656 -- We calculate the function \a -> setField @"foo" a (setField @"bar" (getField @"foo" a) 1).
2657 mkProjUpdateSetField :: Name -> Name -> LHsRecProj GhcRn (LHsExpr GhcRn) -> (LHsExpr GhcRn -> LHsExpr GhcRn)
2658 mkProjUpdateSetField get_field set_field (L _ (HsFieldBind { hfbLHS = (L _ (FieldLabelStrings flds')), hfbRHS = arg } ))
2659 = let {
2660 ; flds = map (fmap (unLoc . dfoLabel)) flds'
2661 ; final = last flds -- quux
2662 ; fields = init flds -- [foo, bar, baz]
2663 ; getters = \a -> foldl' (mkGet get_field) [a] fields -- Ordered from deep to shallow.
2664 -- [getField@"baz"(getField@"bar"(getField@"foo" a), getField@"bar"(getField@"foo" a), getField@"foo" a, a]
2665 ; zips = \a -> (final, head (getters a)) : zip (reverse fields) (tail (getters a)) -- Ordered from deep to shallow.
2666 -- [("quux", getField@"baz"(getField@"bar"(getField@"foo" a)), ("baz", getField@"bar"(getField@"foo" a)), ("bar", getField@"foo" a), ("foo", a)]
2667 }
2668 in (\a -> foldl' (mkSet set_field) arg (zips a))
2669 -- setField@"foo" (a) (setField@"bar" (getField @"foo" (a))(setField@"baz" (getField @"bar" (getField @"foo" (a)))(setField@"quux" (getField @"baz" (getField @"bar" (getField @"foo" (a))))(quux))))
2670
2671 mkRecordDotUpd :: Name -> Name -> LHsExpr GhcRn -> [LHsRecUpdProj GhcRn] -> HsExpr GhcRn
2672 mkRecordDotUpd get_field set_field exp updates = foldl' fieldUpdate (unLoc exp) updates
2673 where
2674 fieldUpdate :: HsExpr GhcRn -> LHsRecUpdProj GhcRn -> HsExpr GhcRn
2675 fieldUpdate acc lpu = unLoc $ (mkProjUpdateSetField get_field set_field lpu) (wrapGenSpan acc)
2676
2677 rnHsUpdProjs :: [LHsRecUpdProj GhcPs] -> RnM ([LHsRecUpdProj GhcRn], FreeVars)
2678 rnHsUpdProjs us = do
2679 (u, fvs) <- unzip <$> mapM rnRecUpdProj us
2680 pure (u, plusFVs fvs)
2681 where
2682 rnRecUpdProj :: LHsRecUpdProj GhcPs -> RnM (LHsRecUpdProj GhcRn, FreeVars)
2683 rnRecUpdProj (L l (HsFieldBind _ fs arg pun))
2684 = do { (arg, fv) <- rnLExpr arg
2685 ; return $
2686 (L l (HsFieldBind {
2687 hfbAnn = noAnn
2688 , hfbLHS = fmap rnFieldLabelStrings fs
2689 , hfbRHS = arg
2690 , hfbPun = pun}), fv ) }