62c153ef524af25066a84871607a29d383d4f8b7
[ghc.git] / compiler / hsSyn / HsUtils.hs
1 {-
2 (c) The University of Glasgow, 1992-2006
3
4
5 Here we collect a variety of helper functions that construct or
6 analyse HsSyn. All these functions deal with generic HsSyn; functions
7 which deal with the instantiated versions are located elsewhere:
8
9 Parameterised by Module
10 ---------------- -------------
11 GhcPs/RdrName parser/RdrHsSyn
12 GhcRn/Name rename/RnHsSyn
13 GhcTc/Id typecheck/TcHsSyn
14 -}
15
16 {-# LANGUAGE CPP #-}
17 {-# LANGUAGE ScopedTypeVariables #-}
18 {-# LANGUAGE FlexibleContexts #-}
19 {-# LANGUAGE TypeFamilies #-}
20 {-# LANGUAGE ViewPatterns #-}
21
22 module HsUtils(
23 -- Terms
24 mkHsPar, mkHsApp, mkHsAppType, mkHsAppTypes, mkHsCaseAlt,
25 mkSimpleMatch, unguardedGRHSs, unguardedRHS,
26 mkMatchGroup, mkMatch, mkPrefixFunRhs, mkHsLam, mkHsIf,
27 mkHsWrap, mkLHsWrap, mkHsWrapCo, mkHsWrapCoR, mkLHsWrapCo,
28 mkHsDictLet, mkHsLams,
29 mkHsOpApp, mkHsDo, mkHsComp, mkHsWrapPat, mkHsWrapPatCo,
30 mkLHsPar, mkHsCmdWrap, mkLHsCmdWrap,
31 mkHsCmdIf,
32
33 nlHsTyApp, nlHsTyApps, nlHsVar, nlHsDataCon,
34 nlHsLit, nlHsApp, nlHsApps, nlHsSyntaxApps,
35 nlHsIntLit, nlHsVarApps,
36 nlHsDo, nlHsOpApp, nlHsLam, nlHsPar, nlHsIf, nlHsCase, nlList,
37 mkLHsTupleExpr, mkLHsVarTuple, missingTupArg,
38 typeToLHsType,
39
40 -- * Constructing general big tuples
41 -- $big_tuples
42 mkChunkified, chunkify,
43
44 -- Bindings
45 mkFunBind, mkVarBind, mkHsVarBind, mk_easy_FunBind, mkTopFunBind,
46 mkPatSynBind,
47 isInfixFunBind,
48
49 -- Literals
50 mkHsIntegral, mkHsFractional, mkHsIsString, mkHsString, mkHsStringPrimLit,
51
52 -- Patterns
53 mkNPat, mkNPlusKPat, nlVarPat, nlLitPat, nlConVarPat, nlConVarPatName, nlConPat,
54 nlConPatName, nlInfixConPat, nlNullaryConPat, nlWildConPat, nlWildPat,
55 nlWildPatName, nlTuplePat, mkParPat, nlParPat,
56 mkBigLHsVarTup, mkBigLHsTup, mkBigLHsVarPatTup, mkBigLHsPatTup,
57
58 -- Types
59 mkHsAppTy, mkHsAppKindTy, userHsTyVarBndrs, userHsLTyVarBndrs,
60 mkLHsSigType, mkLHsSigWcType, mkClassOpSigs, mkHsSigEnv,
61 nlHsAppTy, nlHsAppKindTy, nlHsTyVar, nlHsFunTy, nlHsParTy, nlHsTyConApp,
62
63 -- Stmts
64 mkTransformStmt, mkTransformByStmt, mkBodyStmt, mkBindStmt, mkTcBindStmt,
65 mkLastStmt,
66 emptyTransStmt, mkGroupUsingStmt, mkGroupByUsingStmt,
67 emptyRecStmt, emptyRecStmtName, emptyRecStmtId, mkRecStmt,
68 unitRecStmtTc,
69
70 -- Template Haskell
71 mkUntypedSplice, mkTypedSplice,
72 mkHsQuasiQuote, unqualQuasiQuote,
73
74 -- Collecting binders
75 isUnliftedHsBind, isBangedHsBind,
76
77 collectLocalBinders, collectHsValBinders, collectHsBindListBinders,
78 collectHsIdBinders,
79 collectHsBindsBinders, collectHsBindBinders, collectMethodBinders,
80 collectPatBinders, collectPatsBinders,
81 collectLStmtsBinders, collectStmtsBinders,
82 collectLStmtBinders, collectStmtBinders,
83
84 hsLTyClDeclBinders, hsTyClForeignBinders,
85 hsPatSynSelectors, getPatSynBinds,
86 hsForeignDeclsBinders, hsGroupBinders, hsDataFamInstBinders,
87
88 -- Collecting implicit binders
89 lStmtsImplicits, hsValBindsImplicits, lPatImplicits
90 ) where
91
92 #include "HsVersions.h"
93
94 import GhcPrelude
95
96 import HsDecls
97 import HsBinds
98 import HsExpr
99 import HsPat
100 import HsTypes
101 import HsLit
102 import PlaceHolder
103 import HsExtension
104
105 import TcEvidence
106 import RdrName
107 import Var
108 import TyCoRep
109 import Type ( tyConArgFlags )
110 import TysWiredIn ( unitTy )
111 import TcType
112 import DataCon
113 import ConLike
114 import Id
115 import Name
116 import NameSet hiding ( unitFV )
117 import NameEnv
118 import BasicTypes
119 import SrcLoc
120 import FastString
121 import Util
122 import Bag
123 import Outputable
124 import Constants
125
126 import Data.Either
127 import Data.Function
128 import Data.List
129
130 {-
131 ************************************************************************
132 * *
133 Some useful helpers for constructing syntax
134 * *
135 ************************************************************************
136
137 These functions attempt to construct a not-completely-useless SrcSpan
138 from their components, compared with the nl* functions below which
139 just attach noSrcSpan to everything.
140 -}
141
142 mkHsPar :: LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
143 mkHsPar e = cL (getLoc e) (HsPar noExt e)
144
145 mkSimpleMatch :: HsMatchContext (NameOrRdrName (IdP (GhcPass p)))
146 -> [LPat (GhcPass p)] -> Located (body (GhcPass p))
147 -> LMatch (GhcPass p) (Located (body (GhcPass p)))
148 mkSimpleMatch ctxt pats rhs
149 = cL loc $
150 Match { m_ext = noExt, m_ctxt = ctxt, m_pats = pats
151 , m_grhss = unguardedGRHSs rhs }
152 where
153 loc = case pats of
154 [] -> getLoc rhs
155 (pat:_) -> combineSrcSpans (getLoc pat) (getLoc rhs)
156
157 unguardedGRHSs :: Located (body (GhcPass p))
158 -> GRHSs (GhcPass p) (Located (body (GhcPass p)))
159 unguardedGRHSs rhs@(dL->L loc _)
160 = GRHSs noExt (unguardedRHS loc rhs) (noLoc emptyLocalBinds)
161
162 unguardedRHS :: SrcSpan -> Located (body (GhcPass p))
163 -> [LGRHS (GhcPass p) (Located (body (GhcPass p)))]
164 unguardedRHS loc rhs = [cL loc (GRHS noExt [] rhs)]
165
166 mkMatchGroup :: (XMG name (Located (body name)) ~ NoExt)
167 => Origin -> [LMatch name (Located (body name))]
168 -> MatchGroup name (Located (body name))
169 mkMatchGroup origin matches = MG { mg_ext = noExt
170 , mg_alts = mkLocatedList matches
171 , mg_origin = origin }
172
173 mkLocatedList :: [Located a] -> Located [Located a]
174 mkLocatedList [] = noLoc []
175 mkLocatedList ms = cL (combineLocs (head ms) (last ms)) ms
176
177 mkHsApp :: LHsExpr (GhcPass id) -> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
178 mkHsApp e1 e2 = addCLoc e1 e2 (HsApp noExt e1 e2)
179
180 mkHsAppType :: (NoGhcTc (GhcPass id) ~ GhcRn)
181 => LHsExpr (GhcPass id) -> LHsWcType GhcRn -> LHsExpr (GhcPass id)
182 mkHsAppType e t = addCLoc e t_body (HsAppType noExt e paren_wct)
183 where
184 t_body = hswc_body t
185 paren_wct = t { hswc_body = parenthesizeHsType appPrec t_body }
186
187 mkHsAppTypes :: LHsExpr GhcRn -> [LHsWcType GhcRn] -> LHsExpr GhcRn
188 mkHsAppTypes = foldl' mkHsAppType
189
190 mkHsLam :: (XMG (GhcPass p) (LHsExpr (GhcPass p)) ~ NoExt) =>
191 [LPat (GhcPass p)] -> LHsExpr (GhcPass p) -> LHsExpr (GhcPass p)
192 mkHsLam pats body = mkHsPar (cL (getLoc body) (HsLam noExt matches))
193 where
194 matches = mkMatchGroup Generated
195 [mkSimpleMatch LambdaExpr pats' body]
196 pats' = map (parenthesizePat appPrec) pats
197
198 mkHsLams :: [TyVar] -> [EvVar] -> LHsExpr GhcTc -> LHsExpr GhcTc
199 mkHsLams tyvars dicts expr = mkLHsWrap (mkWpTyLams tyvars
200 <.> mkWpLams dicts) expr
201
202 -- |A simple case alternative with a single pattern, no binds, no guards;
203 -- pre-typechecking
204 mkHsCaseAlt :: LPat (GhcPass p) -> (Located (body (GhcPass p)))
205 -> LMatch (GhcPass p) (Located (body (GhcPass p)))
206 mkHsCaseAlt pat expr
207 = mkSimpleMatch CaseAlt [pat] expr
208
209 nlHsTyApp :: IdP (GhcPass id) -> [Type] -> LHsExpr (GhcPass id)
210 nlHsTyApp fun_id tys
211 = noLoc (mkHsWrap (mkWpTyApps tys) (HsVar noExt (noLoc fun_id)))
212
213 nlHsTyApps :: IdP (GhcPass id) -> [Type] -> [LHsExpr (GhcPass id)]
214 -> LHsExpr (GhcPass id)
215 nlHsTyApps fun_id tys xs = foldl' nlHsApp (nlHsTyApp fun_id tys) xs
216
217 --------- Adding parens ---------
218 mkLHsPar :: LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
219 -- Wrap in parens if (hsExprNeedsParens appPrec) says it needs them
220 -- So 'f x' becomes '(f x)', but '3' stays as '3'
221 mkLHsPar le@(dL->L loc e)
222 | hsExprNeedsParens appPrec e = cL loc (HsPar noExt le)
223 | otherwise = le
224
225 mkParPat :: LPat (GhcPass name) -> LPat (GhcPass name)
226 mkParPat lp@(dL->L loc p)
227 | patNeedsParens appPrec p = cL loc (ParPat noExt lp)
228 | otherwise = lp
229
230 nlParPat :: LPat (GhcPass name) -> LPat (GhcPass name)
231 nlParPat p = noLoc (ParPat noExt p)
232
233 -------------------------------
234 -- These are the bits of syntax that contain rebindable names
235 -- See RnEnv.lookupSyntaxName
236
237 mkHsIntegral :: IntegralLit -> HsOverLit GhcPs
238 mkHsFractional :: FractionalLit -> HsOverLit GhcPs
239 mkHsIsString :: SourceText -> FastString -> HsOverLit GhcPs
240 mkHsDo :: HsStmtContext Name -> [ExprLStmt GhcPs] -> HsExpr GhcPs
241 mkHsComp :: HsStmtContext Name -> [ExprLStmt GhcPs] -> LHsExpr GhcPs
242 -> HsExpr GhcPs
243
244 mkNPat :: Located (HsOverLit GhcPs) -> Maybe (SyntaxExpr GhcPs)
245 -> Pat GhcPs
246 mkNPlusKPat :: Located RdrName -> Located (HsOverLit GhcPs) -> Pat GhcPs
247
248 mkLastStmt :: Located (bodyR (GhcPass idR))
249 -> StmtLR (GhcPass idL) (GhcPass idR) (Located (bodyR (GhcPass idR)))
250 mkBodyStmt :: Located (bodyR GhcPs)
251 -> StmtLR (GhcPass idL) GhcPs (Located (bodyR GhcPs))
252 mkBindStmt :: (XBindStmt (GhcPass idL) (GhcPass idR)
253 (Located (bodyR (GhcPass idR))) ~ NoExt)
254 => LPat (GhcPass idL) -> Located (bodyR (GhcPass idR))
255 -> StmtLR (GhcPass idL) (GhcPass idR) (Located (bodyR (GhcPass idR)))
256 mkTcBindStmt :: LPat GhcTc -> Located (bodyR GhcTc)
257 -> StmtLR GhcTc GhcTc (Located (bodyR GhcTc))
258
259 emptyRecStmt :: StmtLR (GhcPass idL) GhcPs bodyR
260 emptyRecStmtName :: StmtLR GhcRn GhcRn bodyR
261 emptyRecStmtId :: StmtLR GhcTc GhcTc bodyR
262 mkRecStmt :: [LStmtLR (GhcPass idL) GhcPs bodyR]
263 -> StmtLR (GhcPass idL) GhcPs bodyR
264
265
266 mkHsIntegral i = OverLit noExt (HsIntegral i) noExpr
267 mkHsFractional f = OverLit noExt (HsFractional f) noExpr
268 mkHsIsString src s = OverLit noExt (HsIsString src s) noExpr
269
270 mkHsDo ctxt stmts = HsDo noExt ctxt (mkLocatedList stmts)
271 mkHsComp ctxt stmts expr = mkHsDo ctxt (stmts ++ [last_stmt])
272 where
273 last_stmt = cL (getLoc expr) $ mkLastStmt expr
274
275 mkHsIf :: LHsExpr (GhcPass p) -> LHsExpr (GhcPass p) -> LHsExpr (GhcPass p)
276 -> HsExpr (GhcPass p)
277 mkHsIf c a b = HsIf noExt (Just noSyntaxExpr) c a b
278
279 mkHsCmdIf :: LHsExpr (GhcPass p) -> LHsCmd (GhcPass p) -> LHsCmd (GhcPass p)
280 -> HsCmd (GhcPass p)
281 mkHsCmdIf c a b = HsCmdIf noExt (Just noSyntaxExpr) c a b
282
283 mkNPat lit neg = NPat noExt lit neg noSyntaxExpr
284 mkNPlusKPat id lit
285 = NPlusKPat noExt id lit (unLoc lit) noSyntaxExpr noSyntaxExpr
286
287 mkTransformStmt :: [ExprLStmt GhcPs] -> LHsExpr GhcPs
288 -> StmtLR GhcPs GhcPs (LHsExpr GhcPs)
289 mkTransformByStmt :: [ExprLStmt GhcPs] -> LHsExpr GhcPs
290 -> LHsExpr GhcPs -> StmtLR GhcPs GhcPs (LHsExpr GhcPs)
291 mkGroupUsingStmt :: [ExprLStmt GhcPs] -> LHsExpr GhcPs
292 -> StmtLR GhcPs GhcPs (LHsExpr GhcPs)
293 mkGroupByUsingStmt :: [ExprLStmt GhcPs] -> LHsExpr GhcPs
294 -> LHsExpr GhcPs
295 -> StmtLR GhcPs GhcPs (LHsExpr GhcPs)
296
297 emptyTransStmt :: StmtLR GhcPs GhcPs (LHsExpr GhcPs)
298 emptyTransStmt = TransStmt { trS_ext = noExt
299 , trS_form = panic "emptyTransStmt: form"
300 , trS_stmts = [], trS_bndrs = []
301 , trS_by = Nothing, trS_using = noLoc noExpr
302 , trS_ret = noSyntaxExpr, trS_bind = noSyntaxExpr
303 , trS_fmap = noExpr }
304 mkTransformStmt ss u = emptyTransStmt { trS_form = ThenForm, trS_stmts = ss, trS_using = u }
305 mkTransformByStmt ss u b = emptyTransStmt { trS_form = ThenForm, trS_stmts = ss, trS_using = u, trS_by = Just b }
306 mkGroupUsingStmt ss u = emptyTransStmt { trS_form = GroupForm, trS_stmts = ss, trS_using = u }
307 mkGroupByUsingStmt ss b u = emptyTransStmt { trS_form = GroupForm, trS_stmts = ss, trS_using = u, trS_by = Just b }
308
309 mkLastStmt body = LastStmt noExt body False noSyntaxExpr
310 mkBodyStmt body
311 = BodyStmt noExt body noSyntaxExpr noSyntaxExpr
312 mkBindStmt pat body
313 = BindStmt noExt pat body noSyntaxExpr noSyntaxExpr
314 mkTcBindStmt pat body = BindStmt unitTy pat body noSyntaxExpr noSyntaxExpr
315 -- don't use placeHolderTypeTc above, because that panics during zonking
316
317 emptyRecStmt' :: forall idL idR body.
318 XRecStmt (GhcPass idL) (GhcPass idR) body
319 -> StmtLR (GhcPass idL) (GhcPass idR) body
320 emptyRecStmt' tyVal =
321 RecStmt
322 { recS_stmts = [], recS_later_ids = []
323 , recS_rec_ids = []
324 , recS_ret_fn = noSyntaxExpr
325 , recS_mfix_fn = noSyntaxExpr
326 , recS_bind_fn = noSyntaxExpr
327 , recS_ext = tyVal }
328
329 unitRecStmtTc :: RecStmtTc
330 unitRecStmtTc = RecStmtTc { recS_bind_ty = unitTy
331 , recS_later_rets = []
332 , recS_rec_rets = []
333 , recS_ret_ty = unitTy }
334
335 emptyRecStmt = emptyRecStmt' noExt
336 emptyRecStmtName = emptyRecStmt' noExt
337 emptyRecStmtId = emptyRecStmt' unitRecStmtTc
338 -- a panic might trigger during zonking
339 mkRecStmt stmts = emptyRecStmt { recS_stmts = stmts }
340
341 -------------------------------
342 --- A useful function for building @OpApps@. The operator is always a
343 -- variable, and we don't know the fixity yet.
344 mkHsOpApp :: LHsExpr GhcPs -> IdP GhcPs -> LHsExpr GhcPs -> HsExpr GhcPs
345 mkHsOpApp e1 op e2 = OpApp noExt e1 (noLoc (HsVar noExt (noLoc op))) e2
346
347 unqualSplice :: RdrName
348 unqualSplice = mkRdrUnqual (mkVarOccFS (fsLit "splice"))
349
350 mkUntypedSplice :: SpliceDecoration -> LHsExpr GhcPs -> HsSplice GhcPs
351 mkUntypedSplice hasParen e = HsUntypedSplice noExt hasParen unqualSplice e
352
353 mkTypedSplice :: SpliceDecoration -> LHsExpr GhcPs -> HsSplice GhcPs
354 mkTypedSplice hasParen e = HsTypedSplice noExt hasParen unqualSplice e
355
356 mkHsQuasiQuote :: RdrName -> SrcSpan -> FastString -> HsSplice GhcPs
357 mkHsQuasiQuote quoter span quote
358 = HsQuasiQuote noExt unqualSplice quoter span quote
359
360 unqualQuasiQuote :: RdrName
361 unqualQuasiQuote = mkRdrUnqual (mkVarOccFS (fsLit "quasiquote"))
362 -- A name (uniquified later) to
363 -- identify the quasi-quote
364
365 mkHsString :: String -> HsLit (GhcPass p)
366 mkHsString s = HsString NoSourceText (mkFastString s)
367
368 mkHsStringPrimLit :: FastString -> HsLit (GhcPass p)
369 mkHsStringPrimLit fs = HsStringPrim NoSourceText (bytesFS fs)
370
371 -------------
372 userHsLTyVarBndrs :: SrcSpan -> [Located (IdP (GhcPass p))]
373 -> [LHsTyVarBndr (GhcPass p)]
374 -- Caller sets location
375 userHsLTyVarBndrs loc bndrs = [ cL loc (UserTyVar noExt v) | v <- bndrs ]
376
377 userHsTyVarBndrs :: SrcSpan -> [IdP (GhcPass p)] -> [LHsTyVarBndr (GhcPass p)]
378 -- Caller sets location
379 userHsTyVarBndrs loc bndrs = [ cL loc (UserTyVar noExt (cL loc v))
380 | v <- bndrs ]
381
382
383 {-
384 ************************************************************************
385 * *
386 Constructing syntax with no location info
387 * *
388 ************************************************************************
389 -}
390
391 nlHsVar :: IdP (GhcPass id) -> LHsExpr (GhcPass id)
392 nlHsVar n = noLoc (HsVar noExt (noLoc n))
393
394 -- NB: Only for LHsExpr **Id**
395 nlHsDataCon :: DataCon -> LHsExpr GhcTc
396 nlHsDataCon con = noLoc (HsConLikeOut noExt (RealDataCon con))
397
398 nlHsLit :: HsLit (GhcPass p) -> LHsExpr (GhcPass p)
399 nlHsLit n = noLoc (HsLit noExt n)
400
401 nlHsIntLit :: Integer -> LHsExpr (GhcPass p)
402 nlHsIntLit n = noLoc (HsLit noExt (HsInt noExt (mkIntegralLit n)))
403
404 nlVarPat :: IdP (GhcPass id) -> LPat (GhcPass id)
405 nlVarPat n = noLoc (VarPat noExt (noLoc n))
406
407 nlLitPat :: HsLit GhcPs -> LPat GhcPs
408 nlLitPat l = noLoc (LitPat noExt l)
409
410 nlHsApp :: LHsExpr (GhcPass id) -> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
411 nlHsApp f x = noLoc (HsApp noExt f (mkLHsPar x))
412
413 nlHsSyntaxApps :: SyntaxExpr (GhcPass id) -> [LHsExpr (GhcPass id)]
414 -> LHsExpr (GhcPass id)
415 nlHsSyntaxApps (SyntaxExpr { syn_expr = fun
416 , syn_arg_wraps = arg_wraps
417 , syn_res_wrap = res_wrap }) args
418 | [] <- arg_wraps -- in the noSyntaxExpr case
419 = ASSERT( isIdHsWrapper res_wrap )
420 foldl' nlHsApp (noLoc fun) args
421
422 | otherwise
423 = mkLHsWrap res_wrap (foldl' nlHsApp (noLoc fun) (zipWithEqual "nlHsSyntaxApps"
424 mkLHsWrap arg_wraps args))
425
426 nlHsApps :: IdP (GhcPass id) -> [LHsExpr (GhcPass id)] -> LHsExpr (GhcPass id)
427 nlHsApps f xs = foldl' nlHsApp (nlHsVar f) xs
428
429 nlHsVarApps :: IdP (GhcPass id) -> [IdP (GhcPass id)] -> LHsExpr (GhcPass id)
430 nlHsVarApps f xs = noLoc (foldl' mk (HsVar noExt (noLoc f))
431 (map ((HsVar noExt) . noLoc) xs))
432 where
433 mk f a = HsApp noExt (noLoc f) (noLoc a)
434
435 nlConVarPat :: RdrName -> [RdrName] -> LPat GhcPs
436 nlConVarPat con vars = nlConPat con (map nlVarPat vars)
437
438 nlConVarPatName :: Name -> [Name] -> LPat GhcRn
439 nlConVarPatName con vars = nlConPatName con (map nlVarPat vars)
440
441 nlInfixConPat :: RdrName -> LPat GhcPs -> LPat GhcPs -> LPat GhcPs
442 nlInfixConPat con l r = noLoc (ConPatIn (noLoc con)
443 (InfixCon (parenthesizePat opPrec l)
444 (parenthesizePat opPrec r)))
445
446 nlConPat :: RdrName -> [LPat GhcPs] -> LPat GhcPs
447 nlConPat con pats =
448 noLoc (ConPatIn (noLoc con) (PrefixCon (map (parenthesizePat appPrec) pats)))
449
450 nlConPatName :: Name -> [LPat GhcRn] -> LPat GhcRn
451 nlConPatName con pats =
452 noLoc (ConPatIn (noLoc con) (PrefixCon (map (parenthesizePat appPrec) pats)))
453
454 nlNullaryConPat :: IdP (GhcPass p) -> LPat (GhcPass p)
455 nlNullaryConPat con = noLoc (ConPatIn (noLoc con) (PrefixCon []))
456
457 nlWildConPat :: DataCon -> LPat GhcPs
458 nlWildConPat con = noLoc (ConPatIn (noLoc (getRdrName con))
459 (PrefixCon (nOfThem (dataConSourceArity con)
460 nlWildPat)))
461
462 nlWildPat :: LPat GhcPs
463 nlWildPat = noLoc (WildPat noExt ) -- Pre-typechecking
464
465 nlWildPatName :: LPat GhcRn
466 nlWildPatName = noLoc (WildPat noExt ) -- Pre-typechecking
467
468 nlHsDo :: HsStmtContext Name -> [LStmt GhcPs (LHsExpr GhcPs)]
469 -> LHsExpr GhcPs
470 nlHsDo ctxt stmts = noLoc (mkHsDo ctxt stmts)
471
472 nlHsOpApp :: LHsExpr GhcPs -> IdP GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
473 nlHsOpApp e1 op e2 = noLoc (mkHsOpApp e1 op e2)
474
475 nlHsLam :: LMatch GhcPs (LHsExpr GhcPs) -> LHsExpr GhcPs
476 nlHsPar :: LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
477 nlHsIf :: LHsExpr (GhcPass id) -> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
478 -> LHsExpr (GhcPass id)
479 nlHsCase :: LHsExpr GhcPs -> [LMatch GhcPs (LHsExpr GhcPs)]
480 -> LHsExpr GhcPs
481 nlList :: [LHsExpr GhcPs] -> LHsExpr GhcPs
482
483 nlHsLam match = noLoc (HsLam noExt (mkMatchGroup Generated [match]))
484 nlHsPar e = noLoc (HsPar noExt e)
485
486 -- Note [Rebindable nlHsIf]
487 -- nlHsIf should generate if-expressions which are NOT subject to
488 -- RebindableSyntax, so the first field of HsIf is Nothing. (#12080)
489 nlHsIf cond true false = noLoc (HsIf noExt Nothing cond true false)
490
491 nlHsCase expr matches
492 = noLoc (HsCase noExt expr (mkMatchGroup Generated matches))
493 nlList exprs = noLoc (ExplicitList noExt Nothing exprs)
494
495 nlHsAppTy :: LHsType (GhcPass p) -> LHsType (GhcPass p) -> LHsType (GhcPass p)
496 nlHsTyVar :: IdP (GhcPass p) -> LHsType (GhcPass p)
497 nlHsFunTy :: LHsType (GhcPass p) -> LHsType (GhcPass p) -> LHsType (GhcPass p)
498 nlHsParTy :: LHsType (GhcPass p) -> LHsType (GhcPass p)
499
500 nlHsAppTy f t = noLoc (HsAppTy noExt f (parenthesizeHsType appPrec t))
501 nlHsTyVar x = noLoc (HsTyVar noExt NotPromoted (noLoc x))
502 nlHsFunTy a b = noLoc (HsFunTy noExt (parenthesizeHsType funPrec a) b)
503 nlHsParTy t = noLoc (HsParTy noExt t)
504
505 nlHsTyConApp :: IdP (GhcPass p) -> [LHsType (GhcPass p)] -> LHsType (GhcPass p)
506 nlHsTyConApp tycon tys = foldl' nlHsAppTy (nlHsTyVar tycon) tys
507
508 nlHsAppKindTy ::
509 LHsType (GhcPass p) -> LHsKind (GhcPass p) -> LHsType (GhcPass p)
510 nlHsAppKindTy f k
511 = noLoc (HsAppKindTy noSrcSpan f (parenthesizeHsType appPrec k))
512
513 {-
514 Tuples. All these functions are *pre-typechecker* because they lack
515 types on the tuple.
516 -}
517
518 mkLHsTupleExpr :: [LHsExpr (GhcPass a)] -> LHsExpr (GhcPass a)
519 -- Makes a pre-typechecker boxed tuple, deals with 1 case
520 mkLHsTupleExpr [e] = e
521 mkLHsTupleExpr es
522 = noLoc $ ExplicitTuple noExt (map (noLoc . (Present noExt)) es) Boxed
523
524 mkLHsVarTuple :: [IdP (GhcPass a)] -> LHsExpr (GhcPass a)
525 mkLHsVarTuple ids = mkLHsTupleExpr (map nlHsVar ids)
526
527 nlTuplePat :: [LPat GhcPs] -> Boxity -> LPat GhcPs
528 nlTuplePat pats box = noLoc (TuplePat noExt pats box)
529
530 missingTupArg :: HsTupArg GhcPs
531 missingTupArg = Missing noExt
532
533 mkLHsPatTup :: [LPat GhcRn] -> LPat GhcRn
534 mkLHsPatTup [] = noLoc $ TuplePat noExt [] Boxed
535 mkLHsPatTup [lpat] = lpat
536 mkLHsPatTup lpats = cL (getLoc (head lpats)) $ TuplePat noExt lpats Boxed
537
538 -- The Big equivalents for the source tuple expressions
539 mkBigLHsVarTup :: [IdP (GhcPass id)] -> LHsExpr (GhcPass id)
540 mkBigLHsVarTup ids = mkBigLHsTup (map nlHsVar ids)
541
542 mkBigLHsTup :: [LHsExpr (GhcPass id)] -> LHsExpr (GhcPass id)
543 mkBigLHsTup = mkChunkified mkLHsTupleExpr
544
545 -- The Big equivalents for the source tuple patterns
546 mkBigLHsVarPatTup :: [IdP GhcRn] -> LPat GhcRn
547 mkBigLHsVarPatTup bs = mkBigLHsPatTup (map nlVarPat bs)
548
549 mkBigLHsPatTup :: [LPat GhcRn] -> LPat GhcRn
550 mkBigLHsPatTup = mkChunkified mkLHsPatTup
551
552 -- $big_tuples
553 -- #big_tuples#
554 --
555 -- GHCs built in tuples can only go up to 'mAX_TUPLE_SIZE' in arity, but
556 -- we might concievably want to build such a massive tuple as part of the
557 -- output of a desugaring stage (notably that for list comprehensions).
558 --
559 -- We call tuples above this size \"big tuples\", and emulate them by
560 -- creating and pattern matching on >nested< tuples that are expressible
561 -- by GHC.
562 --
563 -- Nesting policy: it's better to have a 2-tuple of 10-tuples (3 objects)
564 -- than a 10-tuple of 2-tuples (11 objects), so we want the leaves of any
565 -- construction to be big.
566 --
567 -- If you just use the 'mkBigCoreTup', 'mkBigCoreVarTupTy', 'mkTupleSelector'
568 -- and 'mkTupleCase' functions to do all your work with tuples you should be
569 -- fine, and not have to worry about the arity limitation at all.
570
571 -- | Lifts a \"small\" constructor into a \"big\" constructor by recursive decompositon
572 mkChunkified :: ([a] -> a) -- ^ \"Small\" constructor function, of maximum input arity 'mAX_TUPLE_SIZE'
573 -> [a] -- ^ Possible \"big\" list of things to construct from
574 -> a -- ^ Constructed thing made possible by recursive decomposition
575 mkChunkified small_tuple as = mk_big_tuple (chunkify as)
576 where
577 -- Each sub-list is short enough to fit in a tuple
578 mk_big_tuple [as] = small_tuple as
579 mk_big_tuple as_s = mk_big_tuple (chunkify (map small_tuple as_s))
580
581 chunkify :: [a] -> [[a]]
582 -- ^ Split a list into lists that are small enough to have a corresponding
583 -- tuple arity. The sub-lists of the result all have length <= 'mAX_TUPLE_SIZE'
584 -- But there may be more than 'mAX_TUPLE_SIZE' sub-lists
585 chunkify xs
586 | n_xs <= mAX_TUPLE_SIZE = [xs]
587 | otherwise = split xs
588 where
589 n_xs = length xs
590 split [] = []
591 split xs = take mAX_TUPLE_SIZE xs : split (drop mAX_TUPLE_SIZE xs)
592
593 {-
594 ************************************************************************
595 * *
596 LHsSigType and LHsSigWcType
597 * *
598 ********************************************************************* -}
599
600 mkLHsSigType :: LHsType GhcPs -> LHsSigType GhcPs
601 mkLHsSigType ty = mkHsImplicitBndrs ty
602
603 mkLHsSigWcType :: LHsType GhcPs -> LHsSigWcType GhcPs
604 mkLHsSigWcType ty = mkHsWildCardBndrs (mkHsImplicitBndrs ty)
605
606 mkHsSigEnv :: forall a. (LSig GhcRn -> Maybe ([Located Name], a))
607 -> [LSig GhcRn]
608 -> NameEnv a
609 mkHsSigEnv get_info sigs
610 = mkNameEnv (mk_pairs ordinary_sigs)
611 `extendNameEnvList` (mk_pairs gen_dm_sigs)
612 -- The subtlety is this: in a class decl with a
613 -- default-method signature as well as a method signature
614 -- we want the latter to win (Trac #12533)
615 -- class C x where
616 -- op :: forall a . x a -> x a
617 -- default op :: forall b . x b -> x b
618 -- op x = ...(e :: b -> b)...
619 -- The scoped type variables of the 'default op', namely 'b',
620 -- scope over the code for op. The 'forall a' does not!
621 -- This applies both in the renamer and typechecker, both
622 -- of which use this function
623 where
624 (gen_dm_sigs, ordinary_sigs) = partition is_gen_dm_sig sigs
625 is_gen_dm_sig (dL->L _ (ClassOpSig _ True _ _)) = True
626 is_gen_dm_sig _ = False
627
628 mk_pairs :: [LSig GhcRn] -> [(Name, a)]
629 mk_pairs sigs = [ (n,a) | Just (ns,a) <- map get_info sigs
630 , (dL->L _ n) <- ns ]
631
632 mkClassOpSigs :: [LSig GhcPs] -> [LSig GhcPs]
633 -- Convert TypeSig to ClassOpSig
634 -- The former is what is parsed, but the latter is
635 -- what we need in class/instance declarations
636 mkClassOpSigs sigs
637 = map fiddle sigs
638 where
639 fiddle (dL->L loc (TypeSig _ nms ty))
640 = cL loc (ClassOpSig noExt False nms (dropWildCards ty))
641 fiddle sig = sig
642
643 typeToLHsType :: Type -> LHsType GhcPs
644 -- ^ Converting a Type to an HsType RdrName
645 -- This is needed to implement GeneralizedNewtypeDeriving.
646 --
647 -- Note that we use 'getRdrName' extensively, which
648 -- generates Exact RdrNames rather than strings.
649 typeToLHsType ty
650 = go ty
651 where
652 go :: Type -> LHsType GhcPs
653 go ty@(FunTy { ft_af = af, ft_arg = arg, ft_res = res })
654 = case af of
655 VisArg -> nlHsFunTy (go arg) (go res)
656 InvisArg | (theta, tau) <- tcSplitPhiTy ty
657 -> noLoc (HsQualTy { hst_ctxt = noLoc (map go theta)
658 , hst_xqual = noExt
659 , hst_body = go tau })
660
661 go ty@(ForAllTy (Bndr _ argf) _)
662 | (tvs, tau) <- tcSplitForAllTysSameVis argf ty
663 = noLoc (HsForAllTy { hst_fvf = argToForallVisFlag argf
664 , hst_bndrs = map go_tv tvs
665 , hst_xforall = noExt
666 , hst_body = go tau })
667 go (TyVarTy tv) = nlHsTyVar (getRdrName tv)
668 go (AppTy t1 t2) = nlHsAppTy (go t1) (go t2)
669 go (LitTy (NumTyLit n))
670 = noLoc $ HsTyLit NoExt (HsNumTy NoSourceText n)
671 go (LitTy (StrTyLit s))
672 = noLoc $ HsTyLit NoExt (HsStrTy NoSourceText s)
673 go ty@(TyConApp tc args)
674 | tyConAppNeedsKindSig True tc (length args)
675 -- We must produce an explicit kind signature here to make certain
676 -- programs kind-check. See Note [Kind signatures in typeToLHsType].
677 = nlHsParTy $ noLoc $ HsKindSig NoExt lhs_ty (go (tcTypeKind ty))
678 | otherwise = lhs_ty
679 where
680 arg_flags :: [ArgFlag]
681 arg_flags = tyConArgFlags tc args
682
683 lhs_ty :: LHsType GhcPs
684 lhs_ty = foldl' (\f (arg, flag) ->
685 let arg' = go arg in
686 case flag of
687 Inferred -> f
688 Specified -> f `nlHsAppKindTy` arg'
689 Required -> f `nlHsAppTy` arg')
690 (nlHsTyVar (getRdrName tc))
691 (zip args arg_flags)
692 go (CastTy ty _) = go ty
693 go (CoercionTy co) = pprPanic "toLHsSigWcType" (ppr co)
694
695 -- Source-language types have _invisible_ kind arguments,
696 -- so we must remove them here (Trac #8563)
697
698 go_tv :: TyVar -> LHsTyVarBndr GhcPs
699 go_tv tv = noLoc $ KindedTyVar noExt (noLoc (getRdrName tv))
700 (go (tyVarKind tv))
701
702 {-
703 Note [Kind signatures in typeToLHsType]
704 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
705 There are types that typeToLHsType can produce which require explicit kind
706 signatures in order to kind-check. Here is an example from Trac #14579:
707
708 -- type P :: forall {k} {t :: k}. Proxy t
709 type P = 'Proxy
710
711 -- type Wat :: forall a. Proxy a -> *
712 newtype Wat (x :: Proxy (a :: Type)) = MkWat (Maybe a)
713 deriving Eq
714
715 -- type Wat2 :: forall {a}. Proxy a -> *
716 type Wat2 = Wat
717
718 -- type Glurp :: * -> *
719 newtype Glurp a = MkGlurp (Wat2 (P :: Proxy a))
720 deriving Eq
721
722 The derived Eq instance for Glurp (without any kind signatures) would be:
723
724 instance Eq a => Eq (Glurp a) where
725 (==) = coerce @(Wat2 P -> Wat2 P -> Bool)
726 @(Glurp a -> Glurp a -> Bool)
727 (==) :: Glurp a -> Glurp a -> Bool
728
729 (Where the visible type applications use types produced by typeToLHsType.)
730
731 The type P (in Wat2 P) has an underspecified kind, so we must ensure that
732 typeToLHsType ascribes it with its kind: Wat2 (P :: Proxy a). To accomplish
733 this, whenever we see an application of a tycon to some arguments, we use
734 the tyConAppNeedsKindSig function to determine if it requires an explicit kind
735 signature to resolve some ambiguity. (See Note
736 Note [When does a tycon application need an explicit kind signature?] for a
737 more detailed explanation of how this works.)
738
739 Note that we pass True to tyConAppNeedsKindSig since we are generated code with
740 visible kind applications, so even specified arguments count towards injective
741 positions in the kind of the tycon.
742 -}
743
744 {- *********************************************************************
745 * *
746 --------- HsWrappers: type args, dict args, casts ---------
747 * *
748 ********************************************************************* -}
749
750 mkLHsWrap :: HsWrapper -> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
751 mkLHsWrap co_fn (dL->L loc e) = cL loc (mkHsWrap co_fn e)
752
753 -- Avoid (HsWrap co (HsWrap co' _)).
754 -- See Note [Detecting forced eta expansion] in DsExpr
755 mkHsWrap :: HsWrapper -> HsExpr (GhcPass id) -> HsExpr (GhcPass id)
756 mkHsWrap co_fn e | isIdHsWrapper co_fn = e
757 mkHsWrap co_fn (HsWrap _ co_fn' e) = mkHsWrap (co_fn <.> co_fn') e
758 mkHsWrap co_fn e = HsWrap noExt co_fn e
759
760 mkHsWrapCo :: TcCoercionN -- A Nominal coercion a ~N b
761 -> HsExpr (GhcPass id) -> HsExpr (GhcPass id)
762 mkHsWrapCo co e = mkHsWrap (mkWpCastN co) e
763
764 mkHsWrapCoR :: TcCoercionR -- A Representational coercion a ~R b
765 -> HsExpr (GhcPass id) -> HsExpr (GhcPass id)
766 mkHsWrapCoR co e = mkHsWrap (mkWpCastR co) e
767
768 mkLHsWrapCo :: TcCoercionN -> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
769 mkLHsWrapCo co (dL->L loc e) = cL loc (mkHsWrapCo co e)
770
771 mkHsCmdWrap :: HsWrapper -> HsCmd (GhcPass p) -> HsCmd (GhcPass p)
772 mkHsCmdWrap w cmd | isIdHsWrapper w = cmd
773 | otherwise = HsCmdWrap noExt w cmd
774
775 mkLHsCmdWrap :: HsWrapper -> LHsCmd (GhcPass p) -> LHsCmd (GhcPass p)
776 mkLHsCmdWrap w (dL->L loc c) = cL loc (mkHsCmdWrap w c)
777
778 mkHsWrapPat :: HsWrapper -> Pat (GhcPass id) -> Type -> Pat (GhcPass id)
779 mkHsWrapPat co_fn p ty | isIdHsWrapper co_fn = p
780 | otherwise = CoPat noExt co_fn p ty
781
782 mkHsWrapPatCo :: TcCoercionN -> Pat (GhcPass id) -> Type -> Pat (GhcPass id)
783 mkHsWrapPatCo co pat ty | isTcReflCo co = pat
784 | otherwise = CoPat noExt (mkWpCastN co) pat ty
785
786 mkHsDictLet :: TcEvBinds -> LHsExpr GhcTc -> LHsExpr GhcTc
787 mkHsDictLet ev_binds expr = mkLHsWrap (mkWpLet ev_binds) expr
788
789 {-
790 l
791 ************************************************************************
792 * *
793 Bindings; with a location at the top
794 * *
795 ************************************************************************
796 -}
797
798 mkFunBind :: Located RdrName -> [LMatch GhcPs (LHsExpr GhcPs)]
799 -> HsBind GhcPs
800 -- Not infix, with place holders for coercion and free vars
801 mkFunBind fn ms = FunBind { fun_id = fn
802 , fun_matches = mkMatchGroup Generated ms
803 , fun_co_fn = idHsWrapper
804 , fun_ext = noExt
805 , fun_tick = [] }
806
807 mkTopFunBind :: Origin -> Located Name -> [LMatch GhcRn (LHsExpr GhcRn)]
808 -> HsBind GhcRn
809 -- In Name-land, with empty bind_fvs
810 mkTopFunBind origin fn ms = FunBind { fun_id = fn
811 , fun_matches = mkMatchGroup origin ms
812 , fun_co_fn = idHsWrapper
813 , fun_ext = emptyNameSet -- NB: closed
814 -- binding
815 , fun_tick = [] }
816
817 mkHsVarBind :: SrcSpan -> RdrName -> LHsExpr GhcPs -> LHsBind GhcPs
818 mkHsVarBind loc var rhs = mk_easy_FunBind loc var [] rhs
819
820 mkVarBind :: IdP (GhcPass p) -> LHsExpr (GhcPass p) -> LHsBind (GhcPass p)
821 mkVarBind var rhs = cL (getLoc rhs) $
822 VarBind { var_ext = noExt,
823 var_id = var, var_rhs = rhs, var_inline = False }
824
825 mkPatSynBind :: Located RdrName -> HsPatSynDetails (Located RdrName)
826 -> LPat GhcPs -> HsPatSynDir GhcPs -> HsBind GhcPs
827 mkPatSynBind name details lpat dir = PatSynBind noExt psb
828 where
829 psb = PSB{ psb_ext = noExt
830 , psb_id = name
831 , psb_args = details
832 , psb_def = lpat
833 , psb_dir = dir }
834
835 -- |If any of the matches in the 'FunBind' are infix, the 'FunBind' is
836 -- considered infix.
837 isInfixFunBind :: HsBindLR id1 id2 -> Bool
838 isInfixFunBind (FunBind _ _ (MG _ matches _) _ _)
839 = any (isInfixMatch . unLoc) (unLoc matches)
840 isInfixFunBind _ = False
841
842
843 ------------
844 mk_easy_FunBind :: SrcSpan -> RdrName -> [LPat GhcPs]
845 -> LHsExpr GhcPs -> LHsBind GhcPs
846 mk_easy_FunBind loc fun pats expr
847 = cL loc $ mkFunBind (cL loc fun)
848 [mkMatch (mkPrefixFunRhs (cL loc fun)) pats expr
849 (noLoc emptyLocalBinds)]
850
851 -- | Make a prefix, non-strict function 'HsMatchContext'
852 mkPrefixFunRhs :: Located id -> HsMatchContext id
853 mkPrefixFunRhs n = FunRhs { mc_fun = n
854 , mc_fixity = Prefix
855 , mc_strictness = NoSrcStrict }
856
857 ------------
858 mkMatch :: HsMatchContext (NameOrRdrName (IdP (GhcPass p)))
859 -> [LPat (GhcPass p)] -> LHsExpr (GhcPass p)
860 -> Located (HsLocalBinds (GhcPass p))
861 -> LMatch (GhcPass p) (LHsExpr (GhcPass p))
862 mkMatch ctxt pats expr lbinds
863 = noLoc (Match { m_ext = noExt
864 , m_ctxt = ctxt
865 , m_pats = map paren pats
866 , m_grhss = GRHSs noExt (unguardedRHS noSrcSpan expr) lbinds })
867 where
868 paren lp@(dL->L l p)
869 | patNeedsParens appPrec p = cL l (ParPat noExt lp)
870 | otherwise = lp
871
872 {-
873 ************************************************************************
874 * *
875 Collecting binders
876 * *
877 ************************************************************************
878
879 Get all the binders in some HsBindGroups, IN THE ORDER OF APPEARANCE. eg.
880
881 ...
882 where
883 (x, y) = ...
884 f i j = ...
885 [a, b] = ...
886
887 it should return [x, y, f, a, b] (remember, order important).
888
889 Note [Collect binders only after renaming]
890 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
891 These functions should only be used on HsSyn *after* the renamer,
892 to return a [Name] or [Id]. Before renaming the record punning
893 and wild-card mechanism makes it hard to know what is bound.
894 So these functions should not be applied to (HsSyn RdrName)
895
896 Note [Unlifted id check in isUnliftedHsBind]
897 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
898 The function isUnliftedHsBind is used to complain if we make a top-level
899 binding for a variable of unlifted type.
900
901 Such a binding is illegal if the top-level binding would be unlifted;
902 but also if the local letrec generated by desugaring AbsBinds would be.
903 E.g.
904 f :: Num a => (# a, a #)
905 g :: Num a => a -> a
906 f = ...g...
907 g = ...g...
908
909 The top-level bindings for f,g are not unlifted (because of the Num a =>),
910 but the local, recursive, monomorphic bindings are:
911
912 t = /\a \(d:Num a).
913 letrec fm :: (# a, a #) = ...g...
914 gm :: a -> a = ...f...
915 in (fm, gm)
916
917 Here the binding for 'fm' is illegal. So generally we check the abe_mono types.
918
919 BUT we have a special case when abs_sig is true;
920 see HsBinds Note [The abs_sig field of AbsBinds]
921 -}
922
923 ----------------- Bindings --------------------------
924
925 -- | Should we treat this as an unlifted bind? This will be true for any
926 -- bind that binds an unlifted variable, but we must be careful around
927 -- AbsBinds. See Note [Unlifted id check in isUnliftedHsBind]. For usage
928 -- information, see Note [Strict binds check] is DsBinds.
929 isUnliftedHsBind :: HsBind GhcTc -> Bool -- works only over typechecked binds
930 isUnliftedHsBind bind
931 | AbsBinds { abs_exports = exports, abs_sig = has_sig } <- bind
932 = if has_sig
933 then any (is_unlifted_id . abe_poly) exports
934 else any (is_unlifted_id . abe_mono) exports
935 -- If has_sig is True we wil never generate a binding for abe_mono,
936 -- so we don't need to worry about it being unlifted. The abe_poly
937 -- binding might not be: e.g. forall a. Num a => (# a, a #)
938
939 | otherwise
940 = any is_unlifted_id (collectHsBindBinders bind)
941 where
942 is_unlifted_id id = isUnliftedType (idType id)
943
944 -- | Is a binding a strict variable or pattern bind (e.g. @!x = ...@)?
945 isBangedHsBind :: HsBind GhcTc -> Bool
946 isBangedHsBind (AbsBinds { abs_binds = binds })
947 = anyBag (isBangedHsBind . unLoc) binds
948 isBangedHsBind (FunBind {fun_matches = matches})
949 | [dL->L _ match] <- unLoc $ mg_alts matches
950 , FunRhs{mc_strictness = SrcStrict} <- m_ctxt match
951 = True
952 isBangedHsBind (PatBind {pat_lhs = pat})
953 = isBangedLPat pat
954 isBangedHsBind _
955 = False
956
957 collectLocalBinders :: HsLocalBindsLR (GhcPass idL) (GhcPass idR)
958 -> [IdP (GhcPass idL)]
959 collectLocalBinders (HsValBinds _ binds) = collectHsIdBinders binds
960 -- No pattern synonyms here
961 collectLocalBinders (HsIPBinds {}) = []
962 collectLocalBinders (EmptyLocalBinds _) = []
963 collectLocalBinders (XHsLocalBindsLR _) = []
964
965 collectHsIdBinders, collectHsValBinders
966 :: HsValBindsLR (GhcPass idL) (GhcPass idR) -> [IdP (GhcPass idL)]
967 -- Collect Id binders only, or Ids + pattern synonyms, respectively
968 collectHsIdBinders = collect_hs_val_binders True
969 collectHsValBinders = collect_hs_val_binders False
970
971 collectHsBindBinders :: (SrcSpanLess (LPat p) ~ Pat p, HasSrcSpan (LPat p))=>
972 HsBindLR p idR -> [IdP p]
973 -- Collect both Ids and pattern-synonym binders
974 collectHsBindBinders b = collect_bind False b []
975
976 collectHsBindsBinders :: LHsBindsLR (GhcPass p) idR -> [IdP (GhcPass p)]
977 collectHsBindsBinders binds = collect_binds False binds []
978
979 collectHsBindListBinders :: [LHsBindLR (GhcPass p) idR] -> [IdP (GhcPass p)]
980 -- Same as collectHsBindsBinders, but works over a list of bindings
981 collectHsBindListBinders = foldr (collect_bind False . unLoc) []
982
983 collect_hs_val_binders :: Bool -> HsValBindsLR (GhcPass idL) (GhcPass idR)
984 -> [IdP (GhcPass idL)]
985 collect_hs_val_binders ps (ValBinds _ binds _) = collect_binds ps binds []
986 collect_hs_val_binders ps (XValBindsLR (NValBinds binds _))
987 = collect_out_binds ps binds
988
989 collect_out_binds :: Bool -> [(RecFlag, LHsBinds (GhcPass p))] ->
990 [IdP (GhcPass p)]
991 collect_out_binds ps = foldr (collect_binds ps . snd) []
992
993 collect_binds :: Bool -> LHsBindsLR (GhcPass p) idR ->
994 [IdP (GhcPass p)] -> [IdP (GhcPass p)]
995 -- Collect Ids, or Ids + pattern synonyms, depending on boolean flag
996 collect_binds ps binds acc = foldrBag (collect_bind ps . unLoc) acc binds
997
998 collect_bind :: (SrcSpanLess (LPat p) ~ Pat p , HasSrcSpan (LPat p)) =>
999 Bool -> HsBindLR p idR -> [IdP p] -> [IdP p]
1000 collect_bind _ (PatBind { pat_lhs = p }) acc = collect_lpat p acc
1001 collect_bind _ (FunBind { fun_id = (dL->L _ f) }) acc = f : acc
1002 collect_bind _ (VarBind { var_id = f }) acc = f : acc
1003 collect_bind _ (AbsBinds { abs_exports = dbinds }) acc = map abe_poly dbinds ++ acc
1004 -- I don't think we want the binders from the abe_binds
1005
1006 -- binding (hence see AbsBinds) is in zonking in TcHsSyn
1007 collect_bind omitPatSyn (PatSynBind _ (PSB { psb_id = (dL->L _ ps) })) acc
1008 | omitPatSyn = acc
1009 | otherwise = ps : acc
1010 collect_bind _ (PatSynBind _ (XPatSynBind _)) acc = acc
1011 collect_bind _ (XHsBindsLR _) acc = acc
1012
1013 collectMethodBinders :: LHsBindsLR idL idR -> [Located (IdP idL)]
1014 -- Used exclusively for the bindings of an instance decl which are all FunBinds
1015 collectMethodBinders binds = foldrBag (get . unLoc) [] binds
1016 where
1017 get (FunBind { fun_id = f }) fs = f : fs
1018 get _ fs = fs
1019 -- Someone else complains about non-FunBinds
1020
1021 ----------------- Statements --------------------------
1022 collectLStmtsBinders :: [LStmtLR (GhcPass idL) (GhcPass idR) body]
1023 -> [IdP (GhcPass idL)]
1024 collectLStmtsBinders = concatMap collectLStmtBinders
1025
1026 collectStmtsBinders :: [StmtLR (GhcPass idL) (GhcPass idR) body]
1027 -> [IdP (GhcPass idL)]
1028 collectStmtsBinders = concatMap collectStmtBinders
1029
1030 collectLStmtBinders :: LStmtLR (GhcPass idL) (GhcPass idR) body
1031 -> [IdP (GhcPass idL)]
1032 collectLStmtBinders = collectStmtBinders . unLoc
1033
1034 collectStmtBinders :: StmtLR (GhcPass idL) (GhcPass idR) body
1035 -> [IdP (GhcPass idL)]
1036 -- Id Binders for a Stmt... [but what about pattern-sig type vars]?
1037 collectStmtBinders (BindStmt _ pat _ _ _) = collectPatBinders pat
1038 collectStmtBinders (LetStmt _ binds) = collectLocalBinders (unLoc binds)
1039 collectStmtBinders (BodyStmt {}) = []
1040 collectStmtBinders (LastStmt {}) = []
1041 collectStmtBinders (ParStmt _ xs _ _) = collectLStmtsBinders
1042 $ [s | ParStmtBlock _ ss _ _ <- xs, s <- ss]
1043 collectStmtBinders (TransStmt { trS_stmts = stmts }) = collectLStmtsBinders stmts
1044 collectStmtBinders (RecStmt { recS_stmts = ss }) = collectLStmtsBinders ss
1045 collectStmtBinders (ApplicativeStmt _ args _) = concatMap collectArgBinders args
1046 where
1047 collectArgBinders (_, ApplicativeArgOne _ pat _ _) = collectPatBinders pat
1048 collectArgBinders (_, ApplicativeArgMany _ _ _ pat) = collectPatBinders pat
1049 collectArgBinders _ = []
1050 collectStmtBinders XStmtLR{} = panic "collectStmtBinders"
1051
1052
1053 ----------------- Patterns --------------------------
1054 collectPatBinders :: LPat (GhcPass p) -> [IdP (GhcPass p)]
1055 collectPatBinders pat = collect_lpat pat []
1056
1057 collectPatsBinders :: [LPat (GhcPass p)] -> [IdP (GhcPass p)]
1058 collectPatsBinders pats = foldr collect_lpat [] pats
1059
1060 -------------
1061 collect_lpat :: (SrcSpanLess (LPat p) ~ Pat p , HasSrcSpan (LPat p)) =>
1062 LPat p -> [IdP p] -> [IdP p]
1063 collect_lpat p bndrs
1064 = go (unLoc p)
1065 where
1066 go (VarPat _ var) = unLoc var : bndrs
1067 go (WildPat _) = bndrs
1068 go (LazyPat _ pat) = collect_lpat pat bndrs
1069 go (BangPat _ pat) = collect_lpat pat bndrs
1070 go (AsPat _ a pat) = unLoc a : collect_lpat pat bndrs
1071 go (ViewPat _ _ pat) = collect_lpat pat bndrs
1072 go (ParPat _ pat) = collect_lpat pat bndrs
1073
1074 go (ListPat _ pats) = foldr collect_lpat bndrs pats
1075 go (TuplePat _ pats _) = foldr collect_lpat bndrs pats
1076 go (SumPat _ pat _ _) = collect_lpat pat bndrs
1077
1078 go (ConPatIn _ ps) = foldr collect_lpat bndrs (hsConPatArgs ps)
1079 go (ConPatOut {pat_args=ps}) = foldr collect_lpat bndrs (hsConPatArgs ps)
1080 -- See Note [Dictionary binders in ConPatOut]
1081 go (LitPat _ _) = bndrs
1082 go (NPat {}) = bndrs
1083 go (NPlusKPat _ n _ _ _ _) = unLoc n : bndrs
1084
1085 go (SigPat _ pat _) = collect_lpat pat bndrs
1086
1087 go (SplicePat _ (HsSpliced _ _ (HsSplicedPat pat)))
1088 = go pat
1089 go (SplicePat _ _) = bndrs
1090 go (CoPat _ _ pat _) = go pat
1091 go (XPat {}) = bndrs
1092
1093 {-
1094 Note [Dictionary binders in ConPatOut] See also same Note in DsArrows
1095 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1096 Do *not* gather (a) dictionary and (b) dictionary bindings as binders
1097 of a ConPatOut pattern. For most calls it doesn't matter, because
1098 it's pre-typechecker and there are no ConPatOuts. But it does matter
1099 more in the desugarer; for example, DsUtils.mkSelectorBinds uses
1100 collectPatBinders. In a lazy pattern, for example f ~(C x y) = ...,
1101 we want to generate bindings for x,y but not for dictionaries bound by
1102 C. (The type checker ensures they would not be used.)
1103
1104 Desugaring of arrow case expressions needs these bindings (see DsArrows
1105 and arrowcase1), but SPJ (Jan 2007) says it's safer for it to use its
1106 own pat-binder-collector:
1107
1108 Here's the problem. Consider
1109
1110 data T a where
1111 C :: Num a => a -> Int -> T a
1112
1113 f ~(C (n+1) m) = (n,m)
1114
1115 Here, the pattern (C (n+1)) binds a hidden dictionary (d::Num a),
1116 and *also* uses that dictionary to match the (n+1) pattern. Yet, the
1117 variables bound by the lazy pattern are n,m, *not* the dictionary d.
1118 So in mkSelectorBinds in DsUtils, we want just m,n as the variables bound.
1119 -}
1120
1121 hsGroupBinders :: HsGroup GhcRn -> [Name]
1122 hsGroupBinders (HsGroup { hs_valds = val_decls, hs_tyclds = tycl_decls,
1123 hs_fords = foreign_decls })
1124 = collectHsValBinders val_decls
1125 ++ hsTyClForeignBinders tycl_decls foreign_decls
1126 hsGroupBinders (XHsGroup {}) = panic "hsGroupBinders"
1127
1128 hsTyClForeignBinders :: [TyClGroup GhcRn]
1129 -> [LForeignDecl GhcRn]
1130 -> [Name]
1131 -- We need to look at instance declarations too,
1132 -- because their associated types may bind data constructors
1133 hsTyClForeignBinders tycl_decls foreign_decls
1134 = map unLoc (hsForeignDeclsBinders foreign_decls)
1135 ++ getSelectorNames
1136 (foldMap (foldMap hsLTyClDeclBinders . group_tyclds) tycl_decls
1137 `mappend`
1138 foldMap (foldMap hsLInstDeclBinders . group_instds) tycl_decls)
1139 where
1140 getSelectorNames :: ([Located Name], [LFieldOcc GhcRn]) -> [Name]
1141 getSelectorNames (ns, fs) = map unLoc ns ++ map (extFieldOcc . unLoc) fs
1142
1143 -------------------
1144 hsLTyClDeclBinders :: Located (TyClDecl pass)
1145 -> ([Located (IdP pass)], [LFieldOcc pass])
1146 -- ^ Returns all the /binding/ names of the decl. The first one is
1147 -- guaranteed to be the name of the decl. The first component
1148 -- represents all binding names except record fields; the second
1149 -- represents field occurrences. For record fields mentioned in
1150 -- multiple constructors, the SrcLoc will be from the first occurrence.
1151 --
1152 -- Each returned (Located name) has a SrcSpan for the /whole/ declaration.
1153 -- See Note [SrcSpan for binders]
1154
1155 hsLTyClDeclBinders (dL->L loc (FamDecl { tcdFam = FamilyDecl
1156 { fdLName = (dL->L _ name) } }))
1157 = ([cL loc name], [])
1158 hsLTyClDeclBinders (dL->L _ (FamDecl { tcdFam = XFamilyDecl _ }))
1159 = panic "hsLTyClDeclBinders"
1160 hsLTyClDeclBinders (dL->L loc (SynDecl
1161 { tcdLName = (dL->L _ name) }))
1162 = ([cL loc name], [])
1163 hsLTyClDeclBinders (dL->L loc (ClassDecl
1164 { tcdLName = (dL->L _ cls_name)
1165 , tcdSigs = sigs
1166 , tcdATs = ats }))
1167 = (cL loc cls_name :
1168 [ cL fam_loc fam_name | (dL->L fam_loc (FamilyDecl
1169 { fdLName = L _ fam_name })) <- ats ]
1170 ++
1171 [ cL mem_loc mem_name | (dL->L mem_loc (ClassOpSig _ False ns _)) <- sigs
1172 , (dL->L _ mem_name) <- ns ]
1173 , [])
1174 hsLTyClDeclBinders (dL->L loc (DataDecl { tcdLName = (dL->L _ name)
1175 , tcdDataDefn = defn }))
1176 = (\ (xs, ys) -> (cL loc name : xs, ys)) $ hsDataDefnBinders defn
1177 hsLTyClDeclBinders (dL->L _ (XTyClDecl _)) = panic "hsLTyClDeclBinders"
1178 hsLTyClDeclBinders _ = panic "hsLTyClDeclBinders: Impossible Match"
1179 -- due to #15884
1180
1181
1182 -------------------
1183 hsForeignDeclsBinders :: [LForeignDecl pass] -> [Located (IdP pass)]
1184 -- See Note [SrcSpan for binders]
1185 hsForeignDeclsBinders foreign_decls
1186 = [ cL decl_loc n
1187 | (dL->L decl_loc (ForeignImport { fd_name = (dL->L _ n) }))
1188 <- foreign_decls]
1189
1190
1191 -------------------
1192 hsPatSynSelectors :: HsValBinds (GhcPass p) -> [IdP (GhcPass p)]
1193 -- Collects record pattern-synonym selectors only; the pattern synonym
1194 -- names are collected by collectHsValBinders.
1195 hsPatSynSelectors (ValBinds _ _ _) = panic "hsPatSynSelectors"
1196 hsPatSynSelectors (XValBindsLR (NValBinds binds _))
1197 = foldrBag addPatSynSelector [] . unionManyBags $ map snd binds
1198
1199 addPatSynSelector:: LHsBind p -> [IdP p] -> [IdP p]
1200 addPatSynSelector bind sels
1201 | PatSynBind _ (PSB { psb_args = RecCon as }) <- unLoc bind
1202 = map (unLoc . recordPatSynSelectorId) as ++ sels
1203 | otherwise = sels
1204
1205 getPatSynBinds :: [(RecFlag, LHsBinds id)] -> [PatSynBind id id]
1206 getPatSynBinds binds
1207 = [ psb | (_, lbinds) <- binds
1208 , (dL->L _ (PatSynBind _ psb)) <- bagToList lbinds ]
1209
1210 -------------------
1211 hsLInstDeclBinders :: LInstDecl (GhcPass p)
1212 -> ([Located (IdP (GhcPass p))], [LFieldOcc (GhcPass p)])
1213 hsLInstDeclBinders (dL->L _ (ClsInstD
1214 { cid_inst = ClsInstDecl
1215 { cid_datafam_insts = dfis }}))
1216 = foldMap (hsDataFamInstBinders . unLoc) dfis
1217 hsLInstDeclBinders (dL->L _ (DataFamInstD { dfid_inst = fi }))
1218 = hsDataFamInstBinders fi
1219 hsLInstDeclBinders (dL->L _ (TyFamInstD {})) = mempty
1220 hsLInstDeclBinders (dL->L _ (ClsInstD _ (XClsInstDecl {})))
1221 = panic "hsLInstDeclBinders"
1222 hsLInstDeclBinders (dL->L _ (XInstDecl _))
1223 = panic "hsLInstDeclBinders"
1224 hsLInstDeclBinders _ = panic "hsLInstDeclBinders: Impossible Match"
1225 -- due to #15884
1226
1227 -------------------
1228 -- the SrcLoc returned are for the whole declarations, not just the names
1229 hsDataFamInstBinders :: DataFamInstDecl pass
1230 -> ([Located (IdP pass)], [LFieldOcc pass])
1231 hsDataFamInstBinders (DataFamInstDecl { dfid_eqn = HsIB { hsib_body =
1232 FamEqn { feqn_rhs = defn }}})
1233 = hsDataDefnBinders defn
1234 -- There can't be repeated symbols because only data instances have binders
1235 hsDataFamInstBinders (DataFamInstDecl
1236 { dfid_eqn = HsIB { hsib_body = XFamEqn _}})
1237 = panic "hsDataFamInstBinders"
1238 hsDataFamInstBinders (DataFamInstDecl (XHsImplicitBndrs _))
1239 = panic "hsDataFamInstBinders"
1240
1241 -------------------
1242 -- the SrcLoc returned are for the whole declarations, not just the names
1243 hsDataDefnBinders :: HsDataDefn pass -> ([Located (IdP pass)], [LFieldOcc pass])
1244 hsDataDefnBinders (HsDataDefn { dd_cons = cons })
1245 = hsConDeclsBinders cons
1246 -- See Note [Binders in family instances]
1247 hsDataDefnBinders (XHsDataDefn _) = panic "hsDataDefnBinders"
1248
1249 -------------------
1250 type Seen pass = [LFieldOcc pass] -> [LFieldOcc pass]
1251 -- Filters out ones that have already been seen
1252
1253 hsConDeclsBinders :: [LConDecl pass] -> ([Located (IdP pass)], [LFieldOcc pass])
1254 -- See hsLTyClDeclBinders for what this does
1255 -- The function is boringly complicated because of the records
1256 -- And since we only have equality, we have to be a little careful
1257 hsConDeclsBinders cons
1258 = go id cons
1259 where
1260 go :: Seen pass -> [LConDecl pass]
1261 -> ([Located (IdP pass)], [LFieldOcc pass])
1262 go _ [] = ([], [])
1263 go remSeen (r:rs)
1264 -- Don't re-mangle the location of field names, because we don't
1265 -- have a record of the full location of the field declaration anyway
1266 = let loc = getLoc r
1267 in case unLoc r of
1268 -- remove only the first occurrence of any seen field in order to
1269 -- avoid circumventing detection of duplicate fields (#9156)
1270 ConDeclGADT { con_names = names, con_args = args }
1271 -> (map (cL loc . unLoc) names ++ ns, flds ++ fs)
1272 where
1273 (remSeen', flds) = get_flds remSeen args
1274 (ns, fs) = go remSeen' rs
1275
1276 ConDeclH98 { con_name = name, con_args = args }
1277 -> ([cL loc (unLoc name)] ++ ns, flds ++ fs)
1278 where
1279 (remSeen', flds) = get_flds remSeen args
1280 (ns, fs) = go remSeen' rs
1281
1282 XConDecl _ -> panic "hsConDeclsBinders"
1283
1284 get_flds :: Seen pass -> HsConDeclDetails pass
1285 -> (Seen pass, [LFieldOcc pass])
1286 get_flds remSeen (RecCon flds)
1287 = (remSeen', fld_names)
1288 where
1289 fld_names = remSeen (concatMap (cd_fld_names . unLoc) (unLoc flds))
1290 remSeen' = foldr (.) remSeen
1291 [deleteBy ((==) `on` unLoc . rdrNameFieldOcc . unLoc) v
1292 | v <- fld_names]
1293 get_flds remSeen _
1294 = (remSeen, [])
1295
1296 {-
1297
1298 Note [SrcSpan for binders]
1299 ~~~~~~~~~~~~~~~~~~~~~~~~~~
1300 When extracting the (Located RdrNme) for a binder, at least for the
1301 main name (the TyCon of a type declaration etc), we want to give it
1302 the @SrcSpan@ of the whole /declaration/, not just the name itself
1303 (which is how it appears in the syntax tree). This SrcSpan (for the
1304 entire declaration) is used as the SrcSpan for the Name that is
1305 finally produced, and hence for error messages. (See Trac #8607.)
1306
1307 Note [Binders in family instances]
1308 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1309 In a type or data family instance declaration, the type
1310 constructor is an *occurrence* not a binding site
1311 type instance T Int = Int -> Int -- No binders
1312 data instance S Bool = S1 | S2 -- Binders are S1,S2
1313
1314
1315 ************************************************************************
1316 * *
1317 Collecting binders the user did not write
1318 * *
1319 ************************************************************************
1320
1321 The job of this family of functions is to run through binding sites and find the set of all Names
1322 that were defined "implicitly", without being explicitly written by the user.
1323
1324 The main purpose is to find names introduced by record wildcards so that we can avoid
1325 warning the user when they don't use those names (#4404)
1326
1327 Since the addition of -Wunused-record-wildcards, this function returns a pair
1328 of [(SrcSpan, [Name])]. Each element of the list is one set of implicit
1329 binders, the first component of the tuple is the document describes the possible
1330 fix to the problem (by removing the ..).
1331
1332 This means there is some unfortunate coupling between this function and where it
1333 is used but it's only used for one specific purpose in one place so it seemed
1334 easier.
1335 -}
1336
1337 lStmtsImplicits :: [LStmtLR GhcRn (GhcPass idR) (Located (body (GhcPass idR)))]
1338 -> [(SrcSpan, [Name])]
1339 lStmtsImplicits = hs_lstmts
1340 where
1341 hs_lstmts :: [LStmtLR GhcRn (GhcPass idR) (Located (body (GhcPass idR)))]
1342 -> [(SrcSpan, [Name])]
1343 hs_lstmts = concatMap (hs_stmt . unLoc)
1344
1345 hs_stmt :: StmtLR GhcRn (GhcPass idR) (Located (body (GhcPass idR)))
1346 -> [(SrcSpan, [Name])]
1347 hs_stmt (BindStmt _ pat _ _ _) = lPatImplicits pat
1348 hs_stmt (ApplicativeStmt _ args _) = concatMap do_arg args
1349 where do_arg (_, ApplicativeArgOne _ pat _ _) = lPatImplicits pat
1350 do_arg (_, ApplicativeArgMany _ stmts _ _) = hs_lstmts stmts
1351 do_arg (_, XApplicativeArg _) = panic "lStmtsImplicits"
1352 hs_stmt (LetStmt _ binds) = hs_local_binds (unLoc binds)
1353 hs_stmt (BodyStmt {}) = []
1354 hs_stmt (LastStmt {}) = []
1355 hs_stmt (ParStmt _ xs _ _) = hs_lstmts [s | ParStmtBlock _ ss _ _ <- xs
1356 , s <- ss]
1357 hs_stmt (TransStmt { trS_stmts = stmts }) = hs_lstmts stmts
1358 hs_stmt (RecStmt { recS_stmts = ss }) = hs_lstmts ss
1359 hs_stmt (XStmtLR {}) = panic "lStmtsImplicits"
1360
1361 hs_local_binds (HsValBinds _ val_binds) = hsValBindsImplicits val_binds
1362 hs_local_binds (HsIPBinds {}) = []
1363 hs_local_binds (EmptyLocalBinds _) = []
1364 hs_local_binds (XHsLocalBindsLR _) = []
1365
1366 hsValBindsImplicits :: HsValBindsLR GhcRn (GhcPass idR) -> [(SrcSpan, [Name])]
1367 hsValBindsImplicits (XValBindsLR (NValBinds binds _))
1368 = concatMap (lhsBindsImplicits . snd) binds
1369 hsValBindsImplicits (ValBinds _ binds _)
1370 = lhsBindsImplicits binds
1371
1372 lhsBindsImplicits :: LHsBindsLR GhcRn idR -> [(SrcSpan, [Name])]
1373 lhsBindsImplicits = foldBag (++) (lhs_bind . unLoc) []
1374 where
1375 lhs_bind (PatBind { pat_lhs = lpat }) = lPatImplicits lpat
1376 lhs_bind _ = []
1377
1378 lPatImplicits :: LPat GhcRn -> [(SrcSpan, [Name])]
1379 lPatImplicits = hs_lpat
1380 where
1381 hs_lpat lpat = hs_pat (unLoc lpat)
1382
1383 hs_lpats = foldr (\pat rest -> hs_lpat pat ++ rest) []
1384
1385 hs_pat (LazyPat _ pat) = hs_lpat pat
1386 hs_pat (BangPat _ pat) = hs_lpat pat
1387 hs_pat (AsPat _ _ pat) = hs_lpat pat
1388 hs_pat (ViewPat _ _ pat) = hs_lpat pat
1389 hs_pat (ParPat _ pat) = hs_lpat pat
1390 hs_pat (ListPat _ pats) = hs_lpats pats
1391 hs_pat (TuplePat _ pats _) = hs_lpats pats
1392
1393 hs_pat (SigPat _ pat _) = hs_lpat pat
1394 hs_pat (CoPat _ _ pat _) = hs_pat pat
1395
1396 hs_pat (ConPatIn n ps) = details n ps
1397 hs_pat (ConPatOut {pat_con=con, pat_args=ps}) = details (fmap conLikeName con) ps
1398
1399 hs_pat _ = []
1400
1401 details :: Located Name -> HsConPatDetails GhcRn -> [(SrcSpan, [Name])]
1402 details _ (PrefixCon ps) = hs_lpats ps
1403 details n (RecCon fs) =
1404 [(err_loc, collectPatsBinders implicit_pats) | Just{} <- [rec_dotdot fs] ]
1405 ++ hs_lpats explicit_pats
1406
1407 where implicit_pats = map (hsRecFieldArg . unLoc) implicit
1408 explicit_pats = map (hsRecFieldArg . unLoc) explicit
1409
1410
1411 (explicit, implicit) = partitionEithers [if pat_explicit then Left fld else Right fld
1412 | (i, fld) <- [0..] `zip` rec_flds fs
1413 , let pat_explicit =
1414 maybe True ((i<) . unLoc)
1415 (rec_dotdot fs)]
1416 err_loc = maybe (getLoc n) getLoc (rec_dotdot fs)
1417
1418 details _ (InfixCon p1 p2) = hs_lpat p1 ++ hs_lpat p2