never executed always true always false
1 {-# LANGUAGE ConstraintKinds #-}
2 {-|
3 Module : GHC.Hs.Utils
4 Description : Generic helpers for the HsSyn type.
5 Copyright : (c) The University of Glasgow, 1992-2006
6
7 Here we collect a variety of helper functions that construct or
8 analyse HsSyn. All these functions deal with generic HsSyn; functions
9 which deal with the instantiated versions are located elsewhere:
10
11 Parameterised by Module
12 ---------------- -------------
13 GhcPs/RdrName GHC.Parser.PostProcess
14 GhcRn/Name GHC.Rename.*
15 GhcTc/Id GHC.Tc.Utils.Zonk
16
17 The @mk*@ functions attempt to construct a not-completely-useless SrcSpan
18 from their components, compared with the @nl*@ functions which
19 just attach noSrcSpan to everything.
20
21 -}
22
23
24 {-# LANGUAGE ScopedTypeVariables #-}
25 {-# LANGUAGE FlexibleContexts #-}
26 {-# LANGUAGE TypeFamilies #-}
27 {-# LANGUAGE PatternSynonyms #-}
28 {-# LANGUAGE ViewPatterns #-}
29 {-# LANGUAGE TypeApplications #-}
30 {-# LANGUAGE DataKinds #-}
31 {-# LANGUAGE FlexibleInstances #-}
32 {-# LANGUAGE LambdaCase #-}
33 {-# LANGUAGE GADTs #-}
34
35 {-# OPTIONS_GHC -Wno-incomplete-record-updates #-}
36
37 module GHC.Hs.Utils(
38 -- * Terms
39 mkHsPar, mkHsApp, mkHsAppWith, mkHsApps, mkHsAppsWith,
40 mkHsAppType, mkHsAppTypes, mkHsCaseAlt,
41 mkSimpleMatch, unguardedGRHSs, unguardedRHS,
42 mkMatchGroup, mkMatch, mkPrefixFunRhs, mkHsLam, mkHsIf,
43 mkHsWrap, mkLHsWrap, mkHsWrapCo, mkHsWrapCoR, mkLHsWrapCo,
44 mkHsDictLet, mkHsLams,
45 mkHsOpApp, mkHsDo, mkHsDoAnns, mkHsComp, mkHsCompAnns, mkHsWrapPat, mkHsWrapPatCo,
46 mkLHsPar, mkHsCmdWrap, mkLHsCmdWrap,
47 mkHsCmdIf, mkConLikeTc,
48
49 nlHsTyApp, nlHsTyApps, nlHsVar, nl_HsVar, nlHsDataCon,
50 nlHsLit, nlHsApp, nlHsApps, nlHsSyntaxApps,
51 nlHsIntLit, nlHsVarApps,
52 nlHsDo, nlHsOpApp, nlHsLam, nlHsPar, nlHsIf, nlHsCase, nlList,
53 mkLHsTupleExpr, mkLHsVarTuple, missingTupArg,
54 mkLocatedList,
55
56 -- * Constructing general big tuples
57 -- $big_tuples
58 mkChunkified, chunkify,
59
60 -- * Bindings
61 mkFunBind, mkVarBind, mkHsVarBind, mkSimpleGeneratedFunBind, mkTopFunBind,
62 mkPatSynBind,
63 isInfixFunBind,
64 spanHsLocaLBinds,
65
66 -- * Literals
67 mkHsIntegral, mkHsFractional, mkHsIsString, mkHsString, mkHsStringPrimLit,
68 mkHsCharPrimLit,
69
70 -- * Patterns
71 mkNPat, mkNPlusKPat, nlVarPat, nlLitPat, nlConVarPat, nlConVarPatName, nlConPat,
72 nlConPatName, nlInfixConPat, nlNullaryConPat, nlWildConPat, nlWildPat,
73 nlWildPatName, nlTuplePat, mkParPat, nlParPat,
74 mkBigLHsVarTup, mkBigLHsTup, mkBigLHsVarPatTup, mkBigLHsPatTup,
75
76 -- * Types
77 mkHsAppTy, mkHsAppKindTy,
78 hsTypeToHsSigType, hsTypeToHsSigWcType, mkClassOpSigs, mkHsSigEnv,
79 nlHsAppTy, nlHsAppKindTy, nlHsTyVar, nlHsFunTy, nlHsParTy, nlHsTyConApp,
80
81 -- * Stmts
82 mkTransformStmt, mkTransformByStmt, mkBodyStmt,
83 mkPsBindStmt, mkRnBindStmt, mkTcBindStmt,
84 mkLastStmt,
85 emptyTransStmt, mkGroupUsingStmt, mkGroupByUsingStmt,
86 emptyRecStmt, emptyRecStmtName, emptyRecStmtId, mkRecStmt,
87 unitRecStmtTc,
88 mkLetStmt,
89
90 -- * Template Haskell
91 mkUntypedSplice, mkTypedSplice,
92 mkHsQuasiQuote,
93
94 -- * Collecting binders
95 isUnliftedHsBind, isBangedHsBind,
96
97 collectLocalBinders, collectHsValBinders, collectHsBindListBinders,
98 collectHsIdBinders,
99 collectHsBindsBinders, collectHsBindBinders, collectMethodBinders,
100
101 collectPatBinders, collectPatsBinders,
102 collectLStmtsBinders, collectStmtsBinders,
103 collectLStmtBinders, collectStmtBinders,
104 CollectPass(..), CollectFlag(..),
105
106 hsLTyClDeclBinders, hsTyClForeignBinders,
107 hsPatSynSelectors, getPatSynBinds,
108 hsForeignDeclsBinders, hsGroupBinders, hsDataFamInstBinders,
109
110 -- * Collecting implicit binders
111 lStmtsImplicits, hsValBindsImplicits, lPatImplicits
112 ) where
113
114 import GHC.Prelude
115
116 import GHC.Hs.Decls
117 import GHC.Hs.Binds
118 import GHC.Hs.Expr
119 import GHC.Hs.Pat
120 import GHC.Hs.Type
121 import GHC.Hs.Lit
122 import Language.Haskell.Syntax.Extension
123 import GHC.Hs.Extension
124 import GHC.Parser.Annotation
125
126 import GHC.Tc.Types.Evidence
127 import GHC.Core.TyCo.Rep
128 import GHC.Core.Multiplicity ( pattern Many )
129 import GHC.Builtin.Types ( unitTy )
130 import GHC.Tc.Utils.TcType
131 import GHC.Core.DataCon
132 import GHC.Core.ConLike
133 import GHC.Types.Id
134 import GHC.Types.Name
135 import GHC.Types.Name.Set hiding ( unitFV )
136 import GHC.Types.Name.Env
137 import GHC.Types.Name.Reader
138 import GHC.Types.Var
139 import GHC.Types.Basic
140 import GHC.Types.SrcLoc
141 import GHC.Types.Fixity
142 import GHC.Types.SourceText
143 import GHC.Data.FastString
144 import GHC.Data.Bag
145 import GHC.Settings.Constants
146
147 import GHC.Utils.Misc
148 import GHC.Utils.Outputable
149 import GHC.Utils.Panic
150
151 import Data.Either
152 import Data.Function
153 import Data.List ( partition, deleteBy )
154 import Data.Proxy
155
156 {-
157 ************************************************************************
158 * *
159 Some useful helpers for constructing syntax
160 * *
161 ************************************************************************
162
163 These functions attempt to construct a not-completely-useless 'SrcSpan'
164 from their components, compared with the @nl*@ functions below which
165 just attach 'noSrcSpan' to everything.
166 -}
167
168 -- | @e => (e)@
169 mkHsPar :: LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
170 mkHsPar e = L (getLoc e) (gHsPar e)
171
172 mkSimpleMatch :: (Anno (Match (GhcPass p) (LocatedA (body (GhcPass p))))
173 ~ SrcSpanAnnA,
174 Anno (GRHS (GhcPass p) (LocatedA (body (GhcPass p))))
175 ~ SrcAnn NoEpAnns)
176 => HsMatchContext (GhcPass p)
177 -> [LPat (GhcPass p)] -> LocatedA (body (GhcPass p))
178 -> LMatch (GhcPass p) (LocatedA (body (GhcPass p)))
179 mkSimpleMatch ctxt pats rhs
180 = L loc $
181 Match { m_ext = noAnn, m_ctxt = ctxt, m_pats = pats
182 , m_grhss = unguardedGRHSs (locA loc) rhs noAnn }
183 where
184 loc = case pats of
185 [] -> getLoc rhs
186 (pat:_) -> combineSrcSpansA (getLoc pat) (getLoc rhs)
187
188 unguardedGRHSs :: Anno (GRHS (GhcPass p) (LocatedA (body (GhcPass p))))
189 ~ SrcAnn NoEpAnns
190 => SrcSpan -> LocatedA (body (GhcPass p)) -> EpAnn GrhsAnn
191 -> GRHSs (GhcPass p) (LocatedA (body (GhcPass p)))
192 unguardedGRHSs loc rhs an
193 = GRHSs emptyComments (unguardedRHS an loc rhs) emptyLocalBinds
194
195 unguardedRHS :: Anno (GRHS (GhcPass p) (LocatedA (body (GhcPass p))))
196 ~ SrcAnn NoEpAnns
197 => EpAnn GrhsAnn -> SrcSpan -> LocatedA (body (GhcPass p))
198 -> [LGRHS (GhcPass p) (LocatedA (body (GhcPass p)))]
199 unguardedRHS an loc rhs = [L (noAnnSrcSpan loc) (GRHS an [] rhs)]
200
201 type AnnoBody p body
202 = ( XMG (GhcPass p) (LocatedA (body (GhcPass p))) ~ NoExtField
203 , Anno [LocatedA (Match (GhcPass p) (LocatedA (body (GhcPass p))))] ~ SrcSpanAnnL
204 , Anno (Match (GhcPass p) (LocatedA (body (GhcPass p)))) ~ SrcSpanAnnA
205 )
206
207 mkMatchGroup :: AnnoBody p body
208 => Origin
209 -> LocatedL [LocatedA (Match (GhcPass p) (LocatedA (body (GhcPass p))))]
210 -> MatchGroup (GhcPass p) (LocatedA (body (GhcPass p)))
211 mkMatchGroup origin matches = MG { mg_ext = noExtField
212 , mg_alts = matches
213 , mg_origin = origin }
214
215 mkLocatedList :: Semigroup a
216 => [GenLocated (SrcAnn a) e2] -> LocatedAn an [GenLocated (SrcAnn a) e2]
217 mkLocatedList [] = noLocA []
218 mkLocatedList ms = L (noAnnSrcSpan $ locA $ combineLocsA (head ms) (last ms)) ms
219
220 mkHsApp :: LHsExpr (GhcPass id) -> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
221 mkHsApp e1 e2 = addCLocAA e1 e2 (HsApp noComments e1 e2)
222
223 mkHsAppWith
224 :: (LHsExpr (GhcPass id) -> LHsExpr (GhcPass id) -> HsExpr (GhcPass id) -> LHsExpr (GhcPass id))
225 -> LHsExpr (GhcPass id)
226 -> LHsExpr (GhcPass id)
227 -> LHsExpr (GhcPass id)
228 mkHsAppWith mkLocated e1 e2 = mkLocated e1 e2 (HsApp noAnn e1 e2)
229
230 mkHsApps
231 :: LHsExpr (GhcPass id) -> [LHsExpr (GhcPass id)] -> LHsExpr (GhcPass id)
232 mkHsApps = mkHsAppsWith addCLocAA
233
234 mkHsAppsWith
235 :: (LHsExpr (GhcPass id) -> LHsExpr (GhcPass id) -> HsExpr (GhcPass id) -> LHsExpr (GhcPass id))
236 -> LHsExpr (GhcPass id)
237 -> [LHsExpr (GhcPass id)]
238 -> LHsExpr (GhcPass id)
239 mkHsAppsWith mkLocated = foldl' (mkHsAppWith mkLocated)
240
241 mkHsAppType :: LHsExpr GhcRn -> LHsWcType GhcRn -> LHsExpr GhcRn
242 mkHsAppType e t = addCLocAA t_body e (HsAppType noExtField e paren_wct)
243 where
244 t_body = hswc_body t
245 paren_wct = t { hswc_body = parenthesizeHsType appPrec t_body }
246
247 mkHsAppTypes :: LHsExpr GhcRn -> [LHsWcType GhcRn] -> LHsExpr GhcRn
248 mkHsAppTypes = foldl' mkHsAppType
249
250 mkHsLam :: (IsPass p, XMG (GhcPass p) (LHsExpr (GhcPass p)) ~ NoExtField)
251 => [LPat (GhcPass p)]
252 -> LHsExpr (GhcPass p)
253 -> LHsExpr (GhcPass p)
254 mkHsLam pats body = mkHsPar (L (getLoc body) (HsLam noExtField matches))
255 where
256 matches = mkMatchGroup Generated
257 (noLocA [mkSimpleMatch LambdaExpr pats' body])
258 pats' = map (parenthesizePat appPrec) pats
259
260 mkHsLams :: [TyVar] -> [EvVar] -> LHsExpr GhcTc -> LHsExpr GhcTc
261 mkHsLams tyvars dicts expr = mkLHsWrap (mkWpTyLams tyvars
262 <.> mkWpLams dicts) expr
263
264 -- |A simple case alternative with a single pattern, no binds, no guards;
265 -- pre-typechecking
266 mkHsCaseAlt :: (Anno (GRHS (GhcPass p) (LocatedA (body (GhcPass p))))
267 ~ SrcAnn NoEpAnns,
268 Anno (Match (GhcPass p) (LocatedA (body (GhcPass p))))
269 ~ SrcSpanAnnA)
270 => LPat (GhcPass p) -> (LocatedA (body (GhcPass p)))
271 -> LMatch (GhcPass p) (LocatedA (body (GhcPass p)))
272 mkHsCaseAlt pat expr
273 = mkSimpleMatch CaseAlt [pat] expr
274
275 nlHsTyApp :: Id -> [Type] -> LHsExpr GhcTc
276 nlHsTyApp fun_id tys
277 = noLocA (mkHsWrap (mkWpTyApps tys) (HsVar noExtField (noLocA fun_id)))
278
279 nlHsTyApps :: Id -> [Type] -> [LHsExpr GhcTc] -> LHsExpr GhcTc
280 nlHsTyApps fun_id tys xs = foldl' nlHsApp (nlHsTyApp fun_id tys) xs
281
282 --------- Adding parens ---------
283 -- | Wrap in parens if @'hsExprNeedsParens' appPrec@ says it needs them
284 -- So @f x@ becomes @(f x)@, but @3@ stays as @3@.
285 mkLHsPar :: IsPass id => LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
286 mkLHsPar = parenthesizeHsExpr appPrec
287
288 mkParPat :: IsPass p => LPat (GhcPass p) -> LPat (GhcPass p)
289 mkParPat = parenthesizePat appPrec
290
291 nlParPat :: LPat (GhcPass name) -> LPat (GhcPass name)
292 nlParPat p = noLocA (gParPat p)
293
294 -------------------------------
295 -- These are the bits of syntax that contain rebindable names
296 -- See GHC.Rename.Env.lookupSyntax
297
298 mkHsIntegral :: IntegralLit -> HsOverLit GhcPs
299 mkHsFractional :: FractionalLit -> HsOverLit GhcPs
300 mkHsIsString :: SourceText -> FastString -> HsOverLit GhcPs
301 mkHsDo :: HsDoFlavour -> LocatedL [ExprLStmt GhcPs] -> HsExpr GhcPs
302 mkHsDoAnns :: HsDoFlavour -> LocatedL [ExprLStmt GhcPs] -> EpAnn AnnList -> HsExpr GhcPs
303 mkHsComp :: HsDoFlavour -> [ExprLStmt GhcPs] -> LHsExpr GhcPs
304 -> HsExpr GhcPs
305 mkHsCompAnns :: HsDoFlavour -> [ExprLStmt GhcPs] -> LHsExpr GhcPs
306 -> EpAnn AnnList
307 -> HsExpr GhcPs
308
309 mkNPat :: LocatedAn NoEpAnns (HsOverLit GhcPs) -> Maybe (SyntaxExpr GhcPs) -> EpAnn [AddEpAnn]
310 -> Pat GhcPs
311 mkNPlusKPat :: LocatedN RdrName -> LocatedAn NoEpAnns (HsOverLit GhcPs) -> EpAnn EpaLocation
312 -> Pat GhcPs
313
314 -- NB: The following functions all use noSyntaxExpr: the generated expressions
315 -- will not work with rebindable syntax if used after the renamer
316 mkLastStmt :: IsPass idR => LocatedA (bodyR (GhcPass idR))
317 -> StmtLR (GhcPass idL) (GhcPass idR) (LocatedA (bodyR (GhcPass idR)))
318 mkBodyStmt :: LocatedA (bodyR GhcPs)
319 -> StmtLR (GhcPass idL) GhcPs (LocatedA (bodyR GhcPs))
320 mkPsBindStmt :: EpAnn [AddEpAnn] -> LPat GhcPs -> LocatedA (bodyR GhcPs)
321 -> StmtLR GhcPs GhcPs (LocatedA (bodyR GhcPs))
322 mkRnBindStmt :: LPat GhcRn -> LocatedA (bodyR GhcRn)
323 -> StmtLR GhcRn GhcRn (LocatedA (bodyR GhcRn))
324 mkTcBindStmt :: LPat GhcTc -> LocatedA (bodyR GhcTc)
325 -> StmtLR GhcTc GhcTc (LocatedA (bodyR GhcTc))
326
327 emptyRecStmt :: (Anno [GenLocated
328 (Anno (StmtLR (GhcPass idL) GhcPs bodyR))
329 (StmtLR (GhcPass idL) GhcPs bodyR)]
330 ~ SrcSpanAnnL)
331 => StmtLR (GhcPass idL) GhcPs bodyR
332 emptyRecStmtName :: (Anno [GenLocated
333 (Anno (StmtLR GhcRn GhcRn bodyR))
334 (StmtLR GhcRn GhcRn bodyR)]
335 ~ SrcSpanAnnL)
336 => StmtLR GhcRn GhcRn bodyR
337 emptyRecStmtId :: Stmt GhcTc (LocatedA (HsCmd GhcTc))
338 mkRecStmt :: (Anno [GenLocated
339 (Anno (StmtLR (GhcPass idL) GhcPs bodyR))
340 (StmtLR (GhcPass idL) GhcPs bodyR)]
341 ~ SrcSpanAnnL)
342 => EpAnn AnnList
343 -> LocatedL [LStmtLR (GhcPass idL) GhcPs bodyR]
344 -> StmtLR (GhcPass idL) GhcPs bodyR
345
346
347 mkHsIntegral i = OverLit noExtField (HsIntegral i)
348 mkHsFractional f = OverLit noExtField (HsFractional f)
349 mkHsIsString src s = OverLit noExtField (HsIsString src s)
350
351 mkHsDo ctxt stmts = HsDo noAnn ctxt stmts
352 mkHsDoAnns ctxt stmts anns = HsDo anns ctxt stmts
353 mkHsComp ctxt stmts expr = mkHsCompAnns ctxt stmts expr noAnn
354 mkHsCompAnns ctxt stmts expr anns = mkHsDoAnns ctxt (mkLocatedList (stmts ++ [last_stmt])) anns
355 where
356 -- Strip the annotations from the location, they are in the embedded expr
357 last_stmt = L (noAnnSrcSpan $ getLocA expr) $ mkLastStmt expr
358
359 -- restricted to GhcPs because other phases might need a SyntaxExpr
360 mkHsIf :: LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs -> EpAnn AnnsIf
361 -> HsExpr GhcPs
362 mkHsIf c a b anns = HsIf anns c a b
363
364 -- restricted to GhcPs because other phases might need a SyntaxExpr
365 mkHsCmdIf :: LHsExpr GhcPs -> LHsCmd GhcPs -> LHsCmd GhcPs -> EpAnn AnnsIf
366 -> HsCmd GhcPs
367 mkHsCmdIf c a b anns = HsCmdIf anns noSyntaxExpr c a b
368
369 mkNPat lit neg anns = NPat anns lit neg noSyntaxExpr
370 mkNPlusKPat id lit anns
371 = NPlusKPat anns id lit (unLoc lit) noSyntaxExpr noSyntaxExpr
372
373 mkTransformStmt :: EpAnn [AddEpAnn] -> [ExprLStmt GhcPs] -> LHsExpr GhcPs
374 -> StmtLR GhcPs GhcPs (LHsExpr GhcPs)
375 mkTransformByStmt :: EpAnn [AddEpAnn] -> [ExprLStmt GhcPs] -> LHsExpr GhcPs
376 -> LHsExpr GhcPs -> StmtLR GhcPs GhcPs (LHsExpr GhcPs)
377 mkGroupUsingStmt :: EpAnn [AddEpAnn] -> [ExprLStmt GhcPs] -> LHsExpr GhcPs
378 -> StmtLR GhcPs GhcPs (LHsExpr GhcPs)
379 mkGroupByUsingStmt :: EpAnn [AddEpAnn] -> [ExprLStmt GhcPs] -> LHsExpr GhcPs
380 -> LHsExpr GhcPs
381 -> StmtLR GhcPs GhcPs (LHsExpr GhcPs)
382
383 emptyTransStmt :: EpAnn [AddEpAnn] -> StmtLR GhcPs GhcPs (LHsExpr GhcPs)
384 emptyTransStmt anns = TransStmt { trS_ext = anns
385 , trS_form = panic "emptyTransStmt: form"
386 , trS_stmts = [], trS_bndrs = []
387 , trS_by = Nothing, trS_using = noLocA noExpr
388 , trS_ret = noSyntaxExpr, trS_bind = noSyntaxExpr
389 , trS_fmap = noExpr }
390 mkTransformStmt a ss u = (emptyTransStmt a) { trS_form = ThenForm, trS_stmts = ss, trS_using = u }
391 mkTransformByStmt a ss u b = (emptyTransStmt a) { trS_form = ThenForm, trS_stmts = ss, trS_using = u, trS_by = Just b }
392 mkGroupUsingStmt a ss u = (emptyTransStmt a) { trS_form = GroupForm, trS_stmts = ss, trS_using = u }
393 mkGroupByUsingStmt a ss b u = (emptyTransStmt a) { trS_form = GroupForm, trS_stmts = ss, trS_using = u, trS_by = Just b }
394
395 mkLastStmt body = LastStmt noExtField body Nothing noSyntaxExpr
396 mkBodyStmt body
397 = BodyStmt noExtField body noSyntaxExpr noSyntaxExpr
398 mkPsBindStmt ann pat body = BindStmt ann pat body
399 mkRnBindStmt pat body = BindStmt (XBindStmtRn { xbsrn_bindOp = noSyntaxExpr, xbsrn_failOp = Nothing }) pat body
400 mkTcBindStmt pat body = BindStmt (XBindStmtTc { xbstc_bindOp = noSyntaxExpr,
401 xbstc_boundResultType = unitTy,
402 -- unitTy is a dummy value
403 -- can't panic here: it's forced during zonking
404 xbstc_boundResultMult = Many,
405 xbstc_failOp = Nothing }) pat body
406
407 emptyRecStmt' :: forall idL idR body .
408 (WrapXRec (GhcPass idR) [LStmtLR (GhcPass idL) (GhcPass idR) body], IsPass idR)
409 => XRecStmt (GhcPass idL) (GhcPass idR) body
410 -> StmtLR (GhcPass idL) (GhcPass idR) body
411 emptyRecStmt' tyVal =
412 RecStmt
413 { recS_stmts = wrapXRec @(GhcPass idR) []
414 , recS_later_ids = []
415 , recS_rec_ids = []
416 , recS_ret_fn = noSyntaxExpr
417 , recS_mfix_fn = noSyntaxExpr
418 , recS_bind_fn = noSyntaxExpr
419 , recS_ext = tyVal }
420
421 unitRecStmtTc :: RecStmtTc
422 unitRecStmtTc = RecStmtTc { recS_bind_ty = unitTy
423 , recS_later_rets = []
424 , recS_rec_rets = []
425 , recS_ret_ty = unitTy }
426
427 emptyRecStmt = emptyRecStmt' noAnn
428 emptyRecStmtName = emptyRecStmt' noExtField
429 emptyRecStmtId = emptyRecStmt' unitRecStmtTc
430 -- a panic might trigger during zonking
431 mkRecStmt anns stmts = (emptyRecStmt' anns) { recS_stmts = stmts }
432
433 mkLetStmt :: EpAnn [AddEpAnn] -> HsLocalBinds GhcPs -> StmtLR GhcPs GhcPs (LocatedA b)
434 mkLetStmt anns binds = LetStmt anns binds
435
436 -------------------------------
437 -- | A useful function for building @OpApps@. The operator is always a
438 -- variable, and we don't know the fixity yet.
439 mkHsOpApp :: LHsExpr GhcPs -> IdP GhcPs -> LHsExpr GhcPs -> HsExpr GhcPs
440 mkHsOpApp e1 op e2 = OpApp noAnn e1 (noLocA (HsVar noExtField (noLocA op))) e2
441
442 unqualSplice :: RdrName
443 unqualSplice = mkRdrUnqual (mkVarOccFS (fsLit "splice"))
444
445 mkUntypedSplice :: EpAnn [AddEpAnn] -> SpliceDecoration -> LHsExpr GhcPs -> HsSplice GhcPs
446 mkUntypedSplice ann hasParen e = HsUntypedSplice ann hasParen unqualSplice e
447
448 mkTypedSplice :: EpAnn [AddEpAnn] -> SpliceDecoration -> LHsExpr GhcPs -> HsSplice GhcPs
449 mkTypedSplice ann hasParen e = HsTypedSplice ann hasParen unqualSplice e
450
451 mkHsQuasiQuote :: RdrName -> SrcSpan -> FastString -> HsSplice GhcPs
452 mkHsQuasiQuote quoter span quote
453 = HsQuasiQuote noExtField unqualSplice quoter span quote
454
455 mkHsString :: String -> HsLit (GhcPass p)
456 mkHsString s = HsString NoSourceText (mkFastString s)
457
458 mkHsStringPrimLit :: FastString -> HsLit (GhcPass p)
459 mkHsStringPrimLit fs = HsStringPrim NoSourceText (bytesFS fs)
460
461 mkHsCharPrimLit :: Char -> HsLit (GhcPass p)
462 mkHsCharPrimLit c = HsChar NoSourceText c
463
464 mkConLikeTc :: ConLike -> HsExpr GhcTc
465 mkConLikeTc con = XExpr (ConLikeTc con [] [])
466
467 {-
468 ************************************************************************
469 * *
470 Constructing syntax with no location info
471 * *
472 ************************************************************************
473 -}
474
475 nlHsVar :: IsSrcSpanAnn p a
476 => IdP (GhcPass p) -> LHsExpr (GhcPass p)
477 nlHsVar n = noLocA (HsVar noExtField (noLocA n))
478
479 nl_HsVar :: IsSrcSpanAnn p a
480 => IdP (GhcPass p) -> HsExpr (GhcPass p)
481 nl_HsVar n = HsVar noExtField (noLocA n)
482
483 -- | NB: Only for 'LHsExpr' 'Id'.
484 nlHsDataCon :: DataCon -> LHsExpr GhcTc
485 nlHsDataCon con = noLocA (mkConLikeTc (RealDataCon con))
486
487 nlHsLit :: HsLit (GhcPass p) -> LHsExpr (GhcPass p)
488 nlHsLit n = noLocA (HsLit noComments n)
489
490 nlHsIntLit :: Integer -> LHsExpr (GhcPass p)
491 nlHsIntLit n = noLocA (HsLit noComments (HsInt noExtField (mkIntegralLit n)))
492
493 nlVarPat :: IsSrcSpanAnn p a
494 => IdP (GhcPass p) -> LPat (GhcPass p)
495 nlVarPat n = noLocA (VarPat noExtField (noLocA n))
496
497 nlLitPat :: HsLit GhcPs -> LPat GhcPs
498 nlLitPat l = noLocA (LitPat noExtField l)
499
500 nlHsApp :: IsPass id => LHsExpr (GhcPass id) -> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
501 nlHsApp f x = noLocA (HsApp noComments f (mkLHsPar x))
502
503 nlHsSyntaxApps :: SyntaxExprTc -> [LHsExpr GhcTc]
504 -> LHsExpr GhcTc
505 nlHsSyntaxApps (SyntaxExprTc { syn_expr = fun
506 , syn_arg_wraps = arg_wraps
507 , syn_res_wrap = res_wrap }) args
508 = mkLHsWrap res_wrap (foldl' nlHsApp (noLocA fun) (zipWithEqual "nlHsSyntaxApps"
509 mkLHsWrap arg_wraps args))
510 nlHsSyntaxApps NoSyntaxExprTc args = pprPanic "nlHsSyntaxApps" (ppr args)
511 -- this function should never be called in scenarios where there is no
512 -- syntax expr
513
514 nlHsApps :: IsSrcSpanAnn p a
515 => IdP (GhcPass p) -> [LHsExpr (GhcPass p)] -> LHsExpr (GhcPass p)
516 nlHsApps f xs = foldl' nlHsApp (nlHsVar f) xs
517
518 nlHsVarApps :: IsSrcSpanAnn p a
519 => IdP (GhcPass p) -> [IdP (GhcPass p)] -> LHsExpr (GhcPass p)
520 nlHsVarApps f xs = noLocA (foldl' mk (HsVar noExtField (noLocA f))
521 (map ((HsVar noExtField) . noLocA) xs))
522 where
523 mk f a = HsApp noComments (noLocA f) (noLocA a)
524
525 nlConVarPat :: RdrName -> [RdrName] -> LPat GhcPs
526 nlConVarPat con vars = nlConPat con (map nlVarPat vars)
527
528 nlConVarPatName :: Name -> [Name] -> LPat GhcRn
529 nlConVarPatName con vars = nlConPatName con (map nlVarPat vars)
530
531 nlInfixConPat :: RdrName -> LPat GhcPs -> LPat GhcPs -> LPat GhcPs
532 nlInfixConPat con l r = noLocA $ ConPat
533 { pat_con = noLocA con
534 , pat_args = InfixCon (parenthesizePat opPrec l)
535 (parenthesizePat opPrec r)
536 , pat_con_ext = noAnn
537 }
538
539 nlConPat :: RdrName -> [LPat GhcPs] -> LPat GhcPs
540 nlConPat con pats = noLocA $ ConPat
541 { pat_con_ext = noAnn
542 , pat_con = noLocA con
543 , pat_args = PrefixCon [] (map (parenthesizePat appPrec) pats)
544 }
545
546 nlConPatName :: Name -> [LPat GhcRn] -> LPat GhcRn
547 nlConPatName con pats = noLocA $ ConPat
548 { pat_con_ext = noExtField
549 , pat_con = noLocA con
550 , pat_args = PrefixCon [] (map (parenthesizePat appPrec) pats)
551 }
552
553 nlNullaryConPat :: RdrName -> LPat GhcPs
554 nlNullaryConPat con = noLocA $ ConPat
555 { pat_con_ext = noAnn
556 , pat_con = noLocA con
557 , pat_args = PrefixCon [] []
558 }
559
560 nlWildConPat :: DataCon -> LPat GhcPs
561 nlWildConPat con = noLocA $ ConPat
562 { pat_con_ext = noAnn
563 , pat_con = noLocA $ getRdrName con
564 , pat_args = PrefixCon [] $
565 replicate (dataConSourceArity con)
566 nlWildPat
567 }
568
569 -- | Wildcard pattern - after parsing
570 nlWildPat :: LPat GhcPs
571 nlWildPat = noLocA (WildPat noExtField )
572
573 -- | Wildcard pattern - after renaming
574 nlWildPatName :: LPat GhcRn
575 nlWildPatName = noLocA (WildPat noExtField )
576
577 nlHsDo :: HsDoFlavour -> [LStmt GhcPs (LHsExpr GhcPs)]
578 -> LHsExpr GhcPs
579 nlHsDo ctxt stmts = noLocA (mkHsDo ctxt (noLocA stmts))
580
581 nlHsOpApp :: LHsExpr GhcPs -> IdP GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
582 nlHsOpApp e1 op e2 = noLocA (mkHsOpApp e1 op e2)
583
584 nlHsLam :: LMatch GhcPs (LHsExpr GhcPs) -> LHsExpr GhcPs
585 nlHsPar :: LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
586 nlHsCase :: LHsExpr GhcPs -> [LMatch GhcPs (LHsExpr GhcPs)]
587 -> LHsExpr GhcPs
588 nlList :: [LHsExpr GhcPs] -> LHsExpr GhcPs
589
590 -- AZ:Is this used?
591 nlHsLam match = noLocA (HsLam noExtField (mkMatchGroup Generated (noLocA [match])))
592 nlHsPar e = noLocA (gHsPar e)
593
594 -- nlHsIf should generate if-expressions which are NOT subject to
595 -- RebindableSyntax, so the first field of HsIf is False. (#12080)
596 nlHsIf :: LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
597 nlHsIf cond true false = noLocA (HsIf noAnn cond true false)
598
599 nlHsCase expr matches
600 = noLocA (HsCase noAnn expr (mkMatchGroup Generated (noLocA matches)))
601 nlList exprs = noLocA (ExplicitList noAnn exprs)
602
603 nlHsAppTy :: LHsType (GhcPass p) -> LHsType (GhcPass p) -> LHsType (GhcPass p)
604 nlHsTyVar :: IsSrcSpanAnn p a
605 => IdP (GhcPass p) -> LHsType (GhcPass p)
606 nlHsFunTy :: LHsType (GhcPass p) -> LHsType (GhcPass p) -> LHsType (GhcPass p)
607 nlHsParTy :: LHsType (GhcPass p) -> LHsType (GhcPass p)
608
609 nlHsAppTy f t = noLocA (HsAppTy noExtField f (parenthesizeHsType appPrec t))
610 nlHsTyVar x = noLocA (HsTyVar noAnn NotPromoted (noLocA x))
611 nlHsFunTy a b = noLocA (HsFunTy noAnn (HsUnrestrictedArrow noHsUniTok) (parenthesizeHsType funPrec a) b)
612 nlHsParTy t = noLocA (HsParTy noAnn t)
613
614 nlHsTyConApp :: IsSrcSpanAnn p a
615 => LexicalFixity -> IdP (GhcPass p)
616 -> [LHsTypeArg (GhcPass p)] -> LHsType (GhcPass p)
617 nlHsTyConApp fixity tycon tys
618 | Infix <- fixity
619 , HsValArg ty1 : HsValArg ty2 : rest <- tys
620 = foldl' mk_app (noLocA $ HsOpTy noExtField ty1 (noLocA tycon) ty2) rest
621 | otherwise
622 = foldl' mk_app (nlHsTyVar tycon) tys
623 where
624 mk_app :: LHsType (GhcPass p) -> LHsTypeArg (GhcPass p) -> LHsType (GhcPass p)
625 mk_app fun@(L _ (HsOpTy {})) arg = mk_app (noLocA $ HsParTy noAnn fun) arg
626 -- parenthesize things like `(A + B) C`
627 mk_app fun (HsValArg ty) = noLocA (HsAppTy noExtField fun (parenthesizeHsType appPrec ty))
628 mk_app fun (HsTypeArg _ ki) = noLocA (HsAppKindTy noSrcSpan fun (parenthesizeHsType appPrec ki))
629 mk_app fun (HsArgPar _) = noLocA (HsParTy noAnn fun)
630
631 nlHsAppKindTy ::
632 LHsType (GhcPass p) -> LHsKind (GhcPass p) -> LHsType (GhcPass p)
633 nlHsAppKindTy f k
634 = noLocA (HsAppKindTy noSrcSpan f (parenthesizeHsType appPrec k))
635
636 {-
637 Tuples. All these functions are *pre-typechecker* because they lack
638 types on the tuple.
639 -}
640
641 mkLHsTupleExpr :: [LHsExpr (GhcPass p)] -> XExplicitTuple (GhcPass p)
642 -> LHsExpr (GhcPass p)
643 -- Makes a pre-typechecker boxed tuple, deals with 1 case
644 mkLHsTupleExpr [e] _ = e
645 mkLHsTupleExpr es ext
646 = noLocA $ ExplicitTuple ext (map (Present noAnn) es) Boxed
647
648 mkLHsVarTuple :: IsSrcSpanAnn p a
649 => [IdP (GhcPass p)] -> XExplicitTuple (GhcPass p)
650 -> LHsExpr (GhcPass p)
651 mkLHsVarTuple ids ext = mkLHsTupleExpr (map nlHsVar ids) ext
652
653 nlTuplePat :: [LPat GhcPs] -> Boxity -> LPat GhcPs
654 nlTuplePat pats box = noLocA (TuplePat noAnn pats box)
655
656 missingTupArg :: EpAnn EpaLocation -> HsTupArg GhcPs
657 missingTupArg ann = Missing ann
658
659 mkLHsPatTup :: [LPat GhcRn] -> LPat GhcRn
660 mkLHsPatTup [] = noLocA $ TuplePat noExtField [] Boxed
661 mkLHsPatTup [lpat] = lpat
662 mkLHsPatTup lpats = L (getLoc (head lpats)) $ TuplePat noExtField lpats Boxed
663
664 -- | The Big equivalents for the source tuple expressions
665 mkBigLHsVarTup :: IsSrcSpanAnn p a
666 => [IdP (GhcPass p)] -> XExplicitTuple (GhcPass p)
667 -> LHsExpr (GhcPass p)
668 mkBigLHsVarTup ids anns = mkBigLHsTup (map nlHsVar ids) anns
669
670 mkBigLHsTup :: [LHsExpr (GhcPass id)] -> XExplicitTuple (GhcPass id)
671 -> LHsExpr (GhcPass id)
672 mkBigLHsTup es anns = mkChunkified (\e -> mkLHsTupleExpr e anns) es
673
674 -- | The Big equivalents for the source tuple patterns
675 mkBigLHsVarPatTup :: [IdP GhcRn] -> LPat GhcRn
676 mkBigLHsVarPatTup bs = mkBigLHsPatTup (map nlVarPat bs)
677
678 mkBigLHsPatTup :: [LPat GhcRn] -> LPat GhcRn
679 mkBigLHsPatTup = mkChunkified mkLHsPatTup
680
681 -- $big_tuples
682 -- #big_tuples#
683 --
684 -- GHCs built in tuples can only go up to 'mAX_TUPLE_SIZE' in arity, but
685 -- we might conceivably want to build such a massive tuple as part of the
686 -- output of a desugaring stage (notably that for list comprehensions).
687 --
688 -- We call tuples above this size \"big tuples\", and emulate them by
689 -- creating and pattern matching on >nested< tuples that are expressible
690 -- by GHC.
691 --
692 -- Nesting policy: it's better to have a 2-tuple of 10-tuples (3 objects)
693 -- than a 10-tuple of 2-tuples (11 objects), so we want the leaves of any
694 -- construction to be big.
695 --
696 -- If you just use the 'mkBigCoreTup', 'mkBigCoreVarTupTy', 'mkTupleSelector'
697 -- and 'mkTupleCase' functions to do all your work with tuples you should be
698 -- fine, and not have to worry about the arity limitation at all.
699
700 -- | Lifts a \"small\" constructor into a \"big\" constructor by recursive decomposition
701 mkChunkified :: ([a] -> a) -- ^ \"Small\" constructor function, of maximum input arity 'mAX_TUPLE_SIZE'
702 -> [a] -- ^ Possible \"big\" list of things to construct from
703 -> a -- ^ Constructed thing made possible by recursive decomposition
704 mkChunkified small_tuple as = mk_big_tuple (chunkify as)
705 where
706 -- Each sub-list is short enough to fit in a tuple
707 mk_big_tuple [as] = small_tuple as
708 mk_big_tuple as_s = mk_big_tuple (chunkify (map small_tuple as_s))
709
710 chunkify :: [a] -> [[a]]
711 -- ^ Split a list into lists that are small enough to have a corresponding
712 -- tuple arity. The sub-lists of the result all have length <= 'mAX_TUPLE_SIZE'
713 -- But there may be more than 'mAX_TUPLE_SIZE' sub-lists
714 chunkify xs
715 | n_xs <= mAX_TUPLE_SIZE = [xs]
716 | otherwise = split xs
717 where
718 n_xs = length xs
719 split [] = []
720 split xs = take mAX_TUPLE_SIZE xs : split (drop mAX_TUPLE_SIZE xs)
721
722 {-
723 ************************************************************************
724 * *
725 LHsSigType and LHsSigWcType
726 * *
727 ********************************************************************* -}
728
729 -- | Convert an 'LHsType' to an 'LHsSigType'.
730 hsTypeToHsSigType :: LHsType GhcPs -> LHsSigType GhcPs
731 hsTypeToHsSigType lty@(L loc ty) = L loc $ case ty of
732 HsForAllTy { hst_tele = HsForAllInvis { hsf_xinvis = an
733 , hsf_invis_bndrs = bndrs }
734 , hst_body = body }
735 -> mkHsExplicitSigType an bndrs body
736 _ -> mkHsImplicitSigType lty
737
738 -- | Convert an 'LHsType' to an 'LHsSigWcType'.
739 hsTypeToHsSigWcType :: LHsType GhcPs -> LHsSigWcType GhcPs
740 hsTypeToHsSigWcType = mkHsWildCardBndrs . hsTypeToHsSigType
741
742 mkHsSigEnv :: forall a. (LSig GhcRn -> Maybe ([LocatedN Name], a))
743 -> [LSig GhcRn]
744 -> NameEnv a
745 mkHsSigEnv get_info sigs
746 = mkNameEnv (mk_pairs ordinary_sigs)
747 `extendNameEnvList` (mk_pairs gen_dm_sigs)
748 -- The subtlety is this: in a class decl with a
749 -- default-method signature as well as a method signature
750 -- we want the latter to win (#12533)
751 -- class C x where
752 -- op :: forall a . x a -> x a
753 -- default op :: forall b . x b -> x b
754 -- op x = ...(e :: b -> b)...
755 -- The scoped type variables of the 'default op', namely 'b',
756 -- scope over the code for op. The 'forall a' does not!
757 -- This applies both in the renamer and typechecker, both
758 -- of which use this function
759 where
760 (gen_dm_sigs, ordinary_sigs) = partition is_gen_dm_sig sigs
761 is_gen_dm_sig (L _ (ClassOpSig _ True _ _)) = True
762 is_gen_dm_sig _ = False
763
764 mk_pairs :: [LSig GhcRn] -> [(Name, a)]
765 mk_pairs sigs = [ (n,a) | Just (ns,a) <- map get_info sigs
766 , L _ n <- ns ]
767
768 mkClassOpSigs :: [LSig GhcPs] -> [LSig GhcPs]
769 -- ^ Convert 'TypeSig' to 'ClassOpSig'.
770 -- The former is what is parsed, but the latter is
771 -- what we need in class/instance declarations
772 mkClassOpSigs sigs
773 = map fiddle sigs
774 where
775 fiddle (L loc (TypeSig anns nms ty))
776 = L loc (ClassOpSig anns False nms (dropWildCards ty))
777 fiddle sig = sig
778
779 {- *********************************************************************
780 * *
781 --------- HsWrappers: type args, dict args, casts ---------
782 * *
783 ********************************************************************* -}
784
785 mkLHsWrap :: HsWrapper -> LHsExpr GhcTc -> LHsExpr GhcTc
786 mkLHsWrap co_fn (L loc e) = L loc (mkHsWrap co_fn e)
787
788 mkHsWrap :: HsWrapper -> HsExpr GhcTc -> HsExpr GhcTc
789 mkHsWrap co_fn e | isIdHsWrapper co_fn = e
790 mkHsWrap co_fn e = XExpr (WrapExpr $ HsWrap co_fn e)
791
792 mkHsWrapCo :: TcCoercionN -- A Nominal coercion a ~N b
793 -> HsExpr GhcTc -> HsExpr GhcTc
794 mkHsWrapCo co e = mkHsWrap (mkWpCastN co) e
795
796 mkHsWrapCoR :: TcCoercionR -- A Representational coercion a ~R b
797 -> HsExpr GhcTc -> HsExpr GhcTc
798 mkHsWrapCoR co e = mkHsWrap (mkWpCastR co) e
799
800 mkLHsWrapCo :: TcCoercionN -> LHsExpr GhcTc -> LHsExpr GhcTc
801 mkLHsWrapCo co (L loc e) = L loc (mkHsWrapCo co e)
802
803 mkHsCmdWrap :: HsWrapper -> HsCmd GhcTc -> HsCmd GhcTc
804 mkHsCmdWrap w cmd | isIdHsWrapper w = cmd
805 | otherwise = XCmd (HsWrap w cmd)
806
807 mkLHsCmdWrap :: HsWrapper -> LHsCmd GhcTc -> LHsCmd GhcTc
808 mkLHsCmdWrap w (L loc c) = L loc (mkHsCmdWrap w c)
809
810 mkHsWrapPat :: HsWrapper -> Pat GhcTc -> Type -> Pat GhcTc
811 mkHsWrapPat co_fn p ty | isIdHsWrapper co_fn = p
812 | otherwise = XPat $ CoPat co_fn p ty
813
814 mkHsWrapPatCo :: TcCoercionN -> Pat GhcTc -> Type -> Pat GhcTc
815 mkHsWrapPatCo co pat ty | isTcReflCo co = pat
816 | otherwise = XPat $ CoPat (mkWpCastN co) pat ty
817
818 mkHsDictLet :: TcEvBinds -> LHsExpr GhcTc -> LHsExpr GhcTc
819 mkHsDictLet ev_binds expr = mkLHsWrap (mkWpLet ev_binds) expr
820
821 {-
822 l
823 ************************************************************************
824 * *
825 Bindings; with a location at the top
826 * *
827 ************************************************************************
828 -}
829
830 mkFunBind :: Origin -> LocatedN RdrName -> [LMatch GhcPs (LHsExpr GhcPs)]
831 -> HsBind GhcPs
832 -- ^ Not infix, with place holders for coercion and free vars
833 mkFunBind origin fn ms
834 = FunBind { fun_id = fn
835 , fun_matches = mkMatchGroup origin (noLocA ms)
836 , fun_ext = noExtField
837 , fun_tick = [] }
838
839 mkTopFunBind :: Origin -> LocatedN Name -> [LMatch GhcRn (LHsExpr GhcRn)]
840 -> HsBind GhcRn
841 -- ^ In Name-land, with empty bind_fvs
842 mkTopFunBind origin fn ms = FunBind { fun_id = fn
843 , fun_matches = mkMatchGroup origin (noLocA ms)
844 , fun_ext = emptyNameSet -- NB: closed
845 -- binding
846 , fun_tick = [] }
847
848 mkHsVarBind :: SrcSpan -> RdrName -> LHsExpr GhcPs -> LHsBind GhcPs
849 mkHsVarBind loc var rhs = mkSimpleGeneratedFunBind loc var [] rhs
850
851 mkVarBind :: IdP (GhcPass p) -> LHsExpr (GhcPass p) -> LHsBind (GhcPass p)
852 mkVarBind var rhs = L (getLoc rhs) $
853 VarBind { var_ext = noExtField,
854 var_id = var, var_rhs = rhs }
855
856 mkPatSynBind :: LocatedN RdrName -> HsPatSynDetails GhcPs
857 -> LPat GhcPs -> HsPatSynDir GhcPs -> EpAnn [AddEpAnn] -> HsBind GhcPs
858 mkPatSynBind name details lpat dir anns = PatSynBind noExtField psb
859 where
860 psb = PSB{ psb_ext = anns
861 , psb_id = name
862 , psb_args = details
863 , psb_def = lpat
864 , psb_dir = dir }
865
866 -- |If any of the matches in the 'FunBind' are infix, the 'FunBind' is
867 -- considered infix.
868 isInfixFunBind :: forall id1 id2. UnXRec id2 => HsBindLR id1 id2 -> Bool
869 isInfixFunBind (FunBind { fun_matches = MG _ matches _ })
870 = any (isInfixMatch . unXRec @id2) (unXRec @id2 matches)
871 isInfixFunBind _ = False
872
873 -- |Return the 'SrcSpan' encompassing the contents of any enclosed binds
874 spanHsLocaLBinds :: HsLocalBinds (GhcPass p) -> SrcSpan
875 spanHsLocaLBinds (EmptyLocalBinds _) = noSrcSpan
876 spanHsLocaLBinds (HsValBinds _ (ValBinds _ bs sigs))
877 = foldr combineSrcSpans noSrcSpan (bsSpans ++ sigsSpans)
878 where
879 bsSpans :: [SrcSpan]
880 bsSpans = map getLocA $ bagToList bs
881 sigsSpans :: [SrcSpan]
882 sigsSpans = map getLocA sigs
883 spanHsLocaLBinds (HsValBinds _ (XValBindsLR (NValBinds bs sigs)))
884 = foldr combineSrcSpans noSrcSpan (bsSpans ++ sigsSpans)
885 where
886 bsSpans :: [SrcSpan]
887 bsSpans = map getLocA $ concatMap (bagToList . snd) bs
888 sigsSpans :: [SrcSpan]
889 sigsSpans = map getLocA sigs
890 spanHsLocaLBinds (HsIPBinds _ (IPBinds _ bs))
891 = foldr combineSrcSpans noSrcSpan (map getLocA bs)
892
893 ------------
894 -- | Convenience function using 'mkFunBind'.
895 -- This is for generated bindings only, do not use for user-written code.
896 mkSimpleGeneratedFunBind :: SrcSpan -> RdrName -> [LPat GhcPs]
897 -> LHsExpr GhcPs -> LHsBind GhcPs
898 mkSimpleGeneratedFunBind loc fun pats expr
899 = L (noAnnSrcSpan loc) $ mkFunBind Generated (L (noAnnSrcSpan loc) fun)
900 [mkMatch (mkPrefixFunRhs (L (noAnnSrcSpan loc) fun)) pats expr
901 emptyLocalBinds]
902
903 -- | Make a prefix, non-strict function 'HsMatchContext'
904 mkPrefixFunRhs :: LIdP p -> HsMatchContext p
905 mkPrefixFunRhs n = FunRhs { mc_fun = n
906 , mc_fixity = Prefix
907 , mc_strictness = NoSrcStrict }
908
909 ------------
910 mkMatch :: forall p. IsPass p
911 => HsMatchContext (GhcPass p)
912 -> [LPat (GhcPass p)]
913 -> LHsExpr (GhcPass p)
914 -> HsLocalBinds (GhcPass p)
915 -> LMatch (GhcPass p) (LHsExpr (GhcPass p))
916 mkMatch ctxt pats expr binds
917 = noLocA (Match { m_ext = noAnn
918 , m_ctxt = ctxt
919 , m_pats = map mkParPat pats
920 , m_grhss = GRHSs emptyComments (unguardedRHS noAnn noSrcSpan expr) binds })
921
922 {-
923 ************************************************************************
924 * *
925 Collecting binders
926 * *
927 ************************************************************************
928
929 Get all the binders in some HsBindGroups, IN THE ORDER OF APPEARANCE. eg.
930
931 ...
932 where
933 (x, y) = ...
934 f i j = ...
935 [a, b] = ...
936
937 it should return [x, y, f, a, b] (remember, order important).
938
939 Note [Collect binders only after renaming]
940 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
941 These functions should only be used on HsSyn *after* the renamer,
942 to return a [Name] or [Id]. Before renaming the record punning
943 and wild-card mechanism makes it hard to know what is bound.
944 So these functions should not be applied to (HsSyn RdrName)
945
946 Note [Unlifted id check in isUnliftedHsBind]
947 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
948 The function isUnliftedHsBind is used to complain if we make a top-level
949 binding for a variable of unlifted type.
950
951 Such a binding is illegal if the top-level binding would be unlifted;
952 but also if the local letrec generated by desugaring AbsBinds would be.
953 E.g.
954 f :: Num a => (# a, a #)
955 g :: Num a => a -> a
956 f = ...g...
957 g = ...g...
958
959 The top-level bindings for f,g are not unlifted (because of the Num a =>),
960 but the local, recursive, monomorphic bindings are:
961
962 t = /\a \(d:Num a).
963 letrec fm :: (# a, a #) = ...g...
964 gm :: a -> a = ...f...
965 in (fm, gm)
966
967 Here the binding for 'fm' is illegal. So generally we check the abe_mono types.
968
969 BUT we have a special case when abs_sig is true;
970 see Note [The abs_sig field of AbsBinds] in GHC.Hs.Binds
971 -}
972
973 ----------------- Bindings --------------------------
974
975 -- | Should we treat this as an unlifted bind? This will be true for any
976 -- bind that binds an unlifted variable, but we must be careful around
977 -- AbsBinds. See Note [Unlifted id check in isUnliftedHsBind]. For usage
978 -- information, see Note [Strict binds checks] is GHC.HsToCore.Binds.
979 isUnliftedHsBind :: HsBind GhcTc -> Bool -- works only over typechecked binds
980 isUnliftedHsBind bind
981 | AbsBinds { abs_exports = exports, abs_sig = has_sig } <- bind
982 = if has_sig
983 then any (is_unlifted_id . abe_poly) exports
984 else any (is_unlifted_id . abe_mono) exports
985 -- If has_sig is True we will never generate a binding for abe_mono,
986 -- so we don't need to worry about it being unlifted. The abe_poly
987 -- binding might not be: e.g. forall a. Num a => (# a, a #)
988
989 | otherwise
990 = any is_unlifted_id (collectHsBindBinders CollNoDictBinders bind)
991 where
992 is_unlifted_id id = isUnliftedType (idType id)
993
994 -- | Is a binding a strict variable or pattern bind (e.g. @!x = ...@)?
995 isBangedHsBind :: HsBind GhcTc -> Bool
996 isBangedHsBind (AbsBinds { abs_binds = binds })
997 = anyBag (isBangedHsBind . unLoc) binds
998 isBangedHsBind (FunBind {fun_matches = matches})
999 | [L _ match] <- unLoc $ mg_alts matches
1000 , FunRhs{mc_strictness = SrcStrict} <- m_ctxt match
1001 = True
1002 isBangedHsBind (PatBind {pat_lhs = pat})
1003 = isBangedLPat pat
1004 isBangedHsBind _
1005 = False
1006
1007 collectLocalBinders :: CollectPass (GhcPass idL)
1008 => CollectFlag (GhcPass idL)
1009 -> HsLocalBindsLR (GhcPass idL) (GhcPass idR)
1010 -> [IdP (GhcPass idL)]
1011 collectLocalBinders flag = \case
1012 HsValBinds _ binds -> collectHsIdBinders flag binds
1013 -- No pattern synonyms here
1014 HsIPBinds {} -> []
1015 EmptyLocalBinds _ -> []
1016
1017 collectHsIdBinders :: CollectPass (GhcPass idL)
1018 => CollectFlag (GhcPass idL)
1019 -> HsValBindsLR (GhcPass idL) (GhcPass idR)
1020 -> [IdP (GhcPass idL)]
1021 -- ^ Collect 'Id' binders only, or 'Id's + pattern synonyms, respectively
1022 collectHsIdBinders flag = collect_hs_val_binders True flag
1023
1024 collectHsValBinders :: CollectPass (GhcPass idL)
1025 => CollectFlag (GhcPass idL)
1026 -> HsValBindsLR (GhcPass idL) (GhcPass idR)
1027 -> [IdP (GhcPass idL)]
1028 collectHsValBinders flag = collect_hs_val_binders False flag
1029
1030 collectHsBindBinders :: CollectPass p
1031 => CollectFlag p
1032 -> HsBindLR p idR
1033 -> [IdP p]
1034 -- ^ Collect both 'Id's and pattern-synonym binders
1035 collectHsBindBinders flag b = collect_bind False flag b []
1036
1037 collectHsBindsBinders :: CollectPass p
1038 => CollectFlag p
1039 -> LHsBindsLR p idR
1040 -> [IdP p]
1041 collectHsBindsBinders flag binds = collect_binds False flag binds []
1042
1043 collectHsBindListBinders :: forall p idR. CollectPass p
1044 => CollectFlag p
1045 -> [LHsBindLR p idR]
1046 -> [IdP p]
1047 -- ^ Same as 'collectHsBindsBinders', but works over a list of bindings
1048 collectHsBindListBinders flag = foldr (collect_bind False flag . unXRec @p) []
1049
1050 collect_hs_val_binders :: CollectPass (GhcPass idL)
1051 => Bool
1052 -> CollectFlag (GhcPass idL)
1053 -> HsValBindsLR (GhcPass idL) (GhcPass idR)
1054 -> [IdP (GhcPass idL)]
1055 collect_hs_val_binders ps flag = \case
1056 ValBinds _ binds _ -> collect_binds ps flag binds []
1057 XValBindsLR (NValBinds binds _) -> collect_out_binds ps flag binds
1058
1059 collect_out_binds :: forall p. CollectPass p
1060 => Bool
1061 -> CollectFlag p
1062 -> [(RecFlag, LHsBinds p)]
1063 -> [IdP p]
1064 collect_out_binds ps flag = foldr (collect_binds ps flag . snd) []
1065
1066 collect_binds :: forall p idR. CollectPass p
1067 => Bool
1068 -> CollectFlag p
1069 -> LHsBindsLR p idR
1070 -> [IdP p]
1071 -> [IdP p]
1072 -- ^ Collect 'Id's, or 'Id's + pattern synonyms, depending on boolean flag
1073 collect_binds ps flag binds acc = foldr (collect_bind ps flag . unXRec @p) acc binds
1074
1075 collect_bind :: forall p idR. CollectPass p
1076 => Bool
1077 -> CollectFlag p
1078 -> HsBindLR p idR
1079 -> [IdP p]
1080 -> [IdP p]
1081 collect_bind _ flag (PatBind { pat_lhs = p }) acc = collect_lpat flag p acc
1082 collect_bind _ _ (FunBind { fun_id = f }) acc = unXRec @p f : acc
1083 collect_bind _ _ (VarBind { var_id = f }) acc = f : acc
1084 collect_bind _ _ (AbsBinds { abs_exports = dbinds }) acc = map abe_poly dbinds ++ acc
1085 -- I don't think we want the binders from the abe_binds
1086
1087 -- binding (hence see AbsBinds) is in zonking in GHC.Tc.Utils.Zonk
1088 collect_bind omitPatSyn _ (PatSynBind _ (PSB { psb_id = ps })) acc
1089 | omitPatSyn = acc
1090 | otherwise = unXRec @p ps : acc
1091 collect_bind _ _ (PatSynBind _ (XPatSynBind _)) acc = acc
1092 collect_bind _ _ (XHsBindsLR _) acc = acc
1093
1094 collectMethodBinders :: forall idL idR. UnXRec idL => LHsBindsLR idL idR -> [LIdP idL]
1095 -- ^ Used exclusively for the bindings of an instance decl which are all
1096 -- 'FunBinds'
1097 collectMethodBinders binds = foldr (get . unXRec @idL) [] binds
1098 where
1099 get (FunBind { fun_id = f }) fs = f : fs
1100 get _ fs = fs
1101 -- Someone else complains about non-FunBinds
1102
1103 ----------------- Statements --------------------------
1104 --
1105 collectLStmtsBinders
1106 :: CollectPass (GhcPass idL)
1107 => CollectFlag (GhcPass idL)
1108 -> [LStmtLR (GhcPass idL) (GhcPass idR) body]
1109 -> [IdP (GhcPass idL)]
1110 collectLStmtsBinders flag = concatMap (collectLStmtBinders flag)
1111
1112 collectStmtsBinders
1113 :: (CollectPass (GhcPass idL))
1114 => CollectFlag (GhcPass idL)
1115 -> [StmtLR (GhcPass idL) (GhcPass idR) body]
1116 -> [IdP (GhcPass idL)]
1117 collectStmtsBinders flag = concatMap (collectStmtBinders flag)
1118
1119 collectLStmtBinders
1120 :: (CollectPass (GhcPass idL))
1121 => CollectFlag (GhcPass idL)
1122 -> LStmtLR (GhcPass idL) (GhcPass idR) body
1123 -> [IdP (GhcPass idL)]
1124 collectLStmtBinders flag = collectStmtBinders flag . unLoc
1125
1126 collectStmtBinders
1127 :: CollectPass (GhcPass idL)
1128 => CollectFlag (GhcPass idL)
1129 -> StmtLR (GhcPass idL) (GhcPass idR) body
1130 -> [IdP (GhcPass idL)]
1131 -- Id Binders for a Stmt... [but what about pattern-sig type vars]?
1132 collectStmtBinders flag = \case
1133 BindStmt _ pat _ -> collectPatBinders flag pat
1134 LetStmt _ binds -> collectLocalBinders flag binds
1135 BodyStmt {} -> []
1136 LastStmt {} -> []
1137 ParStmt _ xs _ _ -> collectLStmtsBinders flag [s | ParStmtBlock _ ss _ _ <- xs, s <- ss]
1138 TransStmt { trS_stmts = stmts } -> collectLStmtsBinders flag stmts
1139 RecStmt { recS_stmts = L _ ss } -> collectLStmtsBinders flag ss
1140 ApplicativeStmt _ args _ -> concatMap collectArgBinders args
1141 where
1142 collectArgBinders = \case
1143 (_, ApplicativeArgOne { app_arg_pattern = pat }) -> collectPatBinders flag pat
1144 (_, ApplicativeArgMany { bv_pattern = pat }) -> collectPatBinders flag pat
1145
1146
1147 ----------------- Patterns --------------------------
1148
1149 collectPatBinders
1150 :: CollectPass p
1151 => CollectFlag p
1152 -> LPat p
1153 -> [IdP p]
1154 collectPatBinders flag pat = collect_lpat flag pat []
1155
1156 collectPatsBinders
1157 :: CollectPass p
1158 => CollectFlag p
1159 -> [LPat p]
1160 -> [IdP p]
1161 collectPatsBinders flag pats = foldr (collect_lpat flag) [] pats
1162
1163
1164 -------------
1165
1166 -- | Indicate if evidence binders have to be collected.
1167 --
1168 -- This type is used as a boolean (should we collect evidence binders or not?)
1169 -- but also to pass an evidence that the AST has been typechecked when we do
1170 -- want to collect evidence binders, otherwise these binders are not available.
1171 --
1172 -- See Note [Dictionary binders in ConPatOut]
1173 data CollectFlag p where
1174 -- | Don't collect evidence binders
1175 CollNoDictBinders :: CollectFlag p
1176 -- | Collect evidence binders
1177 CollWithDictBinders :: CollectFlag GhcTc
1178
1179 collect_lpat :: forall p. (CollectPass p)
1180 => CollectFlag p
1181 -> LPat p
1182 -> [IdP p]
1183 -> [IdP p]
1184 collect_lpat flag pat bndrs = collect_pat flag (unXRec @p pat) bndrs
1185
1186 collect_pat :: forall p. CollectPass p
1187 => CollectFlag p
1188 -> Pat p
1189 -> [IdP p]
1190 -> [IdP p]
1191 collect_pat flag pat bndrs = case pat of
1192 VarPat _ var -> unXRec @p var : bndrs
1193 WildPat _ -> bndrs
1194 LazyPat _ pat -> collect_lpat flag pat bndrs
1195 BangPat _ pat -> collect_lpat flag pat bndrs
1196 AsPat _ a pat -> unXRec @p a : collect_lpat flag pat bndrs
1197 ViewPat _ _ pat -> collect_lpat flag pat bndrs
1198 ParPat _ _ pat _ -> collect_lpat flag pat bndrs
1199 ListPat _ pats -> foldr (collect_lpat flag) bndrs pats
1200 TuplePat _ pats _ -> foldr (collect_lpat flag) bndrs pats
1201 SumPat _ pat _ _ -> collect_lpat flag pat bndrs
1202 LitPat _ _ -> bndrs
1203 NPat {} -> bndrs
1204 NPlusKPat _ n _ _ _ _ -> unXRec @p n : bndrs
1205 SigPat _ pat _ -> collect_lpat flag pat bndrs
1206 XPat ext -> collectXXPat (Proxy @p) flag ext bndrs
1207 SplicePat _ (HsSpliced _ _ (HsSplicedPat pat))
1208 -> collect_pat flag pat bndrs
1209 SplicePat _ _ -> bndrs
1210 -- See Note [Dictionary binders in ConPatOut]
1211 ConPat {pat_args=ps} -> case flag of
1212 CollNoDictBinders -> foldr (collect_lpat flag) bndrs (hsConPatArgs ps)
1213 CollWithDictBinders -> foldr (collect_lpat flag) bndrs (hsConPatArgs ps)
1214 ++ collectEvBinders (cpt_binds (pat_con_ext pat))
1215
1216 collectEvBinders :: TcEvBinds -> [Id]
1217 collectEvBinders (EvBinds bs) = foldr add_ev_bndr [] bs
1218 collectEvBinders (TcEvBinds {}) = panic "ToDo: collectEvBinders"
1219
1220 add_ev_bndr :: EvBind -> [Id] -> [Id]
1221 add_ev_bndr (EvBind { eb_lhs = b }) bs | isId b = b:bs
1222 | otherwise = bs
1223 -- A worry: what about coercion variable binders??
1224
1225
1226 -- | This class specifies how to collect variable identifiers from extension patterns in the given pass.
1227 -- Consumers of the GHC API that define their own passes should feel free to implement instances in order
1228 -- to make use of functions which depend on it.
1229 --
1230 -- In particular, Haddock already makes use of this, with an instance for its 'DocNameI' pass so that
1231 -- it can reuse the code in GHC for collecting binders.
1232 class UnXRec p => CollectPass p where
1233 collectXXPat :: Proxy p -> CollectFlag p -> XXPat p -> [IdP p] -> [IdP p]
1234
1235 instance IsPass p => CollectPass (GhcPass p) where
1236 collectXXPat _ flag ext =
1237 case ghcPass @p of
1238 GhcPs -> noExtCon ext
1239 GhcRn
1240 | HsPatExpanded _ pat <- ext
1241 -> collect_pat flag pat
1242 GhcTc -> case ext of
1243 CoPat _ pat _ -> collect_pat flag pat
1244 ExpansionPat _ pat -> collect_pat flag pat
1245
1246 {-
1247 Note [Dictionary binders in ConPatOut]
1248 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1249
1250 Should we collect dictionary binders in ConPatOut? It depends! Use CollectFlag
1251 to choose.
1252
1253 1. Pre-typechecker there are no ConPatOuts. Use CollNoDictBinders flag.
1254
1255 2. In the desugarer, most of the time we don't want to collect evidence binders,
1256 so we also use CollNoDictBinders flag.
1257
1258 Example of why it matters:
1259
1260 In a lazy pattern, for example f ~(C x y) = ..., we want to generate bindings
1261 for x,y but not for dictionaries bound by C.
1262 (The type checker ensures they would not be used.)
1263
1264 Here's the problem. Consider
1265
1266 data T a where
1267 C :: Num a => a -> Int -> T a
1268
1269 f ~(C (n+1) m) = (n,m)
1270
1271 Here, the pattern (C (n+1)) binds a hidden dictionary (d::Num a),
1272 and *also* uses that dictionary to match the (n+1) pattern. Yet, the
1273 variables bound by the lazy pattern are n,m, *not* the dictionary d.
1274 So in mkSelectorBinds in GHC.HsToCore.Utils, we want just m,n as the
1275 variables bound.
1276
1277 So in this case, we do *not* gather (a) dictionary and (b) dictionary
1278 bindings as binders of a ConPatOut pattern.
1279
1280
1281 3. On the other hand, desugaring of arrows needs evidence bindings and uses
1282 CollWithDictBinders flag.
1283
1284 Consider
1285
1286 h :: (ArrowChoice a, Arrow a) => Int -> a (Int,Int) Int
1287 h x = proc (y,z) -> case compare x y of
1288 GT -> returnA -< z+x
1289
1290 The type checker turns the case into
1291
1292 case compare x y of
1293 GT { $dNum_123 = $dNum_Int } -> returnA -< (+) $dNum_123 z x
1294
1295 That is, it attaches the $dNum_123 binding to a ConPatOut in scope.
1296
1297 During desugaring, evidence binders must be collected because their sets are
1298 intersected with free variable sets of subsequent commands to create
1299 (minimal) command environments. Failing to do it properly leads to bugs
1300 (e.g., #18950).
1301
1302 Note: attaching evidence binders to existing ConPatOut may be suboptimal for
1303 arrows. In the example above we would prefer to generate:
1304
1305 case compare x y of
1306 GT -> returnA -< let $dNum_123 = $dNum_Int in (+) $dNum_123 z x
1307
1308 So that the evidence isn't passed into the command environment. This issue
1309 doesn't arise with desugaring of non-arrow code because the simplifier can
1310 freely float and inline let-expressions created for evidence binders. But
1311 with arrow desugaring, the simplifier would have to see through the command
1312 environment tuple which is more complicated.
1313
1314 -}
1315
1316 hsGroupBinders :: HsGroup GhcRn -> [Name]
1317 hsGroupBinders (HsGroup { hs_valds = val_decls, hs_tyclds = tycl_decls,
1318 hs_fords = foreign_decls })
1319 = collectHsValBinders CollNoDictBinders val_decls
1320 ++ hsTyClForeignBinders tycl_decls foreign_decls
1321
1322 hsTyClForeignBinders :: [TyClGroup GhcRn]
1323 -> [LForeignDecl GhcRn]
1324 -> [Name]
1325 -- We need to look at instance declarations too,
1326 -- because their associated types may bind data constructors
1327 hsTyClForeignBinders tycl_decls foreign_decls
1328 = map unLoc (hsForeignDeclsBinders foreign_decls)
1329 ++ getSelectorNames
1330 (foldMap (foldMap hsLTyClDeclBinders . group_tyclds) tycl_decls
1331 `mappend`
1332 foldMap (foldMap hsLInstDeclBinders . group_instds) tycl_decls)
1333 where
1334 getSelectorNames :: ([LocatedA Name], [LFieldOcc GhcRn]) -> [Name]
1335 getSelectorNames (ns, fs) = map unLoc ns ++ map (foExt . unLoc) fs
1336
1337 -------------------
1338 hsLTyClDeclBinders :: IsPass p
1339 => LocatedA (TyClDecl (GhcPass p))
1340 -> ([LocatedA (IdP (GhcPass p))], [LFieldOcc (GhcPass p)])
1341 -- ^ Returns all the /binding/ names of the decl. The first one is
1342 -- guaranteed to be the name of the decl. The first component
1343 -- represents all binding names except record fields; the second
1344 -- represents field occurrences. For record fields mentioned in
1345 -- multiple constructors, the SrcLoc will be from the first occurrence.
1346 --
1347 -- Each returned (Located name) has a SrcSpan for the /whole/ declaration.
1348 -- See Note [SrcSpan for binders]
1349
1350 hsLTyClDeclBinders (L loc (FamDecl { tcdFam = FamilyDecl
1351 { fdLName = (L _ name) } }))
1352 = ([L loc name], [])
1353 hsLTyClDeclBinders (L loc (SynDecl
1354 { tcdLName = (L _ name) }))
1355 = ([L loc name], [])
1356 hsLTyClDeclBinders (L loc (ClassDecl
1357 { tcdLName = (L _ cls_name)
1358 , tcdSigs = sigs
1359 , tcdATs = ats }))
1360 = (L loc cls_name :
1361 [ L fam_loc fam_name | (L fam_loc (FamilyDecl
1362 { fdLName = L _ fam_name })) <- ats ]
1363 ++
1364 [ L mem_loc mem_name
1365 | (L mem_loc (ClassOpSig _ False ns _)) <- sigs
1366 , (L _ mem_name) <- ns ]
1367 , [])
1368 hsLTyClDeclBinders (L loc (DataDecl { tcdLName = (L _ name)
1369 , tcdDataDefn = defn }))
1370 = (\ (xs, ys) -> (L loc name : xs, ys)) $ hsDataDefnBinders defn
1371
1372
1373 -------------------
1374 hsForeignDeclsBinders :: forall p a. (UnXRec (GhcPass p), IsSrcSpanAnn p a)
1375 => [LForeignDecl (GhcPass p)] -> [LIdP (GhcPass p)]
1376 -- ^ See Note [SrcSpan for binders]
1377 hsForeignDeclsBinders foreign_decls
1378 = [ L (noAnnSrcSpan (locA decl_loc)) n
1379 | L decl_loc (ForeignImport { fd_name = L _ n })
1380 <- foreign_decls]
1381
1382
1383 -------------------
1384 hsPatSynSelectors :: IsPass p => HsValBinds (GhcPass p) -> [FieldOcc (GhcPass p)]
1385 -- ^ Collects record pattern-synonym selectors only; the pattern synonym
1386 -- names are collected by 'collectHsValBinders'.
1387 hsPatSynSelectors (ValBinds _ _ _) = panic "hsPatSynSelectors"
1388 hsPatSynSelectors (XValBindsLR (NValBinds binds _))
1389 = foldr addPatSynSelector [] . unionManyBags $ map snd binds
1390
1391 addPatSynSelector :: forall p. UnXRec p => LHsBind p -> [FieldOcc p] -> [FieldOcc p]
1392 addPatSynSelector bind sels
1393 | PatSynBind _ (PSB { psb_args = RecCon as }) <- unXRec @p bind
1394 = map recordPatSynField as ++ sels
1395 | otherwise = sels
1396
1397 getPatSynBinds :: forall id. UnXRec id
1398 => [(RecFlag, LHsBinds id)] -> [PatSynBind id id]
1399 getPatSynBinds binds
1400 = [ psb | (_, lbinds) <- binds
1401 , (unXRec @id -> (PatSynBind _ psb)) <- bagToList lbinds ]
1402
1403 -------------------
1404 hsLInstDeclBinders :: IsPass p
1405 => LInstDecl (GhcPass p)
1406 -> ([LocatedA (IdP (GhcPass p))], [LFieldOcc (GhcPass p)])
1407 hsLInstDeclBinders (L _ (ClsInstD
1408 { cid_inst = ClsInstDecl
1409 { cid_datafam_insts = dfis }}))
1410 = foldMap (hsDataFamInstBinders . unLoc) dfis
1411 hsLInstDeclBinders (L _ (DataFamInstD { dfid_inst = fi }))
1412 = hsDataFamInstBinders fi
1413 hsLInstDeclBinders (L _ (TyFamInstD {})) = mempty
1414
1415 -------------------
1416 -- | the 'SrcLoc' returned are for the whole declarations, not just the names
1417 hsDataFamInstBinders :: IsPass p
1418 => DataFamInstDecl (GhcPass p)
1419 -> ([LocatedA (IdP (GhcPass p))], [LFieldOcc (GhcPass p)])
1420 hsDataFamInstBinders (DataFamInstDecl { dfid_eqn = FamEqn { feqn_rhs = defn }})
1421 = hsDataDefnBinders defn
1422 -- There can't be repeated symbols because only data instances have binders
1423
1424 -------------------
1425 -- | the 'SrcLoc' returned are for the whole declarations, not just the names
1426 hsDataDefnBinders :: IsPass p
1427 => HsDataDefn (GhcPass p)
1428 -> ([LocatedA (IdP (GhcPass p))], [LFieldOcc (GhcPass p)])
1429 hsDataDefnBinders (HsDataDefn { dd_cons = cons })
1430 = hsConDeclsBinders cons
1431 -- See Note [Binders in family instances]
1432
1433 -------------------
1434 type Seen p = [LFieldOcc (GhcPass p)] -> [LFieldOcc (GhcPass p)]
1435 -- Filters out ones that have already been seen
1436
1437 hsConDeclsBinders :: forall p. IsPass p
1438 => [LConDecl (GhcPass p)]
1439 -> ([LocatedA (IdP (GhcPass p))], [LFieldOcc (GhcPass p)])
1440 -- See hsLTyClDeclBinders for what this does
1441 -- The function is boringly complicated because of the records
1442 -- And since we only have equality, we have to be a little careful
1443 hsConDeclsBinders cons
1444 = go id cons
1445 where
1446 go :: Seen p -> [LConDecl (GhcPass p)]
1447 -> ([LocatedA (IdP (GhcPass p))], [LFieldOcc (GhcPass p)])
1448 go _ [] = ([], [])
1449 go remSeen (r:rs)
1450 -- Don't re-mangle the location of field names, because we don't
1451 -- have a record of the full location of the field declaration anyway
1452 = let loc = getLoc r
1453 in case unLoc r of
1454 -- remove only the first occurrence of any seen field in order to
1455 -- avoid circumventing detection of duplicate fields (#9156)
1456 ConDeclGADT { con_names = names, con_g_args = args }
1457 -> (map (L loc . unLoc) names ++ ns, flds ++ fs)
1458 where
1459 (remSeen', flds) = get_flds_gadt remSeen args
1460 (ns, fs) = go remSeen' rs
1461
1462 ConDeclH98 { con_name = name, con_args = args }
1463 -> ([L loc (unLoc name)] ++ ns, flds ++ fs)
1464 where
1465 (remSeen', flds) = get_flds_h98 remSeen args
1466 (ns, fs) = go remSeen' rs
1467
1468 get_flds_h98 :: Seen p -> HsConDeclH98Details (GhcPass p)
1469 -> (Seen p, [LFieldOcc (GhcPass p)])
1470 get_flds_h98 remSeen (RecCon flds) = get_flds remSeen flds
1471 get_flds_h98 remSeen _ = (remSeen, [])
1472
1473 get_flds_gadt :: Seen p -> HsConDeclGADTDetails (GhcPass p)
1474 -> (Seen p, [LFieldOcc (GhcPass p)])
1475 get_flds_gadt remSeen (RecConGADT flds _) = get_flds remSeen flds
1476 get_flds_gadt remSeen _ = (remSeen, [])
1477
1478 get_flds :: Seen p -> LocatedL [LConDeclField (GhcPass p)]
1479 -> (Seen p, [LFieldOcc (GhcPass p)])
1480 get_flds remSeen flds = (remSeen', fld_names)
1481 where
1482 fld_names = remSeen (concatMap (cd_fld_names . unLoc) (unLoc flds))
1483 remSeen' = foldr (.) remSeen
1484 [deleteBy ((==) `on` unLoc . foLabel . unLoc) v
1485 | v <- fld_names]
1486
1487 {-
1488
1489 Note [SrcSpan for binders]
1490 ~~~~~~~~~~~~~~~~~~~~~~~~~~
1491 When extracting the (Located RdrNme) for a binder, at least for the
1492 main name (the TyCon of a type declaration etc), we want to give it
1493 the @SrcSpan@ of the whole /declaration/, not just the name itself
1494 (which is how it appears in the syntax tree). This SrcSpan (for the
1495 entire declaration) is used as the SrcSpan for the Name that is
1496 finally produced, and hence for error messages. (See #8607.)
1497
1498 Note [Binders in family instances]
1499 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1500 In a type or data family instance declaration, the type
1501 constructor is an *occurrence* not a binding site
1502 type instance T Int = Int -> Int -- No binders
1503 data instance S Bool = S1 | S2 -- Binders are S1,S2
1504
1505
1506 ************************************************************************
1507 * *
1508 Collecting binders the user did not write
1509 * *
1510 ************************************************************************
1511
1512 The job of this family of functions is to run through binding sites and find the set of all Names
1513 that were defined "implicitly", without being explicitly written by the user.
1514
1515 The main purpose is to find names introduced by record wildcards so that we can avoid
1516 warning the user when they don't use those names (#4404)
1517
1518 Since the addition of -Wunused-record-wildcards, this function returns a pair
1519 of [(SrcSpan, [Name])]. Each element of the list is one set of implicit
1520 binders, the first component of the tuple is the document describes the possible
1521 fix to the problem (by removing the ..).
1522
1523 This means there is some unfortunate coupling between this function and where it
1524 is used but it's only used for one specific purpose in one place so it seemed
1525 easier.
1526 -}
1527
1528 lStmtsImplicits :: [LStmtLR GhcRn (GhcPass idR) (LocatedA (body (GhcPass idR)))]
1529 -> [(SrcSpan, [Name])]
1530 lStmtsImplicits = hs_lstmts
1531 where
1532 hs_lstmts :: [LStmtLR GhcRn (GhcPass idR) (LocatedA (body (GhcPass idR)))]
1533 -> [(SrcSpan, [Name])]
1534 hs_lstmts = concatMap (hs_stmt . unLoc)
1535
1536 hs_stmt :: StmtLR GhcRn (GhcPass idR) (LocatedA (body (GhcPass idR)))
1537 -> [(SrcSpan, [Name])]
1538 hs_stmt (BindStmt _ pat _) = lPatImplicits pat
1539 hs_stmt (ApplicativeStmt _ args _) = concatMap do_arg args
1540 where do_arg (_, ApplicativeArgOne { app_arg_pattern = pat }) = lPatImplicits pat
1541 do_arg (_, ApplicativeArgMany { app_stmts = stmts }) = hs_lstmts stmts
1542 hs_stmt (LetStmt _ binds) = hs_local_binds binds
1543 hs_stmt (BodyStmt {}) = []
1544 hs_stmt (LastStmt {}) = []
1545 hs_stmt (ParStmt _ xs _ _) = hs_lstmts [s | ParStmtBlock _ ss _ _ <- xs
1546 , s <- ss]
1547 hs_stmt (TransStmt { trS_stmts = stmts }) = hs_lstmts stmts
1548 hs_stmt (RecStmt { recS_stmts = L _ ss }) = hs_lstmts ss
1549
1550 hs_local_binds (HsValBinds _ val_binds) = hsValBindsImplicits val_binds
1551 hs_local_binds (HsIPBinds {}) = []
1552 hs_local_binds (EmptyLocalBinds _) = []
1553
1554 hsValBindsImplicits :: HsValBindsLR GhcRn (GhcPass idR) -> [(SrcSpan, [Name])]
1555 hsValBindsImplicits (XValBindsLR (NValBinds binds _))
1556 = concatMap (lhsBindsImplicits . snd) binds
1557 hsValBindsImplicits (ValBinds _ binds _)
1558 = lhsBindsImplicits binds
1559
1560 lhsBindsImplicits :: LHsBindsLR GhcRn idR -> [(SrcSpan, [Name])]
1561 lhsBindsImplicits = foldBag (++) (lhs_bind . unLoc) []
1562 where
1563 lhs_bind (PatBind { pat_lhs = lpat }) = lPatImplicits lpat
1564 lhs_bind _ = []
1565
1566 lPatImplicits :: LPat GhcRn -> [(SrcSpan, [Name])]
1567 lPatImplicits = hs_lpat
1568 where
1569 hs_lpat lpat = hs_pat (unLoc lpat)
1570
1571 hs_lpats = foldr (\pat rest -> hs_lpat pat ++ rest) []
1572
1573 hs_pat (LazyPat _ pat) = hs_lpat pat
1574 hs_pat (BangPat _ pat) = hs_lpat pat
1575 hs_pat (AsPat _ _ pat) = hs_lpat pat
1576 hs_pat (ViewPat _ _ pat) = hs_lpat pat
1577 hs_pat (ParPat _ _ pat _) = hs_lpat pat
1578 hs_pat (ListPat _ pats) = hs_lpats pats
1579 hs_pat (TuplePat _ pats _) = hs_lpats pats
1580
1581 hs_pat (SigPat _ pat _) = hs_lpat pat
1582
1583 hs_pat (ConPat {pat_con=con, pat_args=ps}) = details con ps
1584
1585 hs_pat _ = []
1586
1587 details :: LocatedN Name -> HsConPatDetails GhcRn -> [(SrcSpan, [Name])]
1588 details _ (PrefixCon _ ps) = hs_lpats ps
1589 details n (RecCon fs) =
1590 [(err_loc, collectPatsBinders CollNoDictBinders implicit_pats) | Just{} <- [rec_dotdot fs] ]
1591 ++ hs_lpats explicit_pats
1592
1593 where implicit_pats = map (hfbRHS . unLoc) implicit
1594 explicit_pats = map (hfbRHS . unLoc) explicit
1595
1596
1597 (explicit, implicit) = partitionEithers [if pat_explicit then Left fld else Right fld
1598 | (i, fld) <- [0..] `zip` rec_flds fs
1599 , let pat_explicit =
1600 maybe True ((i<) . unLoc)
1601 (rec_dotdot fs)]
1602 err_loc = maybe (getLocA n) getLoc (rec_dotdot fs)
1603
1604 details _ (InfixCon p1 p2) = hs_lpat p1 ++ hs_lpat p2