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