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